cabal-cache 1.0.3.0 → 1.0.4.0

raw patch · 30 files changed

+1020/−915 lines, 30 filesdep +http-client-tlsdep +network-uridep +transformersdep −conduit-extradep −hw-hedgehogdep −selectivedep ~aesondep ~hedgehogdep ~optparse-applicativePVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: http-client-tls, network-uri, transformers

Dependencies removed: conduit-extra, hw-hedgehog, selective, tar, time, zlib

Dependency ranges changed: aeson, hedgehog, optparse-applicative, text

API changes (from Hackage documentation)

Files

• CHANGELOG.md +0/−5
• README.md +9/−0
• app/App/Commands.hs +20/−0
• app/App/Commands/Options/Parser.hs +13/−0
• app/App/Commands/Options/Types.hs +42/−0
• app/App/Commands/Plan.hs +107/−0
• app/App/Commands/SyncFromArchive.hs +276/−0
• app/App/Commands/SyncToArchive.hs +239/−0
• app/App/Commands/Version.hs +32/−0
• app/App/Static.hs +11/−0
• app/App/Static/Base.hs +13/−0
• app/App/Static/Posix.hs +8/−0
• app/App/Static/Windows.hs +15/−0
• cabal-cache.cabal +121/−103
• src/App/Commands.hs +0/−20
• src/App/Commands/Options/Parser.hs +0/−13
• src/App/Commands/Options/Types.hs +0/−39
• src/App/Commands/Plan.hs +0/−107
• src/App/Commands/SyncFromArchive.hs +0/−250
• src/App/Commands/SyncToArchive.hs +0/−212
• src/App/Commands/Version.hs +0/−32
• src/App/Static.hs +0/−11
• src/App/Static/Base.hs +0/−13
• src/App/Static/Posix.hs +0/−8
• src/App/Static/Windows.hs +0/−15
• src/HaskellWorks/CabalCache/IO/Error.hs +2/−9
• src/HaskellWorks/CabalCache/IO/Lazy.hs +63/−42
• src/HaskellWorks/CabalCache/Location.hs +27/−23
• test/HaskellWorks/CabalCache/AwsSpec.hs +5/−2
• test/HaskellWorks/CabalCache/LocationSpec.hs +17/−11

@@ -1,5 +0,0 @@-# Revision history for cabal-cache--## 0.1.0.0 -- YYYY-mm-dd--* First version. Released on an unsuspecting world.

@@ -76,6 +76,14 @@ cabal-cache sync-from-archive --threads 16 --archive-uri archive --region Sydney ``` +### Multicloud++To run against a different service, use something like:++```bash+cabal-cache sync-to-archive --threads 16 --archive-uri s3://my-cabal-cache-bucket/archive --host-name-override=s3.us-west.some-service.com --host-port-override=443 --host-ssl-override=True+```+ ## The archive  ### Archive tarball format@@ -157,3 +165,4 @@ if the package's cabal store `share` directory contain unusual files or directories _unless_ the `${store_hash}` matches.  Currently it only considers the `doc` subdirectory to be usual.  More exceptions may be added later.+

@@ -0,0 +1,20 @@+module App.Commands where++import App.Commands.Plan+import App.Commands.SyncFromArchive+import App.Commands.SyncToArchive+import App.Commands.Version+import Options.Applicative++{- HLINT ignore "Monoid law, left identity" -}++commands :: Parser (IO ())+commands = commandsGeneral++commandsGeneral :: Parser (IO ())+commandsGeneral = subparser $ mempty+  <>  commandGroup "Commands:"+  <>  cmdPlan+  <>  cmdSyncFromArchive+  <>  cmdSyncToArchive+  <>  cmdVersion

@@ -0,0 +1,13 @@+module App.Commands.Options.Parser where++import Antiope.Core               (FromText, fromText)+import App.Commands.Options.Types (VersionOptions (..))+import Options.Applicative++import qualified Data.Text as Text++optsVersion :: Parser VersionOptions+optsVersion = pure VersionOptions++text :: FromText a => ReadM a+text = eitherReader (fromText . Text.pack)

@@ -0,0 +1,42 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module App.Commands.Options.Types where++import Antiope.Env                      (Region)+import GHC.Generics+import Data.ByteString                  (ByteString)+import HaskellWorks.CabalCache.Location++import qualified Antiope.Env as AWS++data SyncToArchiveOptions = SyncToArchiveOptions+  { region        :: Region+  , archiveUri    :: Location+  , buildPath     :: FilePath+  , storePath     :: FilePath+  , storePathHash :: Maybe String+  , threads       :: Int+  , awsLogLevel   :: Maybe AWS.LogLevel+  , hostEndpoint  :: Maybe (ByteString, Int, Bool)+  } deriving (Eq, Show, Generic)++data PlanOptions = PlanOptions+  { buildPath     :: FilePath+  , storePath     :: FilePath+  , storePathHash :: Maybe String+  , outputFile    :: FilePath+  } deriving (Eq, Show, Generic)++data SyncFromArchiveOptions = SyncFromArchiveOptions+  { region        :: Region+  , archiveUris   :: [Location]+  , buildPath     :: FilePath+  , storePath     :: FilePath+  , storePathHash :: Maybe String+  , threads       :: Int+  , awsLogLevel   :: Maybe AWS.LogLevel+  , hostEndpoint  :: Maybe (ByteString, Int, Bool)+  } deriving (Eq, Show, Generic)++data VersionOptions = VersionOptions deriving (Eq, Show, Generic)

@@ -0,0 +1,107 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.Plan+  ( 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 Data.Generics.Product.Any        (the)+import Data.Maybe+import HaskellWorks.CabalCache.AppError+import HaskellWorks.CabalCache.Location (Location (..), (<.>), (</>))+import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Version  (archiveVersion)+import Options.Applicative              hiding (columns)++import qualified App.Commands.Options.Types         as Z+import qualified App.Static                         as AS+import qualified Control.Concurrent.STM             as STM+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 System.IO                          as IO++{- HLINT ignore "Monoid law, left identity" -}+{- HLINT ignore "Redundant do"              -}+{- HLINT ignore "Reduce duplication"        -}++runPlan :: Z.PlanOptions -> IO ()+runPlan opts = 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 hash: "  <> T.pack storePathHash+  CIO.putStrLn $ "Archive URIs: "     <> tshow archiveUris+  CIO.putStrLn $ "Archive version: "  <> archiveVersion++  tEarlyExit <- STM.newTVarIO False++  mbPlan <- Z.loadPlan $ 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++      if outputFile == "-"+        then LBS.putStr $ J.encode (fmap (fmap toText) plan)+        else LBS.writeFile outputFile $ J.encode (fmap (fmap toText) plan)++    Left (appError :: AppError) -> do+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError++  earlyExit <- STM.readTVarIO tEarlyExit++  when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error"++optsPlan :: Parser PlanOptions+optsPlan = PlanOptions+  <$> strOption+      (   long "build-path"+      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)+      <>  metavar "DIRECTORY"+      <>  value AS.buildPath+      )+  <*> strOption+      (   long "store-path"+      <>  help "Path to cabal store"+      <>  metavar "DIRECTORY"+      <>  value (AS.cabalDirectory </> "store")+      )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )+      )+  <*> strOption+      (   long "output-file"+      <>  help "Output file"+      <>  metavar "FILE"+      <>  value "-"+      )++cmdPlan :: Mod CommandFields (IO ())+cmdPlan = command "plan"  $ flip info idm $ runPlan <$> optsPlan

