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 Control.Arrow
  20 import Control.Arrow.ArrowList
  21 import Data.ByteString (ByteString)
  22 import qualified Data.ByteString as BS
  23 import qualified Data.ByteString.Char8 as C8
  24 import qualified Data.ByteString.Lazy as LS
  25 import qualified Data.ByteString.Unsafe as BS
  26 import Data.Char
  27 import Data.Monoid.Unicode
  28 import Data.String
  29 import Data.Text (Text)
  30 import Data.Text.Encoding
  31 import Magic
  32 import Network.HTTP.Lucu
  33 import Network.URI
  34 import Numeric
  35 import Prelude.Unicode
  36 import System.IO.Unsafe
  37
  38 yesOrNo ∷ Bool → String
  39 yesOrNo True  = "yes"
  40 yesOrNo False = "no"
  41
  42 trueOrFalse ∷ Bool → String
  43 trueOrFalse True  = "true"
  44 trueOrFalse False = "false"
  45
  46 parseYesOrNo ∷ (Eq s, Show s, IsString s, ArrowChoice (⇝)) ⇒ s ⇝ Bool
  47 parseYesOrNo = arr f
  48     where
  49       f "yes" = True
  50       f "no"  = False
  51       f str   = error ("Expected yes or no: " ⊕ show str)
  52
  53 maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
  54 maybeA a = listA a
  55            >>>
  56            proc xs → case xs of
  57                         []    → returnA ⤙ Nothing
  58                         (x:_) → returnA ⤙ Just x
  59
  60 deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
  61 deleteIfEmpty
  62     = proc str → do case str of
  63                        "" → none    ⤙ ()
  64                        _  → returnA ⤙ str
  65
  66 chomp ∷ String → String
  67 {-# INLINE chomp #-}
  68 chomp = reverse . snd . break (≢ '\n') . reverse
  69
  70 guessMIMEType ∷ LS.ByteString → MIMEType
  71 {-# INLINEABLE guessMIMEType #-}
  72 guessMIMEType = read
  73                 ∘ unsafePerformIO
  74                 ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
  75                 ∘ BS.concat
  76                 ∘ LS.toChunks
  77     where
  78       magic ∷ Magic
  79       {-# NOINLINE magic #-}
  80       magic = unsafePerformIO
  81               $ do m ← magicOpen [MagicMime]
  82                    magicLoadDefault m
  83                    return m
  84
  85 isSafeChar ∷ Char → Bool
  86 {-# INLINEABLE isSafeChar #-}
  87 isSafeChar c
  88     | c ≡ '/'           = True
  89     | isReserved c      = False
  90     | c > ' ' ∧ c ≤ '~' = True
  91     | otherwise         = False
  92
  93 mkQueryString ∷ [(Text, Text)] → ByteString
  94 {-# INLINEABLE mkQueryString #-}
  95 mkQueryString = BS.intercalate (C8.singleton ';') ∘ map encodePair
  96     where
  97       encodePair ∷ (Text, Text) → ByteString
  98       {-# INLINE encodePair #-}
  99       encodePair (k, v)
 100           = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]
 101
 102       encodeText ∷ Text → ByteString
 103       {-# INLINE encodeText #-}
 104       encodeText = toURLEncoded ∘ encodeUtf8
 105
 106 toURLEncoded ∷ ByteString → ByteString
 107 {-# INLINEABLE toURLEncoded #-}
 108 toURLEncoded = C8.concatMap go
 109     where
 110       go ∷ Char → 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 → 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))