+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.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
+import System.IO (hPutStrLn, stderr)
+
+data Context h
+ = Context {
+ cConfig ∷ !Config
+ , cResTree ∷ !ResTree
+ , cFallbacks ∷ ![FallbackHandler]
+ , cHandle ∷ !h
+ , cPort ∷ !PortNumber
+ , cAddr ∷ !SockAddr
+ , cQueue ∷ !InteractionQueue
+ }
+
+data ChunkReceivingState
+ = Initial
+ | InChunk !Int -- ^Number of remaining octets in the current
+ -- chunk. It's always positive.
+
+requestReader ∷ HandleLike h
+ ⇒ Config
+ → ResTree
+ → [FallbackHandler]
+ → h
+ → PortNumber
+ → SockAddr
+ → InteractionQueue
+ → IO ()
+requestReader cnf tree fbs h port addr tQueue
+ = do input ← hGetLBS h
+ acceptRequest (Context cnf tree fbs 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 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)
+ -- Too many requests in the pipeline...
+ retry
+ 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 {..})
+ = do syi ← mkSyntacticallyInvalidInteraction cConfig
+ enqueue ctx syi
+
+acceptParsableRequest ∷ HandleLike h
+ ⇒ Context h
+ → Request
+ → Lazy.ByteString
+ → IO ()
+acceptParsableRequest ctx@(Context {..}) req input
+ = do let ar = preprocess (cnfServerHost cConfig) cPort req
+ if isError $ arInitialStatus ar then
+ acceptSemanticallyInvalidRequest ctx ar input
+ else
+ do rsrc ← findResource cResTree cFallbacks $ reqURI $ arRequest ar
+ case rsrc of
+ Nothing
+ → do let ar' = ar {
+ arInitialStatus = fromStatusCode NotFound
+ }
+ acceptSemanticallyInvalidRequest ctx ar' input
+ Just (path, def)
+ → acceptRequestForResource ctx ar input path def
+
+acceptSemanticallyInvalidRequest ∷ HandleLike h
+ ⇒ Context h
+ → AugmentedRequest
+ → Lazy.ByteString
+ → IO ()
+acceptSemanticallyInvalidRequest ctx@(Context {..}) ar input
+ = do sei ← mkSemanticallyInvalidInteraction cConfig ar
+ enqueue ctx sei
+ acceptRequest ctx input
+
+acceptRequestForResource ∷ HandleLike h
+ ⇒ Context h
+ → AugmentedRequest
+ → Lazy.ByteString
+ → [Strict.ByteString]
+ → ResourceDef
+ → IO ()
+acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef
+ = do
+#if defined(HAVE_SSL)
+ cert ← hGetPeerCert cHandle
+ ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath
+#else
+ ni ← mkNormalInteraction cConfig cAddr ar rsrcPath
+#endif
+ tid ← spawnResource rsrcDef ni
+ enqueue ctx ni
+ if reqMustHaveBody arRequest then
+ waitForReceiveBodyReq ctx ni tid input
+ else
+ acceptRequest ctx input
+
+waitForReceiveBodyReq ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → ThreadId
+ → Lazy.ByteString
+ → IO ()
+waitForReceiveBodyReq ctx ni@(NI {..}) rsrcTid input
+ = case fromJust niReqBodyLength of
+ Chunked
+ → waitForReceiveChunkedBodyReqForTheFirstTime ctx ni rsrcTid input
+ Fixed len
+ → waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni input len
+
+-- Toooooo long name for a function...
+waitForReceiveChunkedBodyReqForTheFirstTime ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → ThreadId
+ → Lazy.ByteString
+ → IO ()
+waitForReceiveChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) rsrcTid input
+ = join $
+ atomically $
+ do req ← takeTMVar niReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → do putTMVar niSendContinue niExpectedContinue
+ return $ readCurrentChunk ctx ni rsrcTid wanted input Initial
+ WasteAll
+ → do putTMVar niSendContinue False
+ return $ wasteAllChunks ctx rsrcTid input Initial
+
+waitForReceiveChunkedBodyReq ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → ThreadId
+ → Lazy.ByteString
+ → ChunkReceivingState
+ → IO ()
+waitForReceiveChunkedBodyReq ctx ni@(NI {..}) rsrcTid input st
+ = do req ← atomically $ takeTMVar niReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → readCurrentChunk ctx ni rsrcTid wanted input st
+ WasteAll
+ → wasteAllChunks ctx rsrcTid input st
+
+wasteAllChunks ∷ HandleLike h
+ ⇒ Context h
+ → ThreadId
+ → Lazy.ByteString
+ → ChunkReceivingState
+ → IO ()
+wasteAllChunks ctx rsrcTid = go
+ where
+ go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
+ go input Initial
+ = case LP.parse chunkHeader input of
+ LP.Done input' chunkLen
+ | chunkLen ≡ 0 → gotFinalChunk input'
+ | otherwise → gotChunk input' chunkLen
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkHeader"
+ go input (InChunk chunkLen)
+ = gotChunk input chunkLen
+
+ gotChunk ∷ Lazy.ByteString → Int → IO ()
+ gotChunk input chunkLen
+ = let input' = Lazy.drop (fromIntegral chunkLen) input
+ in
+ case LP.parse chunkFooter input' of
+ LP.Done input'' _
+ → go input'' Initial
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkFooter"
+
+ gotFinalChunk ∷ Lazy.ByteString → IO ()
+ gotFinalChunk input
+ = case LP.parse chunkTrailer input of
+ LP.Done input' _
+ → acceptRequest ctx input'
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "wasteAllChunks: chunkTrailer"
+
+readCurrentChunk ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → ThreadId
+ → Int
+ → Lazy.ByteString
+ → ChunkReceivingState
+ → IO ()
+readCurrentChunk ctx ni@(NI {..}) rsrcTid wanted = go
+ where
+ go ∷ Lazy.ByteString → ChunkReceivingState → IO ()
+ go input Initial
+ = case LP.parse chunkHeader input of
+ LP.Done input' chunkLen
+ | chunkLen ≡ 0
+ → gotFinalChunk input'
+ | otherwise
+ → gotChunk input' chunkLen
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkHeader"
+ go input (InChunk chunkLen)
+ = gotChunk input chunkLen
+
+ gotChunk ∷ Lazy.ByteString → Int → IO ()
+ gotChunk input chunkLen
+ = do let bytesToRead = min wanted chunkLen
+ (block, input') = Lazy.splitAt (fromIntegral bytesToRead) input
+ block' = Strict.concat $ Lazy.toChunks block
+ actualReadBytes = Strict.length block'
+ chunkLen' = chunkLen - actualReadBytes
+ atomically $ putTMVar niReceivedBody block'
+ if chunkLen' ≡ 0 then
+ case LP.parse chunkFooter input' of
+ LP.Done input'' _
+ → waitForReceiveChunkedBodyReq ctx ni rsrcTid input'' Initial
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkFooter"
+ else
+ waitForReceiveChunkedBodyReq ctx ni rsrcTid input' $ InChunk chunkLen'
+
+ gotFinalChunk ∷ Lazy.ByteString → IO ()
+ gotFinalChunk input
+ = do atomically $ putTMVar niReceivedBody (∅)
+ case LP.parse chunkTrailer input of
+ LP.Done input' _
+ → acceptRequest ctx input'
+ LP.Fail _ eCtx e
+ → chunkWasMalformed rsrcTid eCtx e
+ "readCurrentChunk: chunkTrailer"
+
+chunkWasMalformed ∷ ThreadId → [String] → String → String → IO ()
+chunkWasMalformed tid eCtx e msg
+ = let abo = mkAbortion BadRequest [("Connection", "close")]
+ $ Just
+ $ "chunkWasMalformed: "
+ ⊕ T.pack msg
+ ⊕ ": "
+ ⊕ T.pack (intercalate ", " eCtx)
+ ⊕ ": "
+ ⊕ T.pack e
+ in
+ throwTo tid abo
+
+waitForReceiveNonChunkedBodyReqForTheFirstTime ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+waitForReceiveNonChunkedBodyReqForTheFirstTime ctx ni@(NI {..}) input bodyLen
+ = join $
+ atomically $
+ do req ← takeTMVar niReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → do putTMVar niSendContinue niExpectedContinue
+ return $ readNonChunkedRequestBody ctx ni input bodyLen wanted
+ WasteAll
+ → do putTMVar niSendContinue False
+ return $ wasteNonChunkedRequestBody ctx input bodyLen
+
+waitForReceiveNonChunkedBodyReq ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → Lazy.ByteString
+ → Int
+ → IO ()
+waitForReceiveNonChunkedBodyReq ctx ni@(NI {..}) input bodyLen
+ = do req ← atomically $ takeTMVar niReceiveBodyReq
+ case req of
+ ReceiveBody wanted
+ → readNonChunkedRequestBody ctx ni input bodyLen wanted
+ WasteAll
+ → wasteNonChunkedRequestBody ctx input bodyLen
+
+wasteNonChunkedRequestBody ∷ HandleLike h
+ ⇒ Context h
+ → Lazy.ByteString
+ → Int
+ → IO ()
+wasteNonChunkedRequestBody ctx input bodyLen
+ = do let input' = Lazy.drop (fromIntegral bodyLen) input
+ acceptRequest ctx input'
+
+readNonChunkedRequestBody ∷ HandleLike h
+ ⇒ Context h
+ → NormalInteraction
+ → Lazy.ByteString
+ → Int
+ → Int
+ → IO ()
+readNonChunkedRequestBody ctx ni@(NI {..}) input bodyLen wanted
+ | bodyLen ≡ 0 = gotEndOfRequest
+ | otherwise = gotBody