From 07b641d6c0a4ba07a07ede4d746dfb08a5ed0730 Mon Sep 17 00:00:00 2001 From: pho Date: Thu, 4 Mar 2010 01:49:40 +0900 Subject: [PATCH] Code clean-up (and close ditz/lucu-1) Ignore-this: 62467b5a26cdb109e1dc244adb0d1547 darcs-hash:20100303164940-62b54-079229fe102c0f0d2456679115713ca0bc032c77.gz --- Lucu.cabal | 2 +- Network/HTTP/Lucu/Httpd.hs | 75 +++++++------------ Network/HTTP/Lucu/SocketLike.hs | 9 ++- ...0818803927d05bfdd5c0d4b074d042589edc1.yaml | 18 ++++- bugs/project.yaml | 4 +- examples/HelloWorld.hs | 2 + 6 files changed, 57 insertions(+), 53 deletions(-) diff --git a/Lucu.cabal b/Lucu.cabal index 891efa2..39fa14b 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -16,7 +16,7 @@ Maintainer: PHO 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: diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index d9f28f1..0bb92b1 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -8,6 +8,7 @@ module Network.HTTP.Lucu.Httpd import Control.Concurrent import Control.Exception import Control.Monad +import Data.Maybe import Network.BSD import Network.Socket import Network.HTTP.Lucu.Config @@ -56,55 +57,37 @@ 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 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 () - - 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 () + 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 + 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 () + listenOn :: Family -> HostName -> ServiceName -> IO Socket listenOn fam host srv = do proto <- getProtocolNumber "tcp" diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs index f64e24b..b99811f 100644 --- a/Network/HTTP/Lucu/SocketLike.hs +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -11,21 +11,28 @@ import qualified System.IO as I class (HandleLike (Handle s)) => SocketLike s where type Handle s :: * - accept :: s -> IO (Handle s, So.SockAddr) + 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 \ No newline at end of file diff --git a/bugs/issue-d2a0818803927d05bfdd5c0d4b074d042589edc1.yaml b/bugs/issue-d2a0818803927d05bfdd5c0d4b074d042589edc1.yaml index dce7ca1..7ead2e0 100644 --- a/bugs/issue-d2a0818803927d05bfdd5c0d4b074d042589edc1.yaml +++ b/bugs/issue-d2a0818803927d05bfdd5c0d4b074d042589edc1.yaml @@ -10,10 +10,10 @@ desc: |- Thanks type: :feature component: Lucu -release: 0.4.3 +release: "0.5" reporter: PHO -status: :unstarted -disposition: +status: :closed +disposition: :fixed creation_time: 2010-03-02 12:09:26.521388 Z references: [] @@ -27,3 +27,15 @@ log_events: - PHO - assigned to release 0.4.3 from unassigned - "" +- - 2010-03-03 16:43:24.865175 Z + - PHO + - unassigned from release 0.4.3 + - This change should bump version to 0.5 +- - 2010-03-03 16:46:04.795565 Z + - PHO + - assigned to release 0.5 from unassigned + - "" +- - 2010-03-03 16:47:55.250708 Z + - PHO + - closed with disposition fixed + - Seems working now. diff --git a/bugs/project.yaml b/bugs/project.yaml index f9e9557..d0978a6 100644 --- a/bugs/project.yaml +++ b/bugs/project.yaml @@ -6,11 +6,11 @@ components: name: Lucu releases: - !ditz.rubyforge.org,2008-03-06/release - name: 0.4.3 + name: "0.5" status: :unreleased release_time: log_events: - - - 2010-03-02 12:12:26.585821 Z + - - 2010-03-03 16:45:31.176635 Z - PHO - created - "" diff --git a/examples/HelloWorld.hs b/examples/HelloWorld.hs index 71916f3..dacd4c3 100644 --- a/examples/HelloWorld.hs +++ b/examples/HelloWorld.hs @@ -29,6 +29,8 @@ helloWorld setContentType $ read "text/hello" outputChunk "Hello, " outputChunk "World!\n" + outputChunk =<< getRemoteAddr' + , resPost = Just $ do str1 <- inputChunk 3 str2 <- inputChunk 3 -- 2.40.0