module Network.HTTP.Lucu.RequestReader
    ( requestReader
    )
    where

import           Control.Concurrent.STM
import           Control.Exception
import           Control.Monad
import qualified Data.ByteString.Lazy.Char8 as B
import           Data.ByteString.Lazy.Char8 (ByteString)
import           Data.Maybe
import qualified Data.Sequence as S
import           Data.Sequence ((<|))
import           GHC.Conc (unsafeIOToSTM)
import           Network.Socket
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.Chunk
import           Network.HTTP.Lucu.DefaultPage
import           Network.HTTP.Lucu.HandleLike
import           Network.HTTP.Lucu.Interaction
import           Network.HTTP.Lucu.Parser
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.Tree
import           Prelude hiding (catch)
import           System.IO (stderr)


requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO ()
requestReader !cnf !tree !fbs !h !addr !tQueue
    = do input <- hGetLBS h
         acceptRequest input
      `catches`
      [ Handler (( \ _                   -> return () ) :: IOException -> IO ())
      , Handler  ( \ ThreadKilled        -> return () )
      , Handler  ( \ BlockedIndefinitely -> hPutStrLn stderr "requestReader: blocked indefinitely" )
      , Handler (( \ e                   -> hPutStrLn stderr (show e) ) :: SomeException -> IO ())
      ]
    where
      acceptRequest :: ByteString -> IO ()
      acceptRequest input
          -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
          -- 時は、それが限度以下になるまで待つ。
          = {-# SCC "acceptRequest" #-}
            do atomically $ do queue    <- readTVar tQueue
                               when (S.length queue >= cnfMaxPipelineDepth cnf)
                                    retry

               -- リクエストを讀む。パースできない場合は直ちに 400 Bad
               -- Request 應答を設定し、それを出力してから切斷するやう
               -- に ResponseWriter に通知する。
               case parse requestP input of
                 (# Success req , input' #) -> acceptParsableRequest req input'
                 (# IllegalInput, _      #) -> acceptNonparsableRequest BadRequest
                 (# ReachedEOF  , _      #) -> acceptNonparsableRequest BadRequest

      acceptNonparsableRequest :: StatusCode -> IO ()
      acceptNonparsableRequest status
          = {-# SCC "acceptNonparsableRequest" #-}
            do itr <- newInteraction cnf addr Nothing Nothing
               atomically $ do updateItr itr itrResponse
                                             $ \ res -> res {
                                                          resStatus = status
                                                        }
                               writeItr itr itrWillClose True
                               writeItr itr itrState     Done
                               writeDefaultPage itr
                               postprocess itr
                               enqueue itr

      acceptParsableRequest :: Request -> ByteString -> IO ()
      acceptParsableRequest req input
          = {-# SCC "acceptParsableRequest" #-}
            do cert <- hGetPeerCert h
               itr  <- newInteraction cnf addr cert (Just req)
               action
                   <- atomically $
                      do preprocess itr
                         isErr <- readItr itr itrResponse (isError . resStatus)
                         if isErr then
                             acceptSemanticallyInvalidRequest itr input
                           else
                             do rsrcM <- unsafeIOToSTM $ findResource tree fbs $ reqURI req
                                case rsrcM of
                                  Nothing -- Resource が無かった
                                      -> acceptRequestForNonexistentResource itr input

                                  Just (rsrcPath, rsrcDef) -- あった
                                      -> acceptRequestForExistentResource itr input rsrcPath rsrcDef
               action

      acceptSemanticallyInvalidRequest :: Interaction -> ByteString -> STM (IO ())
      acceptSemanticallyInvalidRequest itr input
          = {-# SCC "acceptSemanticallyInvalidRequest" #-}
            do writeItr itr itrState Done
               writeDefaultPage itr
               postprocess itr
               enqueue itr
               return $ acceptRequest input

      acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
      acceptRequestForNonexistentResource itr input
          = {-# SCC "acceptRequestForNonexistentResource" #-}
            do updateItr itr itrResponse 
                             $ \res -> res {
                                         resStatus = NotFound
                                       }
               writeItr itr itrState Done
               writeDefaultPage itr
               postprocess itr
               enqueue itr
               return $ acceptRequest input

      acceptRequestForExistentResource :: Interaction -> ByteString -> [String] -> ResourceDef -> STM (IO ())
      acceptRequestForExistentResource oldItr input rsrcPath rsrcDef
          = {-# SCC "acceptRequestForExistentResource" #-}
            do let itr = oldItr { itrResourcePath = Just rsrcPath }
               requestHasBody <- readItr itr itrRequestHasBody id
               enqueue itr
               return $ do runResource rsrcDef itr
                           if requestHasBody then
                               observeRequest itr input
                             else
                               acceptRequest input

      observeRequest :: Interaction -> ByteString -> IO ()
      observeRequest itr input
          = {-# SCC "observeRequest" #-}
            do isChunked <- atomically $ readItr itr itrRequestIsChunked id
               if isChunked then
                   observeChunkedRequest itr input
                 else
                   observeNonChunkedRequest itr input

      observeChunkedRequest :: Interaction -> ByteString -> IO ()
      observeChunkedRequest itr input
          = {-# SCC "observeChunkedRequest" #-}
            do action
                   <- atomically $
                      do isOver <- readItr itr itrReqChunkIsOver id
                         if isOver then
                             return $ acceptRequest input
                           else
                             do wantedM <- readItr itr itrReqBodyWanted id
                                if wantedM == Nothing then
                                    do wasteAll <- readItr itr itrReqBodyWasteAll id
                                       if wasteAll then
                                           -- 破棄要求が來た
                                           do remainingM <- readItr itr itrReqChunkRemaining id
                                              if fmap (> 0) remainingM == Just True then
                                                  -- 現在のチャンクをまだ
                                                  -- 讀み終へてゐない
                                                  do let (_, input') = B.splitAt (fromIntegral
                                                                                  $ fromJust remainingM) input
                                                         (# footerR, input'' #) = parse chunkFooterP input'

                                                     if footerR == Success () then
                                                         -- チャンクフッタを正常に讀めた
                                                         do writeItr itr itrReqChunkRemaining $ Just 0
                                                         
                                                            return $ observeChunkedRequest itr input''
                                                       else
                                                         return $ chunkWasMalformed itr
                                                else
                                                  -- 次のチャンクを讀み始める
                                                  seekNextChunk itr input
                                         else
                                           -- 要求がまだ來ない
                                           retry
                                  else
                                    -- 受信要求が來た
                                    do remainingM <- readItr itr itrReqChunkRemaining id
                                       if fmap (> 0) remainingM == Just True then
                                           -- 現在のチャンクをまだ讀み
                                           -- 終へてゐない
                                           do let wanted             = fromJust wantedM
                                                  remaining          = fromJust remainingM
                                                  bytesToRead        = fromIntegral $ min wanted remaining
                                                  (chunk, input')    = B.splitAt bytesToRead input
                                                  actualReadBytes    = fromIntegral $ B.length chunk
                                                  newWanted          = case wanted - actualReadBytes of
                                                                         0 -> Nothing
                                                                         n -> Just n
                                                  newRemaining       = Just $ remaining - actualReadBytes
                                                  updateStates
                                                      = do writeItr itr itrReqChunkRemaining newRemaining
                                                           writeItr itr itrReqBodyWanted newWanted
                                                           updateItr itr itrReceivedBody $ flip B.append chunk

                                              if newRemaining == Just 0 then
                                                  -- チャンクフッタを讀む
                                                  case parse chunkFooterP input' of
                                                    (# Success _, input'' #)
                                                        -> do updateStates
                                                              return $ observeChunkedRequest itr input''
                                                    (# _, _ #)
                                                        -> return $ chunkWasMalformed itr
                                                else
                                                  -- まだチャンクの終はりに達してゐない
                                                  do updateStates
                                                     return $ observeChunkedRequest itr input'
                                         else
                                           -- 次のチャンクを讀み始める
                                           seekNextChunk itr input
               action

      seekNextChunk :: Interaction -> ByteString -> STM (IO ())
      seekNextChunk itr input
          = {-# SCC "seekNextChunk" #-}
            case parse chunkHeaderP input of
              -- 最終チャンク (中身が空)
              (# Success 0, input' #)
                  -> case parse chunkTrailerP input' of
                       (# Success _, input'' #)
                           -> do writeItr itr itrReqChunkLength $ Nothing
                                 writeItr itr itrReqChunkRemaining $ Nothing
                                 writeItr itr itrReqChunkIsOver True
                                 
                                 return $ acceptRequest input''
                       (# _, _ #)
                           -> return $ chunkWasMalformed itr
              -- 最終でないチャンク
              (# Success len, input' #)
                  -> do writeItr itr itrReqChunkLength $ Just len
                        writeItr itr itrReqChunkRemaining $ Just len
                        
                        return $ observeChunkedRequest itr input'
              -- チャンクヘッダがをかしい
              (# _, _ #)
                  -> return $ chunkWasMalformed itr

      chunkWasMalformed :: Interaction -> IO ()
      chunkWasMalformed itr
          = {-# SCC "chunkWasMalformed" #-}
            atomically $ do updateItr itr itrResponse 
                                          $ \ res -> res {
                                                       resStatus = BadRequest
                                                     }
                            writeItr itr itrWillClose True
                            writeItr itr itrState Done
                            writeDefaultPage itr
                            postprocess itr

      observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
      observeNonChunkedRequest itr input
          = {-# SCC "observeNonChunkedRequest" #-}
            do action
                   <- atomically $
                      do wantedM <- readItr itr itrReqBodyWanted id
                         if wantedM == Nothing then
                             do wasteAll <- readItr itr itrReqBodyWasteAll id
                                if wasteAll then
                                    -- 破棄要求が來た
                                    do remainingM <- readItr itr itrReqChunkRemaining id
                                       
                                       let (_, input') = if remainingM == Nothing then
                                                             (B.takeWhile (\ _ -> True) input, B.empty)
                                                         else
                                                             B.splitAt (fromIntegral $ fromJust remainingM) input

                                       writeItr itr itrReqChunkRemaining $ Just 0
                                       writeItr itr itrReqChunkIsOver True

                                       return $ acceptRequest input'
                                  else
                                    -- 要求がまだ来ない
                                    retry
                           else
                               -- 受信要求が來た
                               do remainingM <- readItr itr itrReqChunkRemaining id

                                  let wanted          = fromJust wantedM
                                      bytesToRead     = fromIntegral $ maybe wanted (min wanted) remainingM
                                      (chunk, input') = B.splitAt bytesToRead input
                                      newRemaining    = fmap
                                                        (\ x -> x - (fromIntegral $ B.length chunk))
                                                        remainingM
                                      isOver          = B.length chunk < bytesToRead || newRemaining == Just 0

                                  writeItr itr itrReqChunkRemaining newRemaining
                                  writeItr itr itrReqChunkIsOver isOver
                                  writeItr itr itrReqBodyWanted Nothing
                                  writeItr itr itrReceivedBody chunk

                                  if isOver then
                                      return $ acceptRequest input'
                                    else
                                      return $ observeNonChunkedRequest itr input'
               action

      enqueue :: Interaction -> STM ()
      enqueue itr = {-# SCC "enqueue" #-}
                    do queue <- readTVar tQueue
                       writeTVar tQueue (itr <| queue)