Ssl enhancements

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
 

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"
 

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

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

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

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

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

test/Snap/Internal/Http/Server/Session/Tests.hs

@@ -98,23 +98,31 @@ 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
 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

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