import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import Data.Sequence.Unicode hiding ((∅))
import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Response
import Network.HTTP.Lucu.Resource.Internal
import Network.HTTP.Lucu.Resource.Tree
+import Network.HTTP.Lucu.Utils
import Network.Socket
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
, Handler handleBIOS
, Handler handleOthers
]
+ `finally`
+ enqueue' tQueue EndOfInteraction
where
handleAsyncE ∷ AsyncException → IO ()
handleAsyncE ThreadKilled = return ()
dump ∷ Exception e ⇒ e → IO ()
dump e
= do hPutStrLn stderr "requestReader caught an exception:"
- hPutStrLn stderr (show $ toException e)
+ hPutStrLn stderr $ show e
acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
acceptRequest ctx@(Context {..}) input
- -- キューに最大パイプライン深度以上のリクエストが溜まってゐる時は、
- -- それが限度以下になるまで待つ。
= do atomically $
do queue ← readTVar cQueue
- when (S.length queue ≥ cnfMaxPipelineDepth cConfig) $
+ when (S.length queue ≥ cnfMaxPipelineDepth cConfig)
+ -- Too many requests in the pipeline...
retry
- -- リクエストを讀む。パースできない場合は直ちに 400 Bad
- -- Request 應答を設定し、それを出力してから切斷するやうに
- -- ResponseWriter に通知する。
- case LP.parse request input of
- LP.Done input' req → acceptParsableRequest ctx req input'
- LP.Fail _ _ _ → acceptNonparsableRequest ctx
+ if Lazy.null input then
+ return ()
+ else
+ case LP.parse request input of
+ LP.Done input' req → acceptParsableRequest ctx req input'
+ LP.Fail _ _ _ → acceptNonparsableRequest ctx
acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
acceptNonparsableRequest ctx@(Context {..})
acceptRequest ctx input
enqueue ∷ (HandleLike h, Interaction i) ⇒ Context h → i → IO ()
-{-# INLINEABLE enqueue #-}
-enqueue (Context {..}) itr
+enqueue (Context {..}) = enqueue' cQueue
+
+enqueue' ∷ Interaction i ⇒ InteractionQueue → i → IO ()
+enqueue' tQueue itr
= atomically $
- do queue ← readTVar cQueue
- writeTVar cQueue (toInteraction itr ⊲ queue)
+ do queue ← readTVar tQueue
+ writeTVar tQueue (toInteraction itr ⊲ queue)