{-# LANGUAGE
    FlexibleInstances
  , GeneralizedNewtypeDeriving
  , MultiParamTypeClasses
  , TemplateHaskell
  , TypeSynonymInstances
  , OverloadedStrings
  , UnicodeSyntax
  #-}
{-# OPTIONS_GHC -fno-warn-missing-methods #-}
-- |An internal module for HTTP headers.
module Network.HTTP.Lucu.Headers
    ( Headers
    , HasHeaders(..)
    )
    where
import Control.Applicative hiding (empty)
import Control.Applicative.Unicode hiding ((∅))
import Control.Monad
import Data.Ascii (Ascii, AsciiBuilder, CIAscii)
import qualified Data.Ascii as A
import Data.Attoparsec.Char8
import qualified Data.Collections.Newtype.TH as C
import Data.Convertible.Base
import Data.Convertible.Instances.Ascii ()
import Data.Convertible.Utils
import Data.Default
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 (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 = ((cs <$>) ∘) ∘ 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

C.derive [d| instance Foldable   Headers (CIAscii, Ascii)
             instance Collection Headers (CIAscii, Ascii)
             instance Indexed    Headers  CIAscii  Ascii
             instance Map        Headers  CIAscii  Ascii
             instance SortingCollection Headers (CIAscii, Ascii)
           |]

-- |@'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 = Headers ∘ singleton

instance Monoid Headers where
    {-# INLINE mempty #-}
    mempty  = empty
    {-# INLINE mappend #-}
    mappend = insertMany

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

instance ConvertSuccess Headers Ascii where
    {-# INLINE convertSuccess #-}
    convertSuccess = convertSuccessVia ((⊥) ∷ AsciiBuilder)

instance ConvertSuccess Headers AsciiBuilder where
    {-# INLINEABLE convertSuccess #-}
    convertSuccess (Headers m)
        = mconcat (header <$> fromFoldable m) ⊕ cs ("\x0D\x0A" ∷ Ascii)
        where
          header ∷ (CIAscii, Ascii) → AsciiBuilder
          {-# INLINE header #-}
          header (name, value)
              = cs name                 ⊕
                cs (": " ∷ Ascii)       ⊕
                cs value                ⊕
                cs ("\x0D\x0A" ∷ Ascii)

deriveAttempts [ ([t| Headers |], [t| Ascii        |])
               , ([t| Headers |], [t| AsciiBuilder |])
               ]

{-
  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 に變換される。
-}
instance Default (Parser Headers) where
    {-# INLINEABLE def #-}
    def = do xs ← many header
             crlf
             return $ fromFoldable xs
        where
          header ∷ Parser (CIAscii, Ascii)
          {-# INLINEABLE header #-}
          header = do name ← cs <$> token
                      void $ char ':'
                      skipMany lws
                      values ← content `sepBy` try lws
                      skipMany (try lws)
                      crlf
                      return (name, joinValues values)

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

          joinValues ∷ [Ascii] → Ascii
          {-# INLINEABLE joinValues #-}
          joinValues = cs
                       ∘ mconcat
                       ∘ intersperse (cs ("\x20" ∷ Ascii) ∷ AsciiBuilder)
                       ∘ (cs <$>)