From 874e6a4cc1229d29f1d902f36482cf0f78e30c9f Mon Sep 17 00:00:00 2001 From: PHO Date: Sun, 13 Nov 2011 01:13:32 +0900 Subject: [PATCH] Added a configuration flag -fssl to enable SSL support. (default: off) Ditz-issue: a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f --- GNUmakefile | 1 + Lucu.cabal | 11 ++++++++++- Network/HTTP/Lucu.hs | 2 +- Network/HTTP/Lucu/Config.hs | 13 ++++++++++++- Network/HTTP/Lucu/HandleLike.hs | 9 ++++++++- Network/HTTP/Lucu/Httpd.hs | 19 +++++++++++-------- Network/HTTP/Lucu/Interaction.hs | 15 ++++++++++++++- Network/HTTP/Lucu/RequestReader.hs | 10 ++++++++-- Network/HTTP/Lucu/Resource.hs | 5 ++++- Network/HTTP/Lucu/Resource/Internal.hs | 9 ++++++++- Network/HTTP/Lucu/SocketLike.hs | 7 ++++++- ...6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml | 8 ++++++-- examples/Makefile | 3 +++ 13 files changed, 92 insertions(+), 20 deletions(-) diff --git a/GNUmakefile b/GNUmakefile index 1f0eaf7..bd70335 100644 --- a/GNUmakefile +++ b/GNUmakefile @@ -1,5 +1,6 @@ RUN_COMMAND = $(MAKE) -C examples run CONFIGURE_ARGS = -O +#CONFIGURE_ARGS = -O -fssl include cabal-package.mk diff --git a/Lucu.cabal b/Lucu.cabal index e254dbd..a1a2279 100644 --- a/Lucu.cabal +++ b/Lucu.cabal @@ -44,9 +44,12 @@ Flag build-lucu-implant-file Description: Build the lucu-implant-file program. Default: True +Flag ssl + Description: Enable SSL support. + Default: False + Library Build-Depends: - HsOpenSSL == 0.10.*, ascii == 0.0.*, attoparsec == 0.9.*, base == 4.*, @@ -70,6 +73,12 @@ Library time-http == 0.2.*, transformers == 0.2.* + if flag(ssl) + Build-Depends: + HsOpenSSL == 0.10.* + CPP-Options: + -DHAVE_SSL + Exposed-Modules: Network.HTTP.Lucu Network.HTTP.Lucu.Abortion diff --git a/Network/HTTP/Lucu.hs b/Network/HTTP/Lucu.hs index b2c7895..682e91f 100644 --- a/Network/HTTP/Lucu.hs +++ b/Network/HTTP/Lucu.hs @@ -9,7 +9,7 @@ -- chunked I\/O, ETag comparison and \"100 Continue\". -- -- [/SSL connections/] Lucu can handle HTTP connections over Secure --- Socket Layer. +-- Socket Layer when configured with -fssl flag. -- -- Lucu is not a replacement for Apache or lighttpd. It is intended to -- be used to build an efficient web-based RESTful application which diff --git a/Network/HTTP/Lucu/Config.hs b/Network/HTTP/Lucu/Config.hs index 2ea2055..7549ae5 100644 --- a/Network/HTTP/Lucu/Config.hs +++ b/Network/HTTP/Lucu/Config.hs @@ -1,11 +1,14 @@ {-# LANGUAGE - OverloadedStrings + CPP + , OverloadedStrings , UnicodeSyntax #-} -- |Configurations for the Lucu httpd. module Network.HTTP.Lucu.Config ( Config(..) +#if defined(HAVE_SSL) , SSLConfig(..) +#endif , defaultConfig ) where @@ -16,7 +19,9 @@ import Network import Network.BSD import Network.HTTP.Lucu.MIMEType.Guess import Network.HTTP.Lucu.MIMEType.DefaultExtensionMap +#if defined(HAVE_SSL) import OpenSSL.Session +#endif import System.IO.Unsafe -- |Configuration record for to run the httpd. @@ -46,9 +51,11 @@ data Config = Config { -- problem.) , cnfServerV6Addr ∷ !(Maybe HostName) +#if defined(HAVE_SSL) -- |Configuration for HTTPS connections. Set this 'Nothing' to -- disable HTTPS. , cnfSSLConfig ∷ !(Maybe SSLConfig) +#endif -- |The maximum number of requests to simultaneously accept in one -- connection. If a client exceeds this limitation, its last @@ -77,6 +84,7 @@ data Config = Config { , cnfExtToMIMEType ∷ !ExtMap } +#if defined(HAVE_SSL) -- |Configuration record for HTTPS connections. data SSLConfig = SSLConfig { @@ -89,6 +97,7 @@ data SSLConfig -- up yourself with at least a server certification. , sslContext ∷ !SSLContext } +#endif -- |The default configuration. Generally you can use this value as-is, -- or possibly you just want to replace the 'cnfServerSoftware' and @@ -100,7 +109,9 @@ defaultConfig = Config { , cnfServerPort = "http" , cnfServerV4Addr = Just "0.0.0.0" , cnfServerV6Addr = Just "::" +#if defined(HAVE_SSL) , cnfSSLConfig = Nothing +#endif , cnfMaxPipelineDepth = 100 , cnfMaxEntityLength = 16 * 1024 * 1024 -- 16 MiB , cnfDumpTooLateAbortionToStderr = True diff --git a/Network/HTTP/Lucu/HandleLike.hs b/Network/HTTP/Lucu/HandleLike.hs index a45ce6c..cc90cd6 100644 --- a/Network/HTTP/Lucu/HandleLike.hs +++ b/Network/HTTP/Lucu/HandleLike.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - DoAndIfThenElse + CPP + , DoAndIfThenElse , UnicodeSyntax #-} -- |Type class for things behaves like a 'I.Handle'. @@ -12,8 +13,10 @@ import Blaze.ByteString.Builder (Builder) import qualified Blaze.ByteString.Builder as BB import qualified Data.ByteString as B import qualified Data.ByteString.Lazy.Char8 as L +#if defined(HAVE_SSL) import qualified OpenSSL.Session as SSL import OpenSSL.X509 +#endif import Prelude.Unicode import qualified System.IO as I @@ -23,8 +26,10 @@ class HandleLike h where hGetBS ∷ h → Int → IO B.ByteString hPutBS ∷ h → B.ByteString → IO () +#if defined(HAVE_SSL) hGetPeerCert ∷ h → IO (Maybe X509) hGetPeerCert = const $ return Nothing +#endif hFlush ∷ h → IO () hClose ∷ h → IO () @@ -38,6 +43,7 @@ instance HandleLike I.Handle where hFlush = I.hFlush hClose = I.hClose +#if defined(HAVE_SSL) instance HandleLike SSL.SSL where hGetLBS = SSL.lazyRead @@ -53,6 +59,7 @@ instance HandleLike SSL.SSL where hFlush _ = return () -- No need to do anything. hClose s = SSL.shutdown s SSL.Bidirectional +#endif hPutBuilder ∷ HandleLike h ⇒ h → Builder → IO () {-# INLINE hPutBuilder #-} diff --git a/Network/HTTP/Lucu/Httpd.hs b/Network/HTTP/Lucu/Httpd.hs index c8a21b7..883a9a6 100644 --- a/Network/HTTP/Lucu/Httpd.hs +++ b/Network/HTTP/Lucu/Httpd.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - UnicodeSyntax + CPP + , UnicodeSyntax #-} -- |The entry point of Lucu httpd. module Network.HTTP.Lucu.Httpd @@ -48,7 +49,14 @@ runHttpd cnf tree fbs = withSocketsDo $ do let launchers = catMaybes - [ do scnf ← cnfSSLConfig cnf + [ do addr ← cnfServerV4Addr cnf + return ( launchListener =≪ listenOn AF_INET addr (cnfServerPort cnf) + ) + , do addr ← cnfServerV6Addr cnf + return ( launchListener =≪ listenOn AF_INET6 addr (cnfServerPort cnf) + ) +#if defined(HAVE_SSL) + , do scnf ← cnfSSLConfig cnf addr ← cnfServerV4Addr cnf return ( do so ← listenOn AF_INET addr (sslServerPort scnf) launchListener (sslContext scnf, so) @@ -58,12 +66,7 @@ runHttpd cnf tree fbs 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) - ) +#endif ] sequence_ launchers waitForever diff --git a/Network/HTTP/Lucu/Interaction.hs b/Network/HTTP/Lucu/Interaction.hs index abc1cf5..018ee00 100644 --- a/Network/HTTP/Lucu/Interaction.hs +++ b/Network/HTTP/Lucu/Interaction.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - DeriveDataTypeable + CPP + , DeriveDataTypeable , ExistentialQuantification , OverloadedStrings , RecordWildCards @@ -44,7 +45,9 @@ import Network.HTTP.Lucu.Headers import Network.HTTP.Lucu.Preprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response +#if defined(HAVE_SSL) import OpenSSL.X509 +#endif class Typeable i ⇒ Interaction i where toInteraction ∷ i → SomeInteraction @@ -132,7 +135,9 @@ data NormalInteraction = NI { niConfig ∷ !Config , niRemoteAddr ∷ !SockAddr +#if defined(HAVE_SSL) , niRemoteCert ∷ !(Maybe X509) +#endif , niRequest ∷ !Request , niResourcePath ∷ ![Strict.ByteString] , niExpectedContinue ∷ !Bool @@ -172,11 +177,17 @@ data InteractionState mkNormalInteraction ∷ Config → SockAddr +#if defined(HAVE_SSL) → Maybe X509 +#endif → AugmentedRequest → [Strict.ByteString] → IO NormalInteraction +#if defined(HAVE_SSL) mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPath +#else +mkNormalInteraction config remoteAddr (AugmentedRequest {..}) rsrcPath +#endif = do receiveBodyReq ← newEmptyTMVarIO receivedBody ← newEmptyTMVarIO @@ -192,7 +203,9 @@ mkNormalInteraction config remoteAddr remoteCert (AugmentedRequest {..}) rsrcPat return NI { niConfig = config , niRemoteAddr = remoteAddr +#if defined(HAVE_SSL) , niRemoteCert = remoteCert +#endif , niRequest = arRequest , niResourcePath = rsrcPath , niExpectedContinue = arExpectedContinue diff --git a/Network/HTTP/Lucu/RequestReader.hs b/Network/HTTP/Lucu/RequestReader.hs index b5feafe..5ef7acc 100644 --- a/Network/HTTP/Lucu/RequestReader.hs +++ b/Network/HTTP/Lucu/RequestReader.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - DoAndIfThenElse + CPP + , DoAndIfThenElse , OverloadedStrings , RecordWildCards , ScopedTypeVariables @@ -143,8 +144,13 @@ acceptRequestForResource ∷ HandleLike h → ResourceDef → IO () acceptRequestForResource ctx@(Context {..}) ar@(AugmentedRequest {..}) input rsrcPath rsrcDef - = do cert ← hGetPeerCert cHandle + = do +#if defined(HAVE_SSL) + cert ← hGetPeerCert cHandle ni ← mkNormalInteraction cConfig cAddr cert ar rsrcPath +#else + ni ← mkNormalInteraction cConfig cAddr ar rsrcPath +#endif tid ← spawnResource rsrcDef ni enqueue ctx ni if reqMustHaveBody arRequest then diff --git a/Network/HTTP/Lucu/Resource.hs b/Network/HTTP/Lucu/Resource.hs index d1420ba..ec3447e 100644 --- a/Network/HTTP/Lucu/Resource.hs +++ b/Network/HTTP/Lucu/Resource.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - BangPatterns + CPP + , BangPatterns , GeneralizedNewtypeDeriving , DoAndIfThenElse , OverloadedStrings @@ -82,7 +83,9 @@ module Network.HTTP.Lucu.Resource , getRemoteAddr , getRemoteAddr' , getRemoteHost +#if defined(HAVE_SSL) , getRemoteCertificate +#endif , getRequest , getMethod , getRequestURI diff --git a/Network/HTTP/Lucu/Resource/Internal.hs b/Network/HTTP/Lucu/Resource/Internal.hs index e066fa9..e34512d 100644 --- a/Network/HTTP/Lucu/Resource/Internal.hs +++ b/Network/HTTP/Lucu/Resource/Internal.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - DoAndIfThenElse + CPP + , DoAndIfThenElse , GeneralizedNewtypeDeriving , OverloadedStrings , RecordWildCards @@ -13,7 +14,9 @@ module Network.HTTP.Lucu.Resource.Internal , getConfig , getRemoteAddr +#if defined(HAVE_SSL) , getRemoteCertificate +#endif , getRequest , getResourcePath @@ -54,7 +57,9 @@ import Network.HTTP.Lucu.Postprocess import Network.HTTP.Lucu.Request import Network.HTTP.Lucu.Response import Network.Socket +#if defined(HAVE_SSL) import OpenSSL.X509 +#endif import Prelude hiding (catch) import Prelude.Unicode import System.IO @@ -230,6 +235,7 @@ getConfig = niConfig <$> getInteraction getRemoteAddr ∷ Resource SockAddr getRemoteAddr = niRemoteAddr <$> getInteraction +#if defined(HAVE_SSL) -- | Return the X.509 certificate of the client, or 'Nothing' if: -- -- * This request didn't came through an SSL stream. @@ -241,6 +247,7 @@ getRemoteAddr = niRemoteAddr <$> getInteraction -- 'OpenSSL.Session.VerifyPeer'. getRemoteCertificate ∷ Resource (Maybe X509) getRemoteCertificate = niRemoteCert <$> getInteraction +#endif -- |Return the 'Request' value representing the request header. You -- usually don't need to call this function directly. diff --git a/Network/HTTP/Lucu/SocketLike.hs b/Network/HTTP/Lucu/SocketLike.hs index b9668e0..998e449 100644 --- a/Network/HTTP/Lucu/SocketLike.hs +++ b/Network/HTTP/Lucu/SocketLike.hs @@ -1,5 +1,6 @@ {-# LANGUAGE - FlexibleContexts + CPP + , FlexibleContexts , FlexibleInstances , TypeFamilies , UnicodeSyntax @@ -11,8 +12,10 @@ module Network.HTTP.Lucu.SocketLike where import qualified Network.Socket as So import Network.HTTP.Lucu.HandleLike +#if defined(HAVE_SSL) import qualified OpenSSL.Session as SSL import Prelude.Unicode +#endif import qualified System.IO as I class (HandleLike (Handle s)) ⇒ SocketLike s where @@ -30,6 +33,7 @@ instance SocketLike So.Socket where socketPort = So.socketPort +#if defined(HAVE_SSL) instance SocketLike (SSL.SSLContext, So.Socket) where type Handle (SSL.SSLContext, So.Socket) = SSL.SSL @@ -40,3 +44,4 @@ instance SocketLike (SSL.SSLContext, So.Socket) where return (ssl, addr) socketPort = So.socketPort ∘ snd +#endif diff --git a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml index 43cf56d..71ab9c5 100644 --- a/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml +++ b/bugs/issue-a5e6a89da31d2ca0a69d89ad1d579fee8d0c131f.yaml @@ -7,8 +7,8 @@ type: :task component: Lucu release: Lucu-1.0 reporter: PHO -status: :unstarted -disposition: +status: :closed +disposition: :fixed creation_time: 2011-10-26 23:04:33.719311 Z references: [] @@ -22,4 +22,8 @@ log_events: - PHO - edited title - Should be defaulted to off! +- - 2011-11-12 16:13:20.813907 Z + - PHO + - closed with disposition fixed + - Done. git_branch: diff --git a/examples/Makefile b/examples/Makefile index 37c59cb..606117f 100644 --- a/examples/Makefile +++ b/examples/Makefile @@ -10,6 +10,9 @@ IMPLANT ?= ../dist/build/lucu-implant-file/lucu-implant-file build: $(TARGETS) +SSL: SSL.hs + -ghc -Wall --make $@ -threaded -O3 -idist -odir dist -hidir dist + %: %.hs ghc -Wall --make $@ -threaded -O3 -idist -odir dist -hidir dist -- 2.40.0