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

    , noCaseCmp
    , noCaseEq

    , emptyHeaders
    , toHeaders
    , fromHeaders

    , headersP
    , hPutHeaders
    )
    where

import           Data.ByteString.Base (ByteString, toForeignPtr, w2c, inlinePerformIO)
import qualified Data.ByteString.Char8 as C8
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.Parser
import           Network.HTTP.Lucu.Parser.Http
import           Network.HTTP.Lucu.Utils
import           System.IO

type Headers = Map NCBS ByteString
newtype NCBS = NCBS ByteString

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

fromNCBS :: NCBS -> 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 :: ByteString -> 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 && l1 /= 0 = return LT
    | l1 /= 0 && 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 :: ByteString -> 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 :: ByteString -> a -> Maybe ByteString
    getHeader key a
        = key `seq` a `seq`
          M.lookup (toNCBS key) (getHeaders a)

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

    setHeader :: ByteString -> 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 :: [(ByteString, ByteString)] -> Headers
toHeaders xs = M.fromList [(toNCBS a, b) | (a, b) <- xs]


fromHeaders :: Headers -> [(ByteString, 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 (M.fromList xs)
    where
      header :: Parser (NCBS, 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 (toNCBS $ 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 :: Handle -> Headers -> IO ()
hPutHeaders h hds
    = h `seq` hds `seq`
      mapM_ putH (M.toList hds) >> hPutStr h "\r\n"
    where
      putH :: (NCBS, ByteString) -> IO ()
      putH (name, value)
          = name `seq` value `seq`
            do C8.hPutStr h (fromNCBS name)
               C8.hPutStr h (C8.pack ": ")
               C8.hPutStr h value
               C8.hPutStr h (C8.pack "\r\n")