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]