module Network.HTTP.Lucu.RequestReader
    ( requestReader -- Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
    )
    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.Map as M
import           Data.Map (Map)
import           Data.Maybe
import qualified Data.Sequence as S
import           Data.Sequence (Seq, (<|), ViewR(..))
import           Network
import           Network.HTTP.Lucu.Config
import           Network.HTTP.Lucu.DefaultPage
import           Network.HTTP.Lucu.HttpVersion
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
import           Prelude hiding (catch)
import           System.IO

import GHC.Conc (unsafeIOToSTM)

requestReader :: Config -> ResTree -> Handle -> HostName -> InteractionQueue -> IO ()
requestReader cnf tree h host tQueue
    = do catch (do input <- B.hGetContents h
                   acceptRequest input) $ \ exc ->
             case exc of
               IOException _               -> return ()
               AsyncException ThreadKilled -> return ()
               BlockedIndefinitely         -> putStrLn "requestReader: blocked indefinitely"
               _                           -> print exc
    where
      acceptRequest :: ByteString -> IO ()
      acceptRequest input
          -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
          -- 時は、それが限度以下になるまで待つ。
          = 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
          = do itr <- newInteraction cnf host Nothing
               let res = Response {
                           resVersion = HttpVersion 1 1
                         , resStatus  = status
                         , resHeaders = []

                         }
               atomically $ do writeItr itr itrResponse $ Just res
                               writeItr itr itrWillClose True
                               writeItr itr itrState     Done
                               writeDefaultPage itr
                               postprocess itr
                               enqueue itr

      acceptParsableRequest :: Request -> ByteString -> IO ()
      acceptParsableRequest req input
          = do itr <- newInteraction cnf host (Just req)
               action
                   <- atomically $
                      do preprocess itr
                         isErr <- readItrF itr itrResponse (isError . resStatus)
                         if isErr == Just True then
                             acceptSemanticallyInvalidRequest itr input
                           else
                             case findResource tree $ (reqURI . fromJust . itrRequest) itr of
                               Nothing -- Resource が無かった
                                   -> acceptRequestForNonexistentResource itr input

                               Just rsrcDef -- あった
                                   -> acceptRequestForExistentResource itr input rsrcDef
               action

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

      acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
      acceptRequestForNonexistentResource itr input
          = do let res = Response {
                           resVersion = HttpVersion 1 1
                         , resStatus  = NotFound
                         , resHeaders = []
                         }
               writeItr itr itrResponse $ Just res
               writeItr itr itrState Done
               writeDefaultPage itr
               postprocess itr
               enqueue itr
               return $ acceptRequest input

      acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
      acceptRequestForExistentResource itr input rsrcDef
          = do requestHasBody <- readItr itr itrRequestHasBody id
               writeItr itr itrState (if requestHasBody
                                      then ExaminingHeader
                                      else DecidingHeader)
               enqueue itr
               return $ do runResource rsrcDef itr
                           if requestHasBody then
                               observeRequest itr input
                             else
                               acceptRequest input

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

      observeChunkedRequest :: Interaction -> ByteString -> IO ()
      observeChunkedRequest itr input
          = fail "FIXME: not implemented"

      observeNonChunkedRequest :: Interaction -> ByteString -> IO ()
      observeNonChunkedRequest itr input
          = 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
                                       writeItr itr itrReqBodyWanted Nothing
                                       writeItr itr itrReceivedBody B.empty

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

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

                                  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 = do queue <- readTVar tQueue
                       writeTVar tQueue (itr <| queue)