{-# LANGUAGE
    FlexibleInstances
  , GeneralizedNewtypeDeriving
  , MultiParamTypeClasses
  , TypeSynonymInstances
  , OverloadedStrings
  , UnicodeSyntax
  #-}
-- |An internal module for HTTP headers.
module Network.HTTP.Lucu.Headers
    ( Headers
    , HasHeaders(..)

    , headers
    , printHeaders
    )
    where
import Control.Applicative hiding (empty)
import Control.Applicative.Unicode hiding ((∅))
import Control.Arrow
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8 as P
import Data.List (intersperse)
import qualified Data.Map as M (Map)
import Data.Collections
import Data.Collections.BaseInstances ()
import Data.Monoid
import Data.Monoid.Unicode
import Network.HTTP.Lucu.Parser.Http
import Prelude hiding (filter, foldr, lookup, null)
import Prelude.Unicode

newtype Headers
    = Headers (M.Map CIAscii Ascii)
      deriving (Eq, Show)

class HasHeaders a where
    getHeaders ∷ a → Headers
    setHeaders ∷ a → Headers → a

    modifyHeaders ∷ (Headers → Headers) → a → a
    {-# INLINE modifyHeaders #-}
    modifyHeaders = (setHeaders ⊛) ∘ (∘ getHeaders)

    getHeader ∷ CIAscii → a → Maybe Ascii
    {-# INLINE getHeader #-}
    getHeader = (∘ getHeaders) ∘ lookup

    hasHeader ∷ CIAscii → a → Bool
    {-# INLINE hasHeader #-}
    hasHeader = (∘ getHeaders) ∘ member

    getCIHeader ∷ CIAscii → a → Maybe CIAscii
    {-# INLINE getCIHeader #-}
    getCIHeader = ((A.toCIAscii <$>) ∘) ∘ getHeader

    deleteHeader ∷ CIAscii → a → a
    {-# INLINE deleteHeader #-}
    deleteHeader = modifyHeaders ∘ delete

    setHeader ∷ CIAscii → Ascii → a → a
    {-# INLINE setHeader #-}
    setHeader = (modifyHeaders ∘) ∘ insertWith const

instance HasHeaders Headers where
    getHeaders   = id
    setHeaders _ = id

-- |@'insert' (key, val)@ merges @val@ with an existing one if any.
instance Unfoldable Headers (CIAscii, Ascii) where
    {-# INLINE insert #-}
    insert (key, val) (Headers m)
        = Headers $ insertWith merge key val m
    {-# INLINE empty #-}
    empty
        = Headers empty
    {-# INLINE singleton #-}
    singleton p
        = Headers $ singleton p
    {-# INLINE insertMany #-}
    insertMany f (Headers m)
        = Headers $ insertMany f m
    {-# INLINE insertManySorted #-}
    insertManySorted f (Headers m)
        = Headers $ insertManySorted f m

instance Foldable Headers (CIAscii, Ascii) where
    {-# INLINE null #-}
    null (Headers m) = null m
    {-# INLINE size #-}
    size (Headers m) = size m
    {-# INLINE foldr #-}
    foldr f b (Headers m) = foldr f b m

instance Collection Headers (CIAscii, Ascii) where
    {-# INLINE filter #-}
    filter f (Headers m) = Headers $ filter f m

instance Indexed Headers CIAscii Ascii where
    {-# INLINE index #-}
    index k (Headers m) = index k m
    {-# INLINE adjust #-}
    adjust f k (Headers m) = Headers $ adjust f k m
    {-# INLINE inDomain #-}
    inDomain k (Headers m) = inDomain k m

instance Monoid Headers where
    {-# INLINE mempty #-}
    mempty = empty
    {-# INLINE mappend #-}
    mappend (Headers α) (Headers β)
        = Headers $ insertManySorted β α

-- FIXME: override every methods
instance Map Headers CIAscii Ascii where
    {-# INLINE lookup #-}
    lookup k (Headers m) = lookup k m
    {-# INLINE insertWith #-}
    insertWith f k v (Headers m)
        = Headers $ insertWith f k v m
    {-# INLINE mapWithKey #-}
    mapWithKey f (Headers m)
        = Headers $ mapWithKey f m
    {-# INLINE unionWith #-}
    unionWith f (Headers α) (Headers β)
        = Headers $ unionWith f α β
    {-# INLINE intersectionWith #-}
    intersectionWith f (Headers α) (Headers β)
        = Headers $ intersectionWith f α β
    {-# INLINE differenceWith #-}
    differenceWith f (Headers α) (Headers β)
        = Headers $ differenceWith f α β
    {-# INLINE isSubmapBy #-}
    isSubmapBy f (Headers α) (Headers β)
        = isSubmapBy f α β
    {-# INLINE isProperSubmapBy #-}
    isProperSubmapBy f (Headers α) (Headers β)
        = isProperSubmapBy f α β

instance SortingCollection Headers (CIAscii, Ascii) where
    {-# INLINE minView #-}
    minView (Headers m) = second Headers <$> minView m

merge ∷ Ascii → Ascii → Ascii
{-# INLINE merge #-}
merge a b
    | nullA a ∧ nullA b = (∅)
    | nullA a           = b
    |           nullA b = a
    | otherwise         = a ⊕ ", " ⊕ b
    where
      nullA ∷ Ascii → Bool
      {-# INLINE nullA #-}
      nullA = null ∘ A.toByteString

{-
  message-header = field-name ":" [ field-value ]
  field-name     = token
  field-value    = *( field-content | LWS )
  field-content  = <field-value を構成し、*TEXT あるいは
                    token, separators, quoted-string を連結
                    したものから成る OCTET>

  field-value の先頭および末尾にある LWS は全て削除され、それ以外の
  LWS は單一の SP に變換される。
-}
headers ∷ Parser Headers
{-# INLINEABLE headers #-}
headers = do xs ← P.many header
             crlf
             return $ fromFoldable xs
    where
      header ∷ Parser (CIAscii, Ascii)
      header = do name ← A.toCIAscii <$> token
                  void $ char ':'
                  skipMany lws
                  values ← content `sepBy` try lws
                  skipMany (try lws)
                  crlf
                  return (name, joinValues values)

      content ∷ Parser Ascii
      {-# INLINE content #-}
      content = A.unsafeFromByteString
                <$>
                takeWhile1 (\c → isText c ∧ c ≢ '\x20')

      joinValues ∷ [Ascii] → Ascii
      {-# INLINE joinValues #-}
      joinValues = A.fromAsciiBuilder
                   ∘ mconcat
                   ∘ intersperse (A.toAsciiBuilder "\x20")
                   ∘ map A.toAsciiBuilder

printHeaders ∷ Headers → AsciiBuilder
printHeaders (Headers m)
    = mconcat (map printHeader (fromFoldable m)) ⊕
      A.toAsciiBuilder "\x0D\x0A"
    where
      printHeader ∷ (CIAscii, Ascii) → AsciiBuilder
      printHeader (name, value)
          = A.toAsciiBuilder (A.fromCIAscii name) ⊕
            A.toAsciiBuilder ": "                 ⊕
            A.toAsciiBuilder value                ⊕
            A.toAsciiBuilder "\x0D\x0A"