From 0214f070b80791323430e21b53bcbe8a77b71b23 Mon Sep 17 00:00:00 2001 From: pho Date: Wed, 3 Mar 2010 23:30:16 +0900 Subject: [PATCH] Honor cnfServerV4Addr and cnfServerV6Addr. Ignore-this: 63735347206de657c2c095e677a52f4e darcs-hash:20100303143016-62b54-82d8627a3e3222f5cca265710cb7e9e1da6d60b7.gz --- Network/HTTP/Lucu/Config.hs | 8 +-- Network/HTTP/Lucu/DefaultPage.hs | 6 -- Network/HTTP/Lucu/Httpd.hs | 88 ++++++++++++++++++++++++++---- Network/HTTP/Lucu/Interaction.hs | 6 +- Network/HTTP/Lucu/Preprocess.hs | 28 +++------- Network/HTTP/Lucu/RequestReader.hs | 8 +-- examples/HelloWorld.hs | 3 +- examples/Implanted.hs | 3 +- examples/ImplantedSmall.hs | 3 +- examples/Makefile | 3 +- examples/Multipart.hs | 3 +- examples/SSL.hs | 5 +- 12 files changed, 105 insertions(+), 59 deletions(-) diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 847b737..29c5608 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -26,8 +26,8 @@ data Config = Config { -- 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 HTTP clients. Set this to -- @('Just' "0.0.0.0")@ if you want to accept any IPv4 @@ -88,7 +88,7 @@ data SSLConfig -- |A port ID to listen to HTTPS clients. Local addresses -- (both for IPv4 and IPv6) will be derived from the parent -- 'Config'. - sslServerPort :: !PortID + sslServerPort :: !ServiceName -- |An SSL context for accepting connections. , sslContext :: !SSLContext @@ -101,7 +101,7 @@ defaultConfig :: Config 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 diff --git a/Network/HTTP/Lucu/DefaultPage.hs b/Network/HTTP/Lucu/DefaultPage.hs index cbbf674..2220c7f 100644 --- a/Network/HTTP/Lucu/DefaultPage.hs +++ b/Network/HTTP/Lucu/DefaultPage.hs @@ -12,7 +12,6 @@ import Control.Monad 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 @@ mkDefaultPage !conf !status !msgA 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 index 1d0f2b8..d9f28f1 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -6,13 +6,16 @@ module Network.HTTP.Lucu.Httpd where import Control.Concurrent -import Network hiding (accept) +import Control.Exception +import Control.Monad +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 Network.HTTP.Lucu.SocketLike +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 @@ -53,20 +56,83 @@ runHttpd cnf tree fbs = withSocketsDo $ do _ <- installHandler sigPIPE Ignore Nothing + -- FIXME: TERRIBLE CODE. NEED MAJOR REWRITE. case cnfSSLConfig cnf of Nothing -> return () Just scnf - -> do so <- listenOn (sslServerPort scnf) - _loopTID <- forkIO $ httpLoop (sslContext scnf, so) - return () + -> do case cnfServerV4Addr cnf of + Nothing + -> return () + Just v4addr + -> do so <- listenOn AF_INET v4addr (sslServerPort scnf) + p <- socketPort so + -- FIXME: Don't throw away the thread + -- ID as we can't kill it later + -- then. [1] + _ <- forkIO $ httpLoop p (sslContext scnf, so) + return () + + case cnfServerV6Addr cnf of + Nothing + -> return () + Just v6addr + -> do so <- listenOn AF_INET6 v6addr (sslServerPort scnf) + p <- socketPort so + -- FIXME: [1] + _ <- forkIO $ httpLoop p (sslContext scnf, so) + return () - httpLoop =<< listenOn (cnfServerPort cnf) + case cnfServerV4Addr cnf of + Nothing + -> return () + Just v4addr + -> do so <- listenOn AF_INET v4addr (cnfServerPort cnf) + p <- socketPort so + -- FIXME: [1] + _ <- forkIO $ httpLoop p so + return () + + case cnfServerV6Addr cnf of + Nothing + -> return () + Just v6addr + -> do so <- listenOn AF_INET6 v6addr (cnfServerPort cnf) + p <- socketPort so + -- FIXME: [1] + _ <- forkIO $ httpLoop p so + return () + + waitForever where - httpLoop :: SocketLike s => s -> IO () - httpLoop so - = do (h, addr) <- accept 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 + ) + + httpLoop :: SocketLike s => PortNumber -> s -> IO () + httpLoop port so + = do (h, addr) <- SL.accept so tQueue <- newInteractionQueue - readerTID <- forkIO $ requestReader cnf tree fbs h addr tQueue + readerTID <- forkIO $ requestReader cnf tree fbs h port addr tQueue _writerTID <- forkIO $ responseWriter cnf h tQueue readerTID - httpLoop so + httpLoop port so + + waitForever :: IO () + waitForever = forever (threadDelay 1000000) diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index 5da428d..4c93b41 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -31,6 +31,7 @@ import OpenSSL.X509 data Interaction = Interaction { itrConfig :: !Config + , itrLocalPort :: !PortNumber , itrRemoteAddr :: !SockAddr , itrRemoteCert :: !(Maybe X509) , itrResourcePath :: !(Maybe [String]) @@ -82,8 +83,8 @@ defaultPageContentType :: Strict.ByteString 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 @@ newInteraction !conf !addr !cert !req 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 index de5efaa..fc3fcbd 100644 --- a/Network/HTTP/Lucu/Preprocess.hs +++ b/Network/HTTP/Lucu/Preprocess.hs @@ -15,7 +15,6 @@ import Network.HTTP.Lucu.HttpVersion import Network.HTTP.Lucu.Interaction import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response -import Network import Network.URI {- @@ -79,36 +78,25 @@ preprocess itr 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 index e724489..cfc991a 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -28,8 +28,8 @@ import Prelude hiding (catch) 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 @@ requestReader !cnf !tree !fbs !h !addr !tQueue 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 @@ requestReader !cnf !tree !fbs !h !addr !tQueue 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/examples/HelloWorld.hs b/examples/HelloWorld.hs index 187bd34..71916f3 100644 --- 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 ) diff --git a/examples/Implanted.hs b/examples/Implanted.hs index 390a572..6842308 100644 --- 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 index 9ee3466..af35b63 100644 --- 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 index 002f481..3e2c6f0 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -5,7 +5,6 @@ TARGETS = \ ImplantedSmall \ Multipart \ SSL \ - StaticDir \ $(NULL) build: $(TARGETS) @@ -22,6 +21,8 @@ clean: 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 index f8c1c7b..3897dfb 100644 --- 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 index 129316e..436749f 100644 --- 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 @@ main = withOpenSSL $ SSL.contextSetDefaultCiphers ctx let config = defaultConfig { - cnfServerPort = PortNumber 9000 + cnfServerPort = "9000" , cnfSSLConfig = Just SSLConfig { - sslServerPort = PortNumber 9001 + sslServerPort = "9001" , sslContext = ctx } } -- 2.40.0