@@ -0,0 +1,276 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TupleSections       #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.SyncFromArchive+  ( 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.Types       (SyncFromArchiveOptions (SyncFromArchiveOptions))+import Control.Applicative+import Control.Lens                     hiding ((<.>))+import Control.Monad.Catch              (MonadCatch)+import Control.Monad.Except+import Control.Monad.Trans.AWS          (envOverride, setEndpoint)+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 HaskellWorks.CabalCache.Metadata (loadMetadata)+import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Version  (archiveVersion)+import Options.Applicative              hiding (columns)+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 Data.ByteString.Char8                            as C8+import qualified Data.ByteString.Lazy                             as LBS+import qualified Data.List                                        as L+import qualified Data.Map                                         as M+import qualified Data.Map.Strict                                  as Map+import qualified Data.Text                                        as T+import qualified HaskellWorks.CabalCache.AWS.Env                  as AWS+import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ+import qualified HaskellWorks.CabalCache.Concurrent.Fork          as IO+import qualified HaskellWorks.CabalCache.Core                     as Z+import qualified HaskellWorks.CabalCache.Data.List                as L+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.Types                    as Z+import qualified System.Directory                                 as IO+import qualified System.IO                                        as IO+import qualified System.IO.Temp                                   as IO+import qualified System.IO.Unsafe                                 as IO++{- HLINT ignore "Monoid law, left identity" -}+{- HLINT ignore "Reduce duplication"        -}+{- HLINT ignore "Redundant do"              -}++skippable :: Z.Package -> Bool+skippable package = package ^. the @"packageType" == "pre-existing"++runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO ()+runSyncFromArchive opts = do+  let hostEndpoint          = opts ^. the @"hostEndpoint"+  let storePath             = opts ^. the @"storePath"+  let archiveUris           = opts ^. the @"archiveUris"+  let threads               = opts ^. the @"threads"+  let awsLogLevel           = opts ^. the @"awsLogLevel"+  let versionedArchiveUris  = archiveUris & each %~ (</> archiveVersion)+  let storePathHash         = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)+  let scopedArchiveUris     = versionedArchiveUris & each %~ (</> T.pack storePathHash)++  CIO.putStrLn $ "Store path: "       <> toText storePath+  CIO.putStrLn $ "Store path hash: "  <> T.pack storePathHash+  forM_ archiveUris $ \archiveUri -> do+    CIO.putStrLn $ "Archive URI: "      <> toText archiveUri+  CIO.putStrLn $ "Archive version: "  <> archiveVersion+  CIO.putStrLn $ "Threads: "          <> tshow threads+  CIO.putStrLn $ "AWS Log level: "    <> tshow awsLogLevel++  mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"++  case mbPlan of+    Right planJson -> do+      compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson++      case compilerContextResult of+        Right compilerContext -> do+          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"++          CIO.putStrLn "Creating store directories"+          createDirectoryIfMissing True storePath+          createDirectoryIfMissing True storeCompilerPath+          createDirectoryIfMissing True storeCompilerLibPath++          storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath++          unless storeCompilerPackageDbPathExists $ do+            CIO.putStrLn "Package DB missing. Creating Package DB"+            GhcPkg.init compilerContext storeCompilerPackageDbPath++          packages <- Z.getPackages storePath planJson++          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++          downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps++          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.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++                storeDirectoryExists <- doesDirectoryExist packageStorePath++                case maybePackage of+                  Nothing -> do+                    CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId+                    return True+                  Just package -> if skippable package+                    then do+                      CIO.putStrLn $ "Skipping: " <> packageId+                      return True+                    else if storeDirectoryExists+                      then return True+                      else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do+                        (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles))+                        CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile++                        let tempArchiveFile = tempPath </> archiveBaseName+                        liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents+                        IO.extractTar tempArchiveFile storePath++                        meta <- loadMetadata packageStorePath+                        oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta)++                        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++                            return True+              Nothing -> do+                CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId+                return True++          CIO.putStrLn "Recaching package database"+          GhcPkg.recache compilerContext storeCompilerPackageDbPath++          failures <- STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"++          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++  return ()++cleanupStorePath :: (MonadIO m, MonadCatch m) => FilePath -> Z.PackageId -> AppError -> m ()+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++onError :: MonadIO m => (AppError -> m ()) -> a -> ExceptT AppError m a -> m a+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++optsSyncFromArchive :: Parser SyncFromArchiveOptions+optsSyncFromArchive = SyncFromArchiveOptions+  <$> option (auto <|> text)+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> 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"+        )+      )+  <*> strOption+      (   long "build-path"+      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)+      <>  metavar "DIRECTORY"+      <>  value AS.buildPath+      )+  <*> strOption+      (   long "store-path"+      <>  help ("Path to cabal store.  Defaults to " <> show AS.cabalDirectory)+      <>  metavar "DIRECTORY"+      <>  value (AS.cabalDirectory </> "store")+      )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )+      )+  <*> option auto+      (   long "threads"+      <>  help "Number of concurrent threads"+      <>  metavar "NUM_THREADS"+      <>  value 4+      )+  <*> optional+      ( option autoText+        (   long "aws-log-level"+        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"+        <>  metavar "AWS_LOG_LEVEL"+        )+      )+  <*> optional parseEndpoint++parseEndpoint :: Parser (ByteString, Int, Bool)+parseEndpoint =+  (,,)+  <$>  option autoText+        (   long "host-name-override"+        <>  help "Override the host name (default: s3.amazonaws.com)"+        <>  metavar "HOST_NAME"+        )+  <*> option auto+        (   long "host-port-override"+        <>  help "Override the host port"+        <>  metavar "HOST_PORT"+        )+  <*> option auto+        (   long "host-ssl-override"+        <>  help "Override the host SSL"+        <>  metavar "HOST_SSL"+        )++cmdSyncFromArchive :: Mod CommandFields (IO ())+cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

