Network/HTTP/Lucu/Utils.hs

   1 {-# LANGUAGE
   2     BangPatterns
   3   , OverloadedStrings
   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     , joinWith
  11     , quoteStr
  12     , parseWWWFormURLEncoded
  13     , splitPathInfo
  14     , show3
  15     )
  16     where
  17 import Blaze.ByteString.Builder.ByteString as B
  18 import Blaze.Text.Int as BT
  19 import Control.Monad
  20 import Data.Ascii (Ascii, AsciiBuilder)
  21 import qualified Data.Ascii as A
  22 import Data.ByteString (ByteString)
  23 import qualified Data.ByteString.Char8 as BS
  24 import Data.List hiding (last)
  25 import Data.Monoid.Unicode
  26 import Data.Text (Text)
  27 import Data.Text.Encoding as T
  28 import Network.URI
  29 import Prelude hiding (last)
  30 import Prelude.Unicode
  31
  32 -- |> splitBy (== ':') "ab:c:def"
  33 --  > ==> ["ab", "c", "def"]
  34 splitBy ∷ (a → Bool) → [a] → [[a]]
  35 splitBy isSep src
  36     = case break isSep src
  37       of (last , []       ) → [last]
  38          (first, _sep:rest) → first : splitBy isSep rest
  39
  40 -- |> joinWith ":" ["ab", "c", "def"]
  41 --  > ==> "ab:c:def"
  42 joinWith ∷ Ascii → [AsciiBuilder] → AsciiBuilder
  43 {-# INLINEABLE joinWith #-}
  44 joinWith sep = flip go (∅)
  45     where
  46       go ∷ [AsciiBuilder] → AsciiBuilder → AsciiBuilder
  47       {-# INLINE go #-}
  48       go []     ab = ab
  49       go (x:[]) ab = ab ⊕ x
  50       go (x:xs) ab = go xs (ab ⊕ A.toAsciiBuilder sep ⊕ x)
  51
  52 -- |> quoteStr "abc"
  53 --  > ==> "\"abc\""
  54 --
  55 --  > quoteStr "ab\"c"
  56 --  > ==> "\"ab\\\"c\""
  57 quoteStr ∷ Ascii → AsciiBuilder
  58 quoteStr str = A.toAsciiBuilder "\"" ⊕
  59                go (A.toByteString str) (∅) ⊕
  60                A.toAsciiBuilder "\""
  61     where
  62       go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  63       go bs ab
  64           = case BS.break (≡ '"') bs of
  65               (x, y)
  66                   | BS.null y → ab ⊕ b2ab x
  67                   | otherwise → go (BS.tail y) (ab ⊕ b2ab x
  68                                                    ⊕ A.toAsciiBuilder "\\\"")
  69
  70       b2ab ∷ BS.ByteString → AsciiBuilder
  71       b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
  72
  73 -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
  74 --  > ==> [("aaa", "bbb"), ("ccc", "ddd")]
  75 parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
  76 parseWWWFormURLEncoded src
  77     -- THINKME: We could gain some performance by using attoparsec
  78     -- here.
  79     | src ≡ ""  = []
  80     | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src)
  81                      let (key, value) = break (≡ '=') pairStr
  82                      return ( unescape key
  83                             , unescape $ case value of
  84                                            ('=':val) → val
  85                                            val       → val
  86                             )
  87     where
  88       unescape ∷ String → ByteString
  89       unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace
  90
  91       plusToSpace ∷ Char → Char
  92       plusToSpace '+' = ' '
  93       plusToSpace c   = c
  94
  95 -- |> splitPathInfo "http://example.com/foo/bar"
  96 --  > ==> ["foo", "bar"]
  97 splitPathInfo ∷ URI → [Text]
  98 splitPathInfo uri
  99     = let reqPathStr = uriPath uri
 100           reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
 101       in
 102         map (T.decodeUtf8 ∘ BS.pack) reqPath
 103
 104 -- |> show3 5
 105 --  > ==> "005"
 106 show3 ∷ Integral n ⇒ n → AsciiBuilder
 107 {-# INLINEABLE show3 #-}
 108 show3 = A.unsafeFromBuilder ∘ go
 109     where
 110       go i | i ≥ 0 ∧ i < 10   = B.fromByteString "00" ⊕ BT.digit    i
 111            | i ≥ 0 ∧ i < 100  = B.fromByteString "0"  ⊕ BT.integral i
 112            | i ≥ 0 ∧ i < 1000 =                         BT.integral i
 113            | otherwise        = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i)