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

               -- リクエストを讀む。パースできない場合は直ちに 400 Bad
               -- Request 應答を設定し、それを出力してから切斷するやう
               -- に ResponseWriter に通知する。
               hWaitForInput h (-1)
               chunk <- B.hGetNonBlocking h 1024

               let input = B.append soFar chunk
               case parse requestP input of
                 (Success req , input') -> acceptParsableRequest req input'
                 (IllegalInput, _     ) -> acceptNonparsableRequest
                 (ReachedEOF  , _     ) -> if B.length input >= 1024 * 1024 then
                                               -- ヘッダ長過ぎ
                                               acceptNonparsableRequest
                                           else
                                               acceptRequest input

      
      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 soFar
          = do itr <- newInteraction host (Just req)
               action
                   <- atomically $
                      do preprocess itr
                         isErr <- readItrF itr itrResponse (isError . resStatus)
                         if isErr == Just True then
                             acceptSemanticallyInvalidRequest itr soFar
                           else
                             case findResource tree $ (reqURI . fromJust . itrRequest) itr of
                               Nothing -- Resource が無かった
                                   -> acceptRequestForNonexistentResource itr soFar

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

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

      acceptRequestForNonexistentResource :: Interaction -> ByteString -> STM (IO ())
      acceptRequestForNonexistentResource itr soFar
          = 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 soFar

      acceptRequestForExistentResource :: Interaction -> ByteString -> ResourceDef -> STM (IO ())
      acceptRequestForExistentResource itr soFar 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 soFar
                             else
                               acceptRequest soFar

      observeRequest :: Interaction -> ByteString -> IO ()
      observeRequest itr soFar = fail "FIXME: Not Implemented"

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