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