{-# LANGUAGE
    Arrows
  , UnicodeSyntax
  #-}
module Rakka.Utils
    ( yesOrNo
    , trueOrFalse
    , parseYesOrNo
    , maybeA
    , deleteIfEmpty
    , chomp
    , guessMIMEType
    , mkQueryString
    )
    where
import Control.Arrow
import Control.Arrow.ArrowList
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Unsafe as BS
import qualified Data.ByteString.Lazy as LS
import Data.Char
import qualified Data.Text as T
import Data.Text.Encoding
import Magic
import Network.HTTP.Lucu
import Network.URI
import Numeric
import Prelude.Unicode
import System.IO.Unsafe

yesOrNo ∷ Bool → String
yesOrNo True  = "yes"
yesOrNo False = "no"

trueOrFalse ∷ Bool → String
trueOrFalse True  = "true"
trueOrFalse False = "false"

parseYesOrNo ∷ ArrowChoice a ⇒ a String Bool
parseYesOrNo 
    = proc str → do case str of
                       "yes" → returnA ⤙ True
                       "no"  → returnA ⤙ False
                       _     → returnA ⤙ error ("Expected yes or no: " ⧺ str)

maybeA ∷ (ArrowList a, ArrowChoice a) ⇒ a b c → a b (Maybe c)
maybeA a = listA a
           >>>
           proc xs → case xs of
                        []    → returnA ⤙ Nothing
                        (x:_) → returnA ⤙ Just x

deleteIfEmpty ∷ (ArrowList a, ArrowChoice a) ⇒ a String String
deleteIfEmpty
    = proc str → do case str of
                       "" → none    ⤙ ()
                       _  → returnA ⤙ str

chomp ∷ String → String
{-# INLINE chomp #-}
chomp = reverse . snd . break (≢ '\n') . reverse

guessMIMEType ∷ LS.ByteString → MIMEType
{-# INLINEABLE guessMIMEType #-}
guessMIMEType = read
                ∘ unsafePerformIO
                ∘ flip BS.unsafeUseAsCStringLen (magicCString magic)
                ∘ BS.concat
                ∘ LS.toChunks
    where
      magic ∷ Magic
      {-# NOINLINE magic #-}
      magic = unsafePerformIO
              $ do m ← magicOpen [MagicMime]
                   magicLoadDefault m
                   return m

{-
isSafeChar ∷ Char → Bool
{-# INLINEABLE isSafeChar #-}
isSafeChar c
    | c ≡ '/'           = True
    | isReserved c      = False
    | c > ' ' ∧ c ≤ '~' = True
    | otherwise         = False
-}

mkQueryString ∷ [(T.Text, T.Text)] → Ascii
{-# INLINEABLE mkQueryString #-}
mkQueryString = A.unsafeFromByteString
                ∘ BS.intercalate (C8.singleton ';')
                ∘ map encodePair
    where
      encodePair ∷ (T.Text, T.Text) → BS.ByteString
      {-# INLINE encodePair #-}
      encodePair (k, v)
          = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]

      encodeText ∷ T.Text → BS.ByteString
      {-# INLINE encodeText #-}
      encodeText = toURLEncoded ∘ encodeUtf8

toURLEncoded ∷ BS.ByteString → BS.ByteString
{-# INLINEABLE toURLEncoded #-}
toURLEncoded = C8.concatMap go
    where
      go ∷ Char → BS.ByteString
      {-# INLINE go #-}
      go c | c ≡ ' '        = C8.singleton '+'
           | isReserved   c = urlEncode c
           | isUnreserved c = C8.singleton c
           | otherwise      = urlEncode c

      urlEncode ∷ Char → BS.ByteString
      {-# INLINE urlEncode #-}
      urlEncode c = C8.pack ('%':toHex (ord c))

      toHex ∷ Int → String
      {-# INLINE toHex #-}
      toHex n
          = case showIntAtBase 16 toChrHex n "" of
              []  → "00"
              [c] → ['0', c]
              cs  → cs

      toChrHex ∷ Int → Char
      {-# INLINE toChrHex #-}
      toChrHex d
          | d < 10    = chr (ord '0' + fromIntegral  d    )
          | otherwise = chr (ord 'A' + fromIntegral (d-10))