1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
{-# LANGUAGE FlexibleInstances #-}

--------------------------------------------------------------------------------
  
module Parsers.NanoParsec
  ( Parseable
  , Parser
  , item
  , some, many, sepBy, sepBy1
  , satisfy, oneOf, chainl, chainl1
  , char, string, token, reserved, spaces
  , runParser
  )
where

--------------------------------------------------------------------------------

import qualified Data.ByteString                 as BS
import           Data.String
  ( IsString
  )
import           Control.Applicative.Alternative
  ( Alternative
    ( empty
    , (<|>)
    )
  )
import           Control.Monad.Plus
  ( MonadPlus
    ( mzero
    , mplus
    )
  )

--------------------------------------------------------------------------------

-- NanoParsec:
-- http://dev.stephendiehl.com/fun/002_parsers.html#nanoparsec

newtype Parser s a = Parser { parse :: s -> [ (a, s) ] }

class (Eq a, IsString a) => Parseable a where
  nil :: a -> Bool
  hd  :: a -> Char
  tl  :: a -> a

instance Parseable String where
  nil = (== [])
  hd  =  head
  tl  =  tail

instance Parseable BS.ByteString where
  nil =                         BS.null
  hd  = toEnum . fromIntegral . BS.head
  tl  =                         BS.tail

--------------------------------------------------------------------------------

instance (Parseable s) => Functor (Parser s) where
  fmap f (Parser cs) =
    Parser $ \s -> [(f a, b) | (a, b) <- cs s]

instance (Parseable s) => Applicative (Parser s) where
  pure = return
  (Parser cs1) <*> (Parser cs2) =
    Parser $ \s -> [(f a, s2) | (f, s1) <- cs1 s, (a, s2) <- cs2 s1]

instance (Parseable s) => Monad (Parser s) where
  return = unit
  (>>=)  = bind

instance (Parseable s) => MonadPlus (Parser s) where
  mzero = failure
  mplus = combine

instance (Parseable s) => Alternative (Parser s) where
  empty = mzero
  (<|>) = option

--------------------------------------------------------------------------------

bind
  :: (Parseable s)
  => Parser s a
  -> (a -> Parser s b)
  -> Parser s b
bind p f =
  Parser $ \s -> concatMap (\(a, s') -> parse (f a) s') $ parse p s

unit
  :: (Parseable s)
  => a
  -> Parser s a
unit a =
  Parser $ \s -> [ (a, s) ]

combine
  :: (Parseable s)
  => Parser s a
  -> Parser s a
  -> Parser s a
combine p q =
  Parser $ \s -> parse p s ++ parse q s

failure
  :: (Parseable s)
  => Parser s a
failure =
  Parser $ \_ -> []

option
  :: (Parseable s)
  => Parser s a
  -> Parser s a
  -> Parser s a
option p q =
  Parser
  $ \s ->
      case parse p s of
        [ ] -> parse q s
        res -> res
        
--------------------------------------------------------------------------------

item
  :: (Parseable s)
  => Parser s Char
item =
  Parser
  $ \s ->
      case nil s of
        True  -> []
        False -> [ (hd s, tl s) ]



        
--------------------------------------------------------------------------------

-- | One or more.
some
  :: (Alternative f)
  => f a
  -> f [a]
some v = some_v
  where
    many_v = some_v <|> pure []
    some_v = (:) <$> v <*> many_v

-- | Zero or more.
many
  :: (Alternative f)
  => f a
  -> f [a]
many v = many_v
  where
    many_v = some_v <|> pure []
    some_v = (:) <$> v <*> many_v

-- | One or more.
sepBy1
  :: (Alternative f)
  => f a
  -> f b
  -> f [a]
sepBy1 p sep =
  (:) <$> p <*> (many $ sep *> p)

-- | Zero or more.
sepBy
  :: (Alternative f)
  => f a
  -> f b
  -> f [a]
sepBy p sep =
  sepBy1 p sep <|> pure []

--------------------------------------------------------------------------------

satisfy
  :: (Parseable s)
  => (Char -> Bool)
  -> Parser s Char
satisfy p =
  item `bind`
  \c ->
    if p c
    then unit c
    else Parser $ \_ -> []
    
--------------------------------------------------------------------------------

oneOf
  :: (Parseable s)
  => [Char]
  -> Parser s Char
oneOf s =
  satisfy $ flip elem s

chainl
  :: (Parseable s)
  => Parser s a
  -> Parser s (a -> a -> a)
  -> a
  -> Parser s a
chainl p op a =
  (p `chainl1` op) <|> return a

chainl1
  :: (Parseable s)
  => Parser s a
  -> Parser s (a -> a -> a)
  -> Parser s a
p `chainl1` op =
  do {a <- p; rest a}
  where
    rest a =
      (do f <- op
          b <- p
          rest (f a b)) <|> return a
      
--------------------------------------------------------------------------------

char
  :: (Parseable s)
  => Char
  -> Parser s Char
char c = satisfy (c ==)

string
  :: (Parseable s)
  => String
  -> Parser s String
string [] = return []
string (c:cs) = do { _ <- char c; _ <- string cs; return (c:cs)}

token
  :: (Parseable s)
  => Parser s a
  -> Parser s a
token p = do { a <- p; _ <- spaces ; return a}

reserved
  :: (Parseable s)
  => String
  -> Parser s String
reserved s = token (string s)

spaces
  :: (Parseable s)
  => Parser s String
spaces = many $ oneOf " \n\r"
    
--------------------------------------------------------------------------------

runParser
  :: (Parseable s)
  => Parser s a
  -> s
  -> Either String a
runParser m s =
  ps $ parse m s
  where
    ps [   ] = Left "Parser error."
    ps (x:_) = aux x
    aux x
      |       nil $ rest = Right $ fst $ x
      | not . nil $ rest = Left  $ "Parser didn't consume entire stream."
      | otherwise        = Left  $ "Parser error."
      where
        rest = snd x

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
module Parsers.HTTP.Types
  ( Response (..)
  )
where

--------------------------------------------------------------------------------

import qualified Data.ByteString as BS

--------------------------------------------------------------------------------

{- HyperText Transfer Protocol (Response message):

The response message consists of the following:

* A status line which includes the status code and reason message (e.g.,
  HTTP/1.1 200 OK, which indicates that the client's request succeeded).

* Response header fields (e.g., Content-Type: text/html).

* An empty line.

* An optional message body.
-}

data Response
  = Response
    { statusCode :: Int
    , headers    :: [ (String, String) ]
    , body       :: Maybe BS.ByteString
    }
  deriving Show

-- Reference:
-- 
-- Hypertext Transfer Protocol (Response message):
-- -- https://en.wikipedia.org/wiki/Hypertext_Transfer_Protocol#Response_message
--
-- List of HTTP status codes:
-- -- https://en.wikipedia.org/wiki/List_of_HTTP_status_codes

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------

module Parsers.HTTP.Internal
  ( response
  )
where

--------------------------------------------------------------------------------

import qualified Data.ByteString    as BS
import           Data.Char
  ( isDigit
  )
import           Parsers.NanoParsec
import           Parsers.HTTP.Types as T

--------------------------------------------------------------------------------

noeol
  :: (Parseable s)
  => Parser s Char
noeol =
  satisfy $ \c -> '\r' /= c && '\n' /= c

statusCode'
  :: (Parseable s)
  => Parser s Int
statusCode' =
  do
    __ <-        reserved "HTTP/1.1"
    __ <-        spaces
    sc <- some $ satisfy  isDigit
    __ <- many   noeol
    __ <-        reserved "\r\n"
    return $ read sc 

headers'
  :: (Parseable s)
  => Parser s [ (String, String) ]
headers' =
  do
    h <- pair `sepBy` reserved "\r\n"
    return $ h
    where
      nono = satisfy $ \c -> ':' /= c && '\r' /= c && '\n' /= c
      pair =
        do
          key <- some nono
          ___ <- reserved ": "
          val <- some $ noeol
          return $ (key, val)
          
response
  :: (Parseable s)
  => BS.ByteString
  -> Parser s T.Response
response b =
  do
    s <- statusCode'
    h <- headers'
    _ <- reserved "\r\n"
    return $ T.Response s h $ if b == BS.empty then Nothing else Just b

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------

module Parsers.HTTP
  ( parse
  )
where

--------------------------------------------------------------------------------

import qualified Data.ByteString       as BS
import qualified Parsers.NanoParsec    as NP
import           Parsers.HTTP.Internal
import qualified Parsers.HTTP.Types    as HT
 
--------------------------------------------------------------------------------

findSubByteString
  :: BS.ByteString
  -> BS.ByteString
  -> Maybe Int
findSubByteString ss bs =
  if aux < 0 then Nothing else Just aux
  where
    aux       = if n < m then -1 else sub m m m
    sub c i 0 =
      if com i 0 then c - m else -1
    sub c i j =
      if c > n   then            -1
      else
        if com i j then sub c (i-1) (j-1) else sub c' c' m
      where
        c' = c+1
    -- O(1) length returns the length of a ByteString as an Int.
    n = BS.length bs - 1
    m = BS.length ss - 1
    -- O(1) ByteString index (subscript) operator, starting from 0.
    com i j = BS.index bs i == BS.index ss j

--------------------------------------------------------------------------------

parse
  :: BS.ByteString
  -> Either String HT.Response
parse res =
  aux
  where
    aux =
      case findSubByteString "\r\n\r\n" res of
        Nothing -> Left "Not a valid HTTP response."
        Just  i ->
          NP.runParser (response b) p
          where
            p = BS.take (i+2) res
            b = BS.drop (i+4) res

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
#!/usr/bin/env stack
{- stack
   --resolver lts-11.7
   --install-ghc
   runghc
   --package monadplus
   --package tls
   --package x509-store
   --
-}
--   -Wall -Werror

-- Issue with stack: Version 1.7.1
-- Git revision 681c800873816c022739ca7ed14755e85a579565 x86_64 hpack-0.28.2
-- the following flags after -- aren't read anymore and are just sent as extra
-- arguments which are caught by getArgs. Therefore, they are outcommented

--------------------------------------------------------------------------------

{-# LANGUAGE OverloadedStrings #-}

--------------------------------------------------------------------------------

module Main (main) where

--------------------------------------------------------------------------------

import           Control.Exception
  ( IOException
  , try
  )
import           Data.Maybe
  ( fromJust
  , fromMaybe
  )
import           Data.Default.Class
  ( def
  )
import qualified Data.ByteString            as BS
import qualified Data.ByteString.Char8      as C8
import qualified Data.ByteString.Lazy.Char8 as L8
import           Data.X509.CertificateStore as X509
import           Network.Socket             hiding
  ( recv
  , send
  )
import qualified Network.TLS                as T
import qualified Network.TLS.Extra          as TE
import           System.Environment
  ( getArgs
  )
import qualified Parsers.URL                as URL
import qualified Parsers.URL.Types          as URL
import qualified Parsers.HTTP               as HTTP
import qualified Parsers.HTTP.Types         as HTTP

--------------------------------------------------------------------------------

parsedUrl
  :: String
  -> Either String (String, String, String)

resolveUrl
  :: String
  -> String
  -> IO (Either IOException [AddrInfo])

response
  :: [ AddrInfo ] 
  -> String
  -> String
  -> IO BS.ByteString

curl
  :: String
  -> IO ()

main
  :: IO ()

--------------------------------------------------------------------------------

parsedUrl url =
  case URL.parse url of
    Left  msg -> Left msg
    Right uri ->
      case (host, port, comb) of
        (_, Just p', _) -> Right $ (host, p', comb)
        ______________ -> Left  $ "Scheme not supported."
      where
        auth = URL.authority uri
        host = URL.host      auth
        port =
          case (URL.scheme uri, URL.port auth) of
            (URL.HTTPS, Nothing) -> Just $ "443"
            (URL.HTTPS, Just p') -> Just $ show p'
            ____________________ -> Nothing
        comb = "/" ++ p ++ q ++ f
        p    = fromMaybe "" $              URL.path     uri
        f    = fromMaybe "" $ ("#" ++) <$> URL.fragment uri
        q    = fromMaybe "" $
          (
            \ q' ->
              case URL.keyValues q' of
                [] -> ""
                xs ->
                  foldl1 (\ x y -> x ++ "&" ++ y)
                  $ map (\ (k, mv) -> k ++ "=" ++ fromMaybe "" mv)
                  $ xs
          )
          <$> URL.query uri          

resolveUrl host port =
  try $ getAddrInfo Nothing (Just host) (Just port)

response info host path =
  do
    x509 <- cacs
      
    sock <-
      socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)
    ____ <- connect sock (addrAddress addr)

    ctx <- T.contextNew sock $ para x509 host
    ___ <- T.handshake ctx
    ___ <- T.sendData ctx $
      L8.fromChunks
      [ C8.pack $ "GET " ++ path ++ " HTTP/1.1"
      , "\r\n"
      , C8.pack $ "Host: " ++ host
      , "\r\n"
      , "Connection: close"
      , "\r\n"
      , "\r\n"
      ]

    res <- recv ctx

    return res
    
    where
      addr = head $ filter (\ a -> addrSocketType a == Stream) $ info
      -- CA certificates extracted from Mozilla:
      -- # https://curl.haxx.se/docs/caextract.html
      cacs        = readCertificateStore "cacert.pem" >>= pure . fromJust
      para x509 h =
        ( T.defaultParamsClient h BS.empty )
        { T.clientSupported =
          def
          { T.supportedCiphers  = TE.ciphersuite_strong
          , T.supportedVersions = [ T.TLS12 ]
          }
        , T.clientShared =
          def
          { T.sharedCAStore = x509
          }
        }
      recv ctx    =
        aux BS.empty
        where
          aux acc =
            do
              pkg  <- T.recvData ctx
              if 0 == BS.length  pkg
                then return $ acc `BS.append` pkg
                else aux    $ acc `BS.append` pkg

curl url =
  do
    case parsedUrl url of
      Left msg ->
        putStrLn msg
      Right (host, port, path) ->
        do
          valid <- resolveUrl host port
          
          case valid of
            Left    __ ->
              putStrLn $ "Could not resolve host: " ++ host
            Right info ->
              do
                res <- response info host path
                
                case HTTP.parse res of
                  Left  msg  -> putStrLn msg
                  Right res' ->
                    do
                      case HTTP.body res' of
                        Nothing -> return ()
                        Just  b -> C8.putStr b

--------------------------------------------------------------------------------

main =
  do
    urls <- getArgs
    mapM_ curl urls

user@personal:~/.../src$ ./Main.hs "https://www.spisemisu.com"
Could not resolve host: www.spisemisu.com
user@personal:~/.../src$ curl      "https://www.spisemisu.com"
curl: (6) Could not resolve host: www.spisemisu.com
user@personal:~/.../src$ ./Main.hs "https://spisemisu.com"
<!DOCTYPE html>
<html lang="en">
  <head>
    <meta charset="utf-8">
    <meta name="description" content="SPISE MISU ApS hosted by GitLab" />
    <meta name="author" content="SPISE MISU ApS" />
    <title>SPISE MISU ApS</title>
    <link rel="canonical" href="//spisemisu.com/" />
    <!-- Local font files placed at GitLab:
    <link
       rel="stylesheet"
       media="screen"
       href="assets/fonts/proza-libre.css"
       type="text/css">
    -->
    <link
       rel="stylesheet"
       media="screen"
       href="//fontlibrary.org/face/proza-libre"
       type="text/css">
    <style>
      html,head,body
        { padding : 0
        ; margin  : 0;
        }
      body
        { font-family : ProzaLibreRegular, arial
        ; background-color: black
        ; color : black;
        }
    </style>
    <script src="elm.min.js" type="text/javascript">
    </script>
  </head>
  <body>
    <script type="text/javascript">
      Elm.Main.fullscreen();
    </script>
  </body>
</html>
user@personal:~/.../src$ curl      "https://spisemisu.com"
<!DOCTYPE html>
<html lang="en">
  <head>
    <meta charset="utf-8">
    <meta name="description" content="SPISE MISU ApS hosted by GitLab" />
    <meta name="author" content="SPISE MISU ApS" />
    <title>SPISE MISU ApS</title>
    <link rel="canonical" href="//spisemisu.com/" />
    <!-- Local font files placed at GitLab:
    <link
       rel="stylesheet"
       media="screen"
       href="assets/fonts/proza-libre.css"
       type="text/css">
    -->
    <link
       rel="stylesheet"
       media="screen"
       href="//fontlibrary.org/face/proza-libre"
       type="text/css">
    <style>
      html,head,body
        { padding : 0
        ; margin  : 0;
        }
      body
        { font-family : ProzaLibreRegular, arial
        ; background-color: black
        ; color : black;
        }
    </style>
    <script src="elm.min.js" type="text/javascript">
    </script>
  </head>
  <body>
    <script type="text/javascript">
      Elm.Main.fullscreen();
    </script>
  </body>
</html>
user@personal:~/.../src$