module Network.HTTP.Lucu.Interaction
( Interaction(..)
, SomeInteraction(..)
+ , EndOfInteraction(..)
, SyntacticallyInvalidInteraction(..)
, mkSyntacticallyInvalidInteraction
toInteraction = id
fromInteraction = Just
+-- |'EndOfInteraction' is an 'Interaction' indicating the end of
+-- (possibly pipelined) requests. The connection has already been
+-- closed so no need to reply anything.
+data EndOfInteraction = EndOfInteraction
+ deriving Typeable
+instance Interaction EndOfInteraction
+
-- |'SyntacticallyInvalidInteraction' is an 'Interaction' without even
-- a syntactically valid 'Request'. The response code will always be
-- 'BadRequest'.
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
+ endOfRequests ctx
+ else
+ case LP.parse request input of
+ LP.Done input' req → acceptParsableRequest ctx req input'
+ LP.Fail _ _ _ → acceptNonparsableRequest ctx
+
+endOfRequests ∷ HandleLike h ⇒ Context h → IO ()
+endOfRequests ctx
+ = enqueue ctx EndOfInteraction
acceptNonparsableRequest ∷ HandleLike h ⇒ Context h → IO ()
acceptNonparsableRequest ctx@(Context {..})
import Control.Concurrent.STM
import Control.Exception
import Control.Monad
+import GHC.IO.Exception (IOException(..), IOErrorType(..))
import qualified Data.Ascii as A
import Data.Monoid.Unicode
import qualified Data.Sequence as S
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
+ handleAsyncE ThreadKilled = return ()
+ handleAsyncE e = dump e
handleBIOS ∷ BlockedIndefinitelyOnSTM → IO ()
- handleBIOS = terminate
+ handleBIOS = dump
handleOthers ∷ SomeException → IO ()
- handleOthers = terminate
+ handleOthers = dump
- terminate ∷ Exception e ⇒ e → IO ()
- terminate e
+ dump ∷ Exception e ⇒ e → IO ()
+ dump e
= do hPutStrLn stderr "requestWriter caught an exception:"
hPutStrLn stderr (show $ toException e)
- terminate'
-
- terminate' ∷ IO ()
- terminate' = hClose h
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
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
hPutBuilder cHandle seiBodyToSend
hFlush cHandle
if seiWillClose ∨ seiExpectedContinue then
- do killThread cReader
- hClose cHandle
+ return ()
else
awaitSomethingToWrite ctx
= do hPutBuilder cHandle $ A.toBuilder $ printResponse syiResponse
hPutBuilder cHandle syiBodyToSend
hFlush cHandle
- killThread cReader
- hClose cHandle
+ return ()
+
+endOfResponses ∷ EndOfInteraction → IO ()
+endOfResponses _ = return ()
( SocketLike(..)
)
where
+#if defined(HAVE_SSL)
+import Control.Exception
+#endif
import qualified Network.Socket as So
import Network.HTTP.Lucu.HandleLike
#if defined(HAVE_SSL)
import qualified OpenSSL.Session as SSL
+import Prelude hiding (catch)
import Prelude.Unicode
#endif
import qualified System.IO as I
accept (ctx, soSelf)
= do (soPeer, addr) ← So.accept soSelf
ssl ← SSL.connection ctx soPeer
- SSL.accept ssl
- return (ssl, addr)
+ handshake ssl addr `catch` next ssl addr
+ where
+ handshake ∷ SSL.SSL → So.SockAddr → IO (SSL.SSL, So.SockAddr)
+ handshake ssl addr
+ = do SSL.accept ssl
+ return (ssl, addr)
+
+ next ∷ SSL.SSL
+ → So.SockAddr
+ → SSL.SomeSSLException
+ → IO (SSL.SSL, So.SockAddr)
+ next ssl addr e
+ = do I.hPutStrLn I.stderr
+ $ "Lucu: failed to accept an SSL connection from "
+ ⧺ show addr
+ ⧺ ":"
+ I.hPutStrLn I.stderr
+ $ show e
+ SSL.shutdown ssl SSL.Bidirectional
+ accept (ctx, soSelf)
socketPort = So.socketPort ∘ snd
#endif
projects / Lucu.git / commitdiff