depend on OpenSSL again

wireapp · Jul 6, 2020 · 338b372 · 338b372
1 parent fa22bc2
commit 338b372
Show file tree

Hide file tree

Showing 4 changed files with 58 additions and 70 deletions.
diff --git a/services/cargohold/cargohold.cabal b/services/cargohold/cargohold.cabal
@@ -4,7 +4,7 @@ cabal-version: 1.12
 --
 -- see: https://github.com/sol/hpack
 --
--- hash: 0747b3282dab00aa2a8784ab079ca61faa5b94fe7a8e4e53711ef381bac81308
+-- hash: a04b16e73306ee6c6a80d4b9e921b7c3c33fc5e23236ad94bc479c23caa3f61e
 
 name:           cargohold
 version:        1.5.0
@@ -49,7 +49,9 @@ library
   default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
   build-depends:
-      aeson >=0.11
+      HsOpenSSL >=0.11
+    , HsOpenSSL-x509-system >=0.1
+    , aeson >=0.11
     , amazonka >=1.3.7
     , amazonka-cloudfront >=1.3.7
     , amazonka-core >=1.3.7
@@ -70,7 +72,6 @@ library
     , cereal >=0.4
     , conduit >=1.2
     , conduit-extra >=1.1.5
-    , connection >=0.2
     , containers >=0.5
     , cryptonite >=0.20
     , data-default >=0.5
@@ -79,7 +80,7 @@ library
     , exceptions >=0.6
     , extended
     , http-client >=0.4
-    , http-client-tls >=0.3.5
+    , http-client-openssl >=0.2
     , http-conduit >=2.1
     , http-types >=0.8
     , imports
@@ -103,7 +104,6 @@ library
     , text >=1.1
     , time >=1.4
     , tinylog >=0.10
-    , tls >=1.2
     , transformers >=0.3
     , transformers-base >=0.3
     , types-common >=0.16
@@ -119,9 +119,6 @@ library
     , wai-utilities >=0.16.1
     , warp >=3.0
     , wire-api
-    , x509 >=1.6
-    , x509-store >=1.6
-    , x509-system >=1.6
     , xml-conduit >=1.3
     , yaml >=0.8
   default-language: Haskell2010
@@ -133,7 +130,8 @@ executable cargohold
   default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-T
   build-depends:
-      aeson >=0.11
+      HsOpenSSL >=0.11
+    , aeson >=0.11
     , base
     , base64-bytestring >=1.0
     , bilge >=0.21
@@ -174,7 +172,8 @@ executable cargohold-integration
   default-extensions: AllowAmbiguousTypes BangPatterns ConstraintKinds DataKinds DefaultSignatures DerivingStrategies DeriveFunctor DeriveGeneric DeriveLift DeriveTraversable EmptyCase FlexibleContexts FlexibleInstances FunctionalDependencies GADTs InstanceSigs KindSignatures LambdaCase MultiParamTypeClasses MultiWayIf NamedFieldPuns NoImplicitPrelude OverloadedStrings PackageImports PatternSynonyms PolyKinds QuasiQuotes RankNTypes ScopedTypeVariables StandaloneDeriving TemplateHaskell TupleSections TypeApplications TypeFamilies TypeFamilyDependencies TypeOperators UndecidableInstances ViewPatterns
   ghc-options: -O2 -Wall -Wincomplete-uni-patterns -Wincomplete-record-updates -Wpartial-fields -fwarn-tabs -optP-Wno-nonportable-include-path
   build-depends:
-      aeson >=0.11
+      HsOpenSSL >=0.11
+    , aeson >=0.11
     , base ==4.*
     , base64-bytestring >=1.0
     , bilge >=0.21

diff --git a/services/cargohold/package.yaml b/services/cargohold/package.yaml
@@ -21,6 +21,7 @@ dependencies:
 - errors >=1.4
 - exceptions >=0.6
 - extended
+- HsOpenSSL >=0.11
 - http-client >=0.4
 - http-types >=0.8
 - mime >=0.4
@@ -50,10 +51,10 @@ library:
   - case-insensitive >=1.0
   - conduit >=1.2
   - conduit-extra >=1.1.5
-  - connection >=0.2
   - cryptonite >=0.20
   - either >=4.3
