{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.Preprocess
    ( AugmentedRequest(..)
    , RequestBodyLength(..)
    , preprocess
    )
    where
import Control.Applicative
import Control.Monad
import Control.Monad.State
import Data.Ascii (Ascii)
import qualified Data.Ascii as A
import qualified Data.ByteString.Char8 as C8
import Data.Maybe
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import Network.HTTP.Lucu.Headers
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.Socket
import Network.URI
import Prelude.Unicode

data AugmentedRequest
    = AugmentedRequest {
        arRequest          ∷ !(Maybe Request)
      , arInitialStatus    ∷ !StatusCode
      , arWillClose        ∷ !Bool
      , arWillDiscardBody  ∷ !Bool
      , arExpectedContinue ∷ !(Maybe Bool)
      , arReqBodyLength    ∷ !(Maybe RequestBodyLength)
      }

data RequestBodyLength
    = Fixed !Int
    | Chunked
    deriving (Eq, Show)

preprocess ∷ Text
           → PortNumber
           → Either StatusCode Request
           → AugmentedRequest
preprocess localHost localPort request
    = case request of
        Right req
            → preprocess' localHost localPort req
        Left sc
            → unparsable sc

unparsable ∷ StatusCode → AugmentedRequest
unparsable sc
    = AugmentedRequest {
        arRequest          = Nothing
      , arInitialStatus    = sc
      , arWillClose        = True
      , arWillDiscardBody  = False
      , arExpectedContinue = Nothing
      , arReqBodyLength    = Nothing
      }

preprocess' ∷ Text → PortNumber → Request → AugmentedRequest
preprocess' localHost localPort req@(Request {..})
    = execState go initialAR
    where
      initialAR ∷ AugmentedRequest
      initialAR = AugmentedRequest {
                    arRequest          = Just req
                  , arInitialStatus    = Ok
                  , arWillClose        = False
                  , arWillDiscardBody  = False
                  , arExpectedContinue = Just False
                  , arReqBodyLength    = Nothing
                  }

      go ∷ State AugmentedRequest ()
      go = do examineHttpVersion
              examineMethod
              examineAuthority localHost localPort
              examineHeaders
              examineBodyLength

setRequest ∷ Request → State AugmentedRequest ()
setRequest req
    = modify $ \ar → ar { arRequest = Just req }

setStatus ∷ StatusCode → State AugmentedRequest ()
setStatus sc
    = modify $ \ar → ar { arInitialStatus = sc }

setWillClose ∷ Bool → State AugmentedRequest ()
setWillClose b
    = modify $ \ar → ar { arWillClose = b }

setBodyLength ∷ Maybe RequestBodyLength → State AugmentedRequest ()
setBodyLength len
    = modify $ \ar → ar { arReqBodyLength = len }

examineHttpVersion ∷ State AugmentedRequest ()
examineHttpVersion
    = do req ← gets (fromJust ∘ arRequest)
         case reqVersion req of
           -- HTTP/1.0 requests can't Keep-Alive.
           HttpVersion 1 0
               → setWillClose True
           HttpVersion 1 1
               → return ()
           _   → do setStatus    HttpVersionNotSupported
                    setWillClose True

examineMethod ∷ State AugmentedRequest ()
examineMethod
    = do req ← gets (fromJust ∘ arRequest)
         case reqMethod req of
           GET    → return ()
           HEAD   → modify $ \ar → ar { arWillDiscardBody = True }
           POST   → return ()
           PUT    → return ()
           DELETE → return ()
           _      → setStatus NotImplemented

examineAuthority ∷ Text → PortNumber → State AugmentedRequest ()
examineAuthority localHost localPort
    = do req ← gets (fromJust ∘ arRequest)
         when (isNothing $ uriAuthority $ reqURI req) $
             case reqVersion req of
               -- HTTP/1.0 requests have no Host header so complete it
               -- with the configuration value.
               HttpVersion 1 0
                   → let host = localHost
                         port = case localPort of
                                  80 → ""
                                  n  → A.unsafeFromString $ ':':show n
                         req' = updateAuthority host port req
                     in
                       setRequest req'
               -- HTTP/1.1 requests MUST have a Host header.
               HttpVersion 1 1
                   → case getHeader "Host" req of
                        Just str
                            → let (host, port)
                                       = parseHost str
                                  req' = updateAuthority host port req
                              in
                                setRequest req'
                        Nothing
                            → setStatus BadRequest
               -- Should never reach here...
               ver → fail ("internal error: unknown version: " ⧺ show ver)

parseHost ∷ Ascii → (Text, Ascii)
parseHost hp
    = let (h, p) = C8.break (≡ ':') $ A.toByteString hp
          -- FIXME: should decode punycode here.
          hText  = T.decodeUtf8 h
          pAscii = A.unsafeFromByteString p
      in
        (hText, pAscii)

updateAuthority ∷ Text → Ascii → Request → Request
updateAuthority host port req
    = let uri  = reqURI req
          uri' = uri {
                   uriAuthority = Just URIAuth {
                                    uriUserInfo = ""
                                  , uriRegName  = T.unpack host
                                  , uriPort     = A.toString port
                                  }
                 }
      in
        req { reqURI = uri' }

examineHeaders ∷ State AugmentedRequest ()
examineHeaders
    = do req ← gets (fromJust ∘ arRequest)

         case getCIHeader "Expect" req of
           Nothing → return ()
           Just v
               | v ≡ "100-continue"
                   → modify $ \ar → ar { arExpectedContinue = Just True }
               | otherwise
                   → setStatus ExpectationFailed

         case getCIHeader "Transfer-Encoding" req of
           Nothing → return ()
           Just v
               | v ≡ "identity"
                   → return ()
               | v ≡ "chunked"
                   → setBodyLength $ Just Chunked
               | otherwise
                   → setStatus NotImplemented

         case A.toByteString <$> getHeader "Content-Length" req of
           Nothing    → return ()
           Just value → case C8.readInt value of
                           Just (len, garbage)
                               | C8.null garbage ∧ len ≥ 0
                                   → setBodyLength $ Just $ Fixed len
                           _       → setStatus BadRequest

         case getCIHeader "Connection" req of
           Just v
               | v ≡ "close"
                   → setWillClose True
           _       → return ()

examineBodyLength ∷ State AugmentedRequest ()
examineBodyLength
    = do req ← gets (fromJust ∘ arRequest)
         len ← gets arReqBodyLength
         if reqHasBody req then
             -- POST and PUT requests must have an entity body.
             when (isNothing len)
                 $ setStatus LengthRequired
         else
             -- Other requests must NOT have an entity body.
             when (isJust len)
                 $ setStatus BadRequest