Rakka/Utils.hs

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