]> gitweb @ CieloNegro.org - Lucu.git/blob - Network/HTTP/Lucu/Utils.hs
DefaultExtensionMap is now generated with TH.
[Lucu.git] / Network / HTTP / Lucu / Utils.hs
1 {-# LANGUAGE
2     OverloadedStrings
3   , TemplateHaskell
4   , UnicodeSyntax
5   #-}
6 -- |Utility functions used internally in the Lucu httpd. These
7 -- functions may be useful too for something else.
8 module Network.HTTP.Lucu.Utils
9     ( splitBy
10     , quoteStr
11     , parseWWWFormURLEncoded
12     , splitPathInfo
13     , show3
14     , trim
15     , liftCIAscii
16     , liftText
17     , liftMap
18     )
19     where
20 import Blaze.ByteString.Builder.ByteString as B
21 import Blaze.Text.Int as BT
22 import Control.Monad
23 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
24 import qualified Data.Ascii as A
25 import Data.ByteString (ByteString)
26 import qualified Data.ByteString.Char8 as BS
27 import Data.Char
28 import Data.List hiding (last)
29 import Data.Map (Map)
30 import qualified Data.Map as M
31 import Data.Monoid.Unicode
32 import Data.Text (Text)
33 import qualified Data.Text as T
34 import Language.Haskell.TH.Lib
35 import Language.Haskell.TH.Syntax
36 import Network.URI
37 import Prelude hiding (last)
38 import Prelude.Unicode
39
40 -- |>>> splitBy (== ':') "ab:c:def"
41 -- ["ab", "c", "def"]
42 splitBy ∷ (a → Bool) → [a] → [[a]]
43 {-# INLINEABLE splitBy #-}
44 splitBy isSep src
45     = case break isSep src of
46         (last , []       ) → [last]
47         (first, _sep:rest) → first : splitBy isSep rest
48
49 -- |>>> quoteStr "abc"
50 -- "\"abc\""
51 --
52 -- >>> quoteStr "ab\"c"
53 -- "\"ab\\\"c\""
54 quoteStr ∷ Ascii → AsciiBuilder
55 quoteStr str = A.toAsciiBuilder "\"" ⊕
56                go (A.toByteString str) (∅) ⊕
57                A.toAsciiBuilder "\""
58     where
59       go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
60       go bs ab
61           = case BS.break (≡ '"') bs of
62               (x, y)
63                   | BS.null y → ab ⊕ b2ab x
64                   | otherwise → go (BS.tail y) (ab ⊕ b2ab x
65                                                    ⊕ A.toAsciiBuilder "\\\"")
66
67       b2ab ∷ BS.ByteString → AsciiBuilder
68       b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
69
70 -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
71 -- [("aaa", "bbb"), ("ccc", "ddd")]
72 parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
73 parseWWWFormURLEncoded src
74     -- THINKME: We could gain some performance by using attoparsec
75     -- here.
76     | src ≡ ""  = []
77     | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src)
78                      let (key, value) = break (≡ '=') pairStr
79                      return ( unescape key
80                             , unescape $ case value of
81                                            ('=':val) → val
82                                            val       → val
83                             )
84     where
85       unescape ∷ String → ByteString
86       unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace
87
88       plusToSpace ∷ Char → Char
89       plusToSpace '+' = ' '
90       plusToSpace c   = c
91
92 -- |>>> splitPathInfo "http://example.com/foo/bar"
93 -- ["foo", "bar"]
94 splitPathInfo ∷ URI → [ByteString]
95 splitPathInfo uri
96     = let reqPathStr = uriPath uri
97           reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
98       in
99         map BS.pack reqPath
100
101 -- |>>> show3 5
102 -- "005"
103 show3 ∷ Integral n ⇒ n → AsciiBuilder
104 {-# INLINEABLE show3 #-}
105 show3 = A.unsafeFromBuilder ∘ go
106     where
107       go i | i ≥ 0 ∧ i < 10   = B.fromByteString "00" ⊕ BT.digit    i
108            | i ≥ 0 ∧ i < 100  = B.fromByteString "0"  ⊕ BT.integral i
109            | i ≥ 0 ∧ i < 1000 =                         BT.integral i
110            | otherwise        = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i)
111 -- FIXME: Drop this function as soon as possible, to eliminate the
112 -- dependency on blaze-textual.
113
114 -- |>>> trim "  ab c d "
115 -- "ab c d"
116 trim ∷ String → String
117 trim = reverse ∘ f ∘ reverse ∘ f
118     where
119       f = dropWhile isSpace
120
121 -- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
122 liftCIAscii ∷ CIAscii → Q Exp
123 liftCIAscii a = [| A.toCIAscii (A.unsafeFromString $(strLit a)) |]
124     where
125       strLit ∷ CIAscii → Q Exp
126       strLit = liftString ∘ A.toString ∘ A.fromCIAscii
127
128 -- |Convert a 'Text' to an 'Exp' representing it as a literal.
129 liftText ∷ Text → Q Exp
130 liftText t = [| T.pack $(strLit t) |]
131     where
132       strLit ∷ Text → Q Exp
133       strLit = liftString ∘ T.unpack
134
135 -- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
136 -- literal, using a given key lifter and a value lifter.
137 liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
138 liftMap liftK liftV m = [| M.fromAscList $(liftPairs $ M.toAscList m) |]
139     where
140       liftPairs       = listE ∘ map liftPair
141       liftPair (k, v) = tupE [liftK k, liftV v]