module Network.HTTP.Lucu.Preprocess
    ( preprocess
    )
    where

import           Control.Concurrent.STM
import           Control.Monad
import qualified Data.ByteString as Strict (ByteString)
import qualified Data.ByteString.Char8 as C8 hiding (ByteString)
import           Data.Char
import           Data.Maybe
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Headers
import           Network.HTTP.Lucu.HttpVersion
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Request
import           Network.HTTP.Lucu.Response
import           Network.URI

{-

  * URI にホスト名が存在しない時、
    [1] HTTP/1.0 ならば Config を使って補完
    [2] HTTP/1.1 ならば Host ヘッダで補完。Host が無ければ 400。

  * Expect: に問題があった場合は 417 Expectation Failed に設定。
    100-continue 以外のものは全部 417 に。

  * Transfer-Encoding: に問題があったら 501 Not Implemented にする。具
    体的には、identity でも chunked でもなければ 501 Not Implemented に
    する。

  * メソッドが GET, HEAD, POST, PUT, DELETE の何れでもない場合は 501
    Not Implemented にする。

  * HTTP/1.0 でも HTTP/1.1 でもないリクエストに對しては 505 HTTP
    Version Not Supported を返す。

  * POST または PUT に Content-Length も Transfer-Encoding も無い時は、
    411 Length Required にする。

  * Content-Length の値が數値でなかったり負だったりしたら 400 Bad
    Request にする。

  * willDiscardBody その他の變數を設定する。

-}

preprocess :: Interaction -> STM ()
preprocess itr
    = itr `seq`
      do req <- readItr itr itrRequest fromJust

         let reqVer = reqVersion req

         if reqVer /= HttpVersion 1 0 &&
            reqVer /= HttpVersion 1 1 then

             do setStatus HttpVersionNotSupported
                writeItr itr itrWillClose True

           else
             -- HTTP/1.0 では Keep-Alive できない
             do when (reqVer == HttpVersion 1 0)
                     $ writeItr itr itrWillClose True

                -- ホスト部の補完
                completeAuthority req

                case reqMethod req of
                  GET    -> return ()
                  HEAD   -> writeItr itr itrWillDiscardBody True
                  POST   -> writeItr itr itrRequestHasBody True
                  PUT    -> writeItr itr itrRequestHasBody True
                  DELETE -> return ()
                  _      -> setStatus NotImplemented
                  
                preprocessHeader req
    where
      setStatus :: StatusCode -> STM ()
      setStatus !status
          = updateItr itr itrResponse
            $! \ res -> res {
                          resStatus = status
                        }

      completeAuthority :: Request -> STM ()
      completeAuthority !req
          = when (uriAuthority (reqURI req) == Nothing)
            $ if reqVersion req == HttpVersion 1 0 then
                  -- HTTP/1.0 なので Config から補完
                  do let conf = itrConfig itr
                         host = cnfServerHost conf
                         port = itrLocalPort itr
                         portStr
                              = case port of
                                  80 -> ""
                                  n  -> ':' : show n
                     updateAuthority host (C8.pack portStr)
              else
                  case getHeader (C8.pack "Host") req of
                    Just str -> let (host, portStr) = parseHost str
                                in updateAuthority host portStr
                    Nothing  -> setStatus BadRequest


      parseHost :: Strict.ByteString -> (Strict.ByteString, Strict.ByteString)
      parseHost = C8.break (== ':')


      updateAuthority :: Strict.ByteString -> Strict.ByteString -> STM ()
      updateAuthority host portStr
          = host `seq` portStr `seq`
            updateItr itr itrRequest
            $! \ (Just req) -> Just req {
                                 reqURI = let uri = reqURI req
                                          in uri {
                                               uriAuthority = Just URIAuth {
                                                                   uriUserInfo = ""
                                                                 , uriRegName  = C8.unpack host
                                                                 , uriPort     = C8.unpack portStr
                                                              }
                                             }
                               }
                

      preprocessHeader :: Request -> STM ()
      preprocessHeader req
          = req `seq`
            do case getHeader (C8.pack "Expect") req of
                 Nothing    -> return ()
                 Just value -> if value `noCaseEq` C8.pack "100-continue" then
                                   writeItr itr itrExpectedContinue True
                               else
                                   setStatus ExpectationFailed

               case getHeader (C8.pack "Transfer-Encoding") req of
                 Nothing    -> return ()
                 Just value -> unless (value `noCaseEq` C8.pack "identity")
                                   $ if value `noCaseEq` C8.pack "chunked" then
                                         writeItr itr itrRequestIsChunked True
                                     else
                                         setStatus NotImplemented

               case getHeader (C8.pack "Content-Length") req of
                 Nothing    -> return ()
                 Just value -> if C8.all isDigit value then
                                   do let Just (len, _) = C8.readInt value
                                      writeItr itr itrReqChunkLength    $ Just len
                                      writeItr itr itrReqChunkRemaining $ Just len
                               else
                                   setStatus BadRequest

               case getHeader (C8.pack "Connection") req of
                 Nothing    -> return ()
                 Just value -> when (value `noCaseEq` C8.pack "close")
                                   $ writeItr itr itrWillClose True