import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils
import GHC.IO.Exception (IOException(..), IOErrorType(..))
-import qualified Data.Ascii as A
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.HandleLike
import Network.HTTP.Lucu.HttpVersion
import Network.HTTP.Lucu.Interaction
+import Network.HTTP.Lucu.Request
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
`catches`
[ Handler handleIOE
, Handler handleAsyncE
- , Handler handleBIOS
, Handler handleOthers
]
`finally`
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 "requestWriter caught an exception:"
- hPutStrLn stderr (show $ toException e)
+ = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
+ hPutStrLn stderr $ show e
awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
awaitSomethingToWrite ctx@(Context {..})
, resStatus = fromStatusCode Continue
, resHeaders = (∅)
}
- hPutBuilder cHandle $ A.toBuilder $ printResponse cont
+ hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) cont
hFlush cHandle
writeHeader ctx ni
readTVar niResponse
else
retry -- Too early to write header fields.
- hPutBuilder cHandle $ A.toBuilder $ printResponse res
+ hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) res
hFlush cHandle
writeBodyIfNeeded ctx ni
writeBodyIfNeeded ctx ni@(NI {..})
= join $
atomically $
- do willDiscardBody ← readTVar niWillDiscardBody
- if willDiscardBody then
- return $ discardBody ctx ni
- else
+ do canHaveBody ← resCanHaveBody <$> readTVar niResponse
+ if canHaveBody ∧ reqMethod niRequest ≢ HEAD then
if niWillChunkBody then
return $ writeChunkedBody ctx ni
else
return $ writeNonChunkedBody ctx ni
+ else
+ return $ discardBody ctx ni
discardBody ∷ HandleLike h
⇒ Context h
→ SemanticallyInvalidInteraction
→ IO ()
writeResponseForSEI ctx@(Context {..}) (SEI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
- unless seiWillDiscardBody $
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
+ when (reqMethod seiRequest ≢ HEAD) $
if seiWillChunkBody then
do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
hPutBuilder cHandle BB.chunkedTransferTerminator
→ SyntacticallyInvalidInteraction
→ IO ()
writeResponseForSYI (Context {..}) (SYI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
hPutBuilder cHandle syiBodyToSend
hFlush cHandle
return ()