@@ -0,0 +1,239 @@+{-# LANGUAGE BlockArguments      #-}+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.SyncToArchive+  ( 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.Types       (SyncToArchiveOptions (SyncToArchiveOptions))+import Control.Applicative+import Control.Lens                     hiding ((<.>))+import Control.Monad.Except+import Control.Monad.Trans.Resource     (runResourceT)+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 HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), (</>))+import HaskellWorks.CabalCache.Metadata (createMetadata)+import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Topology (buildPlanData, canShare)+import HaskellWorks.CabalCache.Version  (archiveVersion)+import Options.Applicative              hiding (columns)+import System.Directory                 (doesDirectoryExist)++import qualified App.Commands.Options.Types         as Z+import qualified App.Static                         as AS+import qualified Control.Concurrent.STM             as STM+import qualified Data.ByteString.Lazy               as LBS+import qualified Data.ByteString.Lazy.Char8         as LC8+import qualified Data.Text                          as T+import qualified Data.Text                          as Text+import qualified HaskellWorks.CabalCache.AWS.Env    as AWS+import qualified HaskellWorks.CabalCache.Core       as Z+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 System.Directory                   as IO+import qualified System.IO                          as IO+import qualified System.IO.Temp                     as IO+import qualified System.IO.Unsafe                   as IO+import qualified UnliftIO.Async                     as IO++{- HLINT ignore "Monoid law, left identity" -}+{- HLINT ignore "Redundant do"              -}+{- HLINT ignore "Reduce duplication"        -}++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++  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++  tEarlyExit <- STM.newTVarIO False++  mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"++  case mbPlan of+    Right planJson -> do+      compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson++      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++          packages     <- Z.getPackages storePath planJson+          nonShareable <- packages & filterM (fmap not . isShareable storePath)+          let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId")++          let storeCompilerPath           = storePath </> T.unpack compilerId+          let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"++          storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath++          unless storeCompilerPackageDbPathExists $+            GhcPkg.init compilerContext storeCompilerPackageDbPath++          CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages"++          IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+            CIO.putStrLn $ "Temp path: " <> tshow tempPath++            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++                -- 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++                archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile++                unless archiveFileExists $ do+                  packageStorePathExists <- doesDirectoryExist packageStorePath++                  when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do+                    let workingStorePackagePath = tempPath </> Z.packageDir pInfo+                    liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath++                    let rp2 = Z.relativePaths storePath pInfo++                    CIO.putStrLn $ "Creating " <> toText targetFile++                    let tempArchiveFile = tempPath </> archiveFileBasename++                    metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]++                    IO.createTar tempArchiveFile (rp2 <> [metas])++                    void $ catchError (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile) $ \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++                      _ -> return ()+        Left msg -> CIO.hPutStrLn IO.stderr msg++    Left (appError :: AppError) -> do+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError++  earlyExit <- STM.readTVarIO tEarlyExit++  when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error"++isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool+isShareable storePath pkg =+  let packageSharePath = storePath </> Z.packageDir pkg </> "share"+  in IO.listMaybeDirectory packageSharePath <&> (\\ ["doc"]) <&> null++optsSyncToArchive :: Parser SyncToArchiveOptions+optsSyncToArchive = SyncToArchiveOptions+  <$> option (auto <|> text)+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> 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 $ AS.cabalDirectory </> "archive")+      )+  <*> strOption+      (   long "build-path"+      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)+      <>  metavar "DIRECTORY"+      <>  value AS.buildPath+      )+  <*> strOption+      (   long "store-path"+      <>  help "Path to cabal store"+      <>  metavar "DIRECTORY"+      <>  value (AS.cabalDirectory </> "store")+      )+  <*> optional+      ( strOption+        (   long "store-path-hash"+        <>  help "Store path hash (do not use)"+        <>  metavar "HASH"+        )+      )+  <*> option auto+      (   long "threads"+      <>  help "Number of concurrent threads"+      <>  metavar "NUM_THREADS"+      <>  value 4+      )+  <*> optional+      ( option autoText+        (   long "aws-log-level"+        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"+        <>  metavar "AWS_LOG_LEVEL"+        )+      )+  <*> optional parseEndpoint++parseEndpoint :: Parser (ByteString, Int, Bool)+parseEndpoint =+  (,,)+  <$>  option autoText+        (   long "host-name-override"+        <>  help "Override the host name (default: s3.amazonaws.com)"+        <>  metavar "HOST_NAME"+        )+  <*> option auto+        (   long "host-port-override"+        <>  help "Override the host port"+        <>  metavar "HOST_PORT"+        )+  <*> option auto+        (   long "host-ssl-override"+        <>  help "Override the host SSL"+        <>  metavar "HOST_SSL"+        )++cmdSyncToArchive :: Mod CommandFields (IO ())+cmdSyncToArchive = command "sync-to-archive"  $ flip info idm $ runSyncToArchive <$> optsSyncToArchive

@@ -0,0 +1,32 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.Version+  ( cmdVersion+  ) where++import App.Commands.Options.Parser (optsVersion)+import Data.List+import Options.Applicative         hiding (columns)++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++{- HLINT ignore "Redundant do"        -}+{- HLINT ignore "Reduce duplication"  -}++runVersion :: Z.VersionOptions -> IO ()+runVersion _ = do+  let V.Version {..} = P.version++  let version = intercalate "." $ fmap show versionBranch++  CIO.putStrLn $ "cabal-cache " <> T.pack version++cmdVersion :: Mod CommandFields (IO ())+cmdVersion = command "version"  $ flip info idm $ runVersion <$> optsVersion

@@ -0,0 +1,11 @@+module App.Static where++import qualified App.Static.Base    as S+import qualified App.Static.Posix   as P+import qualified App.Static.Windows as W++cabalDirectory :: FilePath+cabalDirectory = if S.isPosix then P.cabalDirectory else W.cabalDirectory++buildPath :: FilePath+buildPath = "dist-newstyle"

@@ -0,0 +1,13 @@+module App.Static.Base where++import qualified System.Directory as IO+import qualified System.IO.Unsafe as IO+import qualified System.Info      as I++homeDirectory :: FilePath+homeDirectory = IO.unsafePerformIO IO.getHomeDirectory+{-# NOINLINE homeDirectory #-}++isPosix :: Bool+isPosix = I.os /= "mingw32"+{-# NOINLINE isPosix #-}

@@ -0,0 +1,8 @@+module App.Static.Posix where++import HaskellWorks.CabalCache.Location ((</>))++import qualified App.Static.Base as S++cabalDirectory :: FilePath+cabalDirectory = S.homeDirectory </> ".cabal"

@@ -0,0 +1,15 @@+module App.Static.Windows where++import Data.Maybe+import HaskellWorks.CabalCache.Location ((</>))++import qualified App.Static.Base    as S+import qualified System.Environment as IO+import qualified System.IO.Unsafe   as IO++appDataDirectory :: FilePath+appDataDirectory = IO.unsafePerformIO $ fmap (fromMaybe S.homeDirectory) (IO.lookupEnv "APPDATA")+{-# NOINLINE appDataDirectory #-}++cabalDirectory :: FilePath+cabalDirectory = appDataDirectory </> "cabal"

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                1.0.3.0+version:                1.0.4.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,9 +9,9 @@ license-file:           LICENSE author:                 John Ky maintainer:             newhoggy@gmail.com-copyright:              John Ky 2019-2020+copyright:              John Ky 2019-2021 category:               Development-extra-source-files:     CHANGELOG.md, README.md+extra-source-files:     README.md  source-repository head   type: git@@ -19,14 +19,14 @@  common base                           { build-depends: base                           >= 4.7        && < 5      } -common aeson                          { build-depends: aeson                          >= 1.4.2.0    && < 1.5    }+common aeson                          { build-depends: aeson                          >= 1.4.2.0    && < 1.6    } 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 bytestring                     { build-depends: bytestring                     >= 0.10.8.2   && < 0.11   }+common bytestring                     { build-depends: bytestring                     >= 0.10.8.2   && < 0.12   } common conduit-extra                  { build-depends: conduit-extra                  >= 1.3.1.1    && < 1.4    } common containers                     { build-depends: containers                     >= 0.6.0.1    && < 0.7    } common cryptonite                     { build-depends: cryptonite                     >= 0.25       && < 1      }@@ -34,21 +34,23 @@ common directory                      { build-depends: directory                      >= 1.3.3.0    && < 1.4    } 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.1    }+common generic-lens                   { build-depends: generic-lens                   >= 1.1.0.0    && < 2.3    } common hedgehog                       { build-depends: hedgehog                       >= 1.0        && < 1.1    } common hspec                          { build-depends: hspec                          >= 2.4        && < 3      }-common http-client                    { build-depends: http-client                    >= 0.5.14     && < 0.7    }+common http-client                    { build-depends: http-client                    >= 0.5.14     && < 0.8    }+common http-client-tls                { build-depends: http-client-tls                >= 0.3        && < 0.4    } common http-types                     { build-depends: http-types                     >= 0.12.3     && < 0.13   } common hw-hedgehog                    { build-depends: hw-hedgehog                    >= 0.1.0.3    && < 0.2    } common hw-hspec-hedgehog              { build-depends: hw-hspec-hedgehog              >= 0.1.0.4    && < 0.2    }-common lens                           { build-depends: lens                           >= 4.17       && < 5      }+common lens                           { build-depends: lens                           >= 4.17       && < 6      } common mtl                            { build-depends: mtl                            >= 2.2.2      && < 2.3    }+common network-uri                    { build-depends: network-uri                    >= 2.6.4.1    && < 2.8    } common optparse-applicative           { build-depends: optparse-applicative           >= 0.14       && < 0.17   } common process                        { build-depends: process                        >= 1.6.5.0    && < 1.7    } common raw-strings-qq                 { build-depends: raw-strings-qq                 >= 1.1        && < 2      } common relation                       { build-depends: relation                       >= 0.5        && < 0.6    } common resourcet                      { build-depends: resourcet                      >= 1.2.2      && < 1.3    }-common selective                      { build-depends: selective                      >= 0.1.0      && < 0.2    }+common selective                      { build-depends: selective                      >= 0.1.0      && < 0.5    } common stm                            { build-depends: stm                            >= 2.5.0.0    && < 3      } common stringsearch                   { build-depends: stringsearch                   >= 0.3.6.6    && < 0.4    } common tar                            { build-depends: tar                            >= 0.5.1.0    && < 0.6    }@@ -56,114 +58,131 @@ common text                           { build-depends: text                           >= 1.2.3.1    && < 1.3    } common time                           { build-depends: time                           >= 1.4        && < 1.10   } common topograph                      { build-depends: topograph                      >= 1          && < 2      }+common transformers                   { build-depends: transformers                   >= 0.5.6.2    && < 0.7    } common unliftio                       { build-depends: unliftio                       >= 0.2.10     && < 0.3    } common zlib                           { build-depends: zlib                           >= 0.6.2      && < 0.7    }  common config   default-language:     Haskell2010-  ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates+  ghc-options:          -Wall+                        -Wincomplete-record-updates+                        -Wincomplete-uni-patterns+                        -Wtabs +  if impl(ghc >= 8.10.1)+    ghc-options:        -Wunused-packages+ library-  import:   base, config-          , aeson-          , amazonka-          , amazonka-core-          , amazonka-s3-          , antiope-core-          , antiope-optparse-applicative-          , antiope-s3-          , bytestring-          , conduit-extra-          , cryptonite-          , containers-          , deepseq-          , directory-          , exceptions-          , filepath-          , generic-lens-          , http-client-          , http-types-          , lens-          , mtl-          , optparse-applicative-          , process-          , relation-          , resourcet-          , selective-          , stm-          , stringsearch-          , tar-          , temporary-          , text-          , time-          , topograph-          , unliftio-          , zlib+  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   other-modules:        Paths_cabal_cache   autogen-modules:      Paths_cabal_cache   hs-source-dirs:       src-  exposed-modules:-      App.Commands-      App.Commands.Options.Parser-      App.Commands.Options.Types-      App.Commands.Plan-      App.Commands.SyncFromArchive-      App.Commands.SyncToArchive-      App.Commands.Version-      App.Static-      App.Static.Base-      App.Static.Posix-      App.Static.Windows-      HaskellWorks.CabalCache.AppError-      HaskellWorks.CabalCache.AWS.Env-      HaskellWorks.CabalCache.Concurrent.DownloadQueue-      HaskellWorks.CabalCache.Concurrent.Fork-      HaskellWorks.CabalCache.Concurrent.Type-      HaskellWorks.CabalCache.Core-      HaskellWorks.CabalCache.Data.List-      HaskellWorks.CabalCache.Error-      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-      HaskellWorks.CabalCache.Location-      HaskellWorks.CabalCache.Metadata-      HaskellWorks.CabalCache.Options-      HaskellWorks.CabalCache.Show-      HaskellWorks.CabalCache.Text-      HaskellWorks.CabalCache.Topology-      HaskellWorks.CabalCache.Types-      HaskellWorks.CabalCache.Version+  exposed-modules:      HaskellWorks.CabalCache.AppError+                        HaskellWorks.CabalCache.AWS.Env+                        HaskellWorks.CabalCache.Concurrent.DownloadQueue+                        HaskellWorks.CabalCache.Concurrent.Fork+                        HaskellWorks.CabalCache.Concurrent.Type+                        HaskellWorks.CabalCache.Core+                        HaskellWorks.CabalCache.Data.List+                        HaskellWorks.CabalCache.Error+                        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+                        HaskellWorks.CabalCache.Location+                        HaskellWorks.CabalCache.Metadata+                        HaskellWorks.CabalCache.Options+                        HaskellWorks.CabalCache.Show+                        HaskellWorks.CabalCache.Text+                        HaskellWorks.CabalCache.Topology+                        HaskellWorks.CabalCache.Types+                        HaskellWorks.CabalCache.Version  executable cabal-cache-  import:   base, config-          , optparse-applicative+  import:               base, config+                      , aeson+                      , amazonka+                      , amazonka-core+                      , antiope-core+                      , antiope-optparse-applicative+                      , bytestring+                      , containers+                      , directory+                      , exceptions+                      , generic-lens+                      , http-types+                      , lens+                      , mtl+                      , 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.Options.Types+                        App.Commands.Plan+                        App.Commands.SyncFromArchive+                        App.Commands.SyncToArchive+                        App.Commands.Version+                        App.Static+                        App.Static.Base+                        App.Static.Posix+                        App.Static.Windows+                        Paths_cabal_cache+  autogen-modules:      Paths_cabal_cache   ghc-options:          -threaded -rtsopts -with-rtsopts=-N  test-suite cabal-cache-test-  import:   base, config-          , aeson-          , antiope-core-          , antiope-s3-          , bytestring-          , containers-          , filepath-          , generic-lens-          , hedgehog-          , hspec-          , http-types-          , hw-hedgehog-          , hw-hspec-hedgehog-          , lens-          , raw-strings-qq-          , relation-          , text+  import:               base, config+                      , aeson+                      , antiope-core+                      , bytestring+                      , filepath+                      , hedgehog+                      , hspec+                      , http-types+                      , hw-hspec-hedgehog+                      , lens+                      , network-uri+                      , raw-strings-qq+                      , text    type:                 exitcode-stdio-1.0   main-is:              Spec.hs@@ -171,7 +190,6 @@   hs-source-dirs:       test   ghc-options:          -threaded -rtsopts -with-rtsopts=-N   build-tool-depends:   hspec-discover:hspec-discover-  other-modules:-      HaskellWorks.CabalCache.AwsSpec-      HaskellWorks.CabalCache.LocationSpec-      HaskellWorks.CabalCache.QuerySpec+  other-modules:        HaskellWorks.CabalCache.AwsSpec+                        HaskellWorks.CabalCache.LocationSpec+                        HaskellWorks.CabalCache.QuerySpec

@@ -1,20 +0,0 @@-module App.Commands where--import App.Commands.SyncFromArchive-import App.Commands.Plan-import App.Commands.SyncToArchive-import App.Commands.Version-import Options.Applicative--{- HLINT ignore "Monoid law, left identity" -}--commands :: Parser (IO ())-commands = commandsGeneral--commandsGeneral :: Parser (IO ())-commandsGeneral = subparser $ mempty-  <>  commandGroup "Commands:"-  <>  cmdPlan-  <>  cmdSyncFromArchive-  <>  cmdSyncToArchive-  <>  cmdVersion

@@ -1,13 +0,0 @@-module App.Commands.Options.Parser where--import Antiope.Core               (FromText, fromText)-import App.Commands.Options.Types (VersionOptions (..))-import Options.Applicative--import qualified Data.Text as Text--optsVersion :: Parser VersionOptions-optsVersion = pure VersionOptions--text :: FromText a => ReadM a-text = eitherReader (fromText . Text.pack)

@@ -1,39 +0,0 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}--module App.Commands.Options.Types where--import Antiope.Env                      (Region)-import GHC.Generics-import HaskellWorks.CabalCache.Location--import qualified Antiope.Env as AWS--data SyncToArchiveOptions = SyncToArchiveOptions-  { region        :: Region-  , archiveUri    :: Location-  , buildPath     :: FilePath-  , storePath     :: FilePath-  , storePathHash :: Maybe String-  , threads       :: Int-  , awsLogLevel   :: Maybe AWS.LogLevel-  } deriving (Eq, Show, Generic)--data PlanOptions = PlanOptions-  { buildPath     :: FilePath-  , storePath     :: FilePath-  , storePathHash :: Maybe String-  , outputFile    :: FilePath-  } deriving (Eq, Show, Generic)--data SyncFromArchiveOptions = SyncFromArchiveOptions-  { region        :: Region-  , archiveUris   :: [Location]-  , buildPath     :: FilePath-  , storePath     :: FilePath-  , storePathHash :: Maybe String-  , threads       :: Int-  , awsLogLevel   :: Maybe AWS.LogLevel-  } deriving (Eq, Show, Generic)--data VersionOptions = VersionOptions deriving (Eq, Show, Generic)

@@ -1,107 +0,0 @@-{-# LANGUAGE BlockArguments      #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}--module App.Commands.Plan-  ( 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 Data.Generics.Product.Any        (the)-import Data.Maybe-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Location (Location (..), (<.>), (</>))-import HaskellWorks.CabalCache.Show-import HaskellWorks.CabalCache.Version  (archiveVersion)-import Options.Applicative              hiding (columns)--import qualified App.Commands.Options.Types         as Z-import qualified App.Static                         as AS-import qualified Control.Concurrent.STM             as STM-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 System.IO                          as IO-import qualified Data.Aeson as J--{- HLINT ignore "Monoid law, left identity" -}-{- HLINT ignore "Redundant do"              -}-{- HLINT ignore "Reduce duplication"        -}--runPlan :: Z.PlanOptions -> IO ()-runPlan opts = 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 hash: "  <> T.pack storePathHash-  CIO.putStrLn $ "Archive URIs: "     <> tshow archiveUris-  CIO.putStrLn $ "Archive version: "  <> archiveVersion--  tEarlyExit <- STM.newTVarIO False--  mbPlan <- Z.loadPlan $ 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--      if outputFile == "-"-        then LBS.putStr $ J.encode (fmap (fmap toText) plan)-        else LBS.writeFile outputFile $ J.encode (fmap (fmap toText) plan)--    Left (appError :: AppError) -> do-      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError--  earlyExit <- STM.readTVarIO tEarlyExit--  when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error"--optsPlan :: Parser PlanOptions-optsPlan = PlanOptions-  <$> strOption-      (   long "build-path"-      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)-      <>  metavar "DIRECTORY"-      <>  value AS.buildPath-      )-  <*> strOption-      (   long "store-path"-      <>  help "Path to cabal store"-      <>  metavar "DIRECTORY"-      <>  value (AS.cabalDirectory </> "store")-      )-  <*> optional-      ( strOption-        (   long "store-path-hash"-        <>  help "Store path hash (do not use)"-        <>  metavar "HASH"-        )-      )-  <*> strOption-      (   long "output-file"-      <>  help "Output file"-      <>  metavar "FILE"-      <>  value "-"-      )--cmdPlan :: Mod CommandFields (IO ())-cmdPlan = command "plan"  $ flip info idm $ runPlan <$> optsPlan

@@ -1,250 +0,0 @@-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TupleSections       #-}-{-# LANGUAGE TypeApplications    #-}--module App.Commands.SyncFromArchive-  ( 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.Types       (SyncFromArchiveOptions (SyncFromArchiveOptions))-import Control.Applicative-import Control.Lens                     hiding ((<.>))-import Control.Monad.Catch              (MonadCatch)-import Control.Monad.Except-import Data.ByteString.Lazy.Search      (replace)-import Data.Generics.Product.Any        (the)-import Data.Maybe-import Foreign.C.Error                  (eXDEV)-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.IO.Error (catchErrno, exceptWarn, maybeToExcept)-import HaskellWorks.CabalCache.Location (toLocation, (<.>), (</>))-import HaskellWorks.CabalCache.Metadata (loadMetadata)-import HaskellWorks.CabalCache.Show-import HaskellWorks.CabalCache.Version  (archiveVersion)-import Options.Applicative              hiding (columns)-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 Data.ByteString.Char8                            as C8-import qualified Data.ByteString.Lazy                             as LBS-import qualified Data.List                                        as L-import qualified Data.Map                                         as M-import qualified Data.Map.Strict                                  as Map-import qualified Data.Text                                        as T-import qualified HaskellWorks.CabalCache.AWS.Env                  as AWS-import qualified HaskellWorks.CabalCache.Concurrent.DownloadQueue as DQ-import qualified HaskellWorks.CabalCache.Concurrent.Fork          as IO-import qualified HaskellWorks.CabalCache.Core                     as Z-import qualified HaskellWorks.CabalCache.Data.List                as L-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.Types                    as Z-import qualified System.Directory                                 as IO-import qualified System.IO                                        as IO-import qualified System.IO.Temp                                   as IO-import qualified System.IO.Unsafe                                 as IO--{- HLINT ignore "Monoid law, left identity" -}-{- HLINT ignore "Reduce duplication"        -}-{- HLINT ignore "Redundant do"              -}--skippable :: Z.Package -> Bool-skippable package = package ^. the @"packageType" == "pre-existing"--runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO ()-runSyncFromArchive opts = do-  let storePath             = opts ^. the @"storePath"-  let archiveUris           = opts ^. the @"archiveUris"-  let threads               = opts ^. the @"threads"-  let awsLogLevel           = opts ^. the @"awsLogLevel"-  let versionedArchiveUris  = archiveUris & each %~ (</> archiveVersion)-  let storePathHash         = opts ^. the @"storePathHash" & fromMaybe (H.hashStorePath storePath)-  let scopedArchiveUris     = versionedArchiveUris & each %~ (</> T.pack storePathHash)--  CIO.putStrLn $ "Store path: "       <> toText storePath-  CIO.putStrLn $ "Store path hash: "  <> T.pack storePathHash-  forM_ archiveUris $ \archiveUri -> do-    CIO.putStrLn $ "Archive URI: "      <> toText archiveUri-  CIO.putStrLn $ "Archive version: "  <> archiveVersion-  CIO.putStrLn $ "Threads: "          <> tshow threads-  CIO.putStrLn $ "AWS Log level: "    <> tshow awsLogLevel--  mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"--  case mbPlan of-    Right planJson -> do-      compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson--      case compilerContextResult of-        Right compilerContext -> do-          GhcPkg.testAvailability compilerContext--          envAws <- IO.unsafeInterleaveIO $ 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--          storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath--          unless storeCompilerPackageDbPathExists $ do-            CIO.putStrLn "Package DB missing. Creating Package DB"-            GhcPkg.init compilerContext storeCompilerPackageDbPath--          packages <- Z.getPackages storePath planJson--          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--          downloadQueue <- STM.atomically $ DQ.createDownloadQueue planDeps--          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.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--                storeDirectoryExists <- doesDirectoryExist packageStorePath--                case maybePackage of-                  Nothing -> do-                    CIO.hPutStrLn IO.stderr $ "Warning: package not found" <> packageId-                    return True-                  Just package -> if skippable package-                    then do-                      CIO.putStrLn $ "Skipping: " <> packageId-                      return True-                    else if storeDirectoryExists-                      then return True-                      else runResAws envAws $ onError (cleanupStorePath packageStorePath packageId) False $ do-                        (existingArchiveFileContents, existingArchiveFile) <- ExceptT $ IO.readFirstAvailableResource envAws (foldMap L.tuple2ToList (L.zip archiveFiles scopedArchiveFiles))-                        CIO.putStrLn $ "Extracting: " <> toText existingArchiveFile--                        let tempArchiveFile = tempPath </> archiveBaseName-                        liftIO $ LBS.writeFile tempArchiveFile existingArchiveFileContents-                        IO.extractTar tempArchiveFile storePath--                        meta <- loadMetadata packageStorePath-                        oldStorePath <- maybeToExcept "store-path is missing from Metadata" (Map.lookup "store-path" meta)--                        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 $ catchErrno [eXDEV] (IO.renameFile tempConfPath theConfPath) (IO.copyFile tempConfPath theConfPath >> IO.removeFile tempConfPath)--                            return True-              Nothing -> do-                CIO.hPutStrLn IO.stderr $ "Warning: Invalid package id: " <> packageId-                return True--          CIO.putStrLn "Recaching package database"-          GhcPkg.recache compilerContext storeCompilerPackageDbPath--          failures <- STM.atomically $ STM.readTVar $ downloadQueue ^. the @"tFailures"--          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--  return ()--cleanupStorePath :: (MonadIO m, MonadCatch m) => FilePath -> Z.PackageId -> AppError -> m ()-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--onError :: MonadIO m => (AppError -> m ()) -> a -> ExceptT AppError m a -> m a-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--optsSyncFromArchive :: Parser SyncFromArchiveOptions-optsSyncFromArchive = SyncFromArchiveOptions-  <$> option (auto <|> text)-      (  long "region"-      <> metavar "AWS_REGION"-      <> showDefault <> value Oregon-      <> 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"-        )-      )-  <*> strOption-      (   long "build-path"-      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)-      <>  metavar "DIRECTORY"-      <>  value AS.buildPath-      )-  <*> strOption-      (   long "store-path"-      <>  help ("Path to cabal store.  Defaults to " <> show AS.cabalDirectory)-      <>  metavar "DIRECTORY"-      <>  value (AS.cabalDirectory </> "store")-      )-  <*> optional-      ( strOption-        (   long "store-path-hash"-        <>  help "Store path hash (do not use)"-        <>  metavar "HASH"-        )-      )-  <*> option auto-      (   long "threads"-      <>  help "Number of concurrent threads"-      <>  metavar "NUM_THREADS"-      <>  value 4-      )-  <*> optional-      ( option autoText-        (   long "aws-log-level"-        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"-        <>  metavar "AWS_LOG_LEVEL"-        )-      )--cmdSyncFromArchive :: Mod CommandFields (IO ())-cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive

@@ -1,212 +0,0 @@-{-# LANGUAGE BlockArguments      #-}-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-{-# LANGUAGE TypeApplications    #-}--module App.Commands.SyncToArchive-  ( 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.Types       (SyncToArchiveOptions (SyncToArchiveOptions))-import Control.Applicative-import Control.Lens                     hiding ((<.>))-import Control.Monad.Except-import Control.Monad.Trans.Resource     (runResourceT)-import Data.Generics.Product.Any        (the)-import Data.List                        ((\\))-import Data.Maybe-import HaskellWorks.CabalCache.AppError-import HaskellWorks.CabalCache.Location (Location (..), toLocation, (<.>), (</>))-import HaskellWorks.CabalCache.Metadata (createMetadata)-import HaskellWorks.CabalCache.Show-import HaskellWorks.CabalCache.Topology (buildPlanData, canShare)-import HaskellWorks.CabalCache.Version  (archiveVersion)-import Options.Applicative              hiding (columns)-import System.Directory                 (doesDirectoryExist)--import qualified App.Commands.Options.Types         as Z-import qualified App.Static                         as AS-import qualified Control.Concurrent.STM             as STM-import qualified Data.ByteString.Lazy               as LBS-import qualified Data.ByteString.Lazy.Char8         as LC8-import qualified Data.Text                          as Text-import qualified Data.Text                          as T-import qualified HaskellWorks.CabalCache.AWS.Env    as AWS-import qualified HaskellWorks.CabalCache.Core       as Z-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 System.Directory                   as IO-import qualified System.IO                          as IO-import qualified System.IO.Temp                     as IO-import qualified System.IO.Unsafe                   as IO-import qualified UnliftIO.Async                     as IO--{- HLINT ignore "Monoid law, left identity" -}-{- HLINT ignore "Redundant do"              -}-{- HLINT ignore "Reduce duplication"        -}--runSyncToArchive :: Z.SyncToArchiveOptions -> IO ()-runSyncToArchive opts = do-  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--  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--  tEarlyExit <- STM.newTVarIO False--  mbPlan <- Z.loadPlan $ opts ^. the @"buildPath"--  case mbPlan of-    Right planJson -> do-      compilerContextResult <- runExceptT $ Z.mkCompilerContext planJson--      case compilerContextResult of-        Right compilerContext -> do-          let compilerId = planJson ^. the @"compilerId"-          envAws <- IO.unsafeInterleaveIO $ mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)-          let archivePath       = versionedArchiveUri </> compilerId-          let scopedArchivePath = scopedArchiveUri </> compilerId-          IO.createLocalDirectoryIfMissing archivePath-          IO.createLocalDirectoryIfMissing scopedArchivePath--          packages     <- Z.getPackages storePath planJson-          nonShareable <- packages & filterM (fmap not . isShareable storePath)-          let planData = buildPlanData planJson (nonShareable ^.. each . the @"packageId")--          let storeCompilerPath           = storePath </> T.unpack compilerId-          let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"--          storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath--          unless storeCompilerPackageDbPathExists $-            GhcPkg.init compilerContext storeCompilerPackageDbPath--          CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages"--          IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do-            CIO.putStrLn $ "Temp path: " <> tshow tempPath--            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--                -- 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--                archiveFileExists <- runResourceT $ IO.resourceExists envAws targetFile--                unless archiveFileExists $ do-                  packageStorePathExists <- doesDirectoryExist packageStorePath--                  when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn $ do-                    let workingStorePackagePath = tempPath </> Z.packageDir pInfo-                    liftIO $ IO.createDirectoryIfMissing True workingStorePackagePath--                    let rp2 = Z.relativePaths storePath pInfo--                    CIO.putStrLn $ "Creating " <> toText targetFile--                    let tempArchiveFile = tempPath </> archiveFileBasename--                    metas <- createMetadata tempPath pInfo [("store-path", LC8.pack storePath)]--                    IO.createTar tempArchiveFile (rp2 <> [metas])--                    void $ catchError (liftIO (LBS.readFile tempArchiveFile) >>= IO.writeResource envAws targetFile) $ \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--                      _ -> return ()-        Left msg -> CIO.hPutStrLn IO.stderr msg--    Left (appError :: AppError) -> do-      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> displayAppError appError--  earlyExit <- STM.readTVarIO tEarlyExit--  when earlyExit $ CIO.hPutStrLn IO.stderr "Early exit due to error"--isShareable :: MonadIO m => FilePath -> Z.PackageInfo -> m Bool-isShareable storePath pkg =-  let packageSharePath = storePath </> Z.packageDir pkg </> "share"-  in IO.listMaybeDirectory packageSharePath <&> (\\ ["doc"]) <&> null--optsSyncToArchive :: Parser SyncToArchiveOptions-optsSyncToArchive = SyncToArchiveOptions-  <$> option (auto <|> text)-      (  long "region"-      <> metavar "AWS_REGION"-      <> showDefault <> value Oregon-      <> 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 $ AS.cabalDirectory </> "archive")-      )-  <*> strOption-      (   long "build-path"-      <>  help ("Path to cabal build directory.  Defaults to " <> show AS.buildPath)-      <>  metavar "DIRECTORY"-      <>  value AS.buildPath-      )-  <*> strOption-      (   long "store-path"-      <>  help "Path to cabal store"-      <>  metavar "DIRECTORY"-      <>  value (AS.cabalDirectory </> "store")-      )-  <*> optional-      ( strOption-        (   long "store-path-hash"-        <>  help "Store path hash (do not use)"-        <>  metavar "HASH"-        )-      )-  <*> option auto-      (   long "threads"-      <>  help "Number of concurrent threads"-      <>  metavar "NUM_THREADS"-      <>  value 4-      )-  <*> optional-      ( option autoText-        (   long "aws-log-level"-        <>  help "AWS Log Level.  One of (Error, Info, Debug, Trace)"-        <>  metavar "AWS_LOG_LEVEL"-        )-      )--cmdSyncToArchive :: Mod CommandFields (IO ())-cmdSyncToArchive = command "sync-to-archive"  $ flip info idm $ runSyncToArchive <$> optsSyncToArchive

@@ -1,32 +0,0 @@-{-# LANGUAGE DataKinds           #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE RecordWildCards     #-}-{-# LANGUAGE ScopedTypeVariables #-}--module App.Commands.Version-  ( cmdVersion-  ) where--import App.Commands.Options.Parser (optsVersion)-import Data.List-import Options.Applicative         hiding (columns)--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--{- HLINT ignore "Redundant do"        -}-{- HLINT ignore "Reduce duplication"  -}--runVersion :: Z.VersionOptions -> IO ()-runVersion _ = do-  let V.Version {..} = P.version--  let version = intercalate "." $ fmap show versionBranch--  CIO.putStrLn $ "cabal-cache " <> T.pack version--cmdVersion :: Mod CommandFields (IO ())-cmdVersion = command "version"  $ flip info idm $ runVersion <$> optsVersion

@@ -1,11 +0,0 @@-module App.Static where--import qualified App.Static.Base    as S-import qualified App.Static.Posix   as P-import qualified App.Static.Windows as W--cabalDirectory :: FilePath-cabalDirectory = if S.isPosix then P.cabalDirectory else W.cabalDirectory--buildPath :: FilePath-buildPath = "dist-newstyle"

@@ -1,13 +0,0 @@-module App.Static.Base where--import qualified System.Directory as IO-import qualified System.Info      as I-import qualified System.IO.Unsafe as IO--homeDirectory :: FilePath-homeDirectory = IO.unsafePerformIO IO.getHomeDirectory-{-# NOINLINE homeDirectory #-}--isPosix :: Bool-isPosix = I.os /= "mingw32"-{-# NOINLINE isPosix #-}

@@ -1,8 +0,0 @@-module App.Static.Posix where--import HaskellWorks.CabalCache.Location ((</>))--import qualified App.Static.Base as S--cabalDirectory :: FilePath-cabalDirectory = S.homeDirectory </> ".cabal"

@@ -1,15 +0,0 @@-module App.Static.Windows where--import Data.Maybe-import HaskellWorks.CabalCache.Location ((</>))--import qualified App.Static.Base    as S-import qualified System.Environment as IO-import qualified System.IO.Unsafe   as IO--appDataDirectory :: FilePath-appDataDirectory = IO.unsafePerformIO $ fmap (fromMaybe S.homeDirectory) (IO.lookupEnv "APPDATA")-{-# NOINLINE appDataDirectory #-}--cabalDirectory :: FilePath-cabalDirectory = appDataDirectory </> "cabal"

@@ -10,16 +10,9 @@   ) where  import Control.Monad.Except-import Foreign.C.Error-  (-    getErrno-  , Errno-  )+import Foreign.C.Error                  (Errno, getErrno) import HaskellWorks.CabalCache.AppError-import System.IO.Error-  (-    catchIOError-  )+import System.IO.Error                  (catchIOError)  import qualified HaskellWorks.CabalCache.IO.Console as CIO import qualified System.Exit                        as IO

@@ -22,12 +22,14 @@ 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 HaskellWorks.CabalCache.AppError import HaskellWorks.CabalCache.Location (Location (..)) import HaskellWorks.CabalCache.Show+import Network.URI                      (URI)  import qualified Antiope.S3.Lazy                    as AWS import qualified Control.Concurrent                 as IO@@ -40,6 +42,7 @@ 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@@ -64,19 +67,28 @@       _                               -> return (Left (GenericAppError (tshow e')))     _                                 -> throwM e -getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError LBS.ByteString)-getS3Uri envAws s3Uri = case reslashS3Uri s3Uri of-  (AWS.S3Uri b k) -> handleAwsError $ runAws envAws $ AWS.unsafeDownload b k+getS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> URI -> m (Either AppError LBS.ByteString)+getS3Uri envAws uri = runExceptT $ 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+ readResource :: (MonadResource m, MonadCatch m) => AWS.Env -> Location -> m (Either AppError LBS.ByteString) readResource envAws = \case-  S3 s3Uri        -> getS3Uri envAws (reslashS3Uri s3Uri)-  Local path      -> liftIO $ do+  Local path -> liftIO $ do     fileExists <- IO.doesFileExist path     if fileExists       then Right <$> LBS.readFile path       else pure (Left NotFound)-  HttpUri httpUri -> liftIO $ readHttpUri (reslashHttpUri httpUri)+  Uri uri -> case uri ^. the @"uriScheme" of+    "s3:"     -> getS3Uri envAws (reslashUri uri)+    "http:"   -> liftIO $ readHttpUri (reslashUri uri)+    "https:"  -> liftIO $ readHttpUri (reslashUri uri)+    scheme    -> return (Left (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)))  readFirstAvailableResource :: (MonadResource m, MonadCatch m) => AWS.Env -> [Location] -> m (Either AppError (LBS.ByteString, Location)) readFirstAvailableResource _ [] = return (Left (GenericAppError "No resources specified in read"))@@ -97,8 +109,6 @@  resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool resourceExists envAws = \case-  S3 s3Uri        -> isRight <$> runResourceT (headS3Uri envAws (reslashS3Uri s3Uri))-  HttpUri httpUri -> isRight <$> headHttpUri (reslashHttpUri httpUri)   Local path  -> do     fileExists <- liftIO $ IO.doesFileExist path     if fileExists@@ -110,6 +120,10 @@             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 <$> headHttpUri (reslashUri uri)+    _scheme -> return False  firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location) firstExistingResource _ [] = return Nothing@@ -119,38 +133,45 @@     then return (Just a)     else firstExistingResource envAws as -headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either AppError AWS.HeadObjectResponse)-headS3Uri envAws s3Uri = case reslashS3Uri s3Uri of-  AWS.S3Uri b k -> handleAwsError $ runAws envAws $ AWS.send $ AWS.headObject b k--uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m (Either AppError ())-uploadToS3 envAws s3Uri lbs = case reslashS3Uri s3Uri of-  AWS.S3Uri b k -> do-    let req = AWS.toBody lbs-    let po  = AWS.putObject b k req-    handleAwsError $ void $ runResAws envAws $ AWS.send po+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 -reslashS3Uri :: S3Uri -> S3Uri-reslashS3Uri uri = uri & the @"objectKey" . the @1 %~ (T.replace "\\" "/")+uploadToS3 :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> URI -> LBS.ByteString -> m (Either AppError ())+uploadToS3 envAws uri lbs = runExceptT $ 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 -reslashHttpUri :: Text -> Text-reslashHttpUri = T.replace "\\" "/"+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 -> LBS.ByteString -> ExceptT AppError m () writeResource envAws loc lbs = ExceptT $ case loc of-  S3 s3Uri   -> uploadToS3 envAws (reslashS3Uri s3Uri) lbs   Local path -> liftIO (LBS.writeFile path lbs) >> return (Right ())-  HttpUri _  -> return (Left (GenericAppError "HTTP PUT method not supported"))+  Uri uri       -> case uri ^. the @"uriScheme" of+    "s3:"   -> uploadToS3 envAws (reslashUri uri) lbs+    "http:" -> return (Left (GenericAppError "HTTP PUT method not supported"))+    scheme  -> return (Left (GenericAppError ("Unrecognised uri scheme: " <> T.pack scheme)))  createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m () createLocalDirectoryIfMissing = \case-  S3 _        -> return ()-  Local path  -> liftIO $ IO.createDirectoryIfMissing True path-  HttpUri _   -> return ()+  Local path -> liftIO $ IO.createDirectoryIfMissing True path+  Uri uri       -> case uri ^. the @"uriScheme" of+    "s3:"   -> return ()+    "http:" -> return ()+    _scheme -> return () -copyS3Uri :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT AppError m ()-copyS3Uri envAws source target = case (reslashS3Uri source, reslashS3Uri target) of-  (AWS.S3Uri sourceBucket sourceObjectKey, AWS.S3Uri targetBucket targetObjectKey) -> ExceptT $ do+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@@ -181,31 +202,31 @@  linkOrCopyResource :: (MonadUnliftIO m, MonadCatch m) => AWS.Env -> Location -> Location -> ExceptT AppError m () linkOrCopyResource envAws source target = case source of-  S3 sourceS3Uri -> case target of-    S3 targetS3Uri -> retryUnless ((== Just 301) . appErrorStatus) 3 (copyS3Uri envAws (reslashS3Uri sourceS3Uri) (reslashS3Uri targetS3Uri))-    Local _        -> throwError "Can't copy between different file backends"-    HttpUri _      -> throwError "Link and copy unsupported for http backend"   Local sourcePath -> case target of-    S3 _             -> throwError "Can't copy between different file backends"     Local targetPath -> do       liftIO $ IO.createDirectoryIfMissing True (FP.takeDirectory targetPath)       targetPathExists <- liftIO $ IO.doesFileExist targetPath       unless targetPathExists $ liftIO $ IO.createFileLink sourcePath targetPath-    HttpUri _      -> throwError "Link and copy unsupported for http backend"-  HttpUri _ -> throwError "HTTP PUT method not supported"+    Uri _ -> throwError "Can't copy between different file backends"+  Uri sourceUri -> case target of+    Local _targetPath -> throwError "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 -readHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString)+readHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString) readHttpUri httpUri = handleHttpError $ do-  manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings-  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> reslashHttpUri httpUri))+  manager <- liftIO $ HTTP.newManager HTTPS.tlsManagerSettings+  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("GET " <> tshow (reslashUri httpUri)))   response <- liftIO $ HTTP.httpLbs request manager    return $ HTTP.responseBody response -headHttpUri :: (MonadIO m, MonadCatch m) => Text -> m (Either AppError LBS.ByteString)+headHttpUri :: (MonadIO m, MonadCatch m) => URI -> m (Either AppError LBS.ByteString) headHttpUri httpUri = handleHttpError $ do   manager <- liftIO $ HTTP.newManager HTTP.defaultManagerSettings-  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> (reslashHttpUri httpUri)))+  request <- liftIO $ HTTP.parseUrlThrow (T.unpack ("HEAD " <> tshow (reslashUri httpUri)))   response <- liftIO $ HTTP.httpLbs request manager    return $ HTTP.responseBody response

@@ -1,8 +1,11 @@+{-# LANGUAGE DataKinds              #-} {-# LANGUAGE DeriveGeneric          #-} {-# LANGUAGE FunctionalDependencies #-} {-# LANGUAGE MultiWayIf             #-} {-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE TypeApplications       #-} {-# LANGUAGE TypeFamilies           #-}+ module HaskellWorks.CabalCache.Location ( IsPath(..) , Location(..)@@ -10,13 +13,18 @@ ) where -import Antiope.Core (ToText (..), fromText)-import Antiope.S3   (ObjectKey (..), S3Uri (..))-import Data.Maybe   (fromMaybe)-import Data.Text    (Text)-import GHC.Generics (Generic)+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 qualified Data.Text       as T+import qualified Network.URI     as URI import qualified System.FilePath as FP  class IsPath a s | a -> s where@@ -27,29 +35,29 @@ infixr 7 <.>  data Location-  = S3 S3Uri+  = Uri URI   | Local FilePath-  | HttpUri Text   deriving (Show, Eq, Generic)  instance ToText Location where-  toText (S3 uri)       = toText uri-  toText (Local p)      = T.pack p-  toText (HttpUri uri)  = uri+  toText (Uri uri) = tshow uri+  toText (Local p) = T.pack p  instance IsPath Location Text where-  (S3      b) </> p = S3      (b </>          p)-  (Local   b) </> p = Local   (b </> T.unpack p)-  (HttpUri b) </> p = HttpUri (b </>          p)+  Uri   b </> p = Uri   (b </> p)+  Local b </> p = Local (b </> T.unpack p) -  (S3      b) <.> e = S3      (b <.>          e)-  (Local   b) <.> e = Local   (b <.> T.unpack e)-  (HttpUri b) <.> e = HttpUri (b <.>          e)+  Uri   b <.> e = Uri   (b <.> e)+  Local b <.> e = Local (b <.> T.unpack e)  instance IsPath Text Text where   b </> p = T.pack (T.unpack b FP.</> T.unpack p)   b <.> e = T.pack (T.unpack b FP.<.> T.unpack e) +instance IsPath URI Text where+  b </> p = b & the @"uriPath" %~ (<> "/" <> T.unpack p)+  b <.> e = b & the @"uriPath" %~ (<> "." <> T.unpack e)+ instance (a ~ Char) => IsPath [a] [a] where   b </> p = b FP.</> p   b <.> e = b FP.<.> e@@ -62,13 +70,9 @@     S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e))  toLocation :: Text -> Maybe Location-toLocation txt = if-  | T.isPrefixOf "s3://" txt'    -> either (const Nothing) (Just . S3) (fromText txt')-  | T.isPrefixOf "file://" txt'  -> Just (Local (T.unpack txt'))-  | T.isPrefixOf "http://" txt'  -> Just (HttpUri txt')-  | T.isInfixOf  "://" txt'      -> Nothing-  | otherwise                       -> Just (Local (T.unpack txt'))-  where txt' = T.strip txt+toLocation t = case URI.parseURI (T.unpack t) of+  Just uri -> Just (Uri uri)+  Nothing  -> Just (Local (T.unpack t))  ------------------------------------------------------------------------------- stripStart :: Text -> Text -> Text

@@ -1,5 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} +{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}+ module HaskellWorks.CabalCache.AwsSpec   ( spec   ) where@@ -16,9 +18,9 @@ import Hedgehog import Test.Hspec -import qualified Antiope.S3.Types           as AWS 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  {- HLINT ignore "Redundant do"        -}@@ -31,7 +33,8 @@     ci <- liftIO $ IO.lookupEnv "CI" <&> isJust     unless ci $ do       envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn)-      result <- liftIO $ runResourceT $ headS3Uri envAws $ AWS.S3Uri "jky-mayhem" "hjddhd"+      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" }         }

