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     , trim
  14     , liftCIAscii
  15     , liftText
  16     , liftMap
  17     )
  18     where
  19 import Control.Monad
  20 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  21 import qualified Data.Ascii as A
  22 import Data.ByteString (ByteString)
  23 import qualified Data.ByteString.Char8 as BS
  24 import Data.Char
  25 import Data.List hiding (last)
  26 import Data.Map (Map)
  27 import qualified Data.Map as M
  28 import Data.Monoid.Unicode
  29 import Data.Text (Text)
  30 import qualified Data.Text as T
  31 import Language.Haskell.TH.Lib
  32 import Language.Haskell.TH.Syntax
  33 import Network.URI
  34 import Prelude hiding (last)
  35 import Prelude.Unicode
  36
  37 -- |>>> splitBy (== ':') "ab:c:def"
  38 -- ["ab", "c", "def"]
  39 splitBy ∷ (a → Bool) → [a] → [[a]]
  40 {-# INLINEABLE splitBy #-}
  41 splitBy isSep src
  42     = case break isSep src of
  43         (last , []       ) → [last]
  44         (first, _sep:rest) → first : splitBy isSep rest
  45
  46 -- |>>> quoteStr "abc"
  47 -- "\"abc\""
  48 --
  49 -- >>> quoteStr "ab\"c"
  50 -- "\"ab\\\"c\""
  51 quoteStr ∷ Ascii → AsciiBuilder
  52 quoteStr str = A.toAsciiBuilder "\"" ⊕
  53                go (A.toByteString str) (∅) ⊕
  54                A.toAsciiBuilder "\""
  55     where
  56       go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  57       go bs ab
  58           = case BS.break (≡ '"') bs of
  59               (x, y)
  60                   | BS.null y → ab ⊕ b2ab x
  61                   | otherwise → go (BS.tail y) (ab ⊕ b2ab x
  62                                                    ⊕ A.toAsciiBuilder "\\\"")
  63
  64       b2ab ∷ BS.ByteString → AsciiBuilder
  65       b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
  66
  67 -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
  68 -- [("aaa", "bbb"), ("ccc", "ddd")]
  69 parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
  70 parseWWWFormURLEncoded src
  71     -- THINKME: We could gain some performance by using attoparsec
  72     -- here.
  73     | src ≡ ""  = []
  74     | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src)
  75                      let (key, value) = break (≡ '=') pairStr
  76                      return ( unescape key
  77                             , unescape $ case value of
  78                                            ('=':val) → val
  79                                            val       → val
  80                             )
  81     where
  82       unescape ∷ String → ByteString
  83       unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace
  84
  85       plusToSpace ∷ Char → Char
  86       plusToSpace '+' = ' '
  87       plusToSpace c   = c
  88
  89 -- |>>> splitPathInfo "http://example.com/foo/bar"
  90 -- ["foo", "bar"]
  91 splitPathInfo ∷ URI → [ByteString]
  92 splitPathInfo uri
  93     = let reqPathStr = uriPath uri
  94           reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
  95       in
  96         map BS.pack reqPath
  97
  98 -- |>>> trim "  ab c d "
  99 -- "ab c d"
 100 trim ∷ String → String
 101 trim = reverse ∘ f ∘ reverse ∘ f
 102     where
 103       f = dropWhile isSpace
 104
 105 -- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
 106 liftCIAscii ∷ CIAscii → Q Exp
 107 liftCIAscii a = [| A.toCIAscii (A.unsafeFromString $(strLit a)) |]
 108     where
 109       strLit ∷ CIAscii → Q Exp
 110       strLit = liftString ∘ A.toString ∘ A.fromCIAscii
 111
 112 -- |Convert a 'Text' to an 'Exp' representing it as a literal.
 113 liftText ∷ Text → Q Exp
 114 liftText t = [| T.pack $(strLit t) |]
 115     where
 116       strLit ∷ Text → Q Exp
 117       strLit = liftString ∘ T.unpack
 118
 119 -- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
 120 -- literal, using a given key lifter and a value lifter.
 121 liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
 122 liftMap liftK liftV m = [| M.fromAscList $(liftPairs $ M.toAscList m) |]
 123     where
 124       liftPairs       = listE ∘ map liftPair
 125       liftPair (k, v) = tupE [liftK k, liftV v]