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     , 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 splitBy isSep src
  33     = case break isSep src
  34       of (last , []       ) → [last]
  35          (first, _sep:rest) → first : splitBy isSep rest
  36
  37 -- |> joinWith ":" ["ab", "c", "def"]
  38 --  > ==> "ab:c:def"
  39 joinWith ∷ Ascii → [AsciiBuilder] → AsciiBuilder
  40 {-# INLINEABLE joinWith #-}
  41 joinWith sep = flip go (∅)
  42     where
  43       go ∷ [AsciiBuilder] → AsciiBuilder → AsciiBuilder
  44       {-# INLINE go #-}
  45       go []     ab = ab
  46       go (x:[]) ab = ab ⊕ x
  47       go (x:xs) ab = go xs (ab ⊕ A.toAsciiBuilder sep ⊕ x)
  48
  49 -- |> quoteStr "abc"
  50 --  > ==> "\"abc\""
  51 --
  52 --  > quoteStr "ab\"c"
  53 --  > ==> "\"ab\\\"c\""
  54 quoteStr ∷ Ascii → AsciiBuilder
  55 quoteStr str = A.toAsciiBuilder "\"" ⊕
  56                go (A.toByteString str) (∅) ⊕
  57                A.toAsciiBuilder "\""
  58     where
  59       go ∷ BS.ByteString → AsciiBuilder → AsciiBuilder
  60       go bs ab
  61           = case BS.break (≡ '"') bs of
  62               (x, y)
  63                   | BS.null y → ab ⊕ b2ab x
  64                   | otherwise → go (BS.tail y) (ab ⊕ b2ab x
  65                                                    ⊕ A.toAsciiBuilder "\\\"")
  66
  67       b2ab ∷ BS.ByteString → AsciiBuilder
  68       b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString
  69
  70 -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
  71 --  > ==> [("aaa", "bbb"), ("ccc", "ddd")]
  72 parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
  73 parseWWWFormURLEncoded src
  74     -- THINKME: We could gain some performance by using attoparsec
  75     -- here.
  76     | src ≡ ""  = []
  77     | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src)
  78                      let (key, value) = break (≡ '=') pairStr
  79                      return ( unescape key
  80                             , unescape $ case value of
  81                                            ('=':val) → val
  82                                            val       → val
  83                             )
  84     where
  85       unescape ∷ String → ByteString
  86       unescape = BS.pack ∘ unEscapeString ∘ map plusToSpace
  87
  88       plusToSpace ∷ Char → Char
  89       plusToSpace '+' = ' '
  90       plusToSpace c   = c
  91
  92 -- |> show3 5
  93 --  > ==> "005"
  94 show3 ∷ Integral n ⇒ n → AsciiBuilder
  95 {-# INLINEABLE show3 #-}
  96 show3 = A.unsafeFromBuilder ∘ go
  97     where
  98       go i | i ≥ 0 ∧ i < 10   = B.fromByteString "00" ⊕ BT.digit    i
  99            | i ≥ 0 ∧ i < 100  = B.fromByteString "0"  ⊕ BT.integral i
 100            | i ≥ 0 ∧ i < 1000 =                         BT.integral i
 101            | otherwise        = error ("show3: the integer i must satisfy 0 <= i < 1000: " ⧺ show i)