{-# LANGUAGE
    DoAndIfThenElse
  , OverloadedStrings
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.RequestReader
    ( requestReader
    )
    where
import Control.Concurrent
import Control.Concurrent.STM
import Control.Exception hiding (block)
import Control.Monad
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
import qualified Data.Strict.Maybe as S
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence.Unicode hiding ((∅))
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Resource.Tree
import Network.Socket
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)

data Context h
    = Context {
        cConfig    ∷ !Config
      , cResTree   ∷ !ResTree
      , cFallbacks ∷ ![FallbackHandler]
      , cHandle    ∷ !h
      , cPort      ∷ !PortNumber
      , cAddr      ∷ !SockAddr
      , cQueue     ∷ !InteractionQueue
      }

data ChunkReceivingState
    = Initial
    | InChunk !Int -- ^Number of remaining octets in the current
                   -- chunk. It's always positive.

requestReader ∷ HandleLike h
              ⇒ Config
              → ResTree
              → [FallbackHandler]
              → h
              → PortNumber
              → SockAddr
              → InteractionQueue
              → IO ()
requestReader cnf tree fbs h port addr tQueue
    = do input ← hGetLBS h
         acceptRequest (Context cnf tree fbs h port addr tQueue) input
      `catches`
      [ Handler handleAsyncE
      , Handler handleBIOS
      , Handler handleOthers
      ]
    where
      handleAsyncE ∷ AsyncException → IO ()
      handleAsyncE ThreadKilled = return ()
      handleAsyncE e            = dump e

      handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
      handleBIOS = dump

      handleOthers ∷ SomeException → IO ()
      handleOthers = dump

      dump ∷ Exception e ⇒ e → IO ()
      dump e
          = do hPutStrLn stderr "requestReader caught an exception:"
               hPutStrLn stderr (show $ toException e)

acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
acceptRequest ctx@(Context {..}) input
    -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
    -- それが限度以下になるまで待つ。
    = do atomically $
             do queue ← readTVar cQueue
                when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
                    retry
         -- リクエストを讀む。パースできない場合は直ちに 400 Bad
         -- Request 應答を設定し、それを出力してから切斷するやうに
         -- ResponseWriter に通知する。
         case LP.parse requestP input of
           LP.Done input' req → acceptParsableRequest ctx req input'
           LP.Fail _ _ _      → acceptNonparsableRequest ctx

acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
acceptNonparsableRequest ctx@(Context {..})
    = do syi ← mkSyntacticallyInvalidInteraction cConfig
         enqueue ctx syi

acceptParsableRequest ∷ HandleLike h
                      ⇒ Context h
                      → Request
                      → Lazy.ByteString
                      → IO ()
acceptParsableRequest ctx@(Context {..}) req input
    = do let ar = preprocess (cnfServerHost cConfig) cPort req
         if isError $ arInitialStatus ar then
             acceptSemanticallyInvalidRequest ctx ar input
         else
             do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
                case rsrc of
                  Nothing
                      → do let ar' = ar { arInitialStatus = NotFound }
                           acceptSemanticallyInvalidRequest ctx ar' input
                  Just (path, def)
                      → acceptRequestForResource ctx ar input path def

acceptSemanticallyInvalidRequest ∷ HandleLike h
                                 ⇒ Context h
                                 → AugmentedRequest
                                 → Lazy.ByteString
                                 → IO ()
acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
    = do sei ← mkSemanticallyInvalidInteraction cConfig ar
         enqueue ctx sei
         acceptRequest ctx input

acceptRequestForResource ∷ HandleLike h
                         ⇒ Context h
                         → AugmentedRequest
                         → Lazy.ByteString
                         → [Strict.ByteString]
                         → ResourceDef
                         → IO ()
acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
    = do cert ← hGetPeerCert cHandle
         ni   ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
         tid  ← spawnResource rsrcDef ni
         if reqMustHaveBody arRequest then
             waitForReceiveBodyReq ctx ni tid input
         else
             acceptRequest ctx input

waitForReceiveBodyReq ∷ HandleLike h
                      ⇒ Context h
                      → NormalInteraction
                      → ThreadId
                      → Lazy.ByteString
                      → IO ()
waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
    = case S.fromJust niReqBodyLength of
        Chunked
            → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
        Fixed len
            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len

-- Toooooo long name for a function...
waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                            ⇒ Context h
                                            → NormalInteraction
                                            → ThreadId
                                            → Lazy.ByteString
                                            → IO ()
waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
    = join $
      atomically $
      do req ← takeTMVar niReceiveBodyReq
         case req of
           ReceiveBody wanted
               → do putTMVar niSendContinue niExpectedContinue
                    return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
           WasteAll
               → do putTMVar niSendContinue False
                    return $ wasteAllChunks ctx rsrcTid input Initial

waitForReceiveChunkedBodyReq ∷ HandleLike h
                             ⇒ Context h
                             → NormalInteraction
                             → ThreadId
                             → Lazy.ByteString
                             → ChunkReceivingState
                             → IO ()
waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
    = do req ← atomically $ takeTMVar niReceiveBodyReq
         case req of
           ReceiveBody wanted
               → readCurrentChunk ctx ni rsrcTid wanted input st
           WasteAll
               → wasteAllChunks ctx rsrcTid input st

wasteAllChunks ∷ HandleLike h
               ⇒ Context h
               → ThreadId
               → Lazy.ByteString
               → ChunkReceivingState
               → IO ()
