Network/HTTP/Lucu/Utils.hs

   1 {-# LANGUAGE
   2     OverloadedStrings
   3   , RecordWildCards
   4   , TemplateHaskell
   5   , UnicodeSyntax
   6   #-}
   7 -- |Utility functions used internally in the Lucu httpd. These
   8 -- functions may be useful too for something else.
   9 module Network.HTTP.Lucu.Utils
  10     ( splitBy
  11     , quoteStr
  12     , parseWWWFormURLEncoded
  13     , splitPathInfo
  14     , trim
  15     , liftByteString
  16     , liftLazyByteString
  17     , liftAscii
  18     , liftCIAscii
  19     , liftText
  20     , liftMap
  21     , liftUTCTime
  22     )
  23     where
  24 import Control.Monad
  25 import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
  26 import qualified Data.Ascii as A
  27 import Data.ByteString (ByteString)
  28 import qualified Data.ByteString.Char8 as Strict
  29 import qualified Data.ByteString.Unsafe as Strict
  30 import qualified Data.ByteString.Lazy.Internal as Lazy
  31 import Data.Char
  32 import Data.List hiding (last)
  33 import Data.Map (Map)
  34 import qualified Data.Map as M
  35 import Data.Monoid.Unicode
  36 import Data.Ratio
  37 import Data.Text (Text)
  38 import qualified Data.Text as T
  39 import Data.Time
  40 import Language.Haskell.TH.Lib
  41 import Language.Haskell.TH.Syntax
  42 import Network.URI
  43 import Prelude hiding (last)
  44 import Prelude.Unicode
  45 import System.IO.Unsafe
  46
  47 -- |>>> splitBy (== ':') "ab:c:def"
  48 -- ["ab", "c", "def"]
  49 splitBy ∷ (a → Bool) → [a] → [[a]]
  50 {-# INLINEABLE splitBy #-}
  51 splitBy isSep src
  52     = case break isSep src of
  53         (last , []       ) → [last]
  54         (first, _sep:rest) → first : splitBy isSep rest
  55
  56 -- |>>> quoteStr "abc"
  57 -- "\"abc\""
  58 --
  59 -- >>> quoteStr "ab\"c"
  60 -- "\"ab\\\"c\""
  61 quoteStr ∷ Ascii → AsciiBuilder
  62 quoteStr str = A.toAsciiBuilder "\"" ⊕
  63                go (A.toByteString str) (∅) ⊕
  64                A.toAsciiBuilder "\""
  65     where
  66       go ∷ Strict.ByteString → AsciiBuilder → AsciiBuilder
  67       go bs ab
  68           = case Strict.break (≡ '"') bs of
  69               (x, y)
  70                   | Strict.null y
  71                       → ab ⊕ b2ab x
  72                   | otherwise
  73                       → go (Strict.tail y)
  74                            (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"")
  75
  76       b2ab ∷ Strict.ByteString → AsciiBuilder
  77       b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
  78
  79 -- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
  80 -- [("aaa", "bbb"), ("ccc", "ddd")]
  81 parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
  82 parseWWWFormURLEncoded src
  83     -- THINKME: We could gain some performance by using attoparsec
  84     -- here.
  85     | src ≡ ""  = []
  86     | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src)
  87                      let (key, value) = break (≡ '=') pairStr
  88                      return ( unescape key
  89                             , unescape $ case value of
  90                                            ('=':val) → val
  91                                            val       → val
  92                             )
  93     where
  94       unescape ∷ String → ByteString
  95       unescape = Strict.pack ∘ unEscapeString ∘ map plusToSpace
  96
  97       plusToSpace ∷ Char → Char
  98       plusToSpace '+' = ' '
  99       plusToSpace c   = c
 100
 101 -- |>>> splitPathInfo "http://example.com/foo/bar"
 102 -- ["foo", "bar"]
 103 splitPathInfo ∷ URI → [ByteString]
 104 splitPathInfo uri
 105     = let reqPathStr = uriPath uri
 106           reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
 107       in
 108         map Strict.pack reqPath
 109
 110 -- |>>> trim "  ab c d "
 111 -- "ab c d"
 112 trim ∷ String → String
 113 trim = reverse ∘ f ∘ reverse ∘ f
 114     where
 115       f = dropWhile isSpace
 116
 117 -- |Convert a 'ByteString' to an 'Exp' representing it as a literal.
 118 liftByteString ∷ ByteString → Q Exp
 119 liftByteString bs
 120     = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]
 121
 122 -- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a
 123 -- literal.
 124 liftLazyByteString ∷ Lazy.ByteString → Q Exp
 125 liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |]
 126     where
 127       f ∷ ByteString → Q Exp → Q Exp
 128       f bs e = [| Lazy.Chunk $(liftByteString bs) $e |]
 129
 130 -- |Convert an 'Ascii' to an 'Exp' representing it as a literal.
 131 liftAscii ∷ Ascii → Q Exp
 132 liftAscii a = [| A.unsafeFromByteString
 133                  $ unsafePerformIO
 134                  $ Strict.unsafePackAddressLen $len $ptr
 135                |]
 136     where
 137       bs ∷ Strict.ByteString
 138       bs = A.toByteString a
 139
 140       len, ptr ∷ Q Exp
 141       len = lift $ Strict.length bs
 142       ptr = litE $ stringPrimL $ Strict.unpack bs
 143
 144 -- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
 145 liftCIAscii ∷ CIAscii → Q Exp
 146 liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |]
 147
 148 -- |Convert a 'Text' to an 'Exp' representing it as a literal.
 149 liftText ∷ Text → Q Exp
 150 liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |]
 151
 152 -- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
 153 -- literal, using a given key lifter and a value lifter.
 154 liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
 155 liftMap liftK liftV m
 156     | M.null m  = [| M.empty |]
 157     | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |]
 158     where
 159       liftPairs       = listE ∘ map liftPair
 160       liftPair (k, v) = tupE [liftK k, liftV v]
 161
 162 -- |Convert an 'UTCTime' to an 'Exp' representing it as a literal.
 163 liftUTCTime ∷ UTCTime → Q Exp
 164 liftUTCTime (UTCTime {..})
 165     = [| UTCTime {
 166            utctDay     = $(liftDay utctDay)
 167          , utctDayTime = $(liftDiffTime utctDayTime)
 168          }
 169        |]
 170
 171 liftDay ∷ Day → Q Exp
 172 liftDay (ModifiedJulianDay {..})
 173     = [| ModifiedJulianDay {
 174            toModifiedJulianDay = $(lift toModifiedJulianDay)
 175          }
 176        |]
 177
 178 liftDiffTime ∷ DiffTime → Q Exp
 179 liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |]
 180     where
 181       n, d ∷ Q Exp
 182       n = lift $ numerator   $ toRational dt
 183       d = lift $ denominator $ toRational dt