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.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 writeTVar (itrResponse  itr) $ Just res
                               writeTVar (itrWillClose itr) True
                               writeTVar (itrState     itr) Done
                               postprocess itr
                               enqueue itr

      acceptParsableRequest :: Request -> ByteString -> IO ()
      acceptParsableRequest req input'
          = do itr <- newInteraction host (Just req)
               action
                   <- atomically $
                      do preprocess itr
                         res <- readTVar (itrResponse itr)
                         if fmap isError (fmap resStatus res) == 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 writeTVar (itrState itr) Done
               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 = []
                         }
               writeTVar (itrResponse  itr) $ Just res
               writeTVar (itrState     itr) Done
               postprocess itr
               enqueue itr
               return $ acceptRequest input

      acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
      acceptRequestForExistentResource itr input rsrcDef
          = do requestHasBody <- readTVar (itrRequestHasBody itr)
               writeTVar (itrState itr) (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)