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
|
module 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)
-- Query string parser
decodeUrl :: Text -> Text
decodeUrl = decodeUtf8 . URI.urlDecode True . encodeUtf8
parseQs :: Text -> (Text, [(Text, Text)])
parseQs url =
let
decoded = decodeUrl url
path = T.takeWhile (\c -> c /= '?') decoded
rest = T.dropWhile (\c -> c /= '?') decoded
parsePair :: Text -> Maybe (Text, Text)
parsePair s
| T.any ((==) '=') s = Just (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 (:)) []
parseFirstLine :: Text -> (Text, Text)
parseFirstLine l = (method, url)
where [method, url, _] = T.words l
parseHeader :: Text -> (Text, Text)
parseHeader line =
(T.takeWhile p line, T.strip $ T.tail
$ T.dropWhile p line)
where p = (\c -> c /= ':')
parseHeaders :: [Text] -> [(Text, Text)]
parseHeaders = map parseHeader
parseHttp :: Text -> ((Text, Text, [(Text, Text)]), [(Text, Text)], [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)
|
