import Control.Concurrent.STM
import Control.Exception
import Control.Monad
-import qualified Data.Ascii as A
+import Data.Ascii (AsciiBuilder)
+import Data.Convertible.Utils
+import GHC.IO.Exception (IOException(..), IOErrorType(..))
import Data.Monoid.Unicode
import qualified Data.Sequence as S
import Data.Sequence (ViewR(..))
import Network.HTTP.Lucu.Response
import Prelude.Unicode
import System.IO (hPutStrLn, stderr)
-import System.IO.Error
data Context h
= Context {
cConfig ∷ !Config
, cHandle ∷ !h
, cQueue ∷ !InteractionQueue
- , cReader ∷ !ThreadId
}
responseWriter ∷ HandleLike h ⇒ Config → h → InteractionQueue → ThreadId → IO ()
responseWriter cnf h tQueue readerTID
- = awaitSomethingToWrite (Context cnf h tQueue readerTID)
+ = awaitSomethingToWrite (Context cnf h tQueue)
`catches`
[ Handler handleIOE
, Handler handleAsyncE
- , Handler handleBIOS
, Handler handleOthers
]
+ `finally`
+ do killThread readerTID
+ hClose h
where
handleIOE ∷ IOException → IO ()
- handleIOE e
- | isIllegalOperation e
- = return () -- EPIPE: should be ignored at all.
- | otherwise
- = terminate e
+ handleIOE e@(IOError {..})
+ | ioe_type ≡ ResourceVanished = return ()
+ | otherwise = dump e
handleAsyncE ∷ AsyncException → IO ()
- handleAsyncE ThreadKilled = terminate'
- handleAsyncE e = terminate e
-
- handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
- handleBIOS = terminate
+ handleAsyncE ThreadKilled = return ()
+ handleAsyncE e = dump e
handleOthers ∷ SomeException → IO ()
- handleOthers = terminate
-
- terminate ∷ Exception e ⇒ e → IO ()
- terminate e
- = do hPutStrLn stderr "requestWriter caught an exception:"
- hPutStrLn stderr (show $ toException e)
- terminate'
+ handleOthers = dump
- terminate' ∷ IO ()
- terminate' = hClose h
+ dump ∷ Exception e ⇒ e → IO ()
+ dump e
+ = do hPutStrLn stderr "Lucu: responseWriter caught an exception:"
+ hPutStrLn stderr $ show e
awaitSomethingToWrite ∷ HandleLike h ⇒ Context h → IO ()
awaitSomethingToWrite ctx@(Context {..})
writeSomething ctx itr
= let writer = writeResponseForNI ctx <$> fromInteraction itr <|>
writeResponseForSEI ctx <$> fromInteraction itr <|>
- writeResponseForSYI ctx <$> fromInteraction itr
+ writeResponseForSYI ctx <$> fromInteraction itr <|>
+ endOfResponses <$> fromInteraction itr
in
case writer of
Just f → f
when isNeeded
$ do let cont = Response {
resVersion = HttpVersion 1 1
- , resStatus = Continue
+ , 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
sentContinue ← takeTMVar niSendContinue
return $
if needToClose willClose sentContinue then
- -- The RequestReader is probably blocking on
- -- hWaitForInput so we have to kill it before closing
- -- the socket. THINKME: Couldn't that somehow be
- -- avoided?
- do killThread cReader
- hClose cHandle
+ return ()
else
awaitSomethingToWrite ctx
where
→ SemanticallyInvalidInteraction
→ IO ()
writeResponseForSEI ctx@(Context {..}) (SEI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse seiResponse
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) seiResponse
unless seiWillDiscardBody $
if seiWillChunkBody then
do hPutBuilder cHandle $ BB.chunkedTransferEncoding seiBodyToSend
hPutBuilder cHandle seiBodyToSend
hFlush cHandle
if seiWillClose ∨ seiExpectedContinue then
- do killThread cReader
- hClose cHandle
+ return ()
else
awaitSomethingToWrite ctx
→ SyntacticallyInvalidInteraction
→ IO ()
writeResponseForSYI (Context {..}) (SYI {..})
- = do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
+ = do hPutBuilder cHandle $ convertSuccessVia ((⊥) ∷ AsciiBuilder) syiResponse
hPutBuilder cHandle syiBodyToSend
hFlush cHandle
- killThread cReader
- hClose cHandle
+ return ()
+
+endOfResponses ∷ EndOfInteraction → IO ()
+endOfResponses _ = return ()