cabal-cache 1.0.5.5 → 1.0.6.0
raw patch · 49 files changed
+1838/−958 lines, 49 filesdep +Globdep +attoparsecdep +conduit-extradep −antiope-coredep −antiope-optparse-applicativedep −antiope-s3
Dependencies added: Glob, attoparsec, conduit-extra, hedgehog-extras, oops, time
Dependencies removed: antiope-core, antiope-optparse-applicative, antiope-s3
Files
- LICENSE +1/−1
- app/App/Commands.hs +11/−7
- app/App/Commands/Debug.hs +16/−0
- app/App/Commands/Debug/S3.hs +16/−0
- app/App/Commands/Debug/S3/Cp.hs +109/−0
- app/App/Commands/Options/Parser.hs +33/−6
- app/App/Commands/Options/Types.hs +43/−24
- app/App/Commands/Plan.hs +52/−59
- app/App/Commands/SyncFromArchive.hs +223/−182
- app/App/Commands/SyncToArchive.hs +204/−148
- app/App/Commands/Version.hs +6/−7
- app/App/Static.hs +5/−5
- app/App/Static/Base.hs +4/−1
- app/App/Static/Posix.hs +3/−1
- app/App/Static/Windows.hs +5/−2
- app/Main.hs +8/−6
- cabal-cache.cabal +95/−72
- src/HaskellWorks/CabalCache/AWS/Env.hs +44/−5
- src/HaskellWorks/CabalCache/AWS/Error.hs +26/−0
- src/HaskellWorks/CabalCache/AWS/S3.hs +125/−0
- src/HaskellWorks/CabalCache/AWS/S3/URI.hs +53/−0
- src/HaskellWorks/CabalCache/AppError.hs +41/−30
- src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +24/−7
- src/HaskellWorks/CabalCache/Concurrent/Fork.hs +6/−4
- src/HaskellWorks/CabalCache/Concurrent/Type.hs +5/−5
- src/HaskellWorks/CabalCache/Core.hs +64/−33
- src/HaskellWorks/CabalCache/Data/List.hs +8/−2
- src/HaskellWorks/CabalCache/Error.hs +33/−5
- src/HaskellWorks/CabalCache/GhcPkg.hs +11/−4
- src/HaskellWorks/CabalCache/IO/Console.hs +4/−4
- src/HaskellWorks/CabalCache/IO/Error.hs +0/−54
- src/HaskellWorks/CabalCache/IO/File.hs +13/−5
- src/HaskellWorks/CabalCache/IO/Lazy.hs +223/−175
- src/HaskellWorks/CabalCache/IO/Tar.hs +33/−16
- src/HaskellWorks/CabalCache/Location.hs +18/−18
- src/HaskellWorks/CabalCache/Metadata.hs +8/−3
- src/HaskellWorks/CabalCache/Options.hs +6/−4
- src/HaskellWorks/CabalCache/Show.hs +1/−1
- src/HaskellWorks/CabalCache/Store.hs +21/−0
- src/HaskellWorks/CabalCache/Text.hs +2/−2
- src/HaskellWorks/CabalCache/Topology.hs +3/−4
- src/HaskellWorks/CabalCache/Types.hs +21/−9
- src/HaskellWorks/CabalCache/URI.hs +16/−0
- src/HaskellWorks/CabalCache/Version.hs +4/−2
- test/HaskellWorks/CabalCache/AwsSpec.hs +28/−17
- test/HaskellWorks/CabalCache/IntegrationSpec.hs +93/−0
- test/HaskellWorks/CabalCache/LocationSpec.hs +24/−25
- test/HaskellWorks/CabalCache/QuerySpec.hs +3/−3
- test/Test/Base.hs +43/−0
LICENSE view
@@ -1,4 +1,4 @@-Copyright (c) 2019, John Ky+Copyright (c) 2019-2023, John Ky All rights reserved.
app/App/Commands.hs view
@@ -1,20 +1,24 @@ module App.Commands where -import App.Commands.Plan-import App.Commands.SyncFromArchive-import App.Commands.SyncToArchive-import App.Commands.Version-import Options.Applicative+import App.Commands.Debug (cmdDebug)+import App.Commands.Plan (cmdPlan)+import App.Commands.SyncFromArchive (cmdSyncFromArchive)+import App.Commands.SyncToArchive (cmdSyncToArchive)+import App.Commands.Version (cmdVersion)+import Options.Applicative (Parser) +import qualified Options.Applicative as OA+ {- HLINT ignore "Monoid law, left identity" -} commands :: Parser (IO ()) commands = commandsGeneral commandsGeneral :: Parser (IO ())-commandsGeneral = subparser $ mempty- <> commandGroup "Commands:"+commandsGeneral = OA.subparser $ mempty+ <> OA.commandGroup "Commands:" <> cmdPlan <> cmdSyncFromArchive <> cmdSyncToArchive <> cmdVersion+ <> cmdDebug
+ app/App/Commands/Debug.hs view
@@ -0,0 +1,16 @@+module App.Commands.Debug+ ( cmdDebug+ ) where++import App.Commands.Debug.S3 (cmdS3)++import qualified Options.Applicative as OA++{- HLINT ignore "Monoid law, left identity" -}++commands :: OA.Parser (IO ())+commands = OA.subparser $ mempty+ <> cmdS3++cmdDebug :: OA.Mod OA.CommandFields (IO ())+cmdDebug = OA.command "debug" $ flip OA.info OA.idm commands
+ app/App/Commands/Debug/S3.hs view
@@ -0,0 +1,16 @@+module App.Commands.Debug.S3+ ( cmdS3+ ) where++import App.Commands.Debug.S3.Cp (cmdCp)++import qualified Options.Applicative as OA++{- HLINT ignore "Monoid law, left identity" -}++commands :: OA.Parser (IO ())+commands = OA.subparser $ mempty+ <> cmdCp++cmdS3 :: OA.Mod OA.CommandFields (IO ())+cmdS3 = OA.command "s3" $ flip OA.info OA.idm commands
+ app/App/Commands/Debug/S3/Cp.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-}+{-# LANGUAGE TypeApplications #-}++module App.Commands.Debug.S3.Cp+ ( cmdCp,+ ) where++import App.Commands.Options.Parser (text)+import App.Commands.Options.Types (CpOptions (CpOptions))+import Control.Applicative (Alternative(..), optional)+import Control.Lens ((.~), (<&>), (&), (^.))+import Control.Monad.Except (MonadIO(..))+import Control.Monad.Trans.AWS (envOverride, setEndpoint)+import Data.ByteString (ByteString)+import Data.Generics.Product.Any (the)+import Data.Monoid (Dual(Dual), Endo(Endo))+import HaskellWorks.CabalCache.AppError (AwsError(..), displayAwsError)+import HaskellWorks.CabalCache.Error (CopyFailed(..), ExitFailure(..), UnsupportedUri)+import HaskellWorks.CabalCache.Show (tshow)+import Network.URI (parseURI)++import qualified App.Commands.Options.Types as Z+import qualified Control.Monad.Oops as OO+import qualified Data.Text as T+import qualified HaskellWorks.CabalCache.AWS.Env as AWS+import qualified HaskellWorks.CabalCache.AWS.S3 as AWS+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified Network.AWS as AWS+import qualified Network.AWS.Data as AWS+import qualified Options.Applicative as OA+import qualified System.IO as IO+import qualified System.IO.Unsafe as IO++{- HLINT ignore "Monoid law, left identity" -}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant do" -}++runCp :: Z.CpOptions -> IO ()+runCp opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do+ let srcUri = opts ^. the @"srcUri"+ let dstUri = opts ^. the @"dstUri"+ let hostEndpoint = opts ^. the @"hostEndpoint"+ let awsLogLevel = opts ^. the @"awsLogLevel"++ OO.catchAndExitFailure @ExitFailure do+ envAws <- liftIO $ IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of+ Just (hostname, port, ssl) -> setEndpoint ssl hostname port s+ Nothing -> s))+ $ AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)++ AWS.copyS3Uri envAws srcUri dstUri+ & do OO.catch @AwsError \e -> do+ CIO.hPutStrLn IO.stderr $ "Copy failed: " <> displayAwsError e+ & do OO.catch @CopyFailed \CopyFailed -> do+ CIO.hPutStrLn IO.stderr $ "Copy failed"+ & do OO.catch @UnsupportedUri \e -> do+ CIO.hPutStrLn IO.stderr $ "Unsupported uri: " <> tshow e++optsCp :: OA.Parser CpOptions+optsCp = CpOptions+ <$> OA.option (OA.auto <|> text)+ ( OA.long "region"+ <> OA.metavar "AWS_REGION"+ <> OA.showDefault+ <> OA.value AWS.Oregon+ <> OA.help "The AWS region in which to operate"+ )+ <*> OA.option (OA.maybeReader parseURI)+ ( OA.long "src-uri"+ <> OA.help "Source URI to copy from"+ <> OA.metavar "S3_URI"+ )+ <*> OA.option (OA.maybeReader parseURI)+ ( OA.long "dst-uri"+ <> OA.help "Destination URI to copy to"+ <> OA.metavar "S3_URI"+ )+ <*> optional+ ( OA.option (OA.eitherReader (AWS.fromText . T.pack))+ ( OA.long "aws-log-level"+ <> OA.help "AWS Log Level. One of (Error, Info, Debug, Trace)"+ <> OA.metavar "AWS_LOG_LEVEL"+ )+ )+ <*> optional parseEndpoint++parseEndpoint :: OA.Parser (ByteString, Int, Bool)+parseEndpoint =+ (,,)+ <$> OA.option (OA.eitherReader (AWS.fromText . T.pack))+ ( OA.long "host-name-override"+ <> OA.help "Override the host name (default: s3.amazonaws.com)"+ <> OA.metavar "HOST_NAME"+ )+ <*> OA.option OA.auto+ ( OA.long "host-port-override"+ <> OA.help "Override the host port"+ <> OA.metavar "HOST_PORT"+ )+ <*> OA.option OA.auto+ ( OA.long "host-ssl-override"+ <> OA.help "Override the host SSL"+ <> OA.metavar "HOST_SSL"+ )++cmdCp :: OA.Mod OA.CommandFields (IO ())+cmdCp = OA.command "cp" $ flip OA.info OA.idm $ runCp <$> optsCp
app/App/Commands/Options/Parser.hs view
@@ -1,13 +1,40 @@-module App.Commands.Options.Parser where+module App.Commands.Options.Parser+ ( optsVersion,+ optsPackageIds,+ text,+ ) where -import Antiope.Core (FromText, fromText) import App.Commands.Options.Types (VersionOptions (..))-import Options.Applicative+import Control.Applicative (Alternative(..))+import Control.Monad (join)+import Data.Set (Set)+import Data.Text (Text)+import Options.Applicative (Parser, ReadM) -import qualified Data.Text as Text+import qualified Data.Set as S+import qualified Data.Text as T+import qualified Data.Text as Text+import qualified HaskellWorks.CabalCache.Types as Z+import qualified Network.AWS.Data as AWS+import qualified Options.Applicative as OA optsVersion :: Parser VersionOptions optsVersion = pure VersionOptions -text :: FromText a => ReadM a-text = eitherReader (fromText . Text.pack)+text :: AWS.FromText a => ReadM a+text = OA.eitherReader (AWS.fromText . Text.pack)++optsPackageIds :: Parser (Set Z.PackageId)+optsPackageIds =+ S.fromList . join <$> many+ ( OA.option packageIds+ ( OA.long "ignore-packages"+ <> OA.help "Packages to ignore"+ <> OA.metavar "PACKAGE_LIST"+ )+ )++packageIds :: ReadM [Text]+packageIds = OA.eitherReader \case+ "" -> pure []+ s -> pure $ T.split (== ',') (T.pack s)
app/App/Commands/Options/Types.hs view
@@ -1,28 +1,46 @@ {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-} -module App.Commands.Options.Types where+module App.Commands.Options.Types+ ( CpOptions(..),+ PlanOptions(..),+ SyncFromArchiveOptions(..),+ SyncToArchiveOptions(..),+ VersionOptions(..),+ ) where -import Antiope.Env (Region)-import GHC.Generics import Data.ByteString (ByteString)-import HaskellWorks.CabalCache.Location+import Data.Set (Set)+import GHC.Generics (Generic)+import HaskellWorks.CabalCache.Location (Location)+import HaskellWorks.CabalCache.Types (PackageId)+import Network.URI (URI) -import qualified Antiope.Env as AWS+import qualified Data.List.NonEmpty as NEL+import qualified Network.AWS as AWS -data SyncToArchiveOptions = SyncToArchiveOptions- { region :: Region- , archiveUri :: Location- , path :: FilePath- , buildPath :: FilePath- , storePath :: FilePath- , storePathHash :: Maybe String- , threads :: Int+data CpOptions = CpOptions+ { region :: AWS.Region+ , srcUri :: URI+ , dstUri :: URI , awsLogLevel :: Maybe AWS.LogLevel , hostEndpoint :: Maybe (ByteString, Int, Bool)- , maxRetries :: Int } deriving (Eq, Show, Generic) +data SyncToArchiveOptions = SyncToArchiveOptions+ { region :: AWS.Region+ , archiveUri :: Location+ , path :: FilePath+ , buildPath :: FilePath+ , storePath :: FilePath+ , storePathHash :: Maybe String+ , threads :: Int+ , awsLogLevel :: Maybe AWS.LogLevel+ , hostEndpoint :: Maybe (ByteString, Int, Bool)+ , maxRetries :: Int+ , ignorePackages :: Set PackageId+ } deriving (Eq, Show, Generic)+ data PlanOptions = PlanOptions { path :: FilePath , buildPath :: FilePath@@ -32,16 +50,17 @@ } deriving (Eq, Show, Generic) data SyncFromArchiveOptions = SyncFromArchiveOptions- { region :: Region- , archiveUris :: [Location]- , path :: FilePath- , buildPath :: FilePath- , storePath :: FilePath- , storePathHash :: Maybe String- , threads :: Int- , awsLogLevel :: Maybe AWS.LogLevel- , hostEndpoint :: Maybe (ByteString, Int, Bool)- , maxRetries :: Int+ { region :: AWS.Region+ , archiveUris :: NEL.NonEmpty Location+ , path :: FilePath+ , buildPath :: FilePath+ , storePath :: FilePath+ , storePathHash :: Maybe String+ , threads :: Int+ , awsLogLevel :: Maybe AWS.LogLevel+ , hostEndpoint :: Maybe (ByteString, Int, Bool)+ , maxRetries :: Int+ , ignorePackages :: Set PackageId } deriving (Eq, Show, Generic) data VersionOptions = VersionOptions deriving (Eq, Show, Generic)
app/App/Commands/Plan.hs view
@@ -1,35 +1,36 @@-{-# LANGUAGE BlockArguments #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module App.Commands.Plan- ( cmdPlan+ ( cmdPlan, ) where -import Antiope.Core (toText) import App.Commands.Options.Types (PlanOptions (PlanOptions))-import Control.Applicative-import Control.Lens hiding ((<.>))-import Control.Monad.Except+import Control.Applicative (optional)+import Control.Lens ((<&>), (&), (^.), (%~), Each(each))+import Control.Monad (forM)+import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Generics.Product.Any (the)-import Data.Maybe-import HaskellWorks.CabalCache.AppError+import Data.Maybe (fromMaybe)+import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure(..)) import HaskellWorks.CabalCache.Location (Location (..), (<.>), (</>))-import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Show (tshow) import HaskellWorks.CabalCache.Version (archiveVersion)-import Options.Applicative hiding (columns)+import Options.Applicative (Parser, Mod, CommandFields) import qualified App.Commands.Options.Types as Z import qualified App.Static as AS-import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.Oops as OO import qualified Data.Aeson as J import qualified Data.ByteString.Lazy as LBS import qualified Data.Text as T import qualified HaskellWorks.CabalCache.Core as Z import qualified HaskellWorks.CabalCache.Hash as H import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified Network.AWS.Data as AWS+import qualified Options.Applicative as OA import qualified System.IO as IO {- HLINT ignore "Monoid law, left identity" -}@@ -37,77 +38,69 @@ {- HLINT ignore "Reduce duplication" -} runPlan :: Z.PlanOptions -> IO ()-runPlan opts = do+runPlan opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do let storePath = opts ^. the @"storePath" let archiveUris = [Local ""] let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath) let versionedArchiveUris = archiveUris & each %~ (</> archiveVersion) let outputFile = opts ^. the @"outputFile" - CIO.putStrLn $ "Store path: " <> toText storePath+ CIO.putStrLn $ "Store path: " <> AWS.toText storePath CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash CIO.putStrLn $ "Archive URIs: " <> tshow archiveUris CIO.putStrLn $ "Archive version: " <> archiveVersion - tEarlyExit <- STM.newTVarIO False-- mbPlan <- Z.loadPlan $ opts ^. the @"path" </> opts ^. the @"buildPath"-- case mbPlan of- Right planJson -> do- packages <- Z.getPackages storePath planJson-- plan <- forM packages $ \pInfo -> do- let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"- let archiveFiles = versionedArchiveUris <&> (</> T.pack archiveFileBasename)- let scopedArchiveFiles = versionedArchiveUris <&> (</> T.pack storePathHash </> T.pack archiveFileBasename)-- return $ archiveFiles <> scopedArchiveFiles+ planJson <- Z.loadPlan (opts ^. the @"path" </> opts ^. the @"buildPath")+ & do OO.catch @DecodeError \e -> do+ CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e+ OO.throw ExitFailure - if outputFile == "-"- then LBS.putStr $ J.encode (fmap (fmap toText) plan)- else LBS.writeFile outputFile $ J.encode (fmap (fmap toText) plan)+ packages <- liftIO $ Z.getPackages storePath planJson - Left (appError :: AppError) -> do- CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError+ plan <- forM packages $ \pInfo -> do+ let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"+ let archiveFiles = versionedArchiveUris <&> (</> T.pack archiveFileBasename)+ let scopedArchiveFiles = versionedArchiveUris <&> (</> T.pack storePathHash </> T.pack archiveFileBasename) - earlyExit <- STM.readTVarIO tEarlyExit+ return $ archiveFiles <> scopedArchiveFiles - when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error"+ if outputFile == "-"+ then liftIO $ LBS.putStr $ J.encode (fmap (fmap AWS.toText) plan)+ else liftIO $ LBS.writeFile outputFile $ J.encode (fmap (fmap AWS.toText) plan) optsPlan :: Parser PlanOptions optsPlan = PlanOptions- <$> strOption- ( long "path"- <> help "Path to cabal project. Defaults to \".\""- <> metavar "DIRECTORY"- <> value AS.path+ <$> OA.strOption+ ( OA.long "path"+ <> OA.help "Path to cabal project. Defaults to \".\""+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.path )- <*> strOption- ( long "build-path"- <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)- <> metavar "DIRECTORY"- <> value AS.buildPath+ <*> OA.strOption+ ( OA.long "build-path"+ <> OA.help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.buildPath )- <*> strOption- ( long "store-path"- <> help "Path to cabal store"- <> metavar "DIRECTORY"- <> value AS.cabalStoreDirectory+ <*> OA.strOption+ ( OA.long "store-path"+ <> OA.help "Path to cabal store"+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.cabalStoreDirectory ) <*> optional- ( strOption- ( long "store-path-hash"- <> help "Store path hash (do not use)"- <> metavar "HASH"+ ( OA.strOption+ ( OA.long "store-path-hash"+ <> OA.help "Store path hash (do not use)"+ <> OA.metavar "HASH" ) )- <*> strOption- ( long "output-file"- <> help "Output file"- <> metavar "FILE"- <> value "-"+ <*> OA.strOption+ ( OA.long "output-file"+ <> OA.help "Output file"+ <> OA.metavar "FILE"+ <> OA.value "-" ) cmdPlan :: Mod CommandFields (IO ())-cmdPlan = command "plan" $ flip info idm $ runPlan <$> optsPlan+cmdPlan = OA.command "plan" $ flip OA.info OA.idm $ runPlan <$> optsPlan
app/App/Commands/SyncFromArchive.hs view
@@ -1,46 +1,53 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} module App.Commands.SyncFromArchive- ( cmdSyncFromArchive+ ( cmdSyncFromArchive, ) where -import Antiope.Core (Region (..), runResAws, toText)-import Antiope.Env (mkEnv)-import Antiope.Options.Applicative-import App.Commands.Options.Parser (text)+import App.Commands.Options.Parser (optsPackageIds, text) import App.Commands.Options.Types (SyncFromArchiveOptions (SyncFromArchiveOptions))-import Control.Applicative-import Control.Lens hiding ((<.>))-import Control.Monad.Except-import Control.Monad.Trans.AWS (envOverride, setEndpoint, AWST', Env)-import Control.Monad.Trans.Resource (ResourceT)+import Control.Applicative (optional, Alternative(..))+import Control.Lens ((^..), (.~), (<&>), (%~), (&), (^.), Each(each))+import Control.Lens.Combinators (traverse1)+import Control.Monad (when, unless, forM_)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.Except (ExceptT)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.AWS (envOverride, setEndpoint)+import Control.Monad.Trans.Resource (runResourceT) import Data.ByteString (ByteString) import Data.ByteString.Lazy.Search (replace) import Data.Generics.Product.Any (the)-import Data.Maybe-import Data.Monoid-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept)-import HaskellWorks.CabalCache.Location (toLocation, (<.>), (</>))+import Data.List.NonEmpty (NonEmpty)+import Data.Maybe (fromMaybe)+import Data.Monoid (Dual(Dual), Endo(Endo))+import Data.Semigroup (Semigroup(..))+import Data.Text (Text)+import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, displayHttpError)+import HaskellWorks.CabalCache.Error (DecodeError(..), ExitFailure(..), InvalidUrl(..), NotFound, UnsupportedUri(..))+import HaskellWorks.CabalCache.IO.Lazy (readFirstAvailableResource)+import HaskellWorks.CabalCache.IO.Tar (ArchiveError(..))+import HaskellWorks.CabalCache.Location (toLocation, (<.>), (</>), Location) import HaskellWorks.CabalCache.Metadata (loadMetadata)-import HaskellWorks.CabalCache.Show-import HaskellWorks.CabalCache.Types (PackageId)+import HaskellWorks.CabalCache.Show (tshow) import HaskellWorks.CabalCache.Version (archiveVersion)-import Options.Applicative hiding (columns)+import Options.Applicative (CommandFields, Mod, Parser)+import Options.Applicative.NonEmpty (some1) import System.Directory (createDirectoryIfMissing, doesDirectoryExist) import qualified App.Commands.Options.Types as Z import qualified App.Static as AS import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Char8 as C8 import qualified Data.ByteString.Lazy as LBS-import qualified Data.List as L+import qualified Data.List.NonEmpty as NEL import qualified Data.Map as M import qualified Data.Map.Strict as Map+import qualified Data.Set as S import qualified Data.Text as T import qualified HaskellWorks.CabalCache.AWS.Env as AWS import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ@@ -50,9 +57,12 @@ import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg import qualified HaskellWorks.CabalCache.Hash as H import qualified HaskellWorks.CabalCache.IO.Console as CIO-import qualified HaskellWorks.CabalCache.IO.Lazy as IO import qualified HaskellWorks.CabalCache.IO.Tar as IO+import qualified HaskellWorks.CabalCache.Store as M import qualified HaskellWorks.CabalCache.Types as Z+import qualified Network.AWS as AWS+import qualified Network.AWS.Data as AWS+import qualified Options.Applicative as OA import qualified System.Directory as IO import qualified System.IO as IO import qualified System.IO.Temp as IO@@ -66,229 +76,260 @@ skippable package = package ^. the @"packageType" == "pre-existing" runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO ()-runSyncFromArchive opts = do+runSyncFromArchive opts = OO.runOops $ OO.catchAndExitFailure @ExitFailure do let hostEndpoint = opts ^. the @"hostEndpoint" let storePath = opts ^. the @"storePath"- let archiveUris = opts ^. the @"archiveUris"+ let archiveUris = opts ^. the @"archiveUris" :: NonEmpty Location let threads = opts ^. the @"threads" let awsLogLevel = opts ^. the @"awsLogLevel"- let versionedArchiveUris = archiveUris & each %~ (</> archiveVersion)+ let versionedArchiveUris = archiveUris & traverse1 %~ (</> archiveVersion) :: NonEmpty Location let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)- let scopedArchiveUris = versionedArchiveUris & each %~ (</> T.pack storePathHash)+ let scopedArchiveUris = versionedArchiveUris & traverse1 %~ (</> T.pack storePathHash) let maxRetries = opts ^. the @"maxRetries"+ let ignorePackages = opts ^. the @"ignorePackages" - CIO.putStrLn $ "Store path: " <> toText storePath+ CIO.putStrLn $ "Store path: " <> AWS.toText storePath CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash forM_ archiveUris $ \archiveUri -> do- CIO.putStrLn $ "Archive URI: " <> toText archiveUri+ CIO.putStrLn $ "Archive URI: " <> AWS.toText archiveUri CIO.putStrLn $ "Archive version: " <> archiveVersion CIO.putStrLn $ "Threads: " <> tshow threads CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - mbPlan <- Z.loadPlan $ opts ^. the @"path" </> opts ^. the @"buildPath"+ OO.catchAndExitFailure @ExitFailure do+ planJson <- Z.loadPlan (opts ^. the @"path" </> opts ^. the @"buildPath")+ & do OO.catch @DecodeError \e -> do+ CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e+ OO.throw ExitFailure - case mbPlan of- Right planJson -> do- compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson+ compilerContext <- Z.mkCompilerContext planJson+ & do OO.catch @Text \e -> do+ CIO.hPutStrLn IO.stderr e+ OO.throw ExitFailure - case compilerContextResult of- Right compilerContext -> do- GhcPkg.testAvailability compilerContext+ liftIO $ GhcPkg.testAvailability compilerContext - envAws <- IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of- Just (hostname, port, ssl) -> setEndpoint ssl hostname port s- Nothing -> s))- $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)- let compilerId = planJson ^. the @"compilerId"- let storeCompilerPath = storePath </> T.unpack compilerId- let storeCompilerPackageDbPath = storeCompilerPath </> "package.db"- let storeCompilerLibPath = storeCompilerPath </> "lib"+ envAws <- liftIO $ IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of+ Just (hostname, port, ssl) -> setEndpoint ssl hostname port s+ Nothing -> s))+ $ AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)+ let compilerId = planJson ^. the @"compilerId"+ let storeCompilerPath = storePath </> T.unpack compilerId+ let storeCompilerPackageDbPath = storeCompilerPath </> "package.db"+ let storeCompilerLibPath = storeCompilerPath </> "lib" - CIO.putStrLn "Creating store directories"- createDirectoryIfMissing True storePath- createDirectoryIfMissing True storeCompilerPath- createDirectoryIfMissing True storeCompilerLibPath+ CIO.putStrLn "Creating store directories"+ liftIO $ createDirectoryIfMissing True storePath+ liftIO $ createDirectoryIfMissing True storeCompilerPath+ liftIO $ createDirectoryIfMissing True storeCompilerLibPath - storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath+ storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath - unless storeCompilerPackageDbPathExists $ do- CIO.putStrLn "Package DB missing. Creating Package DB"- GhcPkg.init compilerContext storeCompilerPackageDbPath+ unless storeCompilerPackageDbPathExists do+ CIO.putStrLn "Package DB missing. Creating Package DB"+ liftIO $ GhcPkg.init compilerContext storeCompilerPackageDbPath - packages <- Z.getPackages storePath planJson+ packages <- liftIO $ Z.getPackages storePath planJson - let installPlan = planJson ^. the @"installPlan"- let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan+ let installPlan = planJson ^. the @"installPlan"+ let planPackages = M.fromList $ fmap (\p -> (p ^. the @"id", p)) installPlan - let planDeps0 = installPlan >>= \p -> fmap (p ^. the @"id", ) $ mempty- <> (p ^. the @"depends")- <> (p ^. the @"exeDepends")- <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends" . each)- <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each)- let planDeps = planDeps0 <> fmap (\p -> ("[universe]", p ^. the @"id")) installPlan+ let planDeps0 = installPlan >>= \p -> fmap (p ^. the @"id", ) $ mempty+ <> (p ^. the @"depends")+ <> (p ^. the @"exeDepends")+ <> (p ^.. the @"components" . each . the @"lib" . each . the @"depends" . each)+ <> (p ^.. the @"components" . each . the @"lib" . each . the @"exeDepends" . each)+ let planDeps = planDeps0 <> fmap (\p -> ("[universe]", p ^. the @"id")) installPlan - downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps+ downloadQueue <- liftIO $ STM.atomically $ DQ.createDownloadQueue planDeps - let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages+ let pInfos = M.fromList $ fmap (\p -> (p ^. the @"packageId", p)) packages - IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do- IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db")+ IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+ liftIO $ IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db") - IO.forkThreadsWait threads $ DQ.runQueue downloadQueue $ \packageId -> case M.lookup packageId pInfos of- Just pInfo -> do- let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz"- let archiveFiles = versionedArchiveUris & each %~ (</> T.pack archiveBaseName)- let scopedArchiveFiles = scopedArchiveUris & each %~ (</> T.pack archiveBaseName)- let packageStorePath = storePath </> Z.packageDir pInfo- let maybePackage = M.lookup packageId planPackages+ liftIO $ IO.forkThreadsWait threads $ OO.runOops $ DQ.runQueue downloadQueue $ \packageId -> do+ OO.recoverOrVoid @DQ.DownloadStatus do+ pInfo <- pure (M.lookup packageId pInfos)+ & do OO.onNothing do+ CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId+ DQ.succeed - storeDirectoryExists <- doesDirectoryExist packageStorePath+ let archiveBaseName = Z.packageDir pInfo <.> ".tar.gz"+ let archiveFiles = versionedArchiveUris & traverse1 %~ (</> T.pack archiveBaseName)+ let scopedArchiveFiles = scopedArchiveUris & traverse1 %~ (</> T.pack archiveBaseName)+ let packageStorePath = storePath </> Z.packageDir pInfo+ let packageName = pInfo ^. the @"packageName" - case maybePackage of- Nothing -> do- CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId- return DQ.DownloadSuccess- Just package -> if skippable package- then do- CIO.putStrLn $ "Skipping: " <> packageId- return DQ.DownloadSuccess- else if storeDirectoryExists- then return DQ.DownloadSuccess- else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) DQ.DownloadFailure $ do- (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles)) maxRetries- CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile+ storeDirectoryExists <- liftIO $ doesDirectoryExist packageStorePath - let tempArchiveFile = tempPath </> archiveBaseName- liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents- IO.extractTar tempArchiveFile storePath+ package <- pure (M.lookup packageId planPackages)+ & do OO.onNothing do+ CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageName+ DQ.succeed - meta <- loadMetadata packageStorePath- oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta)+ when (skippable package) do+ CIO.putStrLn $ "Skipping: " <> packageName+ DQ.succeed - case Z.confPath pInfo of- Z.Tagged conf _ -> do- let theConfPath = storePath </> conf- let tempConfPath = tempPath </> conf- confPathExists <- liftIO $ IO.doesFileExist theConfPath- when confPathExists $ do- confContents <- liftIO $ LBS.readFile theConfPath- liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)- liftIO $ IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath+ when (packageName `S.member` ignorePackages) do+ CIO.putStrLn $ "Ignoring: " <> packageName+ DQ.fail - return DQ.DownloadSuccess- Nothing -> do- CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId- return DQ.DownloadSuccess+ when storeDirectoryExists DQ.succeed - CIO.putStrLn "Recaching package database"- GhcPkg.recache compilerContext storeCompilerPackageDbPath+ OO.suspend runResourceT $ ensureStorePathCleanup packageStorePath do+ let locations = sconcat $ fmap L.tuple2ToNel (NEL.zip archiveFiles scopedArchiveFiles) - failures <- STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"+ (existingArchiveFileContents, existingArchiveFile) <- readFirstAvailableResource envAws locations maxRetries+ & do OO.catch @AwsError \e -> do+ CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayAwsError e+ DQ.fail+ & do OO.catch @HttpError \e -> do+ CIO.putStrLn $ "Unable to download any of: " <> tshow locations <> " because: " <> displayHttpError e+ DQ.fail+ & do OO.catch @NotFound \_ -> do+ CIO.putStrLn $ "Not found: " <> tshow locations+ DQ.fail+ & do OO.catch @InvalidUrl \(InvalidUrl url' reason') -> do+ CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason'+ DQ.fail+ & do OO.catch @UnsupportedUri \e -> do+ CIO.hPutStrLn IO.stderr $ tshow e+ DQ.fail - forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId- Left msg -> CIO.hPutStrLn IO.stderr msg- Left appError -> do- CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError+ CIO.putStrLn $ "Extracting: " <> AWS.toText existingArchiveFile - return ()+ let tempArchiveFile = tempPath </> archiveBaseName+ liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents -cleanupStorePath :: FilePath -> PackageId -> AppError -> AWST' Env (ResourceT IO) ()-cleanupStorePath packageStorePath packageId e = do- CIO.hPutStrLn IO.stderr $ "Warning: Sync failure: " <> packageId <> ", reason: " <> displayAppError e- pathExists <- liftIO $ IO.doesPathExist packageStorePath- when pathExists $ void $ IO.removePathRecursive packageStorePath+ IO.extractTar tempArchiveFile storePath+ & do OO.catch @ArchiveError \(ArchiveError reason') -> do+ CIO.putStrLn $ "Unable to extract tar at " <> tshow tempArchiveFile <> " because: " <> reason'+ DQ.fail -onError :: ()- => (AppError -> AWST' Env (ResourceT IO) ())- -> DQ.DownloadStatus- -> ExceptT AppError (AWST' Env (ResourceT IO)) DQ.DownloadStatus- -> AWST' Env (ResourceT IO) DQ.DownloadStatus-onError h failureValue f = do- result <- runExceptT $ catchError (exceptWarn f) handler- case result of- Left _ -> return failureValue- Right a -> return a- where handler e = lift (h e) >> return failureValue+ meta <- loadMetadata packageStorePath+ oldStorePath <- pure (Map.lookup "store-path" meta)+ & do OO.onNothing do+ CIO.putStrLn "store-path is missing from Metadata"+ DQ.fail + let Z.Tagged conf _ = Z.confPath pInfo+ + let theConfPath = storePath </> conf+ let tempConfPath = tempPath </> conf+ confPathExists <- liftIO $ IO.doesFileExist theConfPath+ when confPathExists do+ confContents <- liftIO $ LBS.readFile theConfPath+ liftIO $ LBS.writeFile tempConfPath (replace (LBS.toStrict oldStorePath) (C8.pack storePath) confContents)+ liftIO $ IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath++ DQ.succeed++ CIO.putStrLn "Recaching package database"++ liftIO $ GhcPkg.recache compilerContext storeCompilerPackageDbPath++ failures <- liftIO $ STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"++ forM_ failures $ \packageId -> CIO.hPutStrLn IO.stderr $ "Failed to download: " <> packageId++ensureStorePathCleanup :: ()+ => MonadIO m+ => MonadCatch m+ => e `OO.CouldBe` DQ.DownloadStatus+ => FilePath+ -> ExceptT (OO.Variant e) m a+ -> ExceptT (OO.Variant e) m a+ensureStorePathCleanup packageStorePath = + OO.snatch @DQ.DownloadStatus \downloadStatus -> do+ case downloadStatus of+ DQ.DownloadFailure -> M.cleanupStorePath packageStorePath+ DQ.DownloadSuccess ->+ CIO.hPutStrLn IO.stdout $ "Successfully cleaned up store path: " <> tshow packageStorePath+ OO.throw downloadStatus+ optsSyncFromArchive :: Parser SyncFromArchiveOptions optsSyncFromArchive = SyncFromArchiveOptions- <$> option (auto <|> text)- ( long "region"- <> metavar "AWS_REGION"- <> showDefault <> value Oregon- <> help "The AWS region in which to operate"+ <$> OA.option (OA.auto <|> text)+ ( OA.long "region"+ <> OA.metavar "AWS_REGION"+ <> OA.showDefault+ <> OA.value AWS.Oregon+ <> OA.help "The AWS region in which to operate" )- <*> some- ( option (maybeReader (toLocation . T.pack))- ( long "archive-uri"- <> help "Archive URI to sync to"- <> metavar "S3_URI"+ <*> some1+ ( OA.option (OA.maybeReader (toLocation . T.pack))+ ( OA.long "archive-uri"+ <> OA.help "Archive URI to sync to"+ <> OA.metavar "S3_URI" ) )- <*> strOption- ( long "path"- <> help "Path to cabal project directory. Defaults to \".\""- <> metavar "DIRECTORY"- <> value AS.path+ <*> OA.strOption+ ( OA.long "path"+ <> OA.help "Path to cabal project directory. Defaults to \".\""+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.path )- <*> strOption- ( long "build-path"- <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)- <> metavar "DIRECTORY"- <> value AS.buildPath+ <*> OA.strOption+ ( OA.long "build-path"+ <> OA.help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.buildPath )- <*> strOption- ( long "store-path"- <> help ("Path to cabal store. Defaults to " <> show AS.cabalStoreDirectory)- <> metavar "DIRECTORY"- <> value AS.cabalStoreDirectory+ <*> OA.strOption+ ( OA.long "store-path"+ <> OA.help ("Path to cabal store. Defaults to " <> show AS.cabalStoreDirectory)+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.cabalStoreDirectory ) <*> optional- ( strOption- ( long "store-path-hash"- <> help "Store path hash (do not use)"- <> metavar "HASH"+ ( OA.strOption+ ( OA.long "store-path-hash"+ <> OA.help "Store path hash (do not use)"+ <> OA.metavar "HASH" ) )- <*> option auto- ( long "threads"- <> help "Number of concurrent threads"- <> metavar "NUM_THREADS"- <> value 4+ <*> OA.option OA.auto+ ( OA.long "threads"+ <> OA.help "Number of concurrent threads"+ <> OA.metavar "NUM_THREADS"+ <> OA.value 4 ) <*> optional- ( option autoText- ( long "aws-log-level"- <> help "AWS Log Level. One of (Error, Info, Debug, Trace)"- <> metavar "AWS_LOG_LEVEL"+ ( OA.option (OA.eitherReader (AWS.fromText . T.pack))+ ( OA.long "aws-log-level"+ <> OA.help "AWS Log Level. One of (Error, Info, Debug, Trace)"+ <> OA.metavar "AWS_LOG_LEVEL" ) ) <*> optional parseEndpoint- <*> option auto- ( long "max-retries"- <> help "Max retries for S3 requests"- <> metavar "NUM_RETRIES"- <> value 3+ <*> OA.option OA.auto+ ( OA.long "max-retries"+ <> OA.help "Max retries for S3 requests"+ <> OA.metavar "NUM_RETRIES"+ <> OA.value 3 )+ <*> optsPackageIds parseEndpoint :: Parser (ByteString, Int, Bool) parseEndpoint = (,,)- <$> option autoText- ( long "host-name-override"- <> help "Override the host name (default: s3.amazonaws.com)"- <> metavar "HOST_NAME"+ <$> OA.option (OA.eitherReader (AWS.fromText . T.pack))+ ( OA.long "host-name-override"+ <> OA.help "Override the host name (default: s3.amazonaws.com)"+ <> OA.metavar "HOST_NAME" )- <*> option auto- ( long "host-port-override"- <> help "Override the host port"- <> metavar "HOST_PORT"+ <*> OA.option OA.auto+ ( OA.long "host-port-override"+ <> OA.help "Override the host port"+ <> OA.metavar "HOST_PORT" )- <*> option auto- ( long "host-ssl-override"- <> help "Override the host SSL"- <> metavar "HOST_SSL"+ <*> OA.option OA.auto+ ( OA.long "host-ssl-override"+ <> OA.help "Override the host SSL"+ <> OA.metavar "HOST_SSL" ) cmdSyncFromArchive :: Mod CommandFields (IO ())-cmdSyncFromArchive = command "sync-from-archive" $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive+cmdSyncFromArchive = OA.command "sync-from-archive" $ flip OA.info OA.idm $ runSyncFromArchive <$> optsSyncFromArchive
app/App/Commands/SyncToArchive.hs view
@@ -1,44 +1,45 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeApplications #-} module App.Commands.SyncToArchive- ( cmdSyncToArchive+ ( cmdSyncToArchive, ) where -import Antiope.Core (Region (..), toText)-import Antiope.Env (mkEnv)-import Antiope.Options.Applicative-import App.Commands.Options.Parser (text)+import App.Commands.Options.Parser (optsPackageIds, text) import App.Commands.Options.Types (SyncToArchiveOptions (SyncToArchiveOptions))-import Control.Applicative-import Control.Lens hiding ((<.>))-import Control.Monad.Except-import Control.Monad.Trans.Resource (runResourceT)+import Control.Applicative (Alternative(..), optional)+import Control.Concurrent.STM (TVar)+import Control.Lens ((<&>), (&), (^..), (^.), (.~), Each(each))+import Control.Monad (filterM, when, unless)+import Control.Monad.Except (ExceptT)+import Control.Monad.IO.Class (MonadIO(..)) import Control.Monad.Trans.AWS (envOverride, setEndpoint) import Data.ByteString (ByteString) import Data.Generics.Product.Any (the) import Data.List ((\\))-import Data.Maybe-import Data.Monoid-import HaskellWorks.CabalCache.AppError+import Data.Maybe (fromMaybe)+import Data.Monoid (Dual(Dual), Endo(Endo))+import Data.Text (Text)+import HaskellWorks.CabalCache.AppError (AwsError, HttpError (..), displayAwsError, displayHttpError)+import HaskellWorks.CabalCache.Error (DecodeError, ExitFailure(..), InvalidUrl(..), NotImplemented(..), UnsupportedUri(..)) import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), (</>))+import HaskellWorks.CabalCache.IO.Tar (ArchiveError) import HaskellWorks.CabalCache.Metadata (createMetadata)-import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Show (tshow) import HaskellWorks.CabalCache.Topology (buildPlanData, canShare) import HaskellWorks.CabalCache.Version (archiveVersion)-import Options.Applicative hiding (columns)+import Options.Applicative (Parser, Mod, CommandFields) import System.Directory (doesDirectoryExist) import System.FilePath (takeDirectory) import qualified App.Commands.Options.Types as Z import qualified App.Static as AS import qualified Control.Concurrent.STM as STM+import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8+import qualified Data.Set as S import qualified Data.Text as T import qualified Data.Text as Text import qualified HaskellWorks.CabalCache.AWS.Env as AWS@@ -46,11 +47,12 @@ import qualified HaskellWorks.CabalCache.GhcPkg as GhcPkg import qualified HaskellWorks.CabalCache.Hash as H import qualified HaskellWorks.CabalCache.IO.Console as CIO-import qualified HaskellWorks.CabalCache.IO.Error as IO import qualified HaskellWorks.CabalCache.IO.File as IO import qualified HaskellWorks.CabalCache.IO.Lazy as IO import qualified HaskellWorks.CabalCache.IO.Tar as IO-import qualified Network.HTTP.Types as HTTP+import qualified Network.AWS as AWS+import qualified Network.AWS.Data as AWS+import qualified Options.Applicative as OA import qualified System.Directory as IO import qualified System.IO as IO import qualified System.IO.Temp as IO@@ -61,110 +63,162 @@ {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} +data WorkResult = WorkSkipped | WorkFatal+ deriving (Eq, Show)+ runSyncToArchive :: Z.SyncToArchiveOptions -> IO () runSyncToArchive opts = do- let hostEndpoint = opts ^. the @"hostEndpoint"- let storePath = opts ^. the @"storePath"- let archiveUri = opts ^. the @"archiveUri"- let threads = opts ^. the @"threads"- let awsLogLevel = opts ^. the @"awsLogLevel"- let versionedArchiveUri = archiveUri </> archiveVersion- let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)- let scopedArchiveUri = versionedArchiveUri </> T.pack storePathHash- let maxRetries = opts ^. the @"maxRetries"+ tEarlyExit <- STM.newTVarIO False - CIO.putStrLn $ "Store path: " <> toText storePath- CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash- CIO.putStrLn $ "Archive URI: " <> toText archiveUri- CIO.putStrLn $ "Archive version: " <> archiveVersion- CIO.putStrLn $ "Threads: " <> tshow threads- CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel+ OO.runOops $ OO.catchAndExitFailure @ExitFailure do+ let hostEndpoint = opts ^. the @"hostEndpoint"+ let storePath = opts ^. the @"storePath"+ let archiveUri = opts ^. the @"archiveUri"+ let threads = opts ^. the @"threads"+ let awsLogLevel = opts ^. the @"awsLogLevel"+ let versionedArchiveUri = archiveUri </> archiveVersion+ let storePathHash = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)+ let scopedArchiveUri = versionedArchiveUri </> T.pack storePathHash+ let maxRetries = opts ^. the @"maxRetries"+ let ignorePackages = opts ^. the @"ignorePackages" - tEarlyExit <- STM.newTVarIO False+ CIO.putStrLn $ "Store path: " <> AWS.toText storePath+ CIO.putStrLn $ "Store path hash: " <> T.pack storePathHash+ CIO.putStrLn $ "Archive URI: " <> AWS.toText archiveUri+ CIO.putStrLn $ "Archive version: " <> archiveVersion+ CIO.putStrLn $ "Threads: " <> tshow threads+ CIO.putStrLn $ "AWS Log level: " <> tshow awsLogLevel - mbPlan <- Z.loadPlan $ opts ^. the @"path" </> opts ^. the @"buildPath"+ planJson <- Z.loadPlan (opts ^. the @"path" </> opts ^. the @"buildPath")+ & do OO.catch @DecodeError \e -> do+ CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> tshow e+ OO.throw ExitFailure - case mbPlan of- Right planJson -> do- compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson+ compilerContext <- Z.mkCompilerContext planJson+ & do OO.catch @Text \e -> do+ CIO.hPutStrLn IO.stderr e+ OO.throw ExitFailure - case compilerContextResult of- Right compilerContext -> do- let compilerId = planJson ^. the @"compilerId"- envAws <- IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of- Just (hostname, port, ssl) -> setEndpoint ssl hostname port s- Nothing -> s))- $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)- let archivePath = versionedArchiveUri </> compilerId- let scopedArchivePath = scopedArchiveUri </> compilerId- IO.createLocalDirectoryIfMissing archivePath- IO.createLocalDirectoryIfMissing scopedArchivePath+ let compilerId = planJson ^. the @"compilerId" - packages <- Z.getPackages storePath planJson- nonShareable <- packages & filterM (fmap not . isShareable storePath)- let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId")+ envAws <- liftIO $ IO.unsafeInterleaveIO $ (<&> envOverride .~ Dual (Endo $ \s -> case hostEndpoint of+ Just (hostname, port, ssl) -> setEndpoint ssl hostname port s+ Nothing -> s))+ $ AWS.mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel) - let storeCompilerPath = storePath </> T.unpack compilerId- let storeCompilerPackageDbPath = storeCompilerPath </> "package.db"+ let archivePath = versionedArchiveUri </> compilerId+ let scopedArchivePath = scopedArchiveUri </> compilerId - storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath+ liftIO $ IO.createLocalDirectoryIfMissing archivePath+ liftIO $ IO.createLocalDirectoryIfMissing scopedArchivePath - unless storeCompilerPackageDbPathExists $- GhcPkg.init compilerContext storeCompilerPackageDbPath+ packages <- liftIO $ Z.getPackages storePath planJson - CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages"+ nonShareable <- packages & filterM (fmap not . isShareable storePath) - IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do- CIO.putStrLn $ "Temp path: " <> tshow tempPath+ let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId") - IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do- earlyExit <- STM.readTVarIO tEarlyExit- unless earlyExit $ do- let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"- let archiveFile = versionedArchiveUri </> T.pack archiveFileBasename- let scopedArchiveFile = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename- let packageStorePath = storePath </> Z.packageDir pInfo+ let storeCompilerPath = storePath </> T.unpack compilerId+ let storeCompilerPackageDbPath = storeCompilerPath </> "package.db" - -- either write "normal" package, or a user-specific one if the package cannot be shared- let targetFile = if canShare planData (Z.packageId pInfo) then archiveFile else scopedArchiveFile+ storeCompilerPackageDbPathExists <- liftIO $ doesDirectoryExist storeCompilerPackageDbPath - archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile+ unless storeCompilerPackageDbPathExists $+ liftIO $ GhcPkg.init compilerContext storeCompilerPackageDbPath - unless archiveFileExists $ do- packageStorePathExists <- doesDirectoryExist packageStorePath+ CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages" - when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do- let workingStorePackagePath = tempPath </> Z.packageDir pInfo- liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath+ IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+ CIO.putStrLn $ "Temp path: " <> tshow tempPath - let rp2 = Z.relativePaths storePath pInfo+ liftIO $ IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do+ OO.runOops $ workLoop tEarlyExit do+ let archiveFileBasename = Z.packageDir pInfo <.> ".tar.gz"+ let archiveFile = versionedArchiveUri </> T.pack archiveFileBasename+ let scopedArchiveFile = versionedArchiveUri </> T.pack storePathHash </> T.pack archiveFileBasename+ let packageStorePath = storePath </> Z.packageDir pInfo+ let packageName = pInfo ^. the @"packageName" - CIO.putStrLn $ "Creating " <> toText targetFile+ when (packageName `S.member` ignorePackages) do+ CIO.hPutStrLn IO.stderr $ "Ignoring package: " <> packageName+ OO.throw WorkSkipped - let tempArchiveFile = tempPath </> archiveFileBasename+ -- either write "normal" package, or a user-specific one if the package cannot be shared+ let targetFile = if canShare planData (Z.packageId pInfo) then archiveFile else scopedArchiveFile - metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]+ archiveFileExists <- IO.resourceExists envAws targetFile+ & do OO.catch @InvalidUrl \(InvalidUrl url' reason') -> do+ CIO.hPutStrLn IO.stderr $ "Invalid URL: " <> tshow url' <> ", " <> reason'+ OO.throw WorkSkipped+ & do OO.catch @UnsupportedUri \e -> do+ CIO.hPutStrLn IO.stderr $ "Unsupported URI: " <> tshow e+ OO.throw WorkSkipped - IO.createTar tempArchiveFile (rp2 <> [metas])+ unless archiveFileExists do+ packageStorePathExists <- liftIO $ doesDirectoryExist packageStorePath - void $ catchError (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile maxRetries) $ \case- e@(AwsAppError (HTTP.Status 301 _)) -> do- liftIO $ STM.atomically $ STM.writeTVar tEarlyExit True- CIO.hPutStrLn IO.stderr $ mempty- <> "ERROR: No write access to archive uris: "- <> tshow (fmap toText [scopedArchiveFile, archiveFile])- <> " " <> displayAppError e+ when packageStorePathExists do+ let workingStorePackagePath = tempPath </> Z.packageDir pInfo+ liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath - _ -> return ()- Left msg -> CIO.hPutStrLn IO.stderr msg+ let rp2 = Z.relativePaths storePath pInfo - Left (appError :: AppError) -> do- CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError+ CIO.putStrLn $ "Creating " <> AWS.toText targetFile + let tempArchiveFile = tempPath </> archiveFileBasename++ metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]++ IO.createTar tempArchiveFile (rp2 <> [metas])+ & do OO.catch @ArchiveError \_ -> do+ CIO.hPutStrLn IO.stderr $ "Unable tar " <> tshow tempArchiveFile+ OO.throw WorkSkipped++ (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile maxRetries)+ & do OO.catch @AwsError \e -> do+ CIO.hPutStrLn IO.stderr $ mempty+ <> "ERROR: No write access to archive uris: "+ <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile])+ <> " " <> displayAwsError e+ OO.throw WorkFatal+ & do OO.catch @HttpError \e -> do+ CIO.hPutStrLn IO.stderr $ mempty+ <> "ERROR: No write access to archive uris: "+ <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile])+ <> " " <> displayHttpError e+ OO.throw WorkFatal+ & do OO.catch @NotImplemented \e -> do+ CIO.hPutStrLn IO.stderr $ mempty+ <> "Operation not implemented: "+ <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile])+ <> " " <> tshow e+ OO.throw WorkFatal+ & do OO.catch @UnsupportedUri \e -> do+ CIO.hPutStrLn IO.stderr $ mempty+ <> "Unsupported URI: "+ <> tshow (fmap AWS.toText [scopedArchiveFile, archiveFile])+ <> ": " <> tshow e+ OO.throw WorkFatal+ + return ()+ earlyExit <- STM.readTVarIO tEarlyExit when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error" +workLoop :: ()+ => MonadIO m+ => TVar Bool+ -> ExceptT (OO.Variant (WorkResult : e')) m ()+ -> ExceptT (OO.Variant e') m ()+workLoop tEarlyExit f = do+ earlyExit <- liftIO $ STM.readTVarIO tEarlyExit++ unless earlyExit do+ f & OO.catch @WorkResult \case+ WorkSkipped -> pure ()+ WorkFatal -> liftIO $ STM.atomically $ STM.writeTVar tEarlyExit True+ isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool isShareable storePath pkg = let packageSharePath = storePath </> Z.packageDir pkg </> "share"@@ -172,82 +226,84 @@ optsSyncToArchive :: Parser SyncToArchiveOptions optsSyncToArchive = SyncToArchiveOptions- <$> option (auto <|> text)- ( long "region"- <> metavar "AWS_REGION"- <> showDefault <> value Oregon- <> help "The AWS region in which to operate"+ <$> OA.option (OA.auto <|> text)+ ( OA.long "region"+ <> OA.metavar "AWS_REGION"+ <> OA.showDefault+ <> OA.value AWS.Oregon+ <> OA.help "The AWS region in which to operate" )- <*> option (maybeReader (toLocation . Text.pack))- ( long "archive-uri"- <> help "Archive URI to sync to"- <> metavar "S3_URI"- <> value (Local $ takeDirectory AS.cabalStoreDirectory </> "archive")+ <*> OA.option (OA.maybeReader (toLocation . Text.pack))+ ( OA.long "archive-uri"+ <> OA.help "Archive URI to sync to"+ <> OA.metavar "S3_URI"+ <> OA.value (Local $ takeDirectory AS.cabalStoreDirectory </> "archive") )- <*> strOption- ( long "path"- <> help "Path to cabal project directory. Defaults to \".\""- <> metavar "DIRECTORY"- <> value AS.path+ <*> OA.strOption+ ( OA.long "path"+ <> OA.help "Path to cabal project directory. Defaults to \".\""+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.path )- <*> strOption- ( long "build-path"- <> help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)- <> metavar "DIRECTORY"- <> value AS.buildPath+ <*> OA.strOption+ ( OA.long "build-path"+ <> OA.help ("Path to cabal build directory. Defaults to " <> show AS.buildPath)+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.buildPath )- <*> strOption- ( long "store-path"- <> help "Path to cabal store"- <> metavar "DIRECTORY"- <> value AS.cabalStoreDirectory+ <*> OA.strOption+ ( OA.long "store-path"+ <> OA.help "Path to cabal store"+ <> OA.metavar "DIRECTORY"+ <> OA.value AS.cabalStoreDirectory ) <*> optional- ( strOption- ( long "store-path-hash"- <> help "Store path hash (do not use)"- <> metavar "HASH"+ ( OA.strOption+ ( OA.long "store-path-hash"+ <> OA.help "Store path hash (do not use)"+ <> OA.metavar "HASH" ) )- <*> option auto- ( long "threads"- <> help "Number of concurrent threads"- <> metavar "NUM_THREADS"- <> value 4+ <*> OA.option OA.auto+ ( OA.long "threads"+ <> OA.help "Number of concurrent threads"+ <> OA.metavar "NUM_THREADS"+ <> OA.value 4 ) <*> optional- ( option autoText- ( long "aws-log-level"- <> help "AWS Log Level. One of (Error, Info, Debug, Trace)"- <> metavar "AWS_LOG_LEVEL"+ ( OA.option (OA.eitherReader (AWS.fromText . T.pack))+ ( OA.long "aws-log-level"+ <> OA.help "AWS Log Level. One of (Error, Info, Debug, Trace)"+ <> OA.metavar "AWS_LOG_LEVEL" ) ) <*> optional parseEndpoint- <*> option auto- ( long "max-retries"- <> help "Max retries for S3 requests"- <> metavar "NUM_RETRIES"- <> value 3+ <*> OA.option OA.auto+ ( OA.long "max-retries"+ <> OA.help "Max retries for S3 requests"+ <> OA.metavar "NUM_RETRIES"+ <> OA.value 3 )+ <*> optsPackageIds parseEndpoint :: Parser (ByteString, Int, Bool) parseEndpoint = (,,)- <$> option autoText- ( long "host-name-override"- <> help "Override the host name (default: s3.amazonaws.com)"- <> metavar "HOST_NAME"+ <$> OA.option (OA.eitherReader (AWS.fromText . T.pack))+ ( OA.long "host-name-override"+ <> OA.help "Override the host name (default: s3.amazonaws.com)"+ <> OA.metavar "HOST_NAME" )- <*> option auto- ( long "host-port-override"- <> help "Override the host port"- <> metavar "HOST_PORT"+ <*> OA.option OA.auto+ ( OA.long "host-port-override"+ <> OA.help "Override the host port"+ <> OA.metavar "HOST_PORT" )- <*> option auto- ( long "host-ssl-override"- <> help "Override the host SSL"- <> metavar "HOST_SSL"+ <*> OA.option OA.auto+ ( OA.long "host-ssl-override"+ <> OA.help "Override the host SSL"+ <> OA.metavar "HOST_SSL" ) cmdSyncToArchive :: Mod CommandFields (IO ())-cmdSyncToArchive = command "sync-to-archive" $ flip info idm $ runSyncToArchive <$> optsSyncToArchive+cmdSyncToArchive = OA.command "sync-to-archive" $ flip OA.info OA.idm $ runSyncToArchive <$> optsSyncToArchive
app/App/Commands/Version.hs view
@@ -1,21 +1,21 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} module App.Commands.Version- ( cmdVersion+ ( cmdVersion, ) where import App.Commands.Options.Parser (optsVersion)-import Data.List-import Options.Applicative hiding (columns)+import Options.Applicative (Mod, CommandFields) import qualified App.Commands.Options.Types as Z import qualified Data.Text as T import qualified Data.Version as V import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified Paths_cabal_cache as P+import qualified Options.Applicative as OA+import qualified Data.List as L {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -}@@ -23,10 +23,9 @@ runVersion :: Z.VersionOptions -> IO () runVersion _ = do let V.Version {..} = P.version-- let version = intercalate "." $ fmap show versionBranch+ let version = L.intercalate "." $ fmap show versionBranch CIO.putStrLn $ "cabal-cache " <> T.pack version cmdVersion :: Mod CommandFields (IO ())-cmdVersion = command "version" $ flip info idm $ runVersion <$> optsVersion+cmdVersion = OA.command "version" $ flip OA.info OA.idm $ runVersion <$> optsVersion
app/App/Static.hs view
@@ -1,13 +1,13 @@ {-# LANGUAGE ScopedTypeVariables #-} module App.Static- ( cabalStoreDirectory- , buildPath- , path+ ( cabalStoreDirectory,+ buildPath,+ path, ) where -import Control.Monad.Catch-import Control.Exception (IOException)+import Control.Monad.Catch (handle)+import Control.Exception (IOException) import Control.Monad.Identity (Identity(..)) import qualified App.Static.Base as S
app/App/Static/Base.hs view
@@ -1,4 +1,7 @@-module App.Static.Base where+module App.Static.Base+ ( homeDirectory,+ isPosix,+ ) where import qualified System.Directory as IO import qualified System.IO.Unsafe as IO
app/App/Static/Posix.hs view
@@ -1,4 +1,6 @@-module App.Static.Posix where+module App.Static.Posix+ ( cabalDirectory,+ ) where import HaskellWorks.CabalCache.Location ((</>))
app/App/Static/Windows.hs view
@@ -1,6 +1,9 @@-module App.Static.Windows where+module App.Static.Windows+ ( appDataDirectory,+ cabalDirectory,+ ) where -import Data.Maybe+import Data.Maybe (fromMaybe) import HaskellWorks.CabalCache.Location ((</>)) import qualified App.Static.Base as S
app/Main.hs view
@@ -1,10 +1,12 @@ module Main where -import App.Commands-import Control.Monad-import Options.Applicative+import App.Commands (commands)+import Control.Applicative ((<**>))+import Control.Monad (join) +import qualified Options.Applicative as OA+ main :: IO ()-main = join $ customExecParser- (prefs $ showHelpOnEmpty <> showHelpOnError)- (info (commands <**> helper) idm)+main = join $ OA.customExecParser+ (OA.prefs $ OA.showHelpOnEmpty <> OA.showHelpOnError)+ (OA.info (commands <**> OA.helper) OA.idm)
cabal-cache.cabal view
@@ -1,7 +1,7 @@ cabal-version: 2.2 name: cabal-cache-version: 1.0.5.5+version: 1.0.6.0 synopsis: CI Assistant for Haskell projects description: CI Assistant for Haskell projects. Implements package caching. homepage: https://github.com/haskell-works/cabal-cache@@ -9,7 +9,7 @@ license-file: LICENSE author: John Ky maintainer: newhoggy@gmail.com-copyright: John Ky 2019-2021+copyright: John Ky 2019-2023 category: Development extra-source-files: README.md @@ -23,9 +23,7 @@ common amazonka { build-depends: amazonka >= 1.6.1 && < 1.7 } common amazonka-core { build-depends: amazonka-core >= 1.6.1 && < 1.7 } common amazonka-s3 { build-depends: amazonka-s3 >= 1.6.1 && < 1.7 }-common antiope-core { build-depends: antiope-core >= 7.4.4 && < 8 }-common antiope-optparse-applicative { build-depends: antiope-optparse-applicative >= 7.4.4 && < 8 }-common antiope-s3 { build-depends: antiope-s3 >= 7.4.4 && < 8 }+common attoparsec { build-depends: attoparsec >= 0.14 && < 0.15 } common bytestring { build-depends: bytestring >= 0.10.8.2 && < 0.12 } common cabal-install-parsers { build-depends: cabal-install-parsers >= 0.4 && < 0.6 } common conduit-extra { build-depends: conduit-extra >= 1.3.1.1 && < 1.4 }@@ -36,7 +34,9 @@ common exceptions { build-depends: exceptions >= 0.10.1 && < 0.11 } common filepath { build-depends: filepath >= 1.3 && < 1.5 } common generic-lens { build-depends: generic-lens >= 1.1.0.0 && < 2.3 }+common Glob { build-depends: Glob >= 0.10.2 && < 0.11 } common hedgehog { build-depends: hedgehog >= 1.0 && < 1.3 }+common hedgehog-extras { build-depends: hedgehog-extras >= 0.3 && < 0.4 } 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 }@@ -46,6 +46,7 @@ common lens { build-depends: lens >= 4.17 && < 6 } common mtl { build-depends: mtl >= 2.2.2 && < 2.4 } common network-uri { build-depends: network-uri >= 2.6.4.1 && < 2.8 }+common oops { build-depends: oops >= 0.2 && < 0.3 } common optparse-applicative { build-depends: optparse-applicative >= 0.14 && < 0.18 } common process { build-depends: process >= 1.6.5.0 && < 1.7 } common raw-strings-qq { build-depends: raw-strings-qq >= 1.1 && < 2 }@@ -63,8 +64,14 @@ common unliftio { build-depends: unliftio >= 0.2.10 && < 0.3 } common zlib { build-depends: zlib >= 0.6.2 && < 0.7 } -common config+common project-config default-language: Haskell2010+ default-extensions: BlockArguments+ DataKinds+ FlexibleContexts+ LambdaCase+ MonoLocalBinds+ TypeOperators ghc-options: -Wall -Wincomplete-record-updates -Wincomplete-uni-patterns@@ -74,40 +81,44 @@ ghc-options: -Wunused-packages library- import: base, config- , aeson- , amazonka- , amazonka-core- , amazonka-s3- , antiope-core- , antiope-s3- , bytestring- , containers- , cryptonite- , deepseq- , directory- , exceptions- , filepath- , generic-lens- , http-client- , http-client-tls- , http-types- , lens- , mtl- , network-uri- , optparse-applicative- , process- , relation- , resourcet- , stm- , text- , topograph- , transformers+ import: base, project-config,+ aeson,+ amazonka,+ amazonka-core,+ amazonka-s3,+ attoparsec,+ bytestring,+ conduit-extra,+ containers,+ cryptonite,+ deepseq,+ directory,+ exceptions,+ filepath,+ generic-lens,+ http-client,+ http-client-tls,+ http-types,+ lens,+ mtl,+ network-uri,+ oops,+ optparse-applicative,+ process,+ relation,+ resourcet,+ stm,+ text,+ topograph,+ transformers, other-modules: Paths_cabal_cache autogen-modules: Paths_cabal_cache hs-source-dirs: src exposed-modules: HaskellWorks.CabalCache.AppError HaskellWorks.CabalCache.AWS.Env+ HaskellWorks.CabalCache.AWS.Error+ HaskellWorks.CabalCache.AWS.S3+ HaskellWorks.CabalCache.AWS.S3.URI HaskellWorks.CabalCache.Concurrent.DownloadQueue HaskellWorks.CabalCache.Concurrent.Fork HaskellWorks.CabalCache.Concurrent.Type@@ -117,7 +128,6 @@ HaskellWorks.CabalCache.GhcPkg HaskellWorks.CabalCache.Hash HaskellWorks.CabalCache.IO.Console- HaskellWorks.CabalCache.IO.Error HaskellWorks.CabalCache.IO.File HaskellWorks.CabalCache.IO.Lazy HaskellWorks.CabalCache.IO.Tar@@ -125,40 +135,44 @@ HaskellWorks.CabalCache.Metadata HaskellWorks.CabalCache.Options HaskellWorks.CabalCache.Show+ HaskellWorks.CabalCache.Store HaskellWorks.CabalCache.Text HaskellWorks.CabalCache.Topology HaskellWorks.CabalCache.Types+ HaskellWorks.CabalCache.URI HaskellWorks.CabalCache.Version executable cabal-cache- import: base, config- , aeson- , amazonka- , amazonka-core- , antiope-core- , antiope-optparse-applicative- , bytestring- , cabal-install-parsers- , containers- , directory- , exceptions- , filepath- , generic-lens- , http-types- , lens- , mtl- , optparse-applicative- , resourcet- , stm- , stringsearch- , temporary- , text- , unliftio+ import: base, project-config,+ aeson,+ amazonka,+ amazonka-core,+ bytestring,+ cabal-install-parsers,+ containers,+ directory,+ exceptions,+ filepath,+ generic-lens,+ lens,+ mtl,+ network-uri,+ oops,+ optparse-applicative,+ resourcet,+ stm,+ stringsearch,+ temporary,+ text,+ unliftio, build-depends: cabal-cache main-is: Main.hs hs-source-dirs: app other-modules: App.Commands App.Commands.Options.Parser+ App.Commands.Debug+ App.Commands.Debug.S3+ App.Commands.Debug.S3.Cp App.Commands.Options.Types App.Commands.Plan App.Commands.SyncFromArchive@@ -173,19 +187,26 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N test-suite cabal-cache-test- import: base, config- , aeson- , antiope-core- , bytestring- , filepath- , hedgehog- , hspec- , http-types- , hw-hspec-hedgehog- , lens- , network-uri- , raw-strings-qq- , text+ import: base, project-config,+ aeson,+ amazonka,+ bytestring,+ directory,+ exceptions,+ filepath,+ Glob,+ hedgehog-extras,+ hedgehog,+ hspec,+ http-types,+ hw-hspec-hedgehog,+ lens,+ mtl,+ network-uri,+ oops,+ raw-strings-qq,+ text,+ time type: exitcode-stdio-1.0 main-is: Spec.hs@@ -194,5 +215,7 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-tool-depends: hspec-discover:hspec-discover other-modules: HaskellWorks.CabalCache.AwsSpec+ HaskellWorks.CabalCache.IntegrationSpec HaskellWorks.CabalCache.LocationSpec HaskellWorks.CabalCache.QuerySpec+ Test.Base
src/HaskellWorks/CabalCache/AWS/Env.hs view
@@ -2,23 +2,62 @@ module HaskellWorks.CabalCache.AWS.Env ( awsLogger+ , mkEnv ) where -import Antiope.Env (LogLevel (..)) import Control.Concurrent (myThreadId)-import Control.Monad-import HaskellWorks.CabalCache.Show+import Control.Lens ((<&>), (.~))+import Control.Monad (when, forM_)+import Data.ByteString.Builder (toLazyByteString)+import HaskellWorks.CabalCache.Show (tshow)+import Network.HTTP.Client (HttpException (..), HttpExceptionContent (..)) +import qualified Data.ByteString as BS+import qualified Data.ByteString.Lazy as L import qualified Data.ByteString.Lazy as LBS import qualified Data.ByteString.Lazy.Char8 as LC8 import qualified Data.Text.Encoding as T import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified Network.AWS as AWS import qualified System.IO as IO -awsLogger :: Maybe LogLevel -> LogLevel -> LC8.ByteString -> IO ()+mkEnv :: AWS.Region -> (AWS.LogLevel -> LBS.ByteString -> IO ()) -> IO AWS.Env+mkEnv region lg = do+ lgr <- newAwsLogger lg+ AWS.newEnv AWS.Discover+ <&> AWS.envLogger .~ lgr+ <&> AWS.envRegion .~ region+ <&> AWS.envRetryCheck .~ retryPolicy 5++newAwsLogger :: Monad m => (AWS.LogLevel -> LBS.ByteString -> IO ()) -> m AWS.Logger+newAwsLogger lg = return $ \y b ->+ let lazyMsg = toLazyByteString b+ in case L.toStrict lazyMsg of+ msg | BS.isInfixOf "404 Not Found" msg -> lg AWS.Debug lazyMsg+ msg | BS.isInfixOf "304 Not Modified" msg -> lg AWS.Debug lazyMsg+ _ -> lg y lazyMsg++retryPolicy :: Int -> Int -> AWS.HttpException -> Bool+retryPolicy maxNum attempt ex = (attempt <= maxNum) && shouldRetry ex++shouldRetry :: AWS.HttpException -> Bool+shouldRetry ex = case ex of+ HttpExceptionRequest _ ctx -> case ctx of+ ResponseTimeout -> True+ ConnectionTimeout -> True+ ConnectionFailure _ -> True+ InvalidChunkHeaders -> True+ ConnectionClosed -> True+ InternalException _ -> True+ NoResponseDataReceived -> True+ ResponseBodyTooShort _ _ -> True+ _ -> False+ _ -> False++awsLogger :: Maybe AWS.LogLevel -> AWS.LogLevel -> LC8.ByteString -> IO () awsLogger maybeConfigLogLevel msgLogLevel message = forM_ maybeConfigLogLevel $ \configLogLevel ->- when (msgLogLevel <= configLogLevel) $ do+ when (msgLogLevel <= configLogLevel) do threadId <- myThreadId CIO.hPutStrLn IO.stderr $ "[" <> tshow msgLogLevel <> "] [tid: " <> tshow threadId <> "]" <> text where text = T.decodeUtf8 $ LBS.toStrict message
+ src/HaskellWorks/CabalCache/AWS/Error.hs view
@@ -0,0 +1,26 @@+{-# LANGUAGE ScopedTypeVariables #-}++module HaskellWorks.CabalCache.AWS.Error+ ( handleAwsError+ ) where++import Control.Monad.Catch (MonadCatch(..), MonadThrow(throwM))+import Control.Monad.Except (MonadError)+import HaskellWorks.CabalCache.AppError (AwsError(..))++import qualified Control.Monad.Oops as OO+import qualified Network.AWS as AWS+import qualified Network.HTTP.Types as HTTP++{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}++handleAwsError :: (MonadCatch m,+ MonadError (OO.Variant e) m,+ OO.CouldBeF e AwsError) =>+ m a -> m a+handleAwsError f = catch f $ \(e :: AWS.Error) ->+ case e of+ (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status _ _) _ _ _ _)) -> OO.throw $ AwsError s+ _ -> throwM e
+ src/HaskellWorks/CabalCache/AWS/S3.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module HaskellWorks.CabalCache.AWS.S3+ ( uriToS3Uri,+ headS3Uri,+ getS3Uri,+ copyS3Uri,+ putObject,++ ) where++import Control.Lens ((^.))+import Control.Monad (void, unless)+import Control.Monad.Catch (MonadCatch(..))+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.AWS (RsBody)+import Control.Monad.Trans.Except (ExceptT)+import Control.Monad.Trans.Resource (MonadResource, MonadUnliftIO, liftResourceT, runResourceT)+import Data.Conduit.Lazy (lazyConsume)+import HaskellWorks.CabalCache.AppError (AwsError(..))+import HaskellWorks.CabalCache.Error (CopyFailed(..), UnsupportedUri(..))+import HaskellWorks.CabalCache.Show (tshow)+import Network.AWS (MonadAWS, HasEnv)+import Network.AWS.Data (ToText(..), fromText)+import Network.URI (URI)++import qualified Control.Monad.Oops as OO+import qualified Data.ByteString.Lazy as LBS+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified HaskellWorks.CabalCache.AWS.Error as AWS+import qualified HaskellWorks.CabalCache.AWS.S3.URI as AWS+import qualified HaskellWorks.CabalCache.URI as URI+import qualified Network.AWS as AWS+import qualified Network.AWS.Data.Body as AWS+import qualified Network.AWS.S3 as AWS+import qualified System.IO as IO++-- | Access the response body as a lazy bytestring+lazyByteString :: MonadResource m => RsBody -> m LBS.ByteString+lazyByteString rsBody = liftResourceT $ LBS.fromChunks <$> lazyConsume (AWS._streamBody rsBody)++unsafeDownloadRequest :: (MonadAWS m, MonadResource m)+ => AWS.GetObject+ -> m LBS.ByteString+unsafeDownloadRequest req = do+ resp <- AWS.send req+ lazyByteString (resp ^. AWS.gorsBody)++unsafeDownload :: (MonadAWS m, MonadResource m)+ => AWS.BucketName+ -> AWS.ObjectKey+ -> m LBS.ByteString+unsafeDownload bucketName objectKey = unsafeDownloadRequest (AWS.getObject bucketName objectKey)++uriToS3Uri :: URI -> Either UnsupportedUri AWS.S3Uri+uriToS3Uri uri = case fromText @AWS.S3Uri (tshow uri) of+ Right s3Uri -> Right s3Uri+ Left msg -> Left $ UnsupportedUri uri $ "Unable to parse URI" <> tshow msg++headS3Uri :: ()+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` UnsupportedUri+ => MonadCatch m+ => MonadResource m+ => HasEnv r+ => r+ -> URI+ -> m AWS.HeadObjectResponse+headS3Uri envAws uri = do+ AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri)+ AWS.handleAwsError $ AWS.runAWS envAws $ AWS.send $ AWS.headObject b k++putObject :: ()+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` UnsupportedUri+ => MonadCatch m+ => MonadUnliftIO m+ => HasEnv r+ => AWS.ToBody a+ => r+ -> URI+ -> a+ -> ExceptT (OO.Variant e) m ()+putObject envAws uri lbs = do+ AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri)+ let req = AWS.toBody lbs+ let po = AWS.putObject b k req+ AWS.handleAwsError $ void $ OO.suspend runResourceT $ AWS.runAWS envAws $ AWS.send po++getS3Uri :: ()+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` UnsupportedUri+ => MonadCatch m+ => MonadResource m+ => HasEnv r+ => r+ -> URI+ -> m LBS.ByteString+getS3Uri envAws uri = do+ AWS.S3Uri b k <- OO.hoistEither $ uriToS3Uri (URI.reslashUri uri)+ AWS.handleAwsError $ AWS.runAWS envAws $ unsafeDownload b k++copyS3Uri :: ()+ => HasEnv r+ => MonadUnliftIO m+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` CopyFailed+ => e `OO.CouldBe` UnsupportedUri+ => r+ -> URI+ -> URI+ -> ExceptT (OO.Variant e) m ()+copyS3Uri envAws source target = do+ AWS.S3Uri sourceBucket sourceObjectKey <- OO.hoistEither $ uriToS3Uri (URI.reslashUri source)+ AWS.S3Uri targetBucket targetObjectKey <- OO.hoistEither $ uriToS3Uri (URI.reslashUri target)+ let copyObjectRequest = AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey+ response <- OO.suspend runResourceT (AWS.runAWS envAws $ AWS.send copyObjectRequest)+ let responseCode = response ^. AWS.corsResponseStatus+ unless (200 <= responseCode && responseCode < 300) do+ liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response+ OO.throw CopyFailed
+ src/HaskellWorks/CabalCache/AWS/S3/URI.hs view
@@ -0,0 +1,53 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module HaskellWorks.CabalCache.AWS.S3.URI+ ( S3Uri(..)+ ) where++import Control.Applicative (Alternative(many), optional)+import Control.DeepSeq (NFData)+import Control.Lens ((^.))+import Data.Generics.Product.Any (HasAny(the))+import Data.Text (Text)+import GHC.Generics (Generic)++import qualified Data.Aeson as J+import qualified Data.Aeson.Types as J+import qualified Data.Attoparsec.Combinator as DAC+import qualified Data.Attoparsec.Text as DAT+import qualified Data.Text as T+import qualified Network.AWS.Data as AWS+import qualified Network.AWS.S3 as AWS++data S3Uri = S3Uri+ { bucket :: AWS.BucketName+ , objectKey :: AWS.ObjectKey+ } deriving (Show, Eq, Ord, Generic, NFData)++instance AWS.FromText S3Uri where+ parser = do+ _ <- DAT.string "s3://"+ bn <- AWS.BucketName . T.pack <$> DAC.many1 (DAT.satisfy (\c -> c /= '/' && c /= ' '))+ _ <- optional (DAT.char '/')+ ok <- AWS.ObjectKey . T.pack <$> many DAT.anyChar+ DAT.endOfInput+ return (S3Uri bn ok)++instance AWS.ToText S3Uri where+ toText loc = toS3Uri (loc ^. the @"bucket") (loc ^. the @"objectKey")++instance J.ToJSON S3Uri where+ toJSON s3Uri = J.String (AWS.toText s3Uri)++instance J.FromJSON S3Uri where+ parseJSON v = case v of+ J.String s -> case AWS.fromText s of+ Right s3Uri -> return s3Uri+ Left msg -> J.typeMismatch ("S3Uri (" <> msg <> ")") v+ _ -> J.typeMismatch "S3Uri" v++toS3Uri :: AWS.BucketName -> AWS.ObjectKey -> Text+toS3Uri (AWS.BucketName b) (AWS.ObjectKey k) = "s3://" <> b <> "/" <> k
src/HaskellWorks/CabalCache/AppError.hs view
@@ -1,42 +1,53 @@-{-# LANGUAGE DeriveGeneric #-}-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings #-} module HaskellWorks.CabalCache.AppError- ( AppError(..)- , displayAppError- , appErrorStatus+ ( AwsError(..),+ HttpError(..),+ HasStatusCode(..),+ HasMaybeStatusCode(..),+ displayAwsError,+ displayHttpError, ) where -import Data.String import Data.Text (Text)-import GHC.Generics-import HaskellWorks.CabalCache.Show+import GHC.Generics (Generic)+import HaskellWorks.CabalCache.Show (tshow) -import qualified Data.Text as T+import qualified Network.HTTP.Client as HTTP import qualified Network.HTTP.Types as HTTP -data AppError- = AwsAppError- { status :: HTTP.Status- }- | HttpAppError- { status :: HTTP.Status- }- | RetriesFailedAppError- | NotFound- | GenericAppError Text+newtype AwsError = AwsError+ { status :: HTTP.Status+ } deriving (Eq, Show, Generic) -instance IsString AppError where- fromString = GenericAppError . T.pack+data HttpError = HttpError+ { reasponse :: HTTP.Request+ , content :: HTTP.HttpExceptionContent+ }+ deriving (Show, Generic) -displayAppError :: AppError -> Text-displayAppError (AwsAppError s) = tshow s-displayAppError (HttpAppError s) = tshow s-displayAppError RetriesFailedAppError = "Multiple retries failed"-displayAppError NotFound = "Not found"-displayAppError (GenericAppError msg) = msg+displayAwsError :: AwsError -> Text+displayAwsError (AwsError s) = tshow s -appErrorStatus :: AppError -> Maybe Int-appErrorStatus (AwsAppError (HTTP.Status statusCode _)) = Just statusCode-appErrorStatus _ = Nothing+displayHttpError :: HttpError -> Text+displayHttpError (HttpError _ s) = tshow s++class HasStatusCode a where+ statusCodeOf :: a -> Int++class HasMaybeStatusCode a where+ maybeStatusCodeOf :: a -> Maybe Int++instance HasStatusCode AwsError where+ statusCodeOf (AwsError (HTTP.Status c _)) = c++instance HasMaybeStatusCode AwsError where+ maybeStatusCodeOf (AwsError (HTTP.Status c _)) = Just c++instance HasMaybeStatusCode HttpError where+ maybeStatusCodeOf (HttpError _ content') = case content' of+ HTTP.StatusCodeException response _ -> let HTTP.Status c _ = HTTP.responseStatus response in Just c+ _ -> Nothing
src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs view
@@ -1,22 +1,27 @@-{-# LANGUAGE BlockArguments #-}-{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-} {-# LANGUAGE RecordWildCards #-}+{-# LANGUAGE TypeApplications #-} module HaskellWorks.CabalCache.Concurrent.DownloadQueue- ( DownloadStatus(..)- , createDownloadQueue- , runQueue+ ( DownloadStatus(..),+ createDownloadQueue,+ runQueue,+ succeed,+ fail, ) where import Control.Monad.Catch (MonadMask(..))-import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO(liftIO)) import Data.Function ((&)) import Data.Set ((\\)) import HaskellWorks.CabalCache.Show (tshow)+import Prelude hiding (fail) import qualified Control.Concurrent.STM as STM import qualified Control.Monad.Catch as CMC+import qualified Control.Monad.Oops as OO import qualified Data.Relation as R import qualified Data.Set as S import qualified HaskellWorks.CabalCache.Concurrent.Type as Z@@ -25,6 +30,18 @@ data DownloadStatus = DownloadSuccess | DownloadFailure deriving (Eq, Show) +succeed :: forall e a m. ()+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` DownloadStatus+ => m a+succeed = OO.throw DownloadSuccess++fail :: forall e a m. ()+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` DownloadStatus+ => m a+fail = OO.throw DownloadFailure+ createDownloadQueue :: [(Z.ProviderId, Z.ConsumerId)] -> STM.STM Z.DownloadQueue createDownloadQueue dependencies = do tDependencies <- STM.newTVar (R.fromList dependencies)@@ -66,7 +83,7 @@ runQueue :: (MonadIO m, MonadMask m) => Z.DownloadQueue -> (Z.PackageId -> m DownloadStatus) -> m () runQueue downloadQueue f = do- maybePackageId <- (liftIO $ STM.atomically $ takeReady downloadQueue)+ maybePackageId <- liftIO $ STM.atomically $ takeReady downloadQueue case maybePackageId of Just packageId -> do
src/HaskellWorks/CabalCache/Concurrent/Fork.hs view
@@ -1,7 +1,9 @@-module HaskellWorks.CabalCache.Concurrent.Fork where+module HaskellWorks.CabalCache.Concurrent.Fork+ ( forkThreadsWait,+ ) where import Control.Exception (finally)-import Control.Monad+import Control.Monad (when, forM_) import qualified Control.Concurrent as IO import qualified Control.Concurrent.STM as STM@@ -9,9 +11,9 @@ forkThreadsWait :: Int -> IO () -> IO () forkThreadsWait n f = do tDone <- STM.atomically $ STM.newTVar (0 :: Int)- forM_ [1 .. n] $ \_ -> IO.forkIO $ do+ forM_ [1 .. n] $ \_ -> IO.forkIO do f `finally` (STM.atomically $ STM.modifyTVar tDone (+1)) - STM.atomically $ do+ STM.atomically do done <- STM.readTVar tDone when (done < n) STM.retry
src/HaskellWorks/CabalCache/Concurrent/Type.hs view
@@ -2,13 +2,13 @@ {-# LANGUAGE DuplicateRecordFields #-} module HaskellWorks.CabalCache.Concurrent.Type- ( DownloadQueue(..)- , ConsumerId- , ProviderId- , PackageId+ ( DownloadQueue(..),+ ConsumerId,+ ProviderId,+ PackageId, ) where -import GHC.Generics+import GHC.Generics (Generic) import HaskellWorks.CabalCache.Types (PackageId) import qualified Control.Concurrent.STM as STM
src/HaskellWorks/CabalCache/Core.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE DuplicateRecordFields #-}@@ -8,39 +7,38 @@ {-# LANGUAGE TypeApplications #-} module HaskellWorks.CabalCache.Core- ( PackageInfo(..)- , Tagged(..)- , Presence(..)- , getPackages- , relativePaths- , loadPlan- , mkCompilerContext+ ( PackageInfo(..),+ Tagged(..),+ Presence(..),+ getPackages,+ relativePaths,+ loadPlan,+ mkCompilerContext, ) where import Control.DeepSeq (NFData)-import Control.Lens hiding ((<.>))-import Control.Monad.Catch-import Control.Monad.Except+import Control.Lens ((<&>), (&), (^.))+import Control.Monad.Catch (MonadCatch(..))+import Control.Monad.Except (ExceptT, forM, MonadIO(..), MonadError(..)) import Data.Aeson (eitherDecode) import Data.Bifunctor (first) import Data.Bool (bool) import Data.Generics.Product.Any (the)-import Data.String import Data.Text (Text) import GHC.Generics (Generic)-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Error-import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Error (DecodeError(..))+import HaskellWorks.CabalCache.Show (tshow) import System.FilePath ((<.>), (</>)) +import qualified Control.Monad.Oops as OO import qualified Data.ByteString.Lazy as LBS import qualified Data.List as L import qualified Data.Text as T import qualified HaskellWorks.CabalCache.IO.Tar as IO import qualified HaskellWorks.CabalCache.Types as Z import qualified System.Directory as IO-import qualified System.Process as IO import qualified System.Info as I+import qualified System.Process as IO {- HLINT ignore "Monoid law, left identity" -} @@ -56,17 +54,17 @@ } deriving (Eq, Show, Generic, NFData) data PackageInfo = PackageInfo- { compilerId :: Z.CompilerId- , packageId :: Z.PackageId- , packageDir :: PackageDir- , confPath :: Tagged ConfPath Presence- , libs :: [Library]+ { compilerId :: Z.CompilerId+ , packageId :: Z.PackageId+ , packageName :: Z.PackageName+ , packageDir :: PackageDir+ , confPath :: Tagged ConfPath Presence+ , libs :: [Library] } deriving (Show, Eq, Generic, NFData) (<||>) :: Monad m => ExceptT e m a -> ExceptT e m a -> ExceptT e m a (<||>) f g = f `catchError` const g - isPosix :: Bool isPosix = I.os /= "mingw32" {-# NOINLINE isPosix #-}@@ -82,24 +80,49 @@ withExeExt' :: Text -> Text withExeExt' = T.pack . withExeExt . T.unpack -findExecutable :: MonadIO m => Text -> ExceptT Text m Text+findExecutable :: ()+ => MonadIO f+ => MonadError (OO.Variant e) f+ => e `OO.CouldBe` Text+ => Text+ -> f Text findExecutable exe = fmap T.pack $- liftIO (IO.findExecutable (T.unpack exe)) >>= nothingToError (exe <> " is not in path")+ liftIO (IO.findExecutable (T.unpack exe)) >>= OO.hoistMaybe (exe <> " is not in path") -runGhcPkg :: (MonadIO m, MonadCatch m) => Text -> [Text] -> ExceptT Text m Text+runGhcPkg :: ()+ => MonadCatch m+ => MonadIO m+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` Text+ => Text+ -> [Text]+ -> m Text runGhcPkg cmdExe args = catch (liftIO $ T.pack <$> IO.readProcess (T.unpack cmdExe) (fmap T.unpack args) "") $- \(e :: IOError) -> throwError $ "Unable to run " <> cmdExe <> " " <> T.unwords args <> ": " <> tshow e+ \(e :: IOError) -> OO.throw $ "Unable to run " <> cmdExe <> " " <> T.unwords args <> ": " <> tshow e -verifyGhcPkgVersion :: (MonadIO m, MonadCatch m) => Text -> Text -> ExceptT Text m Text+verifyGhcPkgVersion :: ()+ => MonadError (OO.Variant e) m+ => MonadIO m+ => MonadCatch m+ => e `OO.CouldBe` Text+ => Text+ -> Text+ -> m Text verifyGhcPkgVersion version cmdExe = do stdout <- runGhcPkg cmdExe ["--version"] if T.isSuffixOf (" " <> version) (mconcat (L.take 1 (T.lines stdout))) then return cmdExe- else throwError $ cmdExe <> "has is not of version " <> version+ else OO.throw $ cmdExe <> " is not of version " <> version -mkCompilerContext :: (MonadIO m, MonadCatch m) => Z.PlanJson -> ExceptT Text m Z.CompilerContext+mkCompilerContext :: ()+ => MonadIO m+ => MonadCatch m+ => e `OO.CouldBe` Text+ => Z.PlanJson+ -> ExceptT (OO.Variant e) m Z.CompilerContext mkCompilerContext plan = do- compilerVersion <- T.stripPrefix "ghc-" (plan ^. the @"compilerId") & nothingToError "No compiler version available in plan"+ compilerVersion <- T.stripPrefix "ghc-" (plan ^. the @"compilerId")+ & OO.hoistMaybe @Text "No compiler version available in plan" let versionedGhcPkgCmd = "ghc-pkg-" <> compilerVersion ghcPkgCmdPath <- (findExecutable (withExeExt' versionedGhcPkgCmd) >>= verifyGhcPkgVersion compilerVersion)@@ -122,9 +145,16 @@ packages :: [Z.Package] packages = planJson ^. the @"installPlan" -loadPlan :: FilePath -> IO (Either AppError Z.PlanJson)-loadPlan resolvedBuildPath =- first fromString . eitherDecode <$> LBS.readFile (resolvedBuildPath </> "cache" </> "plan.json")+loadPlan :: ()+ => MonadIO m+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` DecodeError+ => FilePath+ -> m Z.PlanJson+loadPlan resolvedBuildPath = do+ lbs <- liftIO (LBS.readFile (resolvedBuildPath </> "cache" </> "plan.json"))+ a <- OO.hoistEither $ first (DecodeError . T.pack) (eitherDecode lbs)+ pure do a :: Z.PlanJson ------------------------------------------------------------------------------- mkPackageInfo :: FilePath -> Z.CompilerId -> Z.Package -> IO PackageInfo@@ -141,6 +171,7 @@ return PackageInfo { compilerId = cid , packageId = pid+ , packageName = pkg ^. the @"name" , packageDir = T.unpack cid </> T.unpack pid , confPath = Tagged relativeConfPath (bool Absent Present absoluteConfPathExists) , libs = libFiles
src/HaskellWorks/CabalCache/Data/List.hs view
@@ -1,10 +1,16 @@ module HaskellWorks.CabalCache.Data.List- ( tuple2ToDL- , tuple2ToList+ ( tuple2ToDL,+ tuple2ToList,+ tuple2ToNel, ) where +import Data.List.NonEmpty (NonEmpty(..))+ tuple2ToDL :: (a, a) -> [a] -> [a] tuple2ToDL (a, b) = (a:) . (b:) tuple2ToList :: (a, a) -> [a] tuple2ToList ab = tuple2ToDL ab []++tuple2ToNel :: (a, a) -> NonEmpty a+tuple2ToNel (a, b) = a :| [b]
src/HaskellWorks/CabalCache/Error.hs view
@@ -1,9 +1,37 @@+{-# LANGUAGE DeriveGeneric #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE ScopedTypeVariables #-}+ module HaskellWorks.CabalCache.Error- ( nothingToError+ ( DecodeError(DecodeError),+ ExitFailure(ExitFailure),+ CopyFailed(CopyFailed),+ InvalidUrl(InvalidUrl),+ NotFound(NotFound),+ NotImplemented(NotImplemented),+ UnsupportedUri(UnsupportedUri), ) where -import Control.Monad.Except+import Data.Text (Text)+import GHC.Generics (Generic)+import Network.URI (URI) -nothingToError :: MonadError e m => e -> Maybe a -> m a-nothingToError _ (Just a) = return a-nothingToError e Nothing = throwError e+data DecodeError = DecodeError Text deriving (Eq, Show, Generic)++data ExitFailure = ExitFailure deriving (Eq, Show, Generic)++data CopyFailed = CopyFailed deriving (Eq, Show, Generic)++data InvalidUrl = InvalidUrl+ { url :: Text+ , reason :: Text+ } deriving (Eq, Show, Generic)++data NotFound = NotFound deriving (Eq, Show, Generic)++data NotImplemented = NotImplemented Text deriving (Eq, Show, Generic)++data UnsupportedUri = UnsupportedUri+ { uri :: URI+ , reason :: Text+ } deriving (Eq, Show, Generic)
src/HaskellWorks/CabalCache/GhcPkg.hs view
@@ -1,10 +1,17 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeApplications #-} -module HaskellWorks.CabalCache.GhcPkg where+module HaskellWorks.CabalCache.GhcPkg+ ( system,+ runGhcPkg,+ testAvailability,+ recache,+ init,+ ) where -import Control.Lens-import Data.Generics.Product.Any+import Prelude hiding (init)++import Control.Lens ((^.))+import Data.Generics.Product.Any (HasAny(the)) import System.Exit (ExitCode (..), exitWith) import System.Process (waitForProcess)
src/HaskellWorks/CabalCache/IO/Console.hs view
@@ -1,8 +1,8 @@ module HaskellWorks.CabalCache.IO.Console- ( putStrLn- , print- , hPutStrLn- , hPrint+ ( putStrLn,+ print,+ hPutStrLn,+ hPrint, ) where import Control.Exception (bracket_)
− src/HaskellWorks/CabalCache/IO/Error.hs
@@ -1,54 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.CabalCache.IO.Error- ( exceptFatal- , exceptWarn- , maybeToExcept- , maybeToExceptM- , catchErrno- ) where--import Control.Monad.Except-import Foreign.C.Error (Errno, getErrno)-import HaskellWorks.CabalCache.AppError-import System.IO.Error (catchIOError)--import qualified HaskellWorks.CabalCache.IO.Console as CIO-import qualified System.Exit as IO-import qualified System.IO as IO--exceptFatal :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a-exceptFatal f = catchError f handler- where handler e = do- liftIO . CIO.hPutStrLn IO.stderr $ "Fatal Error: " <> displayAppError e- void $ liftIO IO.exitFailure- throwError e--exceptWarn :: MonadIO m => ExceptT AppError m a -> ExceptT AppError m a-exceptWarn f = catchError f handler- where handler e = do- liftIO . CIO.hPutStrLn IO.stderr $ "Warning: " <> displayAppError e- throwError e--maybeToExcept :: Monad m => AppError -> Maybe a -> ExceptT AppError m a-maybeToExcept message = maybe (throwError message) pure--maybeToExceptM :: Monad m => AppError -> m (Maybe a) -> ExceptT AppError m a-maybeToExceptM message = ExceptT . fmap (maybe (Left message) Right)----- |Carries out an action, then checks if there is an IOException and--- a specific errno. If so, then it carries out another action, otherwise--- it rethrows the error.-catchErrno :: [Errno] -- ^ errno to catch- -> IO a -- ^ action to try, which can raise an IOException- -> IO a -- ^ action to carry out in case of an IOException and- -- if errno matches- -> IO a-catchErrno en a1 a2 =- catchIOError a1 $ \e -> do- errno <- getErrno- if errno `elem` en- then a2- else ioError e
src/HaskellWorks/CabalCache/IO/File.hs view
@@ -1,26 +1,34 @@ {-# LANGUAGE OverloadedStrings #-} module HaskellWorks.CabalCache.IO.File- ( copyDirectoryRecursive- , listMaybeDirectory+ ( copyDirectoryRecursive,+ listMaybeDirectory, ) where -import Control.Monad.Except+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO(..)) +import qualified Control.Monad.Oops as OO import qualified Data.Text as T import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified System.Directory as IO import qualified System.Exit as IO import qualified System.Process as IO -copyDirectoryRecursive :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()+copyDirectoryRecursive :: ()+ => MonadIO m+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` [Char]+ => String+ -> String+ -> m () copyDirectoryRecursive source target = do CIO.putStrLn $ "Copying recursively from " <> T.pack source <> " to " <> T.pack target process <- liftIO $ IO.spawnProcess "cp" ["-r", source, target] exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return ()- IO.ExitFailure n -> throwError $ "cp exited with " <> show n+ IO.ExitFailure n -> OO.throw $ "cp exited with " <> show n listMaybeDirectory :: MonadIO m => FilePath -> m [FilePath] listMaybeDirectory filepath = do
src/HaskellWorks/CabalCache/IO/Lazy.hs view
@@ -1,108 +1,120 @@-{-# LANGUAGE DataKinds #-}-{-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections #-} {-# LANGUAGE TypeApplications #-} +{-# OPTIONS_GHC -Wno-incomplete-patterns #-}+ module HaskellWorks.CabalCache.IO.Lazy- ( readResource- , readFirstAvailableResource- , resourceExists- , firstExistingResource- , headS3Uri- , writeResource- , createLocalDirectoryIfMissing- , linkOrCopyResource- , readHttpUri- , removePathRecursive+ ( readResource,+ readFirstAvailableResource,+ resourceExists,+ writeResource,+ createLocalDirectoryIfMissing,+ linkOrCopyResource,+ readHttpUri,+ removePathRecursive,+ retryOnE, ) where -import Antiope.Core-import Antiope.S3.Lazy (S3Uri)-import Control.Lens-import Control.Monad.Catch-import Control.Monad.Except-import Control.Monad.Trans.Except-import Control.Monad.Trans.Resource-import Data.Either (isRight)-import Data.Generics.Product.Any-import Data.Maybe (fromMaybe)-import HaskellWorks.CabalCache.AppError+import Control.Lens ((&), (^.))+import Control.Monad (unless)+import Control.Monad.Catch (MonadCatch(..))+import Control.Monad.Except (ExceptT, MonadError)+import Control.Monad.IO.Class (MonadIO(..))+import Control.Monad.Trans.Resource (MonadResource, runResourceT, MonadUnliftIO)+import Data.Functor.Identity (Identity(..))+import Data.Generics.Product.Any (HasAny(the))+import Data.List.NonEmpty (NonEmpty ((:|)))+import HaskellWorks.CabalCache.AppError (AwsError(..), HttpError(..), statusCodeOf)+import HaskellWorks.CabalCache.Error (CopyFailed(..), InvalidUrl(..), NotFound(..), NotImplemented(..), UnsupportedUri(..)) import HaskellWorks.CabalCache.Location (Location (..))-import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Show (tshow)+import Network.AWS (HasEnv) import Network.URI (URI)-import System.Environment (lookupEnv)-import Text.Read (readMaybe) -import qualified Antiope.S3.Lazy as AWS-import qualified Control.Concurrent as IO-import qualified Data.ByteString.Lazy as LBS-import qualified Data.Text as T-import qualified HaskellWorks.CabalCache.IO.Console as CIO-import qualified Network.AWS as AWS-import qualified Network.AWS.S3.CopyObject as AWS-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-import qualified System.IO.Error as IO+import qualified Control.Concurrent as IO+import qualified Control.Monad.Oops as OO+import qualified Data.ByteString.Lazy as LBS+import qualified Data.List.NonEmpty as NEL+import qualified Data.Text as T+import qualified HaskellWorks.CabalCache.AWS.S3 as S3+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified HaskellWorks.CabalCache.URI as URI+import qualified Network.HTTP.Client 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+import qualified System.IO.Error as IO + {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant bracket" -} -handleAwsError :: MonadCatch m => m a -> m (Either AppError a)-handleAwsError f = catch (Right <$> f) $ \(e :: AWS.Error) ->- case e of- (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status 301 _) _ _ _ _)) -> return (Left (AwsAppError s))- (AWS.ServiceError (AWS.ServiceError' _ s@(HTTP.Status i _) _ _ _ _))- | i `elem` retryableHTTPStatuses -> return (Left (AwsAppError s))- _ -> throwM e--handleHttpError :: (MonadCatch m, MonadIO m) => m a -> ExceptT AppError m a-handleHttpError f = catch (lift f) $ \(e :: HTTP.HttpException) ->+handleHttpError :: ()+ => MonadError (OO.Variant e) m+ => MonadCatch m+ => e `OO.CouldBe` HttpError+ => e `OO.CouldBe` InvalidUrl+ => MonadIO m+ => Monad m+ => m a+ -> m a+handleHttpError f = catch f $ \(e :: HTTP.HttpException) -> case e of- (HTTP.HttpExceptionRequest _ e') -> case e' of- HTTP.StatusCodeException resp _ -> throwE (HttpAppError (resp & HTTP.responseStatus))- _ -> throwE (GenericAppError (tshow e'))- _ -> liftIO $ throwM e--getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> ExceptT AppError m LBS.ByteString-getS3Uri envAws uri = do- AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri)- ExceptT . handleAwsError $ runAws envAws $ AWS.unsafeDownload b k--uriToS3Uri :: URI -> Either AppError S3Uri-uriToS3Uri uri = case fromText @S3Uri (tshow uri) of- Right s3Uri -> Right s3Uri- Left msg -> Left . GenericAppError $ "Unable to parse URI" <> tshow msg+ HTTP.HttpExceptionRequest request content' -> OO.throw $ HttpError request content'+ HTTP.InvalidUrlException url' reason' -> OO.throw $ InvalidUrl (tshow url') (tshow reason') -readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Int -> Location -> m (Either AppError LBS.ByteString)+readResource :: ()+ => HasEnv r+ => MonadResource m+ => MonadCatch m+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` UnsupportedUri+ => e `OO.CouldBe` HttpError+ => e `OO.CouldBe` InvalidUrl+ => e `OO.CouldBe` NotFound+ => r+ -> Int+ -> Location+ -> ExceptT (OO.Variant e) m LBS.ByteString readResource envAws maxRetries = \case- Local path -> liftIO $ do- fileExists <- IO.doesFileExist path+ Local path -> do+ fileExists <- liftIO $ IO.doesFileExist path if fileExists- then Right <$> LBS.readFile path- else pure (Left NotFound)- Uri uri -> runExceptT $ retryS3 maxRetries $ case uri ^. the @"uriScheme" of- "s3:" -> getS3Uri envAws (reslashUri uri)- "http:" -> readHttpUri (reslashUri uri)- "https:" -> readHttpUri (reslashUri uri)- scheme -> throwE (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme))+ then liftIO $ LBS.readFile path+ else OO.throw NotFound+ Uri uri -> retryS3 maxRetries $ case uri ^. the @"uriScheme" of+ "s3:" -> S3.getS3Uri envAws (URI.reslashUri uri)+ "http:" -> readHttpUri (URI.reslashUri uri)+ "https:" -> readHttpUri (URI.reslashUri uri)+ scheme -> OO.throw $ UnsupportedUri uri $ "Unrecognised uri scheme: " <> T.pack scheme -readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> Int -> m (Either AppError (LBS.ByteString, Location))-readFirstAvailableResource _ [] _ = return (Left (GenericAppError "No resources specified in read"))-readFirstAvailableResource envAws (a:as) maxRetries = do- result <- readResource envAws maxRetries a- case result of- Right lbs -> return $ Right (lbs, a)- Left e -> if null as- then return $ Left e- else readFirstAvailableResource envAws as maxRetries+readFirstAvailableResource :: ()+ => HasEnv t+ => MonadResource m+ => MonadCatch m+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` HttpError+ => e `OO.CouldBe` InvalidUrl+ => e `OO.CouldBe` NotFound+ => e `OO.CouldBe` UnsupportedUri+ => t+ -> NonEmpty Location+ -> Int+ -> ExceptT (OO.Variant e) m (LBS.ByteString, Location)+readFirstAvailableResource envAws (a:|as) maxRetries = do+ (, a) <$> readResource envAws maxRetries a+ & do OO.catch @AwsError \e -> do+ case NEL.nonEmpty as of+ Nothing -> OO.throwF (Identity e)+ Just nas -> readFirstAvailableResource envAws nas maxRetries+ & do OO.catch @HttpError \e -> do+ case NEL.nonEmpty as of+ Nothing -> OO.throwF (Identity e)+ Just nas -> readFirstAvailableResource envAws nas maxRetries safePathIsSymbolLink :: FilePath -> IO Bool safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler@@ -111,9 +123,17 @@ then return False else return True -resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool+resourceExists :: ()+ => MonadUnliftIO m+ => MonadCatch m+ => HasEnv r+ => e `OO.CouldBe` InvalidUrl+ => e `OO.CouldBe` UnsupportedUri+ => r+ -> Location+ -> ExceptT (OO.Variant e) m Bool resourceExists envAws = \case- Local path -> do+ Local path -> do fileExists <- liftIO $ IO.doesFileExist path if fileExists then return True@@ -124,44 +144,37 @@ target <- liftIO $ IO.getSymbolicLinkTarget path resourceExists envAws (Local target) else return False- Uri uri -> case uri ^. the @"uriScheme" of- "s3:" -> isRight <$> runResourceT (headS3Uri envAws (reslashUri uri))- "http:" -> isRight <$> runExceptT (headHttpUri (reslashUri uri))+ Uri uri -> case uri ^. the @"uriScheme" of+ "s3:" -> do+ OO.suspend runResourceT $ (True <$ S3.headS3Uri envAws (URI.reslashUri uri))+ & OO.catch @AwsError (pure . const False)+ & OO.catch @HttpError (pure . const False)+ "http:" -> do+ (True <$ headHttpUri (URI.reslashUri uri))+ & OO.catch @AwsError (pure . const False)+ & OO.catch @HttpError (pure . const False) _scheme -> return False -firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)-firstExistingResource _ [] = return Nothing-firstExistingResource envAws (a:as) = do- exists <- resourceExists envAws a- if exists- then return (Just a)- else firstExistingResource envAws as--headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> m (Either AppError AWS.HeadObjectResponse)-headS3Uri envAws uri = runExceptT $ do- AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri)- ExceptT . handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k--uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> LBS.ByteString -> ExceptT AppError m ()-uploadToS3 envAws uri lbs = do- AWS.S3Uri b k <- except $ uriToS3Uri (reslashUri uri)- let req = AWS.toBody lbs- let po = AWS.putObject b k req- ExceptT . handleAwsError $ void $ runResAws envAws $ AWS.send po--reslashUri :: URI -> URI-reslashUri uri = uri & the @"uriPath" %~ fmap reslashChar- where reslashChar :: Char -> Char- reslashChar '\\' = '/'- reslashChar c = c--writeResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Int -> LBS.ByteString -> ExceptT AppError m ()-writeResource envAws loc maxRetries lbs = ExceptT $ case loc of- Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ())- Uri uri -> runExceptT $ retryS3 maxRetries $ case uri ^. the @"uriScheme" of- "s3:" -> uploadToS3 envAws (reslashUri uri) lbs- "http:" -> throwE (GenericAppError "HTTP PUT method not supported")- scheme -> throwE (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme))+writeResource :: ()+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` HttpError+ => e `OO.CouldBe` NotImplemented+ => e `OO.CouldBe` UnsupportedUri+ => MonadIO m+ => MonadCatch m+ => MonadUnliftIO m+ => HasEnv r+ => r+ -> Location+ -> Int+ -> LBS.ByteString+ -> ExceptT (OO.Variant e) m ()+writeResource envAws loc maxRetries lbs = case loc of+ Local path -> liftIO (LBS.writeFile path lbs) >> return ()+ Uri uri' -> retryS3 maxRetries $ case uri' ^. the @"uriScheme" of+ "s3:" -> S3.putObject envAws (URI.reslashUri uri') lbs+ "http:" -> OO.throw $ NotImplemented "HTTP PUT method not supported"+ scheme -> OO.throw $ UnsupportedUri uri' $ "Unrecognised uri scheme: " <> T.pack scheme createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case@@ -171,44 +184,57 @@ "http:" -> return () _scheme -> return () -copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> URI -> ExceptT AppError m ()-copyS3Uri envAws source target = do- AWS.S3Uri sourceBucket sourceObjectKey <- except $ uriToS3Uri (reslashUri source)- AWS.S3Uri targetBucket targetObjectKey <- except $ uriToS3Uri (reslashUri target)- ExceptT $ do- responseResult <- runResourceT $- handleAwsError $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)- case responseResult of- Right response -> do- let responseCode = response ^. AWS.corsResponseStatus- if 200 <= responseCode && responseCode < 300- then return (Right ())- else do- liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response- return (Left RetriesFailedAppError)- Left msg -> return (Left msg)+retryOnE :: forall e e' m a. ()+ => Monad m+ => Int+ -> ExceptT (OO.Variant e') m a+ -> ExceptT (OO.Variant (e : e')) m a+ -> ExceptT (OO.Variant e') m a+retryOnE n g f = f+ & do OO.catch @e \_ -> if n > 0+ then retryOnE (n - 1) g f+ else g -retryWhen :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m a -> ExceptT e m a-retryWhen p n f = catchError f $ \exception -> if n > 0- then do- if (p exception)- then do- liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)"- liftIO $ IO.threadDelay 1000000- retryWhen p (n - 1) f- else throwError exception- else throwError exception+retryWhen :: ()+ => MonadIO m+ => Show x+ => e `OO.CouldBe` x+ => (x -> Bool)+ -> Int+ -> ExceptT (OO.Variant e) m a+ -> ExceptT (OO.Variant e) m a+retryWhen p n f = f+ & do OO.snatch \exception -> do+ if n > 0+ then do+ if p exception+ then do+ liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> tshow exception <> " (retrying)"+ liftIO $ IO.threadDelay 1000000+ retryWhen p (n - 1) f+ else OO.throw exception+ else OO.throw exception -retryUnless :: (Show e, MonadIO m) => (e -> Bool) -> Int -> ExceptT e m a -> ExceptT e m a+retryUnless :: forall x e m a. ()+ => MonadIO m+ => Show x+ => e `OO.CouldBe` x+ => (x -> Bool)+ -> Int+ -> ExceptT (OO.Variant e) m a+ -> ExceptT (OO.Variant e) m a retryUnless p = retryWhen (not . p) -retryS3 :: MonadIO m => Int -> ExceptT AppError m a -> ExceptT AppError m a+retryS3 :: ()+ => MonadIO m+ => e `OO.CouldBe` AwsError+ => Int+ -> ExceptT (OO.Variant e) m a+ -> ExceptT (OO.Variant e) m a retryS3 maxRetries a = do retryWhen retryPredicate maxRetries a- where- retryPredicate appe = case appErrorStatus appe of- Just i -> i `elem` retryableHTTPStatuses- Nothing -> False+ where retryPredicate :: AwsError -> Bool+ retryPredicate e = statusCodeOf e `elem` retryableHTTPStatuses -- https://docs.aws.amazon.com/AmazonS3/latest/API/ErrorResponses.html#ErrorCodeList -- https://stackoverflow.com/a/51770411/2976251@@ -216,42 +242,64 @@ retryableHTTPStatuses :: [Int] retryableHTTPStatuses = [408, 409, 425, 426, 502, 503, 504] -linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m ()+linkOrCopyResource :: ()+ => HasEnv r+ => MonadUnliftIO m+ => e `OO.CouldBe` AwsError+ => e `OO.CouldBe` CopyFailed+ => e `OO.CouldBe` NotImplemented+ => e `OO.CouldBe` UnsupportedUri+ => r+ -> Location+ -> Location+ -> ExceptT (OO.Variant e) m () linkOrCopyResource envAws source target = case source of Local sourcePath -> case target of Local targetPath -> do liftIO $ IO.createDirectoryIfMissing True (FP.takeDirectory targetPath) targetPathExists <- liftIO $ IO.doesFileExist targetPath unless targetPathExists $ liftIO $ IO.createFileLink sourcePath targetPath- Uri _ -> throwError "Can't copy between different file backends"+ Uri _ -> OO.throw $ NotImplemented "Can't copy between different file backends" Uri sourceUri -> case target of- Local _targetPath -> throwError "Can't copy between different file backends"+ Local _targetPath -> OO.throw $ NotImplemented "Can't copy between different file backends" Uri targetUri -> case (sourceUri ^. the @"uriScheme", targetUri ^. the @"uriScheme") of- ("s3:", "s3:") -> retryUnless ((== Just 301) . appErrorStatus) 3 (copyS3Uri envAws (reslashUri sourceUri) (reslashUri targetUri))- ("http:", "http:") -> throwError "Link and copy unsupported for http backend"- (sourceScheme, targetScheme) -> throwError $ GenericAppError $ "Unsupported backend combination: " <> T.pack sourceScheme <> " to " <> T.pack targetScheme+ ("s3:", "s3:") -> retryUnless @AwsError ((== 301) . statusCodeOf) 3 (S3.copyS3Uri envAws (URI.reslashUri sourceUri) (URI.reslashUri targetUri))+ ("http:", "http:") -> OO.throw $ NotImplemented "Link and copy unsupported for http backend"+ (sourceScheme, targetScheme) -> OO.throw $ NotImplemented $ "Unsupported backend combination: " <> T.pack sourceScheme <> " to " <> T.pack targetScheme -readHttpUri :: (MonadIO m, MonadCatch m) => URI -> ExceptT AppError m LBS.ByteString-readHttpUri httpUri = handleHttpError $ do+readHttpUri :: ()+ => MonadError (OO.Variant e) m+ => MonadCatch m+ => e `OO.CouldBe` HttpError+ => e `OO.CouldBe` InvalidUrl+ => MonadIO m+ => URI+ -> m LBS.ByteString+readHttpUri httpUri = handleHttpError do manager <- liftIO $ HTTP.newManager HTTPS.tlsManagerSettings- request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (reslashUri httpUri)))+ request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (URI.reslashUri httpUri))) response <- liftIO $ HTTP.httpLbs request manager return $ HTTP.responseBody response -headHttpUri :: (MonadIO m, MonadCatch m) => URI -> ExceptT AppError m LBS.ByteString-headHttpUri httpUri = handleHttpError $ do+headHttpUri :: ()+ => MonadError (OO.Variant e) m+ => MonadCatch m+ => e `OO.CouldBe` HttpError+ => e `OO.CouldBe` InvalidUrl+ => MonadIO m+ => URI+ -> m LBS.ByteString+headHttpUri httpUri = handleHttpError do manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings- request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> tshow (reslashUri httpUri)))+ request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> tshow (URI.reslashUri httpUri))) response <- liftIO $ HTTP.httpLbs request manager return $ HTTP.responseBody response -removePathRecursive :: (MonadIO m, MonadCatch m) => FilePath -> m (Either AppError ())-removePathRecursive pkgStorePath = catch action handler- where action :: MonadIO m => m (Either AppError ())- action = Right <$> liftIO (IO.removeDirectoryRecursive pkgStorePath)- handler :: MonadIO m => IOError -> m (Either AppError ())- handler e = do- CIO.hPutStrLn IO.stderr $ "Warning: Caught " <> tshow e- return (Left (GenericAppError (tshow e)))+removePathRecursive :: ()+ => MonadCatch m+ => MonadIO m+ => [Char]+ -> ExceptT (OO.Variant e) m ()+removePathRecursive pkgStorePath = liftIO (IO.removeDirectoryRecursive pkgStorePath)
src/HaskellWorks/CabalCache/IO/Tar.hs view
@@ -1,47 +1,64 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module HaskellWorks.CabalCache.IO.Tar- ( TarGroup(..)- , createTar- , extractTar+ ( ArchiveError(..),+ TarGroup(..),+ createTar,+ extractTar, ) where import Control.DeepSeq (NFData)-import Control.Lens-import Control.Monad.Except-import Data.Generics.Product.Any-import GHC.Generics-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Show+import Control.Lens ((^.))+import Control.Monad.Except (MonadError)+import Control.Monad.IO.Class (MonadIO(..))+import Data.Generics.Product.Any (HasAny(the))+import Data.Text (Text)+import GHC.Generics (Generic)+import HaskellWorks.CabalCache.Show (tshow) -import qualified System.Exit as IO-import qualified System.Process as IO+import qualified Control.Monad.Oops as OO+import qualified System.Exit as IO+import qualified System.Process as IO +data ArchiveError = ArchiveError Text deriving (Eq, Show, Generic)+ data TarGroup = TarGroup { basePath :: FilePath , entryPaths :: [FilePath] } deriving (Show, Eq, Generic, NFData) -createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT AppError m ()+createTar :: ()+ => MonadIO m+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` ArchiveError+ => Foldable t+ => [Char]+ -> t TarGroup+ -> m () createTar tarFile groups = do let args = ["-zcf", tarFile] <> foldMap tarGroupToArgs groups process <- liftIO $ IO.spawnProcess "tar" args exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return ()- IO.ExitFailure n -> throwError $ GenericAppError $ "Failed to create tar. Exit code: " <> tshow n+ IO.ExitFailure n -> OO.throw $ ArchiveError $ "Failed to create tar. Exit code: " <> tshow n -extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT AppError m ()+extractTar :: ()+ => MonadIO m+ => MonadError (OO.Variant e) m+ => e `OO.CouldBe` ArchiveError+ => String+ -> String+ -> m () extractTar tarFile targetPath = do process <- liftIO $ IO.spawnProcess "tar" ["-C", targetPath, "-zxf", tarFile] exitCode <- liftIO $ IO.waitForProcess process case exitCode of IO.ExitSuccess -> return ()- IO.ExitFailure n -> throwError $ GenericAppError $ "Failed to extract tar. Exit code: " <> tshow n+ IO.ExitFailure n -> OO.throw $ ArchiveError $ "Failed to extract tar. Exit code: " <> tshow n tarGroupToArgs :: TarGroup -> [String] tarGroupToArgs tarGroup = ["-C", tarGroup ^. the @"basePath"] <> tarGroup ^. the @"entryPaths"
src/HaskellWorks/CabalCache/Location.hs view
@@ -1,4 +1,3 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf #-}@@ -13,19 +12,20 @@ ) where -import Antiope.Core (ToText (..))-import Antiope.S3 (ObjectKey (..), S3Uri (..))-import Control.Lens hiding ((<.>))-import Data.Generics.Product.Any-import Data.Maybe (fromMaybe)-import Data.Text (Text)-import GHC.Generics (Generic)-import HaskellWorks.CabalCache.Show-import Network.URI (URI)+import Control.Lens ((&), (%~))+import Data.Generics.Product.Any (HasAny(the))+import Data.Maybe (fromMaybe)+import Data.Text (Text)+import GHC.Generics (Generic)+import HaskellWorks.CabalCache.AWS.S3.URI (S3Uri (..))+import HaskellWorks.CabalCache.Show (tshow)+import Network.URI (URI) -import qualified Data.Text as T-import qualified Network.URI as URI-import qualified System.FilePath as FP+import qualified Data.Text as T+import qualified Network.AWS.Data as AWS+import qualified Network.AWS.S3 as AWS+import qualified Network.URI as URI+import qualified System.FilePath as FP class IsPath a s | a -> s where (</>) :: a -> s -> a@@ -39,7 +39,7 @@ | Local FilePath deriving (Show, Eq, Generic) -instance ToText Location where+instance AWS.ToText Location where toText (Uri uri) = tshow uri toText (Local p) = T.pack p @@ -63,11 +63,11 @@ b <.> e = b FP.<.> e instance IsPath S3Uri Text where- S3Uri b (ObjectKey k) </> p =- S3Uri b (ObjectKey (stripEnd "/" k <> "/" <> stripStart "/" p))+ S3Uri b (AWS.ObjectKey k) </> p =+ S3Uri b (AWS.ObjectKey (stripEnd "/" k <> "/" <> stripStart "/" p)) - S3Uri b (ObjectKey k) <.> e =- S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e))+ S3Uri b (AWS.ObjectKey k) <.> e =+ S3Uri b (AWS.ObjectKey (stripEnd "." k <> "." <> stripStart "." e)) toLocation :: Text -> Maybe Location toLocation t = case URI.parseURI (T.unpack t) of
src/HaskellWorks/CabalCache/Metadata.hs view
@@ -1,6 +1,11 @@ {-# LANGUAGE TupleSections #-} -module HaskellWorks.CabalCache.Metadata where+module HaskellWorks.CabalCache.Metadata+ ( metaDir,+ createMetadata,+ loadMetadata,+ deleteMetadata,+ ) where import Control.Lens ((<&>)) import Control.Monad (forM_)@@ -18,14 +23,14 @@ metaDir = "_CC_METADATA" createMetadata :: MonadIO m => FilePath -> PackageInfo -> [(T.Text, LBS.ByteString)] -> m TarGroup-createMetadata storePath pkg values = liftIO $ do+createMetadata storePath pkg values = liftIO do let pkgMetaPath = storePath </> packageDir pkg </> metaDir IO.createDirectoryIfMissing True pkgMetaPath forM_ values $ \(k, v) -> LBS.writeFile (pkgMetaPath </> T.unpack k) v pure $ TarGroup storePath [packageDir pkg </> metaDir] loadMetadata :: MonadIO m => FilePath -> m (Map.Map T.Text LBS.ByteString)-loadMetadata pkgStorePath = liftIO $ do+loadMetadata pkgStorePath = liftIO do let pkgMetaPath = pkgStorePath </> metaDir exists <- IO.doesDirectoryExist pkgMetaPath if not exists
src/HaskellWorks/CabalCache/Options.hs view
@@ -1,14 +1,16 @@ module HaskellWorks.CabalCache.Options- ( readOrFromTextOption+ ( readOrFromTextOption, ) where +import Control.Applicative (Alternative(..)) import Network.AWS.Data.Text (FromText (..), fromText)-import Options.Applicative hiding (columns)+import Options.Applicative (Parser, Mod, OptionFields) import Text.Read (readEither) -import qualified Data.Text as T+import qualified Data.Text as T+import qualified Options.Applicative as OA readOrFromTextOption :: (Read a, FromText a) => Mod OptionFields a -> Parser a readOrFromTextOption = let fromStr s = readEither s <|> fromText (T.pack s)- in option $ eitherReader fromStr+ in OA.option $ OA.eitherReader fromStr
src/HaskellWorks/CabalCache/Show.hs view
@@ -1,5 +1,5 @@ module HaskellWorks.CabalCache.Show- ( tshow+ ( tshow, ) where import Data.Text (Text)
+ src/HaskellWorks/CabalCache/Store.hs view
@@ -0,0 +1,21 @@+module HaskellWorks.CabalCache.Store+ ( cleanupStorePath,+ ) where++import Control.Monad (when, void)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO(liftIO))+import Control.Monad.Trans.Except (ExceptT)++import qualified Control.Monad.Oops as OO+import qualified HaskellWorks.CabalCache.IO.Lazy as IO+import qualified System.Directory as IO++cleanupStorePath :: ()+ => MonadIO m+ => MonadCatch m+ => FilePath+ -> ExceptT (OO.Variant e) m ()+cleanupStorePath packageStorePath = do+ pathExists <- liftIO $ IO.doesPathExist packageStorePath+ when pathExists $ void $ IO.removePathRecursive packageStorePath
src/HaskellWorks/CabalCache/Text.hs view
@@ -1,8 +1,8 @@ module HaskellWorks.CabalCache.Text- ( maybeStripPrefix+ ( maybeStripPrefix, ) where -import Data.Maybe+import Data.Maybe (fromMaybe) import Data.Text (Text) import qualified Data.Text as T
src/HaskellWorks/CabalCache/Topology.hs view
@@ -1,12 +1,11 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE TypeApplications #-} module HaskellWorks.CabalCache.Topology- ( PlanData(..)- , buildPlanData- , canShare+ ( PlanData(..),+ buildPlanData,+ canShare, ) where import Control.Arrow ((&&&))
src/HaskellWorks/CabalCache/Types.hs view
@@ -4,16 +4,28 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -module HaskellWorks.CabalCache.Types where+module HaskellWorks.CabalCache.Types+ ( CompilerId,+ PackageId,+ PackageName,+ CompilerContext(..),+ Components(..),+ PlanJson(..),+ Package(..),+ Lib(..),+ ) where -import Data.Aeson+import Data.Aeson (FromJSON(parseJSON), (.!=), (.:), (.:?)) import Data.Text (Text)-import GHC.Generics+import GHC.Generics (Generic) import Prelude hiding (id) -type CompilerId = Text-type PackageId = Text+import qualified Data.Aeson as J +type CompilerId = Text+type PackageId = Text+type PackageName = Text+ data PlanJson = PlanJson { compilerId :: CompilerId , installPlan :: [Package]@@ -45,12 +57,12 @@ } deriving (Show, Eq, Generic) instance FromJSON PlanJson where- parseJSON = withObject "PlanJson" $ \v -> PlanJson+ parseJSON = J.withObject "PlanJson" $ \v -> PlanJson <$> v .: "compiler-id" <*> v .: "install-plan" instance FromJSON Package where- parseJSON = withObject "Package" $ \v -> do+ parseJSON = J.withObject "Package" $ \v -> do packageType <- v .: "type" id <- v .: "id" name <- v .: "pkg-name"@@ -63,10 +75,10 @@ return Package {..} instance FromJSON Components where- parseJSON = withObject "Components" $ \v -> Components+ parseJSON = J.withObject "Components" $ \v -> Components <$> v .:? "lib" instance FromJSON Lib where- parseJSON = withObject "Lib" $ \v -> Lib+ parseJSON = J.withObject "Lib" $ \v -> Lib <$> v .:? "depends" .!= [] <*> v .:? "exe-depends" .!= []
+ src/HaskellWorks/CabalCache/URI.hs view
@@ -0,0 +1,16 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++module HaskellWorks.CabalCache.URI+ ( reslashUri,+ ) where++import Control.Lens ((&), (%~))+import Data.Generics.Product.Any (HasAny(the))+import Network.URI (URI)++reslashUri :: URI -> URI+reslashUri uri = uri & the @"uriPath" %~ fmap reslashChar+ where reslashChar :: Char -> Char+ reslashChar '\\' = '/'+ reslashChar c = c
src/HaskellWorks/CabalCache/Version.hs view
@@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} -module HaskellWorks.CabalCache.Version where+module HaskellWorks.CabalCache.Version+ ( archiveVersion,+ ) where -import Data.String+import Data.String (IsString) archiveVersion :: IsString s => s archiveVersion = "v2"
test/HaskellWorks/CabalCache/AwsSpec.hs view
@@ -1,4 +1,6 @@-{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications #-} {-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-} @@ -6,35 +8,44 @@ ( spec ) where -import Antiope.Core-import Antiope.Env import Control.Lens import Control.Monad+import Control.Monad.Except (runExceptT) import Control.Monad.IO.Class import Data.Maybe (isJust)-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.IO.Lazy+import HaskellWorks.CabalCache.AppError (AwsError(..))+import HaskellWorks.CabalCache.Error (UnsupportedUri) import HaskellWorks.Hspec.Hedgehog import Hedgehog import Test.Hspec -import qualified Data.ByteString.Lazy.Char8 as LBSC-import qualified Network.HTTP.Types as HTTP-import qualified Network.URI as URI-import qualified System.Environment as IO+import qualified Control.Monad.Oops as OO+import qualified Data.ByteString.Lazy.Char8 as LBSC+import qualified Data.Variant as OO+import qualified HaskellWorks.CabalCache.AWS.Env as AWS+import qualified HaskellWorks.CabalCache.AWS.S3 as AWS+import qualified Hedgehog as H+import qualified Network.AWS as AWS+import qualified Network.HTTP.Types as HTTP+import qualified Network.URI as URI+import qualified System.Environment as IO {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -} {- HLINT ignore "Redundant bracket" -} spec :: Spec-spec = describe "HaskellWorks.CabalCache.QuerySpec" $ do- xit "stub" $ requireTest $ do+spec = describe "HaskellWorks.CabalCache.QuerySpec" do+ it "stub" $ requireTest do ci <- liftIO $ IO.lookupEnv "CI" <&> isJust- unless ci $ do- envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn)+ unless ci do+ envAws <- liftIO $ AWS.mkEnv AWS.Oregon (const LBSC.putStrLn) let Just uri = URI.parseURI "s3://jky-mayhem/hjddhd"- result <- liftIO $ runResourceT $ headS3Uri envAws uri- result === Left AwsAppError- { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" }- }+ result :: Either (OO.Variant '[AwsError, UnsupportedUri]) ()+ <- liftIO $ runExceptT $ OO.suspend AWS.runResourceT $ void (AWS.headS3Uri envAws uri)++ case result of+ Right _ -> H.failure+ Left e -> OO.toEithers e === Left AwsError+ { status = HTTP.Status { HTTP.statusCode = 404 , HTTP.statusMessage = "Not Found" }+ }
+ test/HaskellWorks/CabalCache/IntegrationSpec.hs view
@@ -0,0 +1,93 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications #-}++{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}++module HaskellWorks.CabalCache.IntegrationSpec+ ( spec+ ) where++import Control.Monad (forM_)+import System.FilePath ((</>))+import Test.Hspec (Spec, describe, it)++import qualified Data.List as L+import qualified Data.Time.Clock as DT+import qualified Data.Time.Format as DT+import qualified HaskellWorks.Hspec.Hedgehog as H+import qualified Hedgehog as H+import qualified Hedgehog.Extras.Test.Base as H+import qualified System.Directory as IO+import qualified System.Environment as IO+import qualified System.FilePath.Glob as IO+import qualified Test.Base as H++{- HLINT ignore "Redundant do" -}+{- HLINT ignore "Reduce duplication" -}+{- HLINT ignore "Redundant bracket" -}++spec :: Spec+spec = describe "HaskellWorks.CabalCache.IntegrationSpec" do+ it "local" $ H.require . H.withTests 1 $ H.integration $ H.runFinallies . H.workspace "local" $ \tempAbsBasePath' -> do+ cwd <- H.noteIO $ IO.getCurrentDirectory+ let archivePath = tempAbsBasePath' </> "archive"+ let storePath = tempAbsBasePath' </> "store"+ let buildPath = cwd </> "dist-newstyle"++ H.execCabalCache_+ [ "sync-to-archive"+ , "--archive-uri"+ , archivePath+ , "--build-path"+ , buildPath+ ]++ H.execCabalCache_+ [ "sync-from-archive"+ , "--archive-uri"+ , archivePath+ , "--store-path"+ , tempAbsBasePath' </> "store"+ , "--build-path"+ , buildPath+ ]++ archivedPackages <- H.noteShowIO $ IO.globDir1 (IO.compile "**/*.tar.gz") archivePath+ restoredPackages <- H.noteShowIO $ IO.globDir1 (IO.compile "**/cabal-hash.txt") storePath++ H.assert $ L.length archivedPackages > 20 -- At least some packages should have been archived+ H.assert $ L.length restoredPackages > 20 -- At least some packages should have been archived++ it "remote" $ H.require . H.withTests 1 $ H.integration $ H.runFinallies . H.workspace "local" $ \tempAbsBasePath' -> do+ cwd <- H.noteIO $ IO.getCurrentDirectory+ mBinaryCacheUri <- H.noteShowIO $ IO.lookupEnv "BINARY_CACHE_URI"++ forM_ mBinaryCacheUri \binaryCacheUri -> do+ now <- H.evalIO DT.getCurrentTime++ let formattedNow = DT.formatTime DT.defaultTimeLocale "%Y-%m-%dT%H:%M:%S" now+ let storePath = tempAbsBasePath' </> "store"+ let buildPath = cwd </> "dist-newstyle"+ let archiveUri = binaryCacheUri <> "/" <> "cabal-cache-test" <> "/" <> formattedNow++ H.execCabalCache_+ [ "sync-to-archive"+ , "--archive-uri"+ , archiveUri+ , "--build-path"+ , buildPath+ ]++ H.execCabalCache_+ [ "sync-from-archive"+ , "--archive-uri"+ , archiveUri+ , "--store-path"+ , tempAbsBasePath' </> "store"+ , "--build-path"+ , buildPath+ ]++ restoredPackages <- H.noteShowIO $ IO.globDir1 (IO.compile "**/cabal-hash.txt") storePath++ H.assert $ L.length restoredPackages > 20 -- At least some packages should have been archived
test/HaskellWorks/CabalCache/LocationSpec.hs view
@@ -1,25 +1,24 @@-{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-}+ module HaskellWorks.CabalCache.LocationSpec-( spec-) where+ ( spec,+ ) where -import Antiope.Core (toText)+import Data.Maybe (fromJust) import HaskellWorks.CabalCache.Location--import Data.Maybe (fromJust) import HaskellWorks.Hspec.Hedgehog import Hedgehog-import Network.URI (URI)+import Network.URI (URI) import Test.Hspec -import qualified Data.List as L-import qualified Data.List as List-import qualified Data.Text as Text-import qualified Hedgehog.Gen as Gen-import qualified Hedgehog.Range as Range-import qualified Network.URI as URI-import qualified System.FilePath as FP+import qualified Data.List as L+import qualified Data.List as List+import qualified Data.Text as Text+import qualified Hedgehog.Gen as Gen+import qualified Hedgehog.Range as Range+import qualified Network.AWS.Data as AWS+import qualified Network.URI as URI+import qualified System.FilePath as FP {- HLINT ignore "Redundant do" -} {- HLINT ignore "Reduce duplication" -}@@ -40,29 +39,29 @@ pure $ "/" <> List.intercalate "/" parts <> "." <> ext spec :: Spec-spec = describe "HaskellWorks.Assist.LocationSpec" $ do- it "URI bucket-only" $ requireTest $ do+spec = describe "HaskellWorks.Assist.LocationSpec" do+ it "URI bucket-only" $ requireTest do fromJust (URI.parseURI "s3://bucket") </> "directory" === fromJust (URI.parseURI "s3://bucket/directory") - it "Location bucket-only" $ requireTest $ do+ it "Location bucket-only" $ requireTest do fromJust (toLocation "s3://bucket") </> "directory" === fromJust (toLocation "s3://bucket/directory") - it "S3 should roundtrip from and to text" $ require $ property $ do+ it "S3 should roundtrip from and to text" $ require $ property do uri <- forAll s3Uri- tripping (Uri uri) toText toLocation+ tripping (Uri uri) AWS.toText toLocation - it "LocalLocation should roundtrip from and to text" $ require $ property $ do+ it "LocalLocation should roundtrip from and to text" $ require $ property do path <- forAll localPath- tripping (Local path) toText toLocation+ tripping (Local path) AWS.toText toLocation - it "Should append s3 path" $ require $ property $ do+ it "Should append s3 path" $ require $ property do loc <- Uri <$> forAll s3Uri part <- forAll $ Gen.text (Range.linear 3 10) Gen.alphaNum ext <- forAll $ Gen.text (Range.linear 2 4) Gen.alphaNum- toText (loc </> part <.> ext) === toText loc <> "/" <> part <> "." <> ext+ AWS.toText (loc </> part <.> ext) === AWS.toText loc <> "/" <> part <> "." <> ext - it "Should append s3 path" $ require $ property $ do+ it "Should append s3 path" $ require $ property do loc <- Local <$> forAll localPath part <- forAll $ Gen.string (Range.linear 3 10) Gen.alphaNum ext <- forAll $ Gen.string (Range.linear 2 4) Gen.alphaNum- toText (loc </> Text.pack part <.> Text.pack ext) === Text.pack ((Text.unpack $ toText loc) FP.</> part FP.<.> ext)+ AWS.toText (loc </> Text.pack part <.> Text.pack ext) === Text.pack ((Text.unpack $ AWS.toText loc) FP.</> part FP.<.> ext)
test/HaskellWorks/CabalCache/QuerySpec.hs view
@@ -3,7 +3,7 @@ {-# LANGUAGE QuasiQuotes #-} module HaskellWorks.CabalCache.QuerySpec- ( spec+ ( spec, ) where import HaskellWorks.Hspec.Hedgehog@@ -20,8 +20,8 @@ {- HLINT ignore "Redundant bracket" -} spec :: Spec-spec = describe "HaskellWorks.Assist.QuerySpec" $ do- it "stub" $ requireTest $ do+spec = describe "HaskellWorks.Assist.QuerySpec" do+ it "stub" $ requireTest do case A.eitherDecode exampleJson of Right planJson -> do planJson === Z.PlanJson
+ test/Test/Base.hs view
@@ -0,0 +1,43 @@+module Test.Base + ( execCabalCache+ , execCabalCache_+ , execCabalCache'+ , integration+ ) where++import Control.Monad (void)+import Control.Monad.Catch (MonadCatch)+import Control.Monad.IO.Class (MonadIO)+import GHC.Stack (HasCallStack)+import Hedgehog (MonadTest)+import Hedgehog.Extras.Test.Process (ExecConfig)++import qualified GHC.Stack as GHC+import qualified Hedgehog as H+import qualified Hedgehog.Extras.Test.Base as H+import qualified Hedgehog.Extras.Test.Process as H++integration :: HasCallStack => H.Integration () -> H.Property+integration = H.withTests 1 . H.propertyOnce++-- | Run cabal-cache, returning the stdout+execCabalCache+ :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+ => [String]+ -> m String+execCabalCache = GHC.withFrozenCallStack $ H.execFlex "cabal-cache" "CABAL_CACHE"++-- | Run cabal-cache, discarding return value+execCabalCache_+ :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+ => [String]+ -> m ()+execCabalCache_ = void . execCabalCache++-- | Run cabal-cache, returning the stdout+execCabalCache'+ :: (MonadTest m, MonadCatch m, MonadIO m, HasCallStack)+ => ExecConfig+ -> [String]+ -> m String+execCabalCache' execConfig = GHC.withFrozenCallStack $ H.execFlex' execConfig "cabal-cache" "CABAL_CACHE"