-- #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.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.HTTP.Lucu.Utils
import           Network
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 その他の變數を設定する。

-}

import GHC.Conc (unsafeIOToSTM)

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
                  _    -> setStatus NotImplemented
                  
                mapM_ (preprocessHeader itr) (reqHeaders req)
    where
      setStatus :: StatusCode -> STM ()
      setStatus status
          = status `seq`
            updateItr itr itrResponse
            $! \ res -> res {
                          resStatus = status
                        }

      completeAuthority :: Request -> STM ()
      completeAuthority req
          = req `seq`
            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 = case cnfServerPort conf of
                                  PortNumber n -> Just $ fromIntegral n
                                  _            -> Nothing
                         portStr
                              = case port of
                                  Just 80 -> Just ""
                                  Just n  -> Just $ ":" ++ show n
                                  Nothing -> Nothing
                     case portStr of
                       Just str -> updateAuthority host str
                       -- FIXME: このエラーの原因は、listen してゐるソ
                       -- ケットが INET でない故にポート番號が分からな
                       -- い事だが、その事をどうにかして通知した方が良
                       -- いと思ふ。stderr？
                       Nothing  -> setStatus InternalServerError
              else
                  do case getHeader "Host" req of
                       Just str -> let (host, portStr) = parseHost str
                                   in updateAuthority host portStr
                       Nothing  -> setStatus BadRequest


      parseHost :: String -> (String, String)
      parseHost = break (== ':')


      updateAuthority :: String -> String -> 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  = host
                                                                 , uriPort     = portStr
                                                              }
                                             }
                               }
                

      preprocessHeader :: Interaction -> (String, String) -> STM ()
      preprocessHeader itr (name, value)
          = itr `seq` name `seq` value `seq`
            case map toLower name of

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

              "transfer-encoding"
                  -> case map toLower value of
                       "identity" -> return ()
                       "chunked"  -> writeItr itr itrRequestIsChunked True
                       _          -> setStatus 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 BadRequest

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

              _ -> return ()