Network/HTTP/Lucu/Utils.hs

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