import Control.Concurrent.STM
import Control.Exception hiding (block)
import Control.Monad
+import Control.Monad.Trans.Maybe
import qualified Data.Attoparsec.Lazy as LP
import qualified Data.ByteString as Strict
import qualified Data.ByteString.Lazy as Lazy
+import Data.Convertible.Base
+import Data.Convertible.Instances.Text ()
+import Data.Default
import Data.List
import Data.Maybe
import Data.Monoid.Unicode
import qualified Data.Sequence as S
-import qualified Data.Text as T
import Network.HTTP.Lucu.Abortion
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
+import Network.HTTP.Lucu.Dispatcher.Internal
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Preprocess
import Network.HTTP.Lucu.Request
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
data Context h
= Context {
- cConfig ∷ !Config
- , cResTree ∷ !ResTree
- , cFallbacks ∷ ![FallbackHandler]
- , cHandle ∷ !h
- , cPort ∷ !PortNumber
- , cAddr ∷ !SockAddr
- , cQueue ∷ !InteractionQueue
+ cConfig ∷ !Config
+ , cHostMap ∷ !HostMap
+ , cHandle ∷ !h
+ , cPort ∷ !PortNumber
+ , cAddr ∷ !SockAddr
+ , cQueue ∷ !InteractionQueue
}
data ChunkReceivingState
| InChunk !Int -- ^Number of remaining octets in the current
-- chunk. It's always positive.
-requestReader ∷ HandleLike h
+requestReader ∷ (HostMapper hm, HandleLike h)
⇒ Config
- → ResTree
- → [FallbackHandler]
+ → hm
→ h
→ PortNumber
→ SockAddr
→ InteractionQueue
→ IO ()
-requestReader cnf tree fbs h port addr tQueue
+requestReader cnf hm h port addr tQueue
= do input ← hGetLBS h
- acceptRequest (Context cnf tree fbs h port addr tQueue) input
+ acceptRequest (Context cnf (hostMap hm) h port addr tQueue) input
`catches`
[ Handler handleAsyncE
- , Handler handleBIOS
, Handler handleOthers
]
+ `finally`
+ enqueue' tQueue EndOfInteraction
where
handleAsyncE ∷ AsyncException → IO ()
handleAsyncE ThreadKilled = return ()
handleAsyncE e = dump e
- handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
- handleBIOS = dump
-
handleOthers ∷ SomeException → IO ()
handleOthers = dump
dump ∷ Exception e ⇒ e → IO ()
dump e
- = do hPutStrLn stderr "requestReader caught an exception:"
- hPutStrLn stderr (show $ toException e)
+ = do hPutStrLn stderr "Lucu: requestReader caught an exception:"
+ 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 def input of
+ LP.Done input' req → acceptParsableRequest ctx req input'
+ LP.Fail _ _ _ → acceptNonparsableRequest ctx
acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
acceptNonparsableRequest ctx@(Context {..})
if isError $ arInitialStatus ar then
acceptSemanticallyInvalidRequest ctx ar input
else
- do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
- case rsrc of
+ do rsrcM ← runMaybeT $ dispatch (reqURI $ arRequest ar) cHostMap
+ case rsrcM of
Nothing
→ do let ar' = ar {
arInitialStatus = fromStatusCode NotFound
}
acceptSemanticallyInvalidRequest ctx ar' input
- Just (path, def)
- → acceptRequestForResource ctx ar input path def
+ Just (path, rsrc)
+ → acceptRequestForResource ctx ar input path rsrc
acceptSemanticallyInvalidRequest ∷ HandleLike h
⇒ Context h
→ AugmentedRequest
→ Lazy.ByteString
→ [Strict.ByteString]
- → ResourceDef
+ → Resource
→ IO ()
-acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrc
= do
#if defined(HAVE_SSL)
cert ← hGetPeerCert cHandle
#else
ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
#endif
- tid ← spawnResource rsrcDef ni
+ tid ← spawnRsrc rsrc ni
enqueue ctx ni
- if reqMustHaveBody arRequest then
+ if reqHasBody arRequest then
waitForReceiveBodyReq ctx ni tid input
else
acceptRequest ctx input
= let abo = mkAbortion BadRequest [("Connection", "close")]
$ Just
$ "chunkWasMalformed: "
- ⊕ T.pack msg
+ ⊕ cs msg
⊕ ": "
- ⊕ T.pack (intercalate ", " eCtx)
+ ⊕ cs (intercalate ", " eCtx)
⊕ ": "
- ⊕ T.pack e
+ ⊕ cs e
in
throwTo tid abo
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)