{-# LANGUAGE
    Arrows
  , OverloadedStrings
  , TypeOperators
  , UnicodeSyntax
  #-}
module Rakka.Utils
    ( yesOrNo
    , trueOrFalse
    , parseYesOrNo
    , maybeA
    , deleteIfEmpty
    , chomp
    , guessMIMEType
    , isSafeChar
    , mkQueryString
    )
    where
import Control.Arrow
import Control.Arrow.ArrowList
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import qualified Data.ByteString.Char8 as C8
import qualified Data.ByteString.Lazy as LS
import qualified Data.ByteString.Unsafe as BS
import Data.Char
import Data.Monoid.Unicode
import Data.String
import Data.Text (Text)
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 ∷ (Eq s, Show s, IsString s, ArrowChoice (⇝)) ⇒ s ⇝ Bool
parseYesOrNo = arr f
    where
      f "yes" = True
      f "no"  = False
      f str   = error ("Expected yes or no: " ⊕ show 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 ∷ [(Text, Text)] → ByteString
{-# INLINEABLE mkQueryString #-}
mkQueryString = BS.intercalate (C8.singleton ';') ∘ map encodePair
    where
      encodePair ∷ (Text, Text) → ByteString
      {-# INLINE encodePair #-}
      encodePair (k, v)
          = BS.intercalate (C8.singleton '=') [encodeText k, encodeText v]

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

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

      urlEncode ∷ Char → 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))