Network/HTTP/Lucu/Utils.hs

   1 -- |Utility functions used internally in the Lucu httpd. These
   2 -- functions may be useful too for something else.
   3 module Network.HTTP.Lucu.Utils
   4     ( splitBy
   5     , joinWith
   6     , trim
   7     , noCaseEq
   8     , noCaseEq'
   9     , isWhiteSpace
  10     , quoteStr
  11     , parseWWWFormURLEncoded
  12     )
  13     where
  14
  15 import Data.Char
  16 import Data.List
  17 import Network.URI
  18
  19 -- |> splitBy (== ':') "ab:c:def"
  20 --  > ==> ["ab", "c", "def"]
  21 splitBy :: (a -> Bool) -> [a] -> [[a]]
  22 splitBy isSeparator src
  23     = isSeparator `seq`
  24       case break isSeparator src
  25       of (last , []      ) -> last  : []
  26          (first, sep:rest) -> first : splitBy isSeparator rest
  27
  28 -- |> joinWith ":" ["ab", "c", "def"]
  29 --  > ==> "ab:c:def"
  30 joinWith :: [a] -> [[a]] -> [a]
  31 joinWith separator xs
  32     = separator `seq` xs `seq`
  33       foldr (++) [] $! intersperse separator xs
  34
  35 -- |> trim (== '_') "__ab_c__def___"
  36 --  > ==> "ab_c__def"
  37 trim :: (a -> Bool) -> [a] -> [a]
  38 trim p = p `seq` trimTail . trimHead
  39     where
  40       trimHead = dropWhile p
  41       trimTail = reverse . trimHead . reverse
  42
  43 -- |@'noCaseEq' a b@ is equivalent to @('Prelude.map'
  44 -- 'Data.Char.toLower' a) == ('Prelude.map' 'Data.Char.toLower'
  45 -- b)@. See 'noCaseEq''.
  46 noCaseEq :: String -> String -> Bool
  47 noCaseEq a b
  48     = (map toLower a) == (map toLower b)
  49 {-# INLINE noCaseEq #-}
  50
  51 -- |@'noCaseEq'' a b@ is a variant of 'noCaseEq' which first checks
  52 -- the length of two strings to avoid possibly unnecessary comparison.
  53 noCaseEq' :: String -> String -> Bool
  54 noCaseEq' a b
  55     | length a /= length b = False
  56     | otherwise            = noCaseEq a b
  57 {-# INLINE noCaseEq' #-}
  58
  59 -- |@'isWhiteSpace' c@ is 'Prelude.True' iff c is one of SP, HT, CR
  60 -- and LF.
  61 isWhiteSpace :: Char -> Bool
  62 isWhiteSpace ' '  = True
  63 isWhiteSpace '\t' = True
  64 isWhiteSpace '\r' = True
  65 isWhiteSpace '\n' = True
  66 isWhiteSpace _    = False
  67 {-# INLINE isWhiteSpace #-}
  68
  69 -- |> quoteStr "abc"
  70 --  > ==> "\"abc\""
  71 --
  72 --  > quoteStr "ab\"c"
  73 --  > ==> "\"ab\\\"c\""
  74 quoteStr :: String -> String
  75 quoteStr str = str `seq`
  76                foldr (++) "" (["\""] ++ map quote str ++ ["\""])
  77     where
  78       quote :: Char -> String
  79       quote '"' = "\\\""
  80       quote c   = [c]
  81
  82
  83 -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
  84 --  > ==> [("aaa", "bbb"), ("ccc", "ddd")]
  85 parseWWWFormURLEncoded :: String -> [(String, String)]
  86 parseWWWFormURLEncoded src
  87     | src == "" = []
  88     | otherwise = do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
  89                      let (key, value) = break (== '=') pairStr
  90                      return ( unEscapeString key
  91                             , unEscapeString $ case value of
  92                                                  ('=':val) -> val
  93                                                  ""        -> ""
  94                             )