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 Blaze.ByteString.Builder as BBB
  18 import Control.Arrow
  19 import Control.Arrow.ArrowList
  20 import Data.Ascii (Ascii)
  21 import qualified Data.Ascii as A
  22 import qualified Data.ByteString as BS
  23 import qualified Data.ByteString.Unsafe as BS
  24 import qualified Data.ByteString.Lazy as LS
  25 import Data.Monoid.Unicode
  26 import qualified Data.Text as T
  27 import qualified Data.Text.Lazy as LT
  28 import Data.Text.Encoding
  29 import Magic
  30 import Network.HTTP.Lucu
  31 import Network.URI
  32 import Prelude.Unicode
  33 import System.IO.Unsafe
  34
  35 yesOrNo ∷ Bool → String
  36 yesOrNo True  = "yes"
  37 yesOrNo False = "no"
  38
  39 trueOrFalse ∷ Bool → String
  40 trueOrFalse True  = "true"
  41 trueOrFalse False = "false"
  42
  43 parseYesOrNo ∷ ArrowChoice a ⇒ a String Bool
  44 parseYesOrNo
  45     = proc str → do case str of
  46                        "yes" → returnA ⤙ True
  47                        "no"  → returnA ⤙ False
  48                        _     → returnA ⤙ error ("Expected yes or no: " ⧺ str)
  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 deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
  58 deleteIfEmpty
  59     = proc str → do case str of
  60                        "" → none    ⤙ ()
  61                        _  → returnA ⤙ str
  62
  63 chomp ∷ String → String
  64 {-# INLINE chomp #-}
  65 chomp = reverse . snd . break (≢ '\n') . reverse
  66
  67 guessMIMEType ∷ LS.ByteString → MIMEType
  68 {-# INLINEABLE guessMIMEType #-}
  69 guessMIMEType = read
  70                 ∘ unsafePerformIO
  71                 ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
  72                 ∘ BS.concat
  73                 ∘ LS.toChunks
  74     where
  75       magic ∷ Magic
  76       {-# NOINLINE magic #-}
  77       magic = unsafePerformIO
  78               $ do m ← magicOpen [MagicMime]
  79                    magicLoadDefault m
  80                    return m
  81
  82 isSafeChar ∷ Char → Bool
  83 {-# INLINEABLE isSafeChar #-}
  84 isSafeChar c
  85     | c ≡ '/'        = True
  86     | isReserved c   = False
  87     | isUnreserved c = True
  88     | otherwise      = False
  89
  90 mkQueryString ∷ [(T.Text, T.Text)] → Ascii
  91 {-# INLINE mkQueryString #-}
  92 mkQueryString = A.unsafeFromByteString
  93                 ∘ BBB.toByteString
  94                 ∘ flip mkBBB (∅)
  95     where
  96       mkBBB ∷ [(T.Text, T.Text)] → BBB.Builder → BBB.Builder
  97       {-# INLINEABLE mkBBB #-}
  98       mkBBB []      acc = acc
  99       mkBBB (kv:[]) acc = acc ⊕ pair kv
 100       mkBBB (kv:xs) acc = mkBBB xs (acc ⊕ pair kv ⊕ semicolon)
 101
 102       pair ∷ (T.Text, T.Text) → BBB.Builder
 103       {-# INLINE pair #-}
 104       pair (k, v)
 105           = encodeText k ⊕ equal ⊕ encodeText v
 106
 107       encodeText ∷ T.Text → BBB.Builder
 108       {-# INLINE encodeText #-}
 109       encodeText = BBB.fromByteString ∘ URI.encode ∘ encodeUtf8