@@ -5,31 +5,33 @@ ) where  import Antiope.Core                     (toText)-import Antiope.S3                       (BucketName (..), ObjectKey (..), S3Uri (..)) import HaskellWorks.CabalCache.Location +import Data.Maybe                  (fromJust) import HaskellWorks.Hspec.Hedgehog import Hedgehog+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  {- HLINT ignore "Redundant do"        -} {- HLINT ignore "Reduce duplication"  -} {- HLINT ignore "Redundant bracket"   -} -s3Uri :: MonadGen m => m S3Uri+s3Uri :: MonadGen m => m URI s3Uri = do-  let partGen = Gen.text (Range.linear 3 10) Gen.alphaNum+  let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum   bkt <- partGen   parts <- Gen.list (Range.linear 1 5) partGen-  ext <- Gen.text (Range.linear 2 4) Gen.alphaNum-  pure $ S3Uri (BucketName bkt) (ObjectKey (Text.intercalate "/" parts <> "." <> ext))-+  ext <- Gen.string (Range.linear 2 4) Gen.alphaNum+  pure $ fromJust $ URI.parseURI $ "s3://" <> bkt <> "/" <> L.intercalate "/" parts <> "." <> ext localPath :: MonadGen m => m FilePath localPath = do   let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum@@ -39,24 +41,28 @@  spec :: Spec 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+    fromJust (toLocation "s3://bucket") </> "directory" === fromJust (toLocation "s3://bucket/directory")+   it "S3 should roundtrip from and to text" $ require $ property $ do     uri <- forAll s3Uri-    tripping (S3 uri) toText toLocation+    tripping (Uri uri) toText toLocation    it "LocalLocation should roundtrip from and to text" $ require $ property $ do     path <- forAll localPath     tripping (Local path) toText toLocation    it "Should append s3 path" $ require $ property $ do-    loc  <- S3 <$> forAll s3Uri+    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-    toText (loc </> ("/" <> part) <.> ("." <> ext)) === (toText loc) <> "/" <> part <> "." <> ext+    toText (loc </> part <.> ext) === toText loc <> "/" <> part <> "." <> ext    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)-