Network/HTTP/Lucu/Utils.hs

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