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 @(map toLower a) == (map toLower
  44 -- b)@. See 'noCaseEq''.
  45 noCaseEq :: String -> String -> Bool
  46 noCaseEq a b
  47     = (map toLower a) == (map toLower b)
  48 {-# INLINE noCaseEq #-}
  49
  50 -- |@'noCaseEq'' a b@ is a variant of 'noCaseEq' which first checks
  51 -- the length of two strings to avoid possibly unnecessary comparison.
  52 noCaseEq' :: String -> String -> Bool
  53 noCaseEq' a b
  54     | length a /= length b = False
  55     | otherwise            = noCaseEq a b
  56 {-# INLINE noCaseEq' #-}
  57
  58 -- |@'isWhiteSpace' c@ is True iff c is one of SP, HT, CR and LF.
  59 isWhiteSpace :: Char -> Bool
  60 isWhiteSpace ' '  = True
  61 isWhiteSpace '\t' = True
  62 isWhiteSpace '\r' = True
  63 isWhiteSpace '\n' = True
  64 isWhiteSpace _    = False
  65 {-# INLINE isWhiteSpace #-}
  66
  67 -- |> quoteStr "abc"
  68 --  > ==> "\"abc\""
  69 --
  70 --  > quoteStr "ab\"c"
  71 --  > ==> "\"ab\\\"c\""
  72 quoteStr :: String -> String
  73 quoteStr str = str `seq`
  74                foldr (++) "" (["\""] ++ map quote str ++ ["\""])
  75     where
  76       quote :: Char -> String
  77       quote '"' = "\\\""
  78       quote c   = [c]
  79
  80
  81 -- |> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
  82 --  > ==> [("aaa", "bbb"), ("ccc", "ddd")]
  83 parseWWWFormURLEncoded :: String -> [(String, String)]
  84 parseWWWFormURLEncoded src
  85     | src == "" = []
  86     | otherwise = do pairStr <- splitBy (\ c -> c == ';' || c == '&') src
  87                      let (key, value) = break (== '=') pairStr
  88                      return ( unEscapeString key
  89                             , unEscapeString $ case value of
  90                                                  ('=':val) -> val
  91                                                  ""        -> ""
  92                             )