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
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
          = 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 :: Int)
                                  _            -> Nothing
                         portStr
                              = case port of
                                  Just 80 -> Just ""
                                  Just n  -> Just $ ":" ++ show n
                                  Nothing -> Nothing
                     case portStr of
                       Just str -> updateAuthority host (C8.pack str)
                       -- FIXME: このエラーの原因は、listen してゐるソ
                       -- ケットが INET でない故にポート番號が分からな
                       -- い事だが、その事をどうにかして通知した方が良
                       -- いと思ふ。stderr？
                       Nothing  -> setStatus InternalServerError
              else
                  do 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 -> if value `noCaseEq` C8.pack "identity" then
                                   return ()
                               else
                                   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 -> if value `noCaseEq` C8.pack "close" then
                                   writeItr itr itrWillClose True
                               else
                                   return ()