module Network.HTTP.Lucu.Headers
    ( Headers
    , HasHeaders(..)

    , noCaseCmp
    , noCaseEq

    , emptyHeaders
    , toHeaders
    , fromHeaders

    , headersP
    , hPutHeaders
    )
    where

import qualified Data.ByteString as Strict (ByteString)
import           Data.ByteString.Internal (toForeignPtr, w2c, inlinePerformIO)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import           Data.Char
import           Data.List
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Word
import           Foreign.ForeignPtr
import           Foreign.Ptr
import           Foreign.Storable
import           Network.HTTP.Lucu.HandleLike
import           Network.HTTP.Lucu.Parser
import           Network.HTTP.Lucu.Parser.Http
import           Network.HTTP.Lucu.Utils

type Headers = Map NCBS Strict.ByteString
newtype NCBS = NCBS Strict.ByteString

toNCBS :: Strict.ByteString -> NCBS
toNCBS = NCBS
{-# INLINE toNCBS #-}

fromNCBS :: NCBS -> Strict.ByteString
fromNCBS (NCBS x) = x
{-# INLINE fromNCBS #-}

instance Eq NCBS where
    (NCBS a) == (NCBS b) = a == b

instance Ord NCBS where
    (NCBS a) `compare` (NCBS b) = a `noCaseCmp` b

instance Show NCBS where
    show (NCBS x) = show x

noCaseCmp :: Strict.ByteString -> Strict.ByteString -> Ordering
noCaseCmp a b = a `seq` b `seq`
                toForeignPtr a `cmp` toForeignPtr b
    where
      cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Ordering
      cmp (x1, s1, l1) (x2, s2, l2)
          | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
          | l1 == 0  && l2 == 0               = EQ
          | x1 == x2 && s1 == s2 && l1 == l2  = EQ
          | otherwise
              = inlinePerformIO $
                withForeignPtr x1 $ \ p1 ->
                withForeignPtr x2 $ \ p2 ->
                noCaseCmp' (p1 `plusPtr` s1) l1 (p2 `plusPtr` s2) l2


-- もし先頭の文字列が等しければ、短い方が小さい。
noCaseCmp' :: Ptr Word8 -> Int -> Ptr Word8 -> Int -> IO Ordering
noCaseCmp' p1 l1 p2 l2
    | p1 `seq` l1 `seq` p2 `seq` l2 `seq` False = undefined
    | l1 == 0 && l2 == 0 = return EQ
    | l1 == 0            = return LT
    |            l2 == 0 = return GT
    | otherwise
        = do c1 <- peek p1
             c2 <- peek p2
             case toLower (w2c c1) `compare` toLower (w2c c2) of
               EQ -> noCaseCmp' (p1 `plusPtr` 1) (l1 - 1) (p2 `plusPtr` 1) (l2 - 1)
               x  -> return x


noCaseEq :: Strict.ByteString -> Strict.ByteString -> Bool
noCaseEq a b = a `seq` b `seq`
               toForeignPtr a `cmp` toForeignPtr b
    where
      cmp :: (ForeignPtr Word8, Int, Int) -> (ForeignPtr Word8, Int, Int) -> Bool
      cmp (x1, s1, l1) (x2, s2, l2)
          | x1 `seq` s1 `seq` l1 `seq` x2 `seq` s2 `seq` l2 `seq` False = undefined
          | l1 /= l2                          = False
          | l1 == 0  && l2 == 0               = True
          | x1 == x2 && s1 == s2 && l1 == l2  = True
          | otherwise
              = inlinePerformIO $
                withForeignPtr x1 $ \ p1 ->
                withForeignPtr x2 $ \ p2 ->
                noCaseEq' (p1 `plusPtr` s1) (p2 `plusPtr` s2) l1


noCaseEq' :: Ptr Word8 -> Ptr Word8 -> Int -> IO Bool
noCaseEq' p1 p2 l
    | p1 `seq` p2 `seq` l `seq` False = undefined
    | l == 0    = return True
    | otherwise
        = do c1 <- peek p1
             c2 <- peek p2
             if toLower (w2c c1) == toLower (w2c c2) then
                 noCaseEq' (p1 `plusPtr` 1) (p2 `plusPtr` 1) (l - 1)
               else
                 return False


class HasHeaders a where
    getHeaders :: a -> Headers
    setHeaders :: a -> Headers -> a

    getHeader :: Strict.ByteString -> a -> Maybe Strict.ByteString
    getHeader key a
        = key `seq` a `seq`
          M.lookup (toNCBS key) (getHeaders a)

    deleteHeader :: Strict.ByteString -> a -> a
    deleteHeader key a
        = key `seq` a `seq`
          setHeaders a $ M.delete (toNCBS key) (getHeaders a)

    setHeader :: Strict.ByteString -> Strict.ByteString -> a -> a
    setHeader key val a
        = key `seq` val `seq` a `seq`
          setHeaders a $ M.insert (toNCBS key) val (getHeaders a)


emptyHeaders :: Headers
emptyHeaders = M.empty


toHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers
toHeaders xs = mkHeaders xs M.empty


mkHeaders :: [(Strict.ByteString, Strict.ByteString)] -> Headers -> Headers
mkHeaders []              m = m
mkHeaders ((key, val):xs) m = mkHeaders xs $
                              case M.lookup (toNCBS key) m of
                                Nothing  -> M.insert (toNCBS key) val m
                                Just old -> M.insert (toNCBS key) (merge old val) m
    where
      merge :: Strict.ByteString -> Strict.ByteString -> Strict.ByteString
      -- カンマ區切りである事を假定する。RFC ではカンマ區切りに出來ない
      -- ヘッダは複數個あってはならない事になってゐる。
      merge a b
          | C8.null a && C8.null b = C8.empty
          | C8.null a              = b
          |              C8.null b = a
          | otherwise              = C8.concat [a, C8.pack ", ", b]


fromHeaders :: Headers -> [(Strict.ByteString, Strict.ByteString)]
fromHeaders hs = [(fromNCBS a, b) | (a, b) <- M.toList hs]


{-
  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 に變換される。
-}
headersP :: Parser Headers
headersP = do xs <- many header
              crlf
              return $! toHeaders xs
    where
      header :: Parser (Strict.ByteString, Strict.ByteString)
      header = do name <- token
                  char ':'
                  -- FIXME: これは多少インチキだが、RFC 2616 のこの部分
                  -- の記述はひどく曖昧であり、この動作が本當に間違って
                  -- ゐるのかどうかも良く分からない。例へば
                  -- quoted-string の内部にある空白は纏めていいのか惡い
                  -- のか？直勸的には駄目さうに思へるが、そんな記述は見
                  -- 付からない。
                  contents <- many (lws <|> many1 text)
                  crlf
                  let value = foldr (++) "" contents
                      norm  = normalize value
                  return (C8.pack name, C8.pack norm)

      normalize :: String -> String
      normalize = trimBody . trim isWhiteSpace

      trimBody = foldr (++) []
                 . map (\ s -> if head s == ' ' then
                                   " "
                               else
                                   s)
                 . group
                 . map (\ c -> if isWhiteSpace c
                               then ' '
                               else c)


hPutHeaders :: HandleLike h => h -> Headers -> IO ()
hPutHeaders h hds
    = h `seq` hds `seq`
      mapM_ putH (M.toList hds) >> hPutBS h (C8.pack "\r\n")
    where
      putH :: (NCBS, Strict.ByteString) -> IO ()
      putH (name, value)
          = name `seq` value `seq`
            do hPutBS h (fromNCBS name)
               hPutBS h (C8.pack ": ")
               hPutBS h value
               hPutBS h (C8.pack "\r\n")