From 9c8f093e83bf3cd3f213c6d6d4cf750497807d12 Mon Sep 17 00:00:00 2001 From: Karel Gardas Date: Thu, 22 Mar 2018 16:02:20 +0100 Subject: [PATCH 1/5] fix compilation of testsuite on Ubuntu 16.04 with its GHC 7.10.x compiler --- snap-server.cabal | 9 +++++++-- 1 file changed, 7 insertions(+), 2 deletions(-) diff --git a/snap-server.cabal b/snap-server.cabal index c1fbc179..7b5c86d8 100644 --- a/snap-server.cabal +++ b/snap-server.cabal @@ -244,7 +244,8 @@ Test-suite testsuite parallel >= 3 && < 4, test-framework >= 0.8.0.3 && < 0.9, test-framework-hunit >= 0.2.7 && < 0.4, - test-framework-quickcheck2 >= 0.2.12.1 && < 0.4 + test-framework-quickcheck2 >= 0.2.12.1 && < 0.4, + Cabal other-extensions: BangPatterns, @@ -495,6 +496,9 @@ Executable snap-test-server System.SendFile, System.SendFile.FreeBSD + if !impl(ghc >= 8.0) + build-depends: semigroups >= 0.16 && < 0.19 + build-depends: attoparsec, base, @@ -516,7 +520,8 @@ Executable snap-test-server time, transformers, unix-compat, - vector + vector, + filepath ghc-options: -Wall -fwarn-tabs -funbox-strict-fields -fno-warn-unused-do-bind -threaded -rtsopts From 9e8f5930225a54f4497c36b8e1ad496a43af99ac Mon Sep 17 00:00:00 2001 From: Karel Gardas Date: Thu, 22 Mar 2018 16:02:53 +0100 Subject: [PATCH 2/5] fix testsuite run script to find the right testsuite binary easily --- runTestsAndCoverage.sh | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/runTestsAndCoverage.sh b/runTestsAndCoverage.sh index d3b791dd..874a2576 100755 --- a/runTestsAndCoverage.sh +++ b/runTestsAndCoverage.sh @@ -8,7 +8,8 @@ export LANG=C rm -Rf testsuite.tix # TODO How do we find the executable without knowing the version number in dist-newstyle? -./dist-newstyle/build/snap-server-1.0.0.0/build/testsuite/testsuite -j4 -a1000 $* +TESTSUITE=`find . -type f -perm 775 -name 'testsuite'` +$TESTSUITE -j4 -a1000 $* DIR="./dist-newstyle/hpc" From 141f32f8866056d507c302d1cbfc5c0714882a99 Mon Sep 17 00:00:00 2001 From: Karel Gardas Date: Thu, 22 Mar 2018 16:06:57 +0100 Subject: [PATCH 3/5] fix README.md with information about how to build the testsuite --- README.md | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/README.md b/README.md index abd2bdac..99087b14 100644 --- a/README.md +++ b/README.md @@ -53,10 +53,10 @@ The docs get put in `dist/doc/html/`. ## Building the testsuite The `snap-server` has a fairly comprehensive test suite. To build and run it, -`cd` into the `test/` directory and run +run - $ cabal configure # for the stock backend, or.. - $ cabal configure -fopenssl # for the SSL backend + $ cabal configure --enable-tests # for the stock backend, or.. + $ cabal configure -fopenssl --enable-tests # for the SSL backend $ cabal build From 1d4d2035973f1ca25dfea35e3242c907f3207468 Mon Sep 17 00:00:00 2001 From: Karel Gardas Date: Fri, 23 Mar 2018 22:04:56 +0100 Subject: [PATCH 4/5] Enhance SSL support by adding options to verify client and option to set CA certificate file. --- src/Snap/Http/Server.hs | 5 +- src/Snap/Http/Server/Config.hs | 6 ++ src/Snap/Internal/Http/Server/Config.hs | 55 +++++++++++++++++++ src/Snap/Internal/Http/Server/TLS.hs | 22 +++++--- .../Internal/Http/Server/Session/Tests.hs | 10 +++- test/Test/Blackbox.hs | 3 + 6 files changed, 91 insertions(+), 10 deletions(-) diff --git a/src/Snap/Http/Server.hs b/src/Snap/Http/Server.hs index 620fa8c2..f9a8001a 100644 --- a/src/Snap/Http/Server.hs +++ b/src/Snap/Http/Server.hs @@ -215,11 +215,14 @@ listeners conf = TLS.withTLS $ do cert <- getSSLCert conf chainCert <- getSSLChainCert conf key <- getSSLKey conf + let verify = fromMaybe False (getSSLClientVerify conf) + let verify_once = fromMaybe False (getSSLClientVerifyOnce conf) + let ca_cert = fromMaybe "" (getSSLCACert conf) return (S.concat [ "https://" , b , ":" , bshow p ], - do (sock, ctx) <- TLS.bindHttps b p cert chainCert key + do (sock, ctx) <- TLS.bindHttps b p cert chainCert key verify verify_once ca_cert return (sock, TLS.httpsAcceptFunc sock ctx) ) httpListener = do diff --git a/src/Snap/Http/Server/Config.hs b/src/Snap/Http/Server/Config.hs index c163f607..de8f0786 100644 --- a/src/Snap/Http/Server/Config.hs +++ b/src/Snap/Http/Server/Config.hs @@ -32,6 +32,9 @@ module Snap.Http.Server.Config , getSSLKey , getSSLChainCert , getSSLPort + , getSSLClientVerify + , getSSLClientVerifyOnce + , getSSLCACert , getVerbose , getStartupHook , getUnixSocket @@ -53,6 +56,9 @@ module Snap.Http.Server.Config , setSSLKey , setSSLChainCert , setSSLPort + , setSSLClientVerify + , setSSLClientVerifyOnce + , setSSLCACert , setVerbose , setUnixSocket , setUnixSocketAccessMode diff --git a/src/Snap/Internal/Http/Server/Config.hs b/src/Snap/Internal/Http/Server/Config.hs index 0345f884..57f7a41c 100644 --- a/src/Snap/Internal/Http/Server/Config.hs +++ b/src/Snap/Internal/Http/Server/Config.hs @@ -39,6 +39,9 @@ module Snap.Internal.Http.Server.Config , getSSLChainCert , getSSLKey , getSSLPort + , getSSLClientVerify + , getSSLClientVerifyOnce + , getSSLCACert , getVerbose , getStartupHook , getUnixSocket @@ -60,6 +63,9 @@ module Snap.Internal.Http.Server.Config , setSSLChainCert , setSSLKey , setSSLPort + , setSSLClientVerify + , setSSLClientVerifyOnce + , setSSLCACert , setVerbose , setUnixSocket , setUnixSocketAccessMode @@ -212,6 +218,9 @@ data Config m a = Config , sslcert :: Maybe FilePath , sslchaincert :: Maybe Bool , sslkey :: Maybe FilePath + , sslclientverify :: Maybe Bool + , sslclientverifyonce :: Maybe Bool + , sslcacert :: Maybe FilePath , unixsocket :: Maybe FilePath , unixaccessmode :: Maybe Int , compression :: Maybe Bool @@ -251,6 +260,9 @@ instance Show (Config m a) where , "sslcert: " ++ _sslcert , "sslchaincert: " ++ _sslchaincert , "sslkey: " ++ _sslkey + , "sslclientverify: " ++ _sslclientverify + , "sslclientverifyonce: " ++ _sslclientverifyonce + , "sslcacert: " ++ _sslcacert , "unixsocket: " ++ _unixsocket , "unixaccessmode: " ++ _unixaccessmode , "compression: " ++ _compression @@ -271,6 +283,9 @@ instance Show (Config m a) where _sslcert = show $ sslcert c _sslchaincert = show $ sslchaincert c _sslkey = show $ sslkey c + _sslclientverify = show $ sslclientverify c + _sslclientverifyonce = show $ sslclientverifyonce c + _sslcacert = show $ sslcacert c _compression = show $ compression c _verbose = show $ verbose c _defaultTimeout = show $ defaultTimeout c @@ -302,6 +317,9 @@ instance Semigroup (Config m a) where , sslcert = ov sslcert , sslchaincert = ov sslchaincert , sslkey = ov sslkey + , sslclientverify = ov sslclientverify + , sslclientverifyonce = ov sslclientverifyonce + , sslcacert = ov sslcacert , unixsocket = ov unixsocket , unixaccessmode = ov unixaccessmode , compression = ov compression @@ -330,6 +348,9 @@ instance Monoid (Config m a) where , sslcert = Nothing , sslchaincert = Nothing , sslkey = Nothing + , sslclientverify = Nothing + , sslclientverifyonce = Nothing + , sslcacert = Nothing , unixsocket = Nothing , unixaccessmode = Nothing , compression = Nothing @@ -362,6 +383,9 @@ defaultConfig = mempty , sslcert = Nothing , sslkey = Nothing , sslchaincert = Nothing + , sslclientverify = Just False + , sslclientverifyonce = Just False + , sslcacert = Nothing , defaultTimeout = Just 60 } @@ -416,6 +440,18 @@ getSSLChainCert = sslchaincert getSSLKey :: Config m a -> Maybe FilePath getSSLKey = sslkey +-- | Verify client SSL certificate +getSSLClientVerify :: Config m a -> Maybe Bool +getSSLClientVerify = sslclientverify + +-- | Verify client SSL certificate only once +getSSLClientVerifyOnce :: Config m a -> Maybe Bool +getSSLClientVerifyOnce = sslclientverifyonce + +-- | Path to the SSL CA certificate file +getSSLCACert :: Config m a -> Maybe FilePath +getSSLCACert = sslcacert + -- | File path to unix socket. Must be absolute path, but allows for symbolic -- links. getUnixSocket :: Config m a -> Maybe FilePath @@ -497,6 +533,15 @@ setSSLChainCert x c = c { sslchaincert = Just x } setSSLKey :: FilePath -> Config m a -> Config m a setSSLKey x c = c { sslkey = Just x } +setSSLClientVerify :: Bool -> Config m a -> Config m a +setSSLClientVerify x c = c { sslclientverify = Just x } + +setSSLClientVerifyOnce :: Bool -> Config m a -> Config m a +setSSLClientVerifyOnce x c = c { sslclientverifyonce = Just x } + +setSSLCACert :: FilePath -> Config m a -> Config m a +setSSLCACert x c = c { sslcacert = Just x } + setUnixSocket :: FilePath -> Config m a -> Config m a setUnixSocket x c = c { unixsocket = Just x } @@ -621,6 +666,16 @@ optDescrs defaults = , Option [] ["ssl-key"] (ReqArg (\s -> Just $ mempty { sslkey = Just s}) "PATH") $ "path to ssl private key in PEM format" ++ defaultO sslkey + , Option [] ["ssl-client-verify"] + (NoArg $ Just $ setConfig setSSLClientVerify True) + $ "server is required to verify client certificate" ++ defaultB getSSLClientVerify "verify client certificate" "do not verify client certificate" + , Option [] ["ssl-client-verify-once"] + (NoArg $ Just $ setConfig setSSLClientVerifyOnce True) + $ concat ["server is required to verify client certificate\n", + "just once per open connection"] ++ defaultB getSSLClientVerifyOnce "verify client certificate once" "do not verify client certificate" + , Option "" ["ssl-ca-cert"] + (ReqArg (\s -> Just $ mempty { sslcacert = Just s}) "PATH") + $ "path to ssl CA certificate in PEM format" ++ defaultO sslcacert , Option "" ["access-log"] (ReqArg (Just . setConfig setAccessLog . ConfigFileLog) "PATH") $ "access log" ++ defaultC getAccessLog diff --git a/src/Snap/Internal/Http/Server/TLS.hs b/src/Snap/Internal/Http/Server/TLS.hs index 551966f5..e5c34c5d 100644 --- a/src/Snap/Internal/Http/Server/TLS.hs +++ b/src/Snap/Internal/Http/Server/TLS.hs @@ -25,7 +25,7 @@ import qualified Network.Socket as Socket import OpenSSL (withOpenSSL) import OpenSSL.Session (SSL, SSLContext) import qualified OpenSSL.Session as SSL -import Prelude (Bool, FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, fst, not, ($), ($!), (.)) +import Prelude (Bool(..), FilePath, IO, Int, Maybe (..), Monad (..), Show, flip, fromIntegral, fst, not, ($), ($!), (.), null) import Snap.Internal.Http.Server.Address (getAddress, getSockAddr) import Snap.Internal.Http.Server.Socket (acceptAndInitialize) import qualified System.IO.Streams as Streams @@ -67,9 +67,9 @@ barf = throwIO sslNotSupportedException ------------------------------------------------------------------------------ -bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath - -> IO (Socket, SSLContext) -bindHttps _ _ _ _ _ = barf +bindHttps :: ByteString -> Int -> FilePath -> Bool -> FilePath -> Bool -> Bool + -> FilePath -> IO (Socket, SSLContext) +bindHttps _ _ _ _ _ _ _ _ = barf ------------------------------------------------------------------------------ @@ -94,8 +94,11 @@ bindHttps :: ByteString -> FilePath -> Bool -> FilePath + -> Bool + -> Bool + -> FilePath -> IO (Socket, SSLContext) -bindHttps bindAddress bindPort cert chainCert key = +bindHttps bindAddress bindPort cert chainCert key verify verify_once ca_cert = withTLS $ bracketOnError (do (family, addr) <- getSockAddr bindPort bindAddress @@ -113,14 +116,19 @@ bindHttps bindAddress bindPort cert chainCert key = if chainCert then SSL.contextSetCertificateChainFile ctx cert else SSL.contextSetCertificateFile ctx cert - + setVerification ctx verify verify_once + when (not $ null ca_cert) $ do + SSL.contextSetCAFile ctx ca_cert certOK <- SSL.contextCheckPrivateKey ctx when (not certOK) $ do - throwIO $ TLSException certificateError + throwIO $ TLSException certificateError return (sock, ctx) where certificateError = "OpenSSL says that the certificate doesn't match the private key!" + setVerification x True False = SSL.contextSetVerificationMode x $ SSL.VerifyPeer True False Nothing + setVerification x _ True = SSL.contextSetVerificationMode x $ SSL.VerifyPeer True True Nothing + setVerification x False False = SSL.contextSetVerificationMode x $ SSL.VerifyNone ------------------------------------------------------------------------------ diff --git a/test/Snap/Internal/Http/Server/Session/Tests.hs b/test/Snap/Internal/Http/Server/Session/Tests.hs index 0e8f34b7..caf3a78a 100644 --- a/test/Snap/Internal/Http/Server/Session/Tests.hs +++ b/test/Snap/Internal/Http/Server/Session/Tests.hs @@ -98,14 +98,20 @@ testTLSKeyMismatch = testCase "session/tls-key-mismatch" $ do (fromIntegral N.aNY_PORT) "test/cert.pem" False - "test/bad_key.pem") + "test/bad_key.pem" + False + False + "") (N.close . fst) (const $ return ()) expectException $ bracket (TLS.bindHttps "127.0.0.1" (fromIntegral N.aNY_PORT) "test/cert.pem" True - "test/bad_key.pem") + "test/bad_key.pem" + False + False + "") (N.close . fst) (const $ return ()) #else diff --git a/test/Test/Blackbox.hs b/test/Test/Blackbox.hs index 001ff1c4..fa389b43 100644 --- a/test/Test/Blackbox.hs +++ b/test/Test/Blackbox.hs @@ -133,6 +133,9 @@ startTestSocketServer serverType = do "test/cert.pem" False "test/key.pem" + False + False + "" #ifdef OPENSSL -- Set client code not to verify HTTP.modifyContextSSL $ \ctx -> do From a11d1b929765dff6291e23a98d387076c310b677 Mon Sep 17 00:00:00 2001 From: Karel Gardas Date: Tue, 27 Mar 2018 22:21:42 +0200 Subject: [PATCH 5/5] fix build without SSL support --- test/Snap/Internal/Http/Server/Session/Tests.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/test/Snap/Internal/Http/Server/Session/Tests.hs b/test/Snap/Internal/Http/Server/Session/Tests.hs index caf3a78a..ac04e344 100644 --- a/test/Snap/Internal/Http/Server/Session/Tests.hs +++ b/test/Snap/Internal/Http/Server/Session/Tests.hs @@ -119,8 +119,10 @@ testCoverTLSStubs :: Test testCoverTLSStubs = testCase "session/tls-stubs" $ do expectException $ TLS.bindHttps "127.0.0.1" 9999 "test/cert.pem" False "test/key.pem" + False False "" expectException $ TLS.bindHttps "127.0.0.1" 9999 "test/cert.pem" True "test/key.pem" + False False "" let (AcceptFunc afunc) = TLS.httpsAcceptFunc undefined undefined expectException $ mask $ \restore -> afunc restore let u = undefined