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
|
module Web.Utils (parseQs, parseHttp) where
import Network.HTTP.Types.URI as URI
import qualified Data.ByteString as S
import Data.ByteString (ByteString)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8, decodeUtf8)
import Data.Text (Text)
import Web.Http
-- Query string parser
decodeUrl :: Text -> Text
decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8
parseQs :: Text -> (Text, [QueryPair])
parseQs url =
let
decoded = decodeUrl url
path = T.takeWhile (\c -> c /= '?') decoded
rest = T.dropWhile (\c -> c /= '?') decoded
parsePair :: Text -> Maybe QueryPair
parsePair s
| T.any ((==) '=') s = Just (QueryPair a b)
| otherwise = Nothing
where a : b : _ = T.splitOn (T.pack "=") s
get (Just p : rest) = p : get rest
get (Nothing : rest) = get rest
get [] = []
pairs =
if T.null rest
then []
else get $ map parsePair $ T.splitOn (T.pack "&") $ T.tail rest
in (path, pairs)
-- HTTP Parser
rev :: [a] -> [a]
rev = foldl (flip (:)) []
getMethod :: Text -> Method
getMethod s
| s == (T.pack "POST") = POST
| s == (T.pack "PUT") = PUT
| otherwise = GET
parseFirstLine :: Text -> (Method, Text)
parseFirstLine l = (getMethod methodT, url)
where [methodT, url, _] = T.words l
parseHeader :: Text -> Header
parseHeader line =
Header (T.takeWhile p line)
(T.strip $ T.tail $ T.dropWhile p line)
where p = (\c -> c /= ':')
parseHeaders :: [Text] -> [Header]
parseHeaders = map parseHeader
parseHttp :: Text -> ((Method, Text, [QueryPair]), [Header], [Text])
parseHttp text =
let
lines = T.splitOn (T.pack "\r\n") text
getFirstLine (l : rest) = (l, rest)
getHeaders (l : rest) acc
| T.null l = (rev acc, rest)
| otherwise = getHeaders rest (l : acc)
(fl, rest1) = getFirstLine lines
(headers, rest2) = getHeaders rest1 []
(method, url) = parseFirstLine fl
(path, query) = parseQs url
in
((method, path, query), parseHeaders headers, rest2)
|
