Lucu 0.4.2 → 0.5

raw patch · 15 files changed

+187/−90 lines, 15 filesPVP ok

version bump matches the API change (PVP)

API changes (from Hackage documentation)

Files

• Lucu.cabal +6/−3
• NEWS +22/−0
• Network/HTTP/Lucu/Config.hs +31/−5
• Network/HTTP/Lucu/DefaultPage.hs +0/−6
• Network/HTTP/Lucu/Httpd.hs +64/−38
• Network/HTTP/Lucu/Interaction.hs +4/−2
• Network/HTTP/Lucu/Preprocess.hs +8/−20
• Network/HTTP/Lucu/RequestReader.hs +4/−4
• Network/HTTP/Lucu/SocketLike.hs +38/−0
• examples/HelloWorld.hs +3/−2
• examples/Implanted.hs +1/−2
• examples/ImplantedSmall.hs +1/−2
• examples/Makefile +2/−1
• examples/Multipart.hs +1/−2
• examples/SSL.hs +2/−3

@@ -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 <pho at cielonegro dot org>@@ -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

@@ -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)

@@ -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

@@ -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"

@@ -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)

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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

@@ -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."

@@ -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."

@@ -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 $@ $<

@@ -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."

@@ -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                                             }                           }