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 input <- B.hGetContents h
         catch (acceptRequest input) $ \ exc ->
             case exc of
               IOException _ -> return ()
               _             -> print exc
    where
      acceptRequest :: ByteString -> IO ()
      acceptRequest input
          -- キューに最大パイプライン深度以上のリクエストが溜まってゐる
          -- 時は、それが限度以下になるまで待つ。
          = do action
                   <- atomically $
                      do queue    <- readTVar tQueue
                         when (S.length queue >= cnfMaxPipelineDepth cnf)
                              retry

                         -- リクエストを讀む。パースできない場合は直ち
                         -- に 400 Bad Request 應答を設定し、それを出力
                         -- してから切斷するやうに ResponseWriter に通
                         -- 知する。
                         case parse requestP input of
                           Nothing            -> return acceptNonparsableRequest
                           Just (req, input') -> return $ acceptParsableRequest req input'
               action
      
      acceptNonparsableRequest :: IO ()
      acceptNonparsableRequest 
          = do itr <- newInteraction host Nothing
               let res = Response {
                           resVersion = HttpVersion 1 1
                         , resStatus  = BadRequest
                         , 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 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 = fail "FIXME: Not Implemented"

      enqueue :: Interaction -> STM ()
      enqueue itr = do queue <- readTVar tQueue
                       writeTVar tQueue (itr <| queue)