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