import Data.Text (Text)
import Network.HTTP.Lucu.Config
import Network.HTTP.Lucu.Chunk
-import Network.HTTP.Lucu.DefaultPage
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.Interaction
import Network.HTTP.Lucu.Postprocess
= do input ← hGetLBS h
acceptRequest (Context cnf tree fbs h port addr tQueue) input
`catches`
- [ Handler $ \ (_ ∷ IOException) → return ()
- , Handler $ \ e → case e of
- ThreadKilled → return ()
- _ → hPutStrLn stderr (show e)
- , Handler $ \ BlockedIndefinitelyOnSTM → hPutStrLn stderr "requestReader: blocked indefinitely"
- , Handler $ \ (e ∷ SomeException) → hPutStrLn stderr (show e)
+ [ Handler handleAsyncE
+ , Handler handleBIOS
+ , Handler handleOthers
]
+ 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)
acceptRequest ∷ HandleLike h ⇒ Context h → Lazy.ByteString → IO ()
acceptRequest ctx@(Context {..}) input
= do itr ← newInteraction cConfig cPort cAddr Nothing (Left sc)
atomically $
do writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
enqueue ctx itr
→ STM (IO ())
acceptSemanticallyInvalidRequest ctx itr input
= do writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
enqueue ctx itr
return $ acceptRequest ctx input
= do atomically $
do setResponseStatus itr NotFound
writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
enqueue ctx itr
acceptRequest ctx input
= do let itr = oldItr { itrResourcePath = Just rsrcPath }
atomically $ enqueue ctx itr
do _ ← runResource rsrcDef itr
- if reqHasBody $ fromJust $ itrRequest itr then
+ if reqMustHaveBody $ fromJust $ itrRequest itr then
observeRequest ctx itr input
else
acceptRequest ctx input
do setResponseStatus itr BadRequest
writeTVar (itrWillClose itr) True
writeTVar (itrState itr) Done
- writeDefaultPage itr
postprocess itr
observeNonChunkedRequest ∷ HandleLike h