{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Preprocess
    ( preprocess
    )
    where
import Control.Applicative
import Control.Concurrent.STM
import Control.Monad
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import Data.ByteString (ByteString)
import qualified Data.ByteString.Char8 as C8
import Data.Char
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
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
import Prelude.Unicode

{-
  TODO: Tanslate this memo into English. It doesn't make sense to
  non-Japanese speakers.

  * 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@(Interaction {..})
    = do req ← fromJust <$> readTVar itrRequest

         let reqVer = reqVersion req

         if reqVer ≢ HttpVersion 1 0 ∧
            reqVer ≢ HttpVersion 1 1 then

             do setStatus itr HttpVersionNotSupported
                writeTVar itrWillClose True

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

                -- ホスト部の補完
                completeAuthority itr req

                case reqMethod req of
                  GET    → return ()
                  HEAD   → writeTVar itrWillDiscardBody True
                  POST   → writeTVar itrRequestHasBody  True
                  PUT    → writeTVar itrRequestHasBody  True
                  DELETE → return ()
                  _      → setStatus itr NotImplemented
                  
                preprocessHeader itr req

setStatus ∷ Interaction → StatusCode → STM ()
setStatus (Interaction {..}) sc
    = do res ← readTVar itrResponse
         let res' = res {
                      resStatus = sc
                    }
         writeTVar itrResponse res'

completeAuthority ∷ Interaction → Request → STM ()
completeAuthority itr@(Interaction {..}) req
    = when (isNothing $ uriAuthority $ reqURI req)
          $ if reqVersion req == HttpVersion 1 0 then
                -- HTTP/1.0 なので Config から補完
                do let host    = cnfServerHost itrConfig
                       portStr = case itrLocalPort of
                                   80 → ""
                                   n  → ':' : show n
                   updateAuthority host $ A.unsafeFromString portStr
            else
                case getHeader "Host" req of
                  Just str → let (host, portStr) = parseHost str
                             in
                               updateAuthority host portStr
                  Nothing  → setStatus itr BadRequest

parseHost ∷ Ascii → (Text, Ascii)
parseHost = C8.break (≡ ':')

updateAuthority ∷ Text → Ascii → STM ()
updateAuthority host portStr
    = do Just req ← readTVar itrRequest
         let uri  = reqURI req
             uri' = uri {
                      uriAuthority = Just URIAuth {
                                       uriUserInfo = ""
                                     , uriRegName  = T.unpack host
                                     , uriPort     = A.toString portStr
                                     }
                    }
             req' = req { reqURI = uri' }
         writeTVar itrRequest $ Just req'

preprocessHeader ∷ Interaction → Request → STM ()
preprocessHeader (Interaction {..}) req
    = do case getCIHeader "Expect" req of
           Nothing    → return ()
           Just value → if value ≡ "100-continue" then
                             writeTVar itrExpectedContinue True
                         else
                             setStatus ExpectationFailed

         case getCIHeader "Transfer-Encoding" req of
           Nothing    → return ()
           Just value → unless (value ≡ "identity")
                            $ if value ≡ "chunked" then
                                  writeTVar itrRequestIsChunked True
                              else
                                  setStatus NotImplemented

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

         case getCIHeader "Connection" req of
           Nothing    → return ()
           Just value → when (value ≡ "close")
                            $ writeTVar itrWillClose True