Merge pull request #169 from haskell-works/add-support-for-https

Add support for https
haskell · Mar 15, 2022 · 43a5daf · 43a5daf
2 parents dd45035 + a625835
commit 43a5daf
Show file tree

Hide file tree

Showing 2 changed files with 8 additions and 4 deletions.
diff --git a/cabal-cache.cabal b/cabal-cache.cabal
@@ -38,6 +38,7 @@ common generic-lens                   { build-depends: generic-lens
 common hedgehog                       { build-depends: hedgehog                       >= 1.0        && < 1.1    }
 common hspec                          { build-depends: hspec                          >= 2.4        && < 3      }
 common http-client                    { build-depends: http-client                    >= 0.5.14     && < 0.8    }
+common http-client-tls                { build-depends: http-client-tls                >= 0.3        && < 0.4    }
 common http-types                     { build-depends: http-types                     >= 0.12.3     && < 0.13   }
 common hw-hedgehog                    { build-depends: hw-hedgehog                    >= 0.1.0.3    && < 0.2    }
 common hw-hspec-hedgehog              { build-depends: hw-hspec-hedgehog              >= 0.1.0.4    && < 0.2    }
@@ -88,6 +89,7 @@ library
                       , filepath
                       , generic-lens
                       , http-client
+                      , http-client-tls
                       , http-types
                       , lens
                       , mtl

diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs
@@ -42,6 +42,7 @@ import qualified Network.AWS.S3.HeadObject          as AWS
 import qualified Network.AWS.S3.PutObject           as AWS
 import qualified Network.HTTP.Client                as HTTP
 import qualified Network.HTTP.Types                 as HTTP
+import qualified Network.HTTP.Client.TLS            as HTTPS
 import qualified System.Directory                   as IO
 import qualified System.FilePath.Posix              as FP
 import qualified System.IO                          as IO
@@ -84,9 +85,10 @@ readResource envAws = \case
       then Right <$> LBS.readFile path
       else pure (Left NotFound)
   Uri uri -> case uri ^. the @"uriScheme" of
-    "s3:"   -> getS3Uri envAws (reslashUri uri)
-    "http:" -> liftIO $ readHttpUri (reslashUri uri)
-    scheme  -> return (Left (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)))
+    "s3:"     -> getS3Uri envAws (reslashUri uri)
+    "http:"   -> liftIO $ readHttpUri (reslashUri uri)
+    "https:"  -> liftIO $ readHttpUri (reslashUri uri)
+    scheme    -> return (Left (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)))
 
 readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location))
 readFirstAvailableResource _ [] = return (Left (GenericAppError "No resources specified in read"))
@@ -215,7 +217,7 @@ linkOrCopyResource envAws source target = case source of
 
 readHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString)
 readHttpUri httpUri = handleHttpError $ do
-  manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings
+  manager <- liftIO $ HTTP.newManager HTTPS.tlsManagerSettings
   request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (reslashUri httpUri)))
   response <- liftIO $ HTTP.httpLbs request manager