Rakka/Utils.hs

   1 module Rakka.Utils
   2     ( yesOrNo
   3     , trueOrFalse
   4     , parseYesOrNo
   5     , maybeA
   6     , deleteIfEmpty
   7     , chomp
   8     , guessMIMEType
   9     , isSafeChar
  10     , mkQueryString
  11     )
  12     where
  13
  14 import qualified Codec.Binary.UTF8.String as UTF8
  15 import           Control.Arrow
  16 import           Control.Arrow.ArrowList
  17 import qualified Data.ByteString.Lazy as Lazy (ByteString)
  18 import qualified Data.ByteString.Lazy.Char8 as L8 hiding (ByteString)
  19 import           Magic
  20 import           Network.HTTP.Lucu
  21 import           Network.URI
  22 import           System.IO.Unsafe
  23
  24
  25 yesOrNo :: Bool -> String
  26 yesOrNo True  = "yes"
  27 yesOrNo False = "no"
  28
  29
  30 trueOrFalse :: Bool -> String
  31 trueOrFalse True  = "true"
  32 trueOrFalse False = "false"
  33
  34
  35 parseYesOrNo :: ArrowChoice a => a String Bool
  36 parseYesOrNo
  37     = proc str -> do case str of
  38                        "yes" -> returnA -< True
  39                        "no"  -> returnA -< False
  40                        _     -> returnA -< error ("Expected yes or no: " ++ str)
  41
  42
  43 maybeA :: (ArrowList a, ArrowChoice a) => a b c -> a b (Maybe c)
  44 maybeA a = listA a
  45            >>>
  46            proc xs -> case xs of
  47                         []    -> returnA -< Nothing
  48                         (x:_) -> returnA -< Just x
  49
  50
  51 deleteIfEmpty :: (ArrowList a, ArrowChoice a) => a String String
  52 deleteIfEmpty
  53     = proc str -> do case str of
  54                        "" -> none    -< ()
  55                        _  -> returnA -< str
  56
  57
  58 chomp :: String -> String
  59 chomp = reverse . snd . break (/= '\n') . reverse
  60
  61
  62 guessMIMEType :: Lazy.ByteString -> MIMEType
  63 guessMIMEType = read . unsafePerformIO . magicString magic . L8.unpack
  64     where
  65       magic :: Magic
  66       magic = unsafePerformIO
  67               $ do m <- magicOpen [MagicMime]
  68                    magicLoadDefault m
  69                    return m
  70
  71
  72 isSafeChar :: Char -> Bool
  73 isSafeChar c
  74     | c == '/'            = True
  75     | isReserved c        = False
  76     | c > ' ' && c <= '~' = True
  77     | otherwise           = False
  78
  79
  80 mkQueryString :: [(String, String)] -> String
  81 mkQueryString []            = ""
  82 mkQueryString ((k, v) : xs) = encode k ++ "=" ++ encode v ++
  83                               if xs == [] then
  84                                   ""
  85                               else
  86                                   ';' : mkQueryString(xs)
  87     where
  88       encode :: String -> String
  89       encode = escapeURIString isSafeChar . UTF8.encodeString