wasteAllChunks ctx rsrcTid = go
    where
      go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
      go input Initial
          = case LP.parse chunkHeaderP input of
              LP.Done input' chunkLen
                  | chunkLen ≡ 0 → gotFinalChunk input'
                  | otherwise    → gotChunk input' chunkLen
              LP.Fail _ _ msg
                  → chunkWasMalformed rsrcTid
                        $ "wasteAllChunks: chunkHeaderP: " ⧺ msg
      go input (InChunk chunkLen)
          = gotChunk input chunkLen

      gotChunk ∷ Lazy.ByteString → Int → IO ()
      gotChunk input chunkLen
          = let input' = Lazy.drop (fromIntegral chunkLen) input
            in
              case LP.parse chunkFooterP input' of
                LP.Done input'' _
                    → go input'' Initial
                LP.Fail _ _ msg
                    → chunkWasMalformed rsrcTid
                          $ "wasteAllChunks: chunkFooterP: " ⧺ msg

      gotFinalChunk ∷ Lazy.ByteString → IO ()
      gotFinalChunk input
          = case LP.parse chunkTrailerP input of
              LP.Done input' _
                  → acceptRequest ctx input'
              LP.Fail _ _ msg
                  → chunkWasMalformed rsrcTid
                        $ "wasteAllChunks: chunkTrailerP: " ⧺ msg

readCurrentChunk ∷ HandleLike h
                 ⇒ Context h
                 → NormalInteraction
                 → ThreadId
                 → Int
                 → Lazy.ByteString
                 → ChunkReceivingState
                 → IO ()
readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
    where
      go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
      go input Initial
          = case LP.parse chunkHeaderP input of
              LP.Done input' chunkLen
                  | chunkLen ≡ 0
                      → gotFinalChunk input'
                  | otherwise
                      → gotChunk input' chunkLen
              LP.Fail _ _ msg
                  → chunkWasMalformed rsrcTid
                        $ "readCurrentChunk: chunkHeaderP: " ⧺ msg
      go input (InChunk chunkLen)
          = gotChunk input chunkLen

      gotChunk ∷ Lazy.ByteString → Int → IO ()
      gotChunk input chunkLen
          = do let bytesToRead     = min wanted chunkLen
                   (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
                   block'          = Strict.concat $ Lazy.toChunks block
                   actualReadBytes = Strict.length block'
                   chunkLen'       = chunkLen - actualReadBytes
               atomically $ putTMVar niReceivedBody block'
               if chunkLen' ≡ 0 then
                   case LP.parse chunkFooterP input' of
                     LP.Done input'' _
                         → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
                     LP.Fail _ _ msg
                         → chunkWasMalformed rsrcTid
                               $ "readCurrentChunk: chunkFooterP: " ⧺ msg
               else
                   waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'

      gotFinalChunk ∷ Lazy.ByteString → IO ()
      gotFinalChunk input
          = do atomically $ putTMVar niReceivedBody (∅)
               case LP.parse chunkTrailerP input of
                 LP.Done input' _
                     → acceptRequest ctx input'
                 LP.Fail _ _ msg
                     → chunkWasMalformed rsrcTid
                           $ "readCurrentChunk: chunkTrailerP: " ⧺ msg

chunkWasMalformed ∷ ThreadId → String → IO ()
chunkWasMalformed tid msg
    = let abo = mkAbortion BadRequest [("Connection", "close")]
                $ Just
                $ "chunkWasMalformed: " ⊕ T.pack msg
      in
        throwTo tid abo

waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                               ⇒ Context h
                                               → NormalInteraction
                                               → Lazy.ByteString
                                               → Int
                                               → IO ()
waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
    = join $
      atomically $
      do req ← takeTMVar niReceiveBodyReq
         case req of
           ReceiveBody wanted
               → do putTMVar niSendContinue niExpectedContinue
                    return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
           WasteAll
               → do putTMVar niSendContinue False
                    return $ wasteNonChunkedRequestBody ctx input bodyLen

waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                ⇒ Context h
                                → NormalInteraction
                                → Lazy.ByteString
                                → Int
                                → IO ()
waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
    = do req ← atomically $ takeTMVar niReceiveBodyReq
         case req of
           ReceiveBody wanted
               → readNonChunkedRequestBody ctx ni input bodyLen wanted
           WasteAll
               → wasteNonChunkedRequestBody ctx input bodyLen

wasteNonChunkedRequestBody ∷ HandleLike h
                           ⇒ Context h
                           → Lazy.ByteString
                           → Int
                           → IO ()
wasteNonChunkedRequestBody ctx input bodyLen
    = do let input' = Lazy.drop (fromIntegral bodyLen) input
         acceptRequest ctx input'

readNonChunkedRequestBody ∷ HandleLike h
                          ⇒ Context h
                          → NormalInteraction
                          → Lazy.ByteString
                          → Int
                          → Int
                          → IO ()
readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
    | bodyLen ≡ 0 = gotEndOfRequest
    | otherwise   = gotBody
    where
      gotBody ∷ IO ()
      gotBody
          = do let bytesToRead     = min wanted bodyLen
                   (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
                   block'          = Strict.concat $ Lazy.toChunks block
                   actualReadBytes = Strict.length block'
                   bodyLen'        = bodyLen - actualReadBytes
               atomically $ putTMVar niReceivedBody block'
               waitForReceiveNonChunkedBodyReq ctx ni input' bodyLen'

      gotEndOfRequest ∷ IO ()
      gotEndOfRequest
          = do atomically $ putTMVar niReceivedBody (∅)
               acceptRequest ctx input

enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
{-# INLINEABLE enqueue #-}
enqueue (Context {..}) itr
    = atomically $
      do queue ← readTVar cQueue
         writeTVar cQueue (toInteraction itr ⊲ queue)