Rakka/Utils.hs

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