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.Unsafe as BS
  22 import qualified Data.ByteString.Lazy as LS
  23 import Data.List
  24 import qualified Data.Text as T
  25 import Data.Text.Encoding
  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 ∷ ArrowChoice a ⇒ a String Bool
  41 parseYesOrNo
  42     = proc str → do case str of
  43                        "yes" → returnA ⤙ True
  44                        "no"  → returnA ⤙ False
  45                        _     → returnA ⤙ error ("Expected yes or no: " ⧺ str)
  46
  47 maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
  48 maybeA a = listA a
  49            >>>
  50            proc xs → case xs of
  51                         []    → returnA ⤙ Nothing
  52                         (x:_) → returnA ⤙ Just x
  53
  54 deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
  55 deleteIfEmpty
  56     = proc str → do case str of
  57                        "" → none    ⤙ ()
  58                        _  → returnA ⤙ str
  59
  60 chomp ∷ String → String
  61 {-# INLINE chomp #-}
  62 chomp = reverse . snd . break (≢ '\n') . reverse
  63
  64 guessMIMEType ∷ LS.ByteString → MIMEType
  65 {-# INLINEABLE guessMIMEType #-}
  66 guessMIMEType = read
  67                 ∘ unsafePerformIO
  68                 ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
  69                 ∘ BS.concat
  70                 ∘ LS.toChunks
  71     where
  72       magic ∷ Magic
  73       {-# NOINLINE magic #-}
  74       magic = unsafePerformIO
  75               $ do m ← magicOpen [MagicMime]
  76                    magicLoadDefault m
  77                    return m
  78
  79 isSafeChar ∷ Char → Bool
  80 {-# INLINEABLE isSafeChar #-}
  81 isSafeChar c
  82     | c ≡ '/'        = True
  83     | isReserved c   = False
  84     | isUnreserved c = True
  85     | otherwise      = False
  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