-  - http-client-tls >=0.3.5
+  - HsOpenSSL-x509-system >=0.1
+  - http-client-openssl >=0.2
   - http-conduit >=2.1
   - lens >=4.1
   - lifted-async >=0.9.3
@@ -69,16 +70,12 @@ library:
   - swagger >=0.2
   - time >=1.4
   - tinylog >=0.10
-  - tls >=1.2
   - types-common >=0.16
   - split >=0.2
   - unliftio-core >=0.1
   - unordered-containers >=0.2
   - uri-bytestring >=0.2
   - uuid >=1.3.5
-  - x509 >=1.6
-  - x509-store >=1.6
-  - x509-system >=1.6
   - wai >=3.0
   - wai-conduit >=3.0
   - wai-extra >=3.0

diff --git a/services/cargohold/src/CargoHold/App.hs b/services/cargohold/src/CargoHold/App.hs
@@ -43,7 +43,7 @@ module CargoHold.App
   )
 where
 
-import Bilge (Manager, MonadHttp, RequestId (..), withResponse)
+import Bilge (Manager, MonadHttp, RequestId (..), newManager, withResponse)
 import qualified Bilge
 import Bilge.RPC (HasRequestId (..))
 import qualified CargoHold.AWS as AWS
@@ -52,22 +52,21 @@ import Control.Error (ExceptT, exceptT)
 import Control.Lens ((^.), makeLenses, set, view)
 import Control.Monad.Catch (MonadCatch, MonadMask, MonadThrow)
 import Control.Monad.Trans.Resource (ResourceT, runResourceT, transResourceT)
-import Data.Default
+import Data.Default (def)
 import Data.Metrics.Middleware (Metrics)
 import qualified Data.Metrics.Middleware as Metrics
 import Imports hiding (log)
-import Network.Connection as NC
 import Network.HTTP.Client (ManagerSettings (..), responseTimeoutMicro)
-import Network.HTTP.Client.TLS
-import qualified Network.TLS as TLS
-import qualified Network.TLS.Extra as TLS
+import Network.HTTP.Client.OpenSSL
 import Network.Wai (Request, ResponseReceived)
 import Network.Wai.Routing (Continue)
 import Network.Wai.Utilities (Error (..), lookupRequestId)
 import qualified Network.Wai.Utilities.Server as Server
+import OpenSSL.Session (SSLContext, SSLOption (..))
+import qualified OpenSSL.Session as SSL
+import qualified OpenSSL.X509.SystemStore as SSL
 import System.Logger.Class hiding (settings)
 import qualified System.Logger.Extended as Log
-import System.X509 (getSystemCertificateStore)
 
 -------------------------------------------------------------------------------
 -- Environment
@@ -104,26 +103,24 @@ initAws o l m =
     downloadEndpoint = fromMaybe (o ^. awsS3Endpoint) (o ^. awsS3DownloadEndpoint)
 
 initHttpManager :: IO Manager
-initHttpManager = do
-  cs <- getSystemCertificateStore
-  let tlsClientParams =
-        (TLS.defaultParamsClient "" mempty)
-          { TLS.clientSupported = def {TLS.supportedCiphers = TLS.ciphersuite_strong},
-            TLS.clientShared =
-              def
-                { TLS.sharedCAStore = cs,
-                  TLS.sharedValidationCache = def
-                }
-          }
-  let manSettings = mkManagerSettings (NC.TLSSettings tlsClientParams) Nothing
-  mgr <-
-    newTlsManagerWith
-      manSettings
-        { managerConnCount = 1024,
-          managerIdleConnectionCount = 2048,
-          managerResponseTimeout = responseTimeoutMicro 10000000
-        }
-  return mgr
+initHttpManager =
+  newManager
+    (opensslManagerSettings initSSLContext)
+      { managerConnCount = 1024,
+        managerIdleConnectionCount = 2048,
+        managerResponseTimeout = responseTimeoutMicro 10000000
+      }
+
+initSSLContext :: IO SSLContext
+initSSLContext = do
+  ctx <- SSL.context
+  SSL.contextAddOption ctx SSL_OP_NO_SSLv2
+  SSL.contextAddOption ctx SSL_OP_NO_SSLv3
+  SSL.contextSetCiphers ctx "HIGH"
+  SSL.contextLoadSystemCerts ctx
+  SSL.contextSetVerificationMode ctx $
+    SSL.VerifyPeer True True Nothing
+  return ctx
 
 closeEnv :: Env -> IO ()
 closeEnv e = Log.close $ e ^. appLogger

