-- #hide
module Network.HTTP.Lucu.Preprocess
    ( preprocess
    )
    where

import           Control.Concurrent.STM
import           Control.Monad
import           Data.Char
import           Data.Maybe
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.HTTP.Lucu.Utils
import           Network.URI

{-

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

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

  * HTTP/1.1 リクエストであり、URI にホスト名が無く、Host: ヘッダも無い
    場合には 400 Bad Request にする。

  * メソッドが 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 その他の變數を設定する。

-}

import GHC.Conc (unsafeIOToSTM)

preprocess :: Interaction -> STM ()
preprocess itr
    = do let req    = fromJust $ itrRequest itr
             reqVer = reqVersion req

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

             do setStatus itr HttpVersionNotSupported
                writeItr itr itrWillClose True

           else
             do if reqVer == HttpVersion 1 0 then
                    -- HTTP/1.0 では Keep-Alive できない
                    writeItr itr itrWillClose True
                  else
                    -- URI または Host: ヘッダのどちらかにホストが無ければ
                    -- ならない。
                    when (uriAuthority (reqURI req) == Nothing &&
                          getHeader "Host" req      == Nothing)
                             $ setStatus itr BadRequest

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

      preprocessHeader itr (name, value)
          = case map toLower name of

              "expect"
                  -> if value `noCaseEq` "100-continue" then
                         writeItr itr itrExpectedContinue True
                     else
                         setStatus itr ExpectationFailed

              "transfer-encoding"
                  -> case map toLower value of
                       "identity" -> return ()
                       "chunked"  -> writeItr itr itrRequestIsChunked True
                       _          -> setStatus itr NotImplemented

              "content-length"
                  -> if all isDigit value then
                         do let len = read value
                            writeItr itr itrReqChunkLength    $ Just len
                            writeItr itr itrReqChunkRemaining $ Just len
                     else
                         setStatus itr BadRequest

              "connection"
                  -> case map toLower value of
                       "close"      -> writeItr itr itrWillClose True
                       _            -> return ()

              _ -> return ()