diff --git a/Lucu.cabal b/Lucu.cabal --- a/Lucu.cabal +++ b/Lucu.cabal @@ -8,7 +8,7 @@ messing around FastCGI. It is also intended to be run behind a reverse-proxy so it doesn't have some facilities like logging, client filtering or such like. -Version: 0.4.2 +Version: 0.5 License: PublicDomain License-File: COPYING Author: PHO @@ -16,7 +16,7 @@ Stability: experimental Homepage: http://cielonegro.org/Lucu.html Category: Network -Tested-With: GHC == 6.10.1 +Tested-With: GHC == 6.12.1 Cabal-Version: >= 1.6 Build-Type: Simple Extra-Source-Files: @@ -81,9 +81,12 @@ 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/NEWS b/NEWS --- a/NEWS +++ b/NEWS @@ -1,3 +1,25 @@ +Changes from 0.4.2 to 0.5 +------------------------- +* Network.HTTP.Lucu.Config: (Suggested by Voker57) + + - New config parameters: + - cnfServerV4Addr (default: Just "0.0.0.0") + - cnfServerV6Addr (default: Just "::") + + These are local IP addresses to listen to both HTTP and HTTPS + clients. If you set 'cnfServerV4Addr' to Nothing, Lucu will not + listen to IPv4 clients. Ditto with 'cnfServerV6Addr'. + + - Type change: + - cnfServerPort + - sslServerPort + + The type of these params used to be Network.PortID but is now + Network.Socket.ServiceName, which means Lucu no longer be able + to listen to UNIX domain sockets. I believe no one wants to do + that but feel free to blame PHO if you miss it. + + Changes from 0.4.1 to 0.4.2 --------------------------- * Fixed build failure on GHC 6.12.1. (Thanks: Voker57) diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -18,35 +18,56 @@ -- |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 + + -- |A port number (or service name) to listen to HTTP clients. + , cnfServerPort :: !ServiceName + + -- |Local IPv4 address to listen to both HTTP and HTTPS + -- clients. Set this to @('Just' "0.0.0.0")@ if you want to accept + -- any IPv4 connections. Set this to 'Nothing' to disable IPv4. + , cnfServerV4Addr :: !(Maybe HostName) + + -- |Local IPv6 address to listen to both HTTP and HTTPS + -- clients. Set this to @('Just' "::")@ if you want to accept any + -- IPv6 connections. Set this to 'Nothing' to disable IPv6. Note + -- that there is currently no way to assign separate ports to IPv4 + -- and IPv6 server sockets. + , cnfServerV6Addr :: !(Maybe HostName) + -- |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 @@ -64,8 +85,11 @@ -- |Configuration record for HTTPS connections. data SSLConfig = SSLConfig { - -- |A port ID to listen to HTTPS clients. - sslServerPort :: !PortID + -- |A port ID to listen to HTTPS clients. Local addresses + -- (both for IPv4 and IPv6) will be derived from the parent + -- 'Config'. + sslServerPort :: !ServiceName + -- |An SSL context for accepting connections. , sslContext :: !SSLContext } @@ -77,7 +101,9 @@ defaultConfig = Config { cnfServerSoftware = C8.pack "Lucu/1.0" , cnfServerHost = C8.pack (unsafePerformIO getHostName) - , cnfServerPort = Service "http" + , cnfServerPort = "http" + , cnfServerV4Addr = Just "0.0.0.0" + , cnfServerV6Addr = Just "::" , cnfSSLConfig = Nothing , cnfMaxPipelineDepth = 100 , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -12,7 +12,6 @@ import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy.Char8 as L8 import Data.Maybe -import Network import Network.HTTP.Lucu.Config import Network.HTTP.Lucu.Format import Network.HTTP.Lucu.Headers @@ -60,11 +59,6 @@ sig = C8.unpack (cnfServerSoftware conf) ++ " at " ++ C8.unpack (cnfServerHost conf) - ++ ( case cnfServerPort conf of - Service serv -> ", service " ++ serv - PortNumber num -> ", port " ++ show num - UnixSocket path -> ", unix socket " ++ show path - ) in ( eelem "/" += ( eelem "html" += sattr "xmlns" "http://www.w3.org/1999/xhtml" diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -6,15 +6,17 @@ where import Control.Concurrent -import Network -import qualified Network.Socket as So +import Control.Exception +import Control.Monad +import Data.Maybe +import Network.BSD +import Network.Socket 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 as SL import System.Posix.Signals -- |This is the entry point of Lucu httpd. It listens to a socket and @@ -55,41 +57,65 @@ = withSocketsDo $ do _ <- installHandler sigPIPE Ignore Nothing - case cnfSSLConfig cnf of - Nothing - -> return () - Just scnf - -> do so <- listenOn (sslServerPort scnf) - _loopTID <- forkIO $ httpsLoop (sslContext scnf) so - return () - - httpLoop =<< listenOn (cnfServerPort cnf) + let launchers + = catMaybes + [ do scnf <- cnfSSLConfig cnf + addr <- cnfServerV4Addr cnf + return ( do so <- listenOn AF_INET addr (sslServerPort scnf) + launchListener (sslContext scnf, so) + ) + , do scnf <- cnfSSLConfig cnf + addr <- cnfServerV6Addr cnf + return ( do so <- listenOn AF_INET6 addr (sslServerPort scnf) + launchListener (sslContext scnf, so) + ) + , do addr <- cnfServerV4Addr cnf + return ( launchListener =<< listenOn AF_INET addr (cnfServerPort cnf) + ) + , do addr <- cnfServerV6Addr cnf + return ( launchListener =<< listenOn AF_INET6 addr (cnfServerPort cnf) + ) + ] + + sequence_ launchers + waitForever where - httpLoop :: Socket -> IO () - httpLoop so - = do (h, addr) <- acceptHTTP so - tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue - _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID - httpLoop so + launchListener :: SocketLike s => s -> IO () + launchListener so + = do p <- SL.socketPort so + -- FIXME: Don't throw away the thread ID as we can't + -- kill it later then. [1] + _ <- forkIO $ httpLoop p so + return () - 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 + listenOn :: Family -> HostName -> ServiceName -> IO Socket + listenOn fam host srv + = do proto <- getProtocolNumber "tcp" + let hints = defaultHints { + addrFlags = [AI_PASSIVE] + , addrFamily = fam + , addrSocketType = Stream + , addrProtocol = proto + } + addrs <- getAddrInfo (Just hints) (Just host) (Just srv) + let addr = head addrs + bracketOnError + (socket (addrFamily addr) (addrSocketType addr) (addrProtocol addr)) + (sClose) + (\ sock -> + do setSocketOption sock ReuseAddr 1 + bindSocket sock (addrAddress addr) + listen sock maxListenQueue + return sock + ) - acceptHTTP :: Socket -> IO (Handle, So.SockAddr) - acceptHTTP soSelf - = do (soPeer, addr) <- So.accept soSelf - hPeer <- So.socketToHandle soPeer ReadWriteMode - return (hPeer, addr) + httpLoop :: SocketLike s => PortNumber -> s -> IO () + httpLoop port so + = do (h, addr) <- SL.accept so + tQueue <- newInteractionQueue + readerTID <- forkIO $ requestReader cnf tree fbs h port addr tQueue + _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID + httpLoop port so - 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) + waitForever :: IO () + waitForever = forever (threadDelay 1000000) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -31,6 +31,7 @@ data Interaction = Interaction { itrConfig :: !Config + , itrLocalPort :: !PortNumber , itrRemoteAddr :: !SockAddr , itrRemoteCert :: !(Maybe X509) , itrResourcePath :: !(Maybe [String]) @@ -82,8 +83,8 @@ defaultPageContentType = C8.pack "application/xhtml+xml" -newInteraction :: Config -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction -newInteraction !conf !addr !cert !req +newInteraction :: Config -> PortNumber -> SockAddr -> Maybe X509 -> Maybe Request -> IO Interaction +newInteraction !conf !port !addr !cert !req = do request <- newTVarIO req responce <- newTVarIO Response { resVersion = HttpVersion 1 1 @@ -117,6 +118,7 @@ return Interaction { itrConfig = conf + , itrLocalPort = port , itrRemoteAddr = addr , itrRemoteCert = cert , itrResourcePath = Nothing diff --git a/Network/HTTP/Lucu/Preprocess.hs b/Network/HTTP/Lucu/Preprocess.hs --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -15,7 +15,6 @@ import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network import Network.URI {- @@ -79,36 +78,25 @@ preprocessHeader req where setStatus :: StatusCode -> STM () - setStatus status - = status `seq` - updateItr itr itrResponse + setStatus !status + = updateItr itr itrResponse $! \ res -> res { resStatus = status } completeAuthority :: Request -> STM () - completeAuthority req - = req `seq` - when (uriAuthority (reqURI req) == Nothing) + completeAuthority !req + = when (uriAuthority (reqURI req) == Nothing) $ if reqVersion req == HttpVersion 1 0 then -- HTTP/1.0 なので Config から補完 do let conf = itrConfig itr host = cnfServerHost conf - port = case cnfServerPort conf of - PortNumber n -> Just (fromIntegral n :: Int) - _ -> Nothing + port = itrLocalPort itr portStr = case port of - Just 80 -> Just "" - Just n -> Just $ ':' : show n - Nothing -> Nothing - case portStr of - Just str -> updateAuthority host (C8.pack str) - -- FIXME: このエラーの原因は、listen してゐるソ - -- ケットが INET でない故にポート番號が分からな - -- い事だが、その事をどうにかして通知した方が良 - -- いと思ふ。stderr？ - Nothing -> setStatus InternalServerError + 80 -> "" + n -> ':' : show n + updateAuthority host (C8.pack portStr) else case getHeader (C8.pack "Host") req of Just str -> let (host, portStr) = parseHost str diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -28,8 +28,8 @@ import System.IO (stderr) -requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> SockAddr -> InteractionQueue -> IO () -requestReader !cnf !tree !fbs !h !addr !tQueue +requestReader :: HandleLike h => Config -> ResTree -> [FallbackHandler] -> h -> PortNumber -> SockAddr -> InteractionQueue -> IO () +requestReader !cnf !tree !fbs !h !port !addr !tQueue = do input <- hGetLBS h acceptRequest input `catches` @@ -59,7 +59,7 @@ acceptNonparsableRequest :: StatusCode -> IO () acceptNonparsableRequest status = {-# SCC "acceptNonparsableRequest" #-} - do itr <- newInteraction cnf addr Nothing Nothing + do itr <- newInteraction cnf port addr Nothing Nothing atomically $ do updateItr itr itrResponse $ \ res -> res { resStatus = status @@ -74,7 +74,7 @@ acceptParsableRequest req input = {-# SCC "acceptParsableRequest" #-} do cert <- hGetPeerCert h - itr <- newInteraction cnf addr cert (Just req) + itr <- newInteraction cnf port addr cert (Just req) action <- atomically $ do preprocess itr diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs new file mode 100644 --- /dev/null +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -0,0 +1,38 @@ +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) + socketPort :: s -> IO So.PortNumber + + +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) + + socketPort = So.socketPort + + +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) + + socketPort = So.socketPort . snd diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -1,8 +1,7 @@ -import Network import Network.HTTP.Lucu main :: IO () -main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } +main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ( [] , helloWorld ) @@ -30,6 +29,8 @@ setContentType $ read "text/hello" outputChunk "Hello, " outputChunk "World!\n" + outputChunk =<< getRemoteAddr' + , resPost = Just $ do str1 <- inputChunk 3 str2 <- inputChunk 3 diff --git a/examples/Implanted.hs b/examples/Implanted.hs --- a/examples/Implanted.hs +++ b/examples/Implanted.hs @@ -1,9 +1,8 @@ import MiseRafturai -import Network import Network.HTTP.Lucu main :: IO () -main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } +main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], miseRafturai) ] in do putStrLn "Access http://localhost:9999/ with your browser." diff --git a/examples/ImplantedSmall.hs b/examples/ImplantedSmall.hs --- a/examples/ImplantedSmall.hs +++ b/examples/ImplantedSmall.hs @@ -1,9 +1,8 @@ -import Network import Network.HTTP.Lucu import SmallFile main :: IO () -main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } +main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], smallFile) ] in do putStrLn "Access http://localhost:9999/ with your browser." diff --git a/examples/Makefile b/examples/Makefile --- a/examples/Makefile +++ b/examples/Makefile @@ -5,7 +5,6 @@ ImplantedSmall \ Multipart \ SSL \ - StaticDir \ $(NULL) build: $(TARGETS) @@ -21,6 +20,8 @@ MiseRafturai.hs: mise-rafturai.html lucu-implant-file -m MiseRafturai -o $@ $< + +ImplantedSmall.hs: SmallFile.hs SmallFile.hs: small-file.txt lucu-implant-file -m SmallFile -o $@ $< diff --git a/examples/Multipart.hs b/examples/Multipart.hs --- a/examples/Multipart.hs +++ b/examples/Multipart.hs @@ -1,11 +1,10 @@ import qualified Data.ByteString.Lazy.Char8 as L8 import Data.List import Data.Maybe -import Network import Network.HTTP.Lucu main :: IO () -main = let config = defaultConfig { cnfServerPort = PortNumber 9999 } +main = let config = defaultConfig { cnfServerPort = "9999" } resources = mkResTree [ ([], resMain) ] in do putStrLn "Access http://localhost:9999/ with your browser." diff --git a/examples/SSL.hs b/examples/SSL.hs --- a/examples/SSL.hs +++ b/examples/SSL.hs @@ -2,7 +2,6 @@ import Control.Monad import "mtl" Control.Monad.Trans import Data.Time.Clock -import Network import Network.HTTP.Lucu import OpenSSL import OpenSSL.EVP.PKey @@ -21,9 +20,9 @@ SSL.contextSetDefaultCiphers ctx let config = defaultConfig { - cnfServerPort = PortNumber 9000 + cnfServerPort = "9000" , cnfSSLConfig = Just SSLConfig { - sslServerPort = PortNumber 9001 + sslServerPort = "9001" , sslContext = ctx } }