{-# LANGUAGE
    OverloadedStrings
  , RecordWildCards
  , TemplateHaskell
  , UnicodeSyntax
  #-}
-- |Utility functions used internally in the Lucu httpd. These
-- functions may be useful too for something else.
module Network.HTTP.Lucu.Utils
    ( splitBy
    , quoteStr
    , parseWWWFormURLEncoded
    , splitPathInfo
    , trim
    , liftByteString
    , liftLazyByteString
    , liftAscii
    , liftCIAscii
    , liftText
    , liftMap
    , liftUTCTime
    )
    where
import Control.Monad
import Data.Ascii (Ascii, CIAscii, AsciiBuilder)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as Strict
import qualified Data.ByteString.Unsafe as Strict
import qualified Data.ByteString.Lazy.Internal as Lazy
import Data.Char
import Data.List hiding (last)
import Data.Map (Map)
import qualified Data.Map as M
import Data.Monoid.Unicode
import Data.Ratio
import Data.Text (Text)
import qualified Data.Text as T
import Data.Time
import Language.Haskell.TH.Lib
import Language.Haskell.TH.Syntax
import Network.URI
import Prelude hiding (last)
import Prelude.Unicode
import System.IO.Unsafe

-- |>>> splitBy (== ':') "ab:c:def"
-- ["ab", "c", "def"]
splitBy ∷ (a → Bool) → [a] → [[a]]
{-# INLINEABLE splitBy #-}
splitBy isSep src
    = case break isSep src of
        (last , []       ) → [last]
        (first, _sep:rest) → first : splitBy isSep rest

-- |>>> quoteStr "abc"
-- "\"abc\""
--
-- >>> quoteStr "ab\"c"
-- "\"ab\\\"c\""
quoteStr ∷ Ascii → AsciiBuilder
quoteStr str = A.toAsciiBuilder "\"" ⊕
               go (A.toByteString str) (∅) ⊕
               A.toAsciiBuilder "\""
    where
      go ∷ Strict.ByteString → AsciiBuilder → AsciiBuilder
      go bs ab
          = case Strict.break (≡ '"') bs of
              (x, y)
                  | Strict.null y
                      → ab ⊕ b2ab x
                  | otherwise
                      → go (Strict.tail y)
                           (ab ⊕ b2ab x ⊕ A.toAsciiBuilder "\\\"")

      b2ab ∷ Strict.ByteString → AsciiBuilder
      b2ab = A.toAsciiBuilder ∘ A.unsafeFromByteString

-- |>>> parseWWWFormURLEncoded "aaa=bbb&ccc=ddd"
-- [("aaa", "bbb"), ("ccc", "ddd")]
parseWWWFormURLEncoded ∷ Ascii → [(ByteString, ByteString)]
parseWWWFormURLEncoded src
    -- THINKME: We could gain some performance by using attoparsec
    -- here.
    | src ≡ ""  = []
    | otherwise = do pairStr ← splitBy (\ c → c ≡ ';' ∨ c ≡ '&') (A.toString src)
                     let (key, value) = break (≡ '=') pairStr
                     return ( unescape key
                            , unescape $ case value of
                                           ('=':val) → val
                                           val       → val
                            )
    where
      unescape ∷ String → ByteString
      unescape = Strict.pack ∘ unEscapeString ∘ map plusToSpace

      plusToSpace ∷ Char → Char
      plusToSpace '+' = ' '
      plusToSpace c   = c

-- |>>> splitPathInfo "http://example.com/foo/bar"
-- ["foo", "bar"]
splitPathInfo ∷ URI → [ByteString]
splitPathInfo uri
    = let reqPathStr = uriPath uri
          reqPath    = [unEscapeString x | x ← splitBy (≡ '/') reqPathStr, (¬) (null x)]
      in
        map Strict.pack reqPath

-- |>>> trim "  ab c d "
-- "ab c d"
trim ∷ String → String
trim = reverse ∘ f ∘ reverse ∘ f
    where
      f = dropWhile isSpace

-- |Convert a 'ByteString' to an 'Exp' representing it as a literal.
liftByteString ∷ ByteString → Q Exp
liftByteString bs
    = [| Strict.pack $(litE $ stringL $ Strict.unpack bs) |]

-- |Convert a 'Lazy.ByteString' to an 'Exp' representing it as a
-- literal.
liftLazyByteString ∷ Lazy.ByteString → Q Exp
liftLazyByteString = Lazy.foldrChunks f [| Lazy.Empty |]
    where
      f ∷ ByteString → Q Exp → Q Exp
      f bs e = [| Lazy.Chunk $(liftByteString bs) $e |]

-- |Convert an 'Ascii' to an 'Exp' representing it as a literal.
liftAscii ∷ Ascii → Q Exp
liftAscii a = [| A.unsafeFromByteString
                 $ unsafePerformIO
                 $ Strict.unsafePackAddressLen $len $ptr
               |]
    where
      bs ∷ Strict.ByteString
      bs = A.toByteString a

      len, ptr ∷ Q Exp
      len = lift $ Strict.length bs
      ptr = litE $ stringPrimL $ Strict.unpack bs

-- |Convert a 'CIAscii' to an 'Exp' representing it as a literal.
liftCIAscii ∷ CIAscii → Q Exp
liftCIAscii a = [| A.toCIAscii $(liftAscii $ A.fromCIAscii a) |]

-- |Convert a 'Text' to an 'Exp' representing it as a literal.
liftText ∷ Text → Q Exp
liftText t = [| T.pack $(litE $ stringL $ T.unpack t) |]

-- |Convert an arbitrary 'Map' to an 'Exp' representing it as a
-- literal, using a given key lifter and a value lifter.
liftMap ∷ Eq k ⇒ (k → Q Exp) → (v → Q Exp) → Map k v → Q Exp
liftMap liftK liftV m
    | M.null m  = [| M.empty |]
    | otherwise = [| M.fromDistinctAscList $(liftPairs (M.toAscList m)) |]
    where
      liftPairs       = listE ∘ map liftPair
      liftPair (k, v) = tupE [liftK k, liftV v]

-- |Convert an 'UTCTime' to an 'Exp' representing it as a literal.
liftUTCTime ∷ UTCTime → Q Exp
liftUTCTime (UTCTime {..})
    = [| UTCTime {
           utctDay     = $(liftDay utctDay)
         , utctDayTime = $(liftDiffTime utctDayTime)
         }
       |]

liftDay ∷ Day → Q Exp
liftDay (ModifiedJulianDay {..})
    = [| ModifiedJulianDay {
           toModifiedJulianDay = $(lift toModifiedJulianDay)
         }
       |]

liftDiffTime ∷ DiffTime → Q Exp
liftDiffTime dt = [| fromRational ($n % $d) ∷ DiffTime |]
    where
      n, d ∷ Q Exp
      n = lift $ numerator   $ toRational dt
      d = lift $ denominator $ toRational dt