From f504167b85561373b4c444e2d37a513e0ab504a9 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 3 Mar 2010 17:20:51 +0900 Subject: [PATCH] Code cleanup (preparation for ditz/lucu-1) Ignore-this: 9b0edd70726ed97ba72b9cca637f575f darcs-hash:20100303082051-62b54-fc2e901fab9b9a2a7fd424c3b888d847bc23d8c3.gz --- Lucu.cabal | 5 ++++- Network/HTTP/Lucu/Config.hs | 9 +++++++++ Network/HTTP/Lucu/Httpd.hs | 33 +++++---------------------------- Network/HTTP/Lucu/SocketLike.hs | 31 +++++++++++++++++++++++++++++++ 4 files changed, 49 insertions(+), 29 deletions(-) create mode 100644 Network/HTTP/Lucu/SocketLike.hs diff --git a/Lucu.cabal b/Lucu.cabal index d2db94e..891efa2 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -81,9 +81,12 @@ Library Network.HTTP.Lucu.Preprocess Network.HTTP.Lucu.RequestReader Network.HTTP.Lucu.ResponseWriter + Network.HTTP.Lucu.SocketLike Extensions: - BangPatterns, DeriveDataTypeable, ScopedTypeVariables, UnboxedTuples + BangPatterns, DeriveDataTypeable, FlexibleContexts, + FlexibleInstances, ScopedTypeVariables, TypeFamilies, + UnboxedTuples ghc-options: -Wall diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index c5f3f3e..d2b0f60 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -18,35 +18,44 @@ import System.IO.Unsafe -- |Configuration record for the Lucu httpd. You need to use -- 'defaultConfig' or setup your own configuration to run the httpd. data Config = Config { + -- |A string which will be sent to clients as \"Server\" field. cnfServerSoftware :: !Strict.ByteString + -- |The host name of the server. This value will be used in -- built-in pages like \"404 Not Found\". , cnfServerHost :: !Strict.ByteString + -- |A port ID to listen to HTTP clients. , cnfServerPort :: !PortID + -- |Configuration for HTTPS connections. Set this 'Nothing' to -- disable HTTPS. , cnfSSLConfig :: !(Maybe SSLConfig) + -- |The maximum number of requests to accept in one connection -- simultaneously. If a client exceeds this limitation, its last -- request won't be processed until a response for its earliest -- pending request is sent back to the client. , cnfMaxPipelineDepth :: !Int + -- |The maximum length of request entity to accept in bytes. Note -- that this is nothing but the default value which is used when -- 'Network.HTTP.Lucu.Resource.input' and such like are applied to -- 'Network.HTTP.Lucu.Resource.defaultLimit', so there is no -- guarantee that this value always constrains all the requests. , cnfMaxEntityLength :: !Int + -- |The maximum length of chunk to output. This value is used by -- 'Network.HTTP.Lucu.Resource.output' and such like to limit the -- chunk length so you can safely output an infinite string (like -- a lazy stream of \/dev\/random) using those actions. , cnfMaxOutputChunkLength :: !Int + -- | Whether to dump too late abortion to the stderr or not. See -- 'Network.HTTP.Lucu.Abortion.abort'. , cnfDumpTooLateAbortionToStderr :: !Bool + -- |A mapping from extension to MIME Type. This value is used by -- 'Network.HTTP.Lucu.StaticFile.staticFile' to guess the MIME -- Type of static files. Note that MIME Types are currently diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index bab8d72..1d0f2b8 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -6,15 +6,13 @@ module Network.HTTP.Lucu.Httpd where import Control.Concurrent -import Network -import qualified Network.Socket as So +import Network hiding (accept) import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.RequestReader import Network.HTTP.Lucu.Resource.Tree import Network.HTTP.Lucu.ResponseWriter -import qualified OpenSSL.Session as SSL -import System.IO +import Network.HTTP.Lucu.SocketLike import System.Posix.Signals -- |This is the entry point of Lucu httpd. It listens to a socket and @@ -60,36 +58,15 @@ runHttpd cnf tree fbs -> return () Just scnf -> do so <- listenOn (sslServerPort scnf) - _loopTID <- forkIO $ httpsLoop (sslContext scnf) so + _loopTID <- forkIO $ httpLoop (sslContext scnf, so) return () httpLoop =<< listenOn (cnfServerPort cnf) where - httpLoop :: Socket -> IO () + httpLoop :: SocketLike s => s -> IO () httpLoop so - = do (h, addr) <- acceptHTTP so + = do (h, addr) <- accept so tQueue <- newInteractionQueue readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID httpLoop so - - httpsLoop :: SSL.SSLContext -> Socket -> IO () - httpsLoop ctx so - = do (ssl, addr) <- acceptHTTPS ctx so - tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree fbs ssl addr tQueue - _writerTID <- forkIO $ responseWriter cnf ssl tQueue readerTID - httpsLoop ctx so - - acceptHTTP :: Socket -> IO (Handle, So.SockAddr) - acceptHTTP soSelf - = do (soPeer, addr) <- So.accept soSelf - hPeer <- So.socketToHandle soPeer ReadWriteMode - return (hPeer, addr) - - acceptHTTPS :: SSL.SSLContext -> Socket -> IO (SSL.SSL, So.SockAddr) - acceptHTTPS ctx so - = do (so', addr) <- So.accept so - ssl <- SSL.connection ctx so' - SSL.accept ssl - return (ssl, addr) diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs new file mode 100644 index 0000000..f64e24b --- /dev/null +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -0,0 +1,31 @@ +module Network.HTTP.Lucu.SocketLike + ( SocketLike(..) + ) + where + +import qualified Network.Socket as So +import Network.HTTP.Lucu.HandleLike +import qualified OpenSSL.Session as SSL +import qualified System.IO as I + + +class (HandleLike (Handle s)) => SocketLike s where + type Handle s :: * + accept :: s -> IO (Handle s, So.SockAddr) + + +instance SocketLike So.Socket where + type Handle So.Socket = I.Handle + accept soSelf + = do (soPeer, addr) <- So.accept soSelf + hPeer <- So.socketToHandle soPeer I.ReadWriteMode + return (hPeer, addr) + + +instance SocketLike (SSL.SSLContext, So.Socket) where + type Handle (SSL.SSLContext, So.Socket) = SSL.SSL + accept (ctx, soSelf) + = do (soPeer, addr) <- So.accept soSelf + ssl <- SSL.connection ctx soPeer + SSL.accept ssl + return (ssl, addr) -- 2.40.0