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     , mkQueryString
  14     )
  15     where
  16 import Control.Arrow
  17 import Control.Arrow.ArrowList
  18 import Data.Ascii (Ascii)
  19 import qualified Data.Ascii as A
  20 import qualified Data.ByteString as BS
  21 import qualified Data.ByteString.Char8 as C8
  22 import qualified Data.ByteString.Unsafe as BS
  23 import qualified Data.ByteString.Lazy as LS
  24 import Data.Char
  25 import qualified Data.Text as T
  26 import Data.Text.Encoding
  27 import Magic
  28 import Network.HTTP.Lucu
  29 import Network.URI
  30 import Numeric
  31 import Prelude.Unicode
  32 import System.IO.Unsafe
  33
  34 yesOrNo ∷ Bool → String
  35 yesOrNo True  = "yes"
  36 yesOrNo False = "no"
  37
  38 trueOrFalse ∷ Bool → String
  39 trueOrFalse True  = "true"
  40 trueOrFalse False = "false"
  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 maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
  50 maybeA a = listA a
  51            >>>
  52            proc xs → case xs of
  53                         []    → returnA ⤙ Nothing
  54                         (x:_) → returnA ⤙ Just x
  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 chomp ∷ String → String
  63 {-# INLINE chomp #-}
  64 chomp = reverse . snd . break (≢ '\n') . reverse
  65
  66 guessMIMEType ∷ LS.ByteString → MIMEType
  67 {-# INLINEABLE guessMIMEType #-}
  68 guessMIMEType = read
  69                 ∘ unsafePerformIO
  70                 ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
  71                 ∘ BS.concat
  72                 ∘ LS.toChunks
  73     where
  74       magic ∷ Magic
  75       {-# NOINLINE magic #-}
  76       magic = unsafePerformIO
  77               $ do m ← magicOpen [MagicMime]
  78                    magicLoadDefault m
  79                    return m
  80
  81 {-
  82 isSafeChar ∷ Char → Bool
  83 {-# INLINEABLE isSafeChar #-}
  84 isSafeChar c
  85     | c ≡ '/'           = True
  86     | isReserved c      = False
  87     | c > ' ' ∧ c ≤ '~' = True
  88     | otherwise         = False
  89 -}
  90
  91 mkQueryString ∷ [(T.Text, T.Text)] → Ascii
  92 {-# INLINEABLE mkQueryString #-}
  93 mkQueryString = A.unsafeFromByteString
  94                 ∘ BS.intercalate (C8.singleton ';')
  95                 ∘ map encodePair
  96     where
  97       encodePair ∷ (T.Text, T.Text) → BS.ByteString
  98       {-# INLINE encodePair #-}
  99       encodePair (k, v)
 100           = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]
 101
 102       encodeText ∷ T.Text → BS.ByteString
 103       {-# INLINE encodeText #-}
 104       encodeText = toURLEncoded ∘ encodeUtf8
 105
 106 toURLEncoded ∷ BS.ByteString → BS.ByteString
 107 {-# INLINEABLE toURLEncoded #-}
 108 toURLEncoded = C8.concatMap go
 109     where
 110       go ∷ Char → BS.ByteString
 111       {-# INLINE go #-}
 112       go c | c ≡ ' '        = C8.singleton '+'
 113            | isReserved   c = urlEncode c
 114            | isUnreserved c = C8.singleton c
 115            | otherwise      = urlEncode c
 116
 117       urlEncode ∷ Char → BS.ByteString
 118       {-# INLINE urlEncode #-}
 119       urlEncode c = C8.pack ('%':toHex (ord c))
 120
 121       toHex ∷ Int → String
 122       {-# INLINE toHex #-}
 123       toHex n
 124           = case showIntAtBase 16 toChrHex n "" of
 125               []  → "00"
 126               [c] → ['0', c]
 127               cs  → cs
 128
 129       toChrHex ∷ Int → Char
 130       {-# INLINE toChrHex #-}
 131       toChrHex d
 132           | d < 10    = chr (ord '0' + fromIntegral  d    )
 133           | otherwise = chr (ord 'A' + fromIntegral (d-10))