{-# LANGUAGE
    DoAndIfThenElse
  , RecordWildCards
  , ScopedTypeVariables
  , UnicodeSyntax
  #-}
module Network.HTTP.Lucu.RequestReader
    ( requestReader
    )
    where
import Control.Applicative
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 Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence.Unicode hiding ((∅))
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
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 Network.URI
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 BadRequest

acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → StatusCode → IO ()
acceptNonparsableRequest ctx@(Context {..}) sc
    = do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
         atomically $
             do writeTVar (itrState itr) Done
                postprocess itr
                enqueue ctx itr

acceptParsableRequest ∷ HandleLike h
                      ⇒ Context h
                      → Request
                      → Lazy.ByteString
                      → IO ()
acceptParsableRequest ctx@(Context {..}) req input
    = do cert ← hGetPeerCert cHandle
         itr  ← newInteraction cConfig cPort cAddr cert (Right req)
         join $ atomically
              $ do isErr ← (isError ∘ resStatus) <$> readTVar (itrResponse itr)
                   if isErr then
                       acceptSemanticallyInvalidRequest ctx itr input
                   else
                       return $ acceptSemanticallyValidRequest ctx itr (reqURI req) input

acceptSemanticallyInvalidRequest ∷ HandleLike h
                                 ⇒ Context h
                                 → Interaction
                                 → Lazy.ByteString
                                 → STM (IO ())
acceptSemanticallyInvalidRequest ctx itr input
    = do writeTVar (itrState itr) Done
         postprocess itr
         enqueue ctx itr
         return $ acceptRequest ctx input

acceptSemanticallyValidRequest ∷ HandleLike h
                               ⇒ Context h
                               → Interaction
                               → URI
                               → Lazy.ByteString
                               → IO ()
acceptSemanticallyValidRequest ctx@(Context {..}) itr uri input
    = do rsrcM ← findResource cResTree cFallbacks uri
         case rsrcM of
           Nothing
               → acceptRequestForNonexistentResource ctx itr input
           Just (rsrcPath, rsrcDef)
               → acceptRequestForExistentResource ctx itr input rsrcPath rsrcDef

acceptRequestForNonexistentResource ∷ HandleLike h
                                    ⇒ Context h
                                    → Interaction
                                    → Lazy.ByteString
                                    → IO ()
acceptRequestForNonexistentResource ctx itr input
    = do atomically $
             do setResponseStatus itr NotFound
                writeTVar (itrState itr) Done
                postprocess itr
                enqueue ctx itr
         acceptRequest ctx input

acceptRequestForExistentResource ∷ HandleLike h
                                 ⇒ Context h
                                 → Interaction
                                 → Lazy.ByteString
                                 → [Strict.ByteString]
                                 → ResourceDef
                                 → IO ()
acceptRequestForExistentResource ctx oldItr input rsrcPath rsrcDef
    = do let itr = oldItr { itrResourcePath = Just rsrcPath }
         atomically $ enqueue ctx itr
         do _ ← spawnResource rsrcDef itr
            if reqMustHaveBody $ fromJust $ itrRequest itr then
                waitForReceiveBodyReq ctx itr input
            else
                acceptRequest ctx input

waitForReceiveBodyReq ∷ HandleLike h
                      ⇒ Context h
                      → Interaction
                      → Lazy.ByteString
                      → IO ()
waitForReceiveBodyReq ctx itr input
    = case fromJust $ itrReqBodyLength itr of
        Chunked
            → waitForReceiveChunkedBodyReqForTheFirstTime ctx itr input
        Fixed len
            → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr input len

-- Toooooo long name for a function...
waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                            ⇒ Context h
                                            → Interaction
                                            → Lazy.ByteString
                                            → IO ()
waitForReceiveChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input
    = join $
      atomically $
      do req ← takeTMVar itrReceiveBodyReq
         case req of
           ReceiveBody wanted
               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
                    return $ readCurrentChunk ctx itr input Initial wanted
           WasteAll
               → do putTMVar itrSendContinue False
                    return $ wasteAllChunks ctx itr input Initial

waitForReceiveChunkedBodyReq ∷ HandleLike h
                             ⇒ Context h
                             → Interaction
                             → Lazy.ByteString
                             → ChunkReceivingState
                             → IO ()
waitForReceiveChunkedBodyReq ctx itr@(Interaction {..}) input st
    = do req ← atomically $ takeTMVar itrReceiveBodyReq
         case req of
           ReceiveBody wanted
               → readCurrentChunk ctx itr input st wanted
           WasteAll
               → wasteAllChunks ctx itr input st

wasteAllChunks ∷ HandleLike h
               ⇒ Context h
               → Interaction
               → Lazy.ByteString
               → ChunkReceivingState
               → IO ()
wasteAllChunks ctx itr = 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 _ _ _
                  → chunkWasMalformed itr
      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 _ _ _
                    → chunkWasMalformed itr

      gotFinalChunk ∷ Lazy.ByteString → IO ()
      gotFinalChunk input
          = case LP.parse chunkFooterP input of
              LP.Done input' _
                  → case LP.parse chunkTrailerP input' of
                       LP.Done input'' _
                           → acceptRequest ctx input''
                       LP.Fail _ _ _
                           → chunkWasMalformed itr
              LP.Fail _ _ _
                  → chunkWasMalformed itr

readCurrentChunk ∷ HandleLike h
                 ⇒ Context h
                 → Interaction
                 → Lazy.ByteString
                 → ChunkReceivingState
                 → Int
                 → IO ()
readCurrentChunk ctx itr@(Interaction {..}) input0 st0 wanted
    = go input0 st0
    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 _ _ _
                  → chunkWasMalformed itr
      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 itrReceivedBody block'
               if chunkLen' ≡ 0 then
                   case LP.parse chunkFooterP input' of
                     LP.Done input'' _
                         → waitForReceiveChunkedBodyReq ctx itr input'' Initial
                     LP.Fail _ _ _
                         → chunkWasMalformed itr
               else
                   waitForReceiveChunkedBodyReq ctx itr input' $ InChunk chunkLen'

      gotFinalChunk ∷ Lazy.ByteString → IO ()
      gotFinalChunk input
          = do atomically $ putTMVar itrReceivedBody (∅)
               case LP.parse chunkFooterP input of
                 LP.Done input' _
                     → case LP.parse chunkTrailerP input' of
                          LP.Done input'' _
                              → acceptRequest ctx input''
                          LP.Fail _ _ _
                              → chunkWasMalformed itr
                 LP.Fail _ _ _
                     → chunkWasMalformed itr

chunkWasMalformed ∷ Interaction → IO ()
chunkWasMalformed itr
    -- FIXME: This is a totally wrong way to abort!
    = atomically $
      do setResponseStatus itr BadRequest
         writeTVar (itrWillClose itr) True
         writeTVar (itrState     itr) Done
         postprocess itr

waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
                                               ⇒ Context h
                                               → Interaction
                                               → Lazy.ByteString
                                               → Int
                                               → IO ()
waitForReceiveNonChunkedBodyReqForTheFirstTime ctx itr@(Interaction {..}) input bodyLen
    = join $
      atomically $
      do req ← takeTMVar itrReceiveBodyReq
         case req of
           ReceiveBody wanted
               → do putTMVar itrSendContinue $ fromJust itrExpectedContinue
                    return $ readNonChunkedRequestBody ctx itr input bodyLen wanted
           WasteAll
               → do putTMVar itrSendContinue False
                    return $ wasteNonChunkedRequestBody ctx input bodyLen

waitForReceiveNonChunkedBodyReq ∷ HandleLike h
                                ⇒ Context h
                                → Interaction
                                → Lazy.ByteString
                                → Int
                                → IO ()
waitForReceiveNonChunkedBodyReq ctx itr@(Interaction {..}) input bodyLen
    = do req ← atomically $ takeTMVar itrReceiveBodyReq
         case req of
           ReceiveBody wanted
               → readNonChunkedRequestBody ctx itr 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
                          → Interaction
                          → Lazy.ByteString
                          → Int
                          → Int
                          → IO ()
readNonChunkedRequestBody ctx itr@(Interaction {..}) 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 itrReceivedBody block'
               waitForReceiveNonChunkedBodyReq ctx itr input' bodyLen'

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

enqueue ∷ HandleLike h ⇒ Context h → Interaction → STM ()
enqueue (Context {..}) itr
    = do queue ← readTVar cQueue
         writeTVar cQueue (itr ⊲ queue)