diff --git a/services/cargohold/src/CargoHold/CloudFront.hs b/services/cargohold/src/CargoHold/CloudFront.hs
@@ -27,23 +27,19 @@ module CargoHold.CloudFront
   )
 where
 
-import qualified CargoHold.Error as AWS
 import Control.AutoUpdate
-import Control.Monad.Catch
-import Crypto.Hash.Algorithms (SHA1 (..))
-import Crypto.PubKey.RSA
-import qualified Crypto.PubKey.RSA.PKCS15 as RSA
 import qualified Data.ByteString.Base64 as B64
 import Data.ByteString.Builder
 import qualified Data.ByteString.Char8 as C8
 import Data.ByteString.Conversion
 import Data.ByteString.Lazy (toStrict)
 import Data.Text.Encoding (encodeUtf8)
 import Data.Time.Clock.POSIX
-import Data.X509 (PrivKey (..))
-import Data.X509.File
 import Data.Yaml (FromJSON)
 import Imports
+import OpenSSL.EVP.Digest (getDigestByName)
+import qualified OpenSSL.EVP.Sign as SSL
+import OpenSSL.PEM (PemPasswordSupply (PwNone), readPrivateKey)
 import URI.ByteString
 
 newtype KeyPairId = KeyPairId Text
@@ -57,7 +53,7 @@ data CloudFront = CloudFront
     _keyPairId :: KeyPairId,
     _ttl :: Word,
     _clock :: IO POSIXTime,
-    _func :: ByteString -> IO (Either Error ByteString)
+    _func :: ByteString -> IO ByteString
   }
 
 initCloudFront :: MonadIO m => FilePath -> KeyPairId -> Word -> Domain -> m CloudFront
@@ -77,18 +73,16 @@ initCloudFront kfp kid ttl (Domain dom) =
 signedURL :: (MonadIO m, ToByteString p) => CloudFront -> p -> m URI
 signedURL (CloudFront base kid ttl clock sign) path = liftIO $ do
   time <- (+ ttl) . round <$> clock
-  sign (toStrict (toLazyByteString (policy url time))) >>= \case
-    Left e -> throwM $ AWS.SigningError e
-    Right sig ->
-      return
-        $! url
-          { uriQuery =
-              Query
-                [ ("Expires", toByteString' time),
-                  ("Signature", b64 sig),
-                  ("Key-Pair-Id", toByteString' kid)
-                ]
-          }
+  sig <- sign (toStrict (toLazyByteString (policy url time)))
+  return
+    $! url
+      { uriQuery =
+          Query
+            [ ("Expires", toByteString' time),
+              ("Signature", b64 sig),
+              ("Key-Pair-Id", toByteString' kid)
+            ]
+      }
   where
     url = base {uriPath = "/" <> toByteString' path}
     policy r t =
@@ -106,14 +100,15 @@ signedURL (CloudFront base kid ttl clock sign) path = liftIO $ do
         f '/' = '~'
         f c = c
 
-sha1Rsa :: FilePath -> IO (ByteString -> IO (Either Error ByteString))
+sha1Rsa :: FilePath -> IO (ByteString -> IO ByteString)
 sha1Rsa fp = do
-  kbs <- readKeyFile fp
-  let key = case kbs of
-        [] -> error $ "no keys found in " ++ show fp
-        (PrivKeyRSA k : []) -> k
-        _ -> error $ "Not one RSA key found in " ++ show fp
-  return (RSA.signSafer (Just SHA1) key)
+  sha1 <-
+    liftIO $
+      getDigestByName "SHA1"
+        >>= maybe (error "OpenSSL: SHA1 not found") return
+  kbs <- readFile fp
+  key <- readPrivateKey kbs PwNone
+  return (SSL.signBS sha1 key)
 
 mkPOSIXClock :: IO (IO POSIXTime)
 mkPOSIXClock =