cabal-cache 1.0.0.1 → 1.0.0.2

raw patch · 48 files changed

+1292/−944 lines, 48 filesdep +antiope-optparse-applicativedep +http-clientdep +stmdep ~antiope-coredep ~antiope-s3PVP: major bump suggested

API removals or changes: PVP suggests a major version bump

Dependencies added: antiope-optparse-applicative, http-client, stm

Dependency ranges changed: antiope-core, antiope-s3

API changes (from Hackage documentation)

Files

• cabal-cache.cabal +67/−55
• src/App/Commands/Options/Parser.hs +22/−5
• src/App/Commands/Options/Types.hs +9/−5
• src/App/Commands/SyncFromArchive.hs +43/−40
• src/App/Commands/SyncToArchive.hs +41/−37
• src/App/Commands/Version.hs +4/−4
• src/HaskellWorks/CabalCache/AWS/Env.hs +24/−0
• src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs +60/−0
• src/HaskellWorks/CabalCache/Concurrent/Type.hs +27/−0
• src/HaskellWorks/CabalCache/Core.hs +102/−0
• src/HaskellWorks/CabalCache/Data/Relation.hs +94/−0
• src/HaskellWorks/CabalCache/Data/Relation/Type.hs +15/−0
• src/HaskellWorks/CabalCache/GhcPkg.hs +27/−0
• src/HaskellWorks/CabalCache/Hash.hs +10/−0
• src/HaskellWorks/CabalCache/IO/Console.hs +36/−0
• src/HaskellWorks/CabalCache/IO/Error.hs +35/−0
• src/HaskellWorks/CabalCache/IO/File.hs +32/−0
• src/HaskellWorks/CabalCache/IO/Lazy.hs +141/−0
• src/HaskellWorks/CabalCache/IO/Tar.hs +51/−0
• src/HaskellWorks/CabalCache/Location.hs +74/−0
• src/HaskellWorks/CabalCache/Metadata.hs +40/−0
• src/HaskellWorks/CabalCache/Options.hs +14/−0
• src/HaskellWorks/CabalCache/Show.hs +10/−0
• src/HaskellWorks/CabalCache/Text.hs +11/−0
• src/HaskellWorks/CabalCache/Types.hs +41/−0
• src/HaskellWorks/CabalCache/Version.hs +8/−0
• src/HaskellWorks/Ci/Assist/Core.hs +0/−102
• src/HaskellWorks/Ci/Assist/GhcPkg.hs +0/−28
• src/HaskellWorks/Ci/Assist/Hash.hs +0/−10
• src/HaskellWorks/Ci/Assist/IO/Console.hs +0/−36
• src/HaskellWorks/Ci/Assist/IO/Error.hs +0/−35
• src/HaskellWorks/Ci/Assist/IO/File.hs +0/−32
• src/HaskellWorks/Ci/Assist/IO/Lazy.hs +0/−139
• src/HaskellWorks/Ci/Assist/IO/Tar.hs +0/−51
• src/HaskellWorks/Ci/Assist/Location.hs +0/−74
• src/HaskellWorks/Ci/Assist/Metadata.hs +0/−40
• src/HaskellWorks/Ci/Assist/Options.hs +0/−14
• src/HaskellWorks/Ci/Assist/Show.hs +0/−10
• src/HaskellWorks/Ci/Assist/Text.hs +0/−11
• src/HaskellWorks/Ci/Assist/Types.hs +0/−37
• src/HaskellWorks/Ci/Assist/Version.hs +0/−8
• test/HaskellWorks/Assist/AwsSpec.hs +0/−41
• test/HaskellWorks/Assist/LocationSpec.hs +0/−67
• test/HaskellWorks/Assist/QuerySpec.hs +0/−63
• test/HaskellWorks/CabalCache/AwsSpec.hs +41/−0
• test/HaskellWorks/CabalCache/Data/RelationSpec.hs +79/−0
• test/HaskellWorks/CabalCache/LocationSpec.hs +67/−0
• test/HaskellWorks/CabalCache/QuerySpec.hs +67/−0

@@ -1,7 +1,7 @@ cabal-version:          2.2  name:                   cabal-cache-version:                1.0.0.1+version:                1.0.0.2 synopsis:               CI Assistant for Haskell projects description:            CI Assistant for Haskell projects.  Implements package caching. homepage:               https://github.com/haskell-works/cabal-cache@@ -17,42 +17,45 @@   type: git   location: https://github.com/haskell-works/cabal-cache -common base                 { build-depends: base                 >= 4.7        && < 5      }+common base                           { build-depends: base                           >= 4.7        && < 5      } -common aeson                { build-depends: aeson                >= 1.4.2.0    && < 1.5    }-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.0.0      && < 8      }-common antiope-s3           { build-depends: antiope-s3           >= 7.0.0      && < 8      }-common bytestring           { build-depends: bytestring           >= 0.10.8.2   && < 0.11   }-common conduit-extra        { build-depends: conduit-extra        >= 1.3.1.1    && < 1.4    }-common cryptonite           { build-depends: cryptonite           >= 0.25       && < 1      }-common containers           { build-depends: containers           >= 0.6.0.1    && < 0.7    }-common deepseq              { build-depends: deepseq              >= 1.4.4.0    && < 1.5    }-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    && < 1.2    }-common hedgehog             { build-depends: hedgehog             >= 0.5        && < 0.7    }-common hspec                { build-depends: hspec                >= 2.4        && < 3      }-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 mtl                  { build-depends: mtl                  >= 2.2.2      && < 2.3    }-common optparse-applicative { build-depends: optparse-applicative >= 0.14       && < 0.15   }-common process              { build-depends: process              >= 1.6.5.0    && < 1.7    }-common raw-strings-qq       { build-depends: raw-strings-qq       >= 1.1        && < 2      }-common resourcet            { build-depends: resourcet            >= 1.2.2      && < 1.3    }-common selective            { build-depends: selective            >= 0.1.0      && < 0.2    }-common stringsearch         { build-depends: stringsearch         >= 0.3.6.6    && < 0.4    }-common tar                  { build-depends: tar                  >= 0.5.1.0    && < 0.6    }-common temporary            { build-depends: temporary            >= 1.3        && < 1.4    }-common text                 { build-depends: text                 >= 1.2.3.1    && < 1.3    }-common time                 { build-depends: time                 >= 1.4        && < 1.10   }-common unliftio             { build-depends: unliftio             >= 0.2.10     && < 0.3    }-common zlib                 { build-depends: zlib                 >= 0.6.2      && < 0.7    }+common aeson                          { build-depends: aeson                          >= 1.4.2.0    && < 1.5    }+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.0.1      && < 8      }+common antiope-optparse-applicative   { build-depends: antiope-optparse-applicative   >= 7.0.1      && < 8      }+common antiope-s3                     { build-depends: antiope-s3                     >= 7.0.1      && < 8      }+common bytestring                     { build-depends: bytestring                     >= 0.10.8.2   && < 0.11   }+common conduit-extra                  { build-depends: conduit-extra                  >= 1.3.1.1    && < 1.4    }+common cryptonite                     { build-depends: cryptonite                     >= 0.25       && < 1      }+common containers                     { build-depends: containers                     >= 0.6.0.1    && < 0.7    }+common deepseq                        { build-depends: deepseq                        >= 1.4.4.0    && < 1.5    }+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    && < 1.2    }+common hedgehog                       { build-depends: hedgehog                       >= 0.5        && < 0.7    }+common hspec                          { build-depends: hspec                          >= 2.4        && < 3      }+common http-client                    { build-depends: http-client                    >= 0.5.14     && < 0.7    }+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 mtl                            { build-depends: mtl                            >= 2.2.2      && < 2.3    }+common optparse-applicative           { build-depends: optparse-applicative           >= 0.14       && < 0.15   }+common process                        { build-depends: process                        >= 1.6.5.0    && < 1.7    }+common raw-strings-qq                 { build-depends: raw-strings-qq                 >= 1.1        && < 2      }+common resourcet                      { build-depends: resourcet                      >= 1.2.2      && < 1.3    }+common selective                      { build-depends: selective                      >= 0.1.0      && < 0.2    }+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    }+common temporary                      { build-depends: temporary                      >= 1.3        && < 1.4    }+common text                           { build-depends: text                           >= 1.2.3.1    && < 1.3    }+common time                           { build-depends: time                           >= 1.4        && < 1.10   }+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@@ -64,6 +67,7 @@           , amazonka-core           , amazonka-s3           , antiope-core+          , antiope-optparse-applicative           , antiope-s3           , bytestring           , conduit-extra@@ -74,6 +78,7 @@           , exceptions           , filepath           , generic-lens+          , http-client           , http-types           , lens           , mtl@@ -81,12 +86,12 @@           , process           , resourcet           , selective+          , stm           , stringsearch           , tar           , temporary           , text           , time-                   , unliftio           , zlib   other-modules:        Paths_cabal_cache@@ -100,21 +105,26 @@       App.Commands.SyncToArchive       App.Commands.Version       App.Static-      HaskellWorks.Ci.Assist.Core-      HaskellWorks.Ci.Assist.Hash-      HaskellWorks.Ci.Assist.IO.Console-      HaskellWorks.Ci.Assist.GhcPkg-      HaskellWorks.Ci.Assist.IO.Error-      HaskellWorks.Ci.Assist.IO.File-      HaskellWorks.Ci.Assist.IO.Lazy-      HaskellWorks.Ci.Assist.IO.Tar-      HaskellWorks.Ci.Assist.Location-      HaskellWorks.Ci.Assist.Metadata-      HaskellWorks.Ci.Assist.Options-      HaskellWorks.Ci.Assist.Show-      HaskellWorks.Ci.Assist.Text-      HaskellWorks.Ci.Assist.Types-      HaskellWorks.Ci.Assist.Version+      HaskellWorks.CabalCache.AWS.Env+      HaskellWorks.CabalCache.Concurrent.DownloadQueue+      HaskellWorks.CabalCache.Concurrent.Type+      HaskellWorks.CabalCache.Core+      HaskellWorks.CabalCache.Data.Relation+      HaskellWorks.CabalCache.Data.Relation.Type+      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.Types+      HaskellWorks.CabalCache.Version  executable cabal-cache   import:   base, config@@ -130,6 +140,7 @@           , antiope-core           , antiope-s3           , bytestring+          , containers           , filepath           , generic-lens           , hedgehog@@ -147,6 +158,7 @@   ghc-options:          -threaded -rtsopts -with-rtsopts=-N   build-tools:          hspec-discover   other-modules:-      HaskellWorks.Assist.AwsSpec-      HaskellWorks.Assist.LocationSpec-      HaskellWorks.Assist.QuerySpec+      HaskellWorks.CabalCache.AwsSpec+      HaskellWorks.CabalCache.Data.RelationSpec+      HaskellWorks.CabalCache.LocationSpec+      HaskellWorks.CabalCache.QuerySpec

@@ -1,14 +1,17 @@ {-# LANGUAGE OverloadedStrings #-}+ module App.Commands.Options.Parser where -import Antiope.Core                    (FromText, Region (..), fromText)-import App.Commands.Options.Types      (SyncFromArchiveOptions (..), SyncToArchiveOptions (..), VersionOptions (..))-import App.Static                      (homeDirectory)+import Antiope.Core                     (FromText, Region (..), fromText)+import Antiope.Options.Applicative+import App.Commands.Options.Types       (SyncFromArchiveOptions (..), SyncToArchiveOptions (..), VersionOptions (..))+import App.Static                       (homeDirectory) import Control.Applicative-import HaskellWorks.Ci.Assist.Location (Location (..), toLocation, (</>))+import HaskellWorks.CabalCache.Location (Location (..), toLocation, (</>)) import Options.Applicative -import qualified Data.Text as Text+import qualified Data.Text         as Text+import qualified Network.AWS.Types as AWS  optsSyncFromArchive :: Parser SyncFromArchiveOptions optsSyncFromArchive = SyncFromArchiveOptions@@ -43,6 +46,13 @@       <>  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"+        )+      )  optsSyncToArchive :: Parser SyncToArchiveOptions optsSyncToArchive = SyncToArchiveOptions@@ -76,6 +86,13 @@       <>  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"+        )       )  optsVersion :: Parser VersionOptions

@@ -3,19 +3,22 @@  module App.Commands.Options.Types where -import Antiope.Env                     (Region)-import Data.Text                       (Text)+import Antiope.Env                      (Region)+import Data.Text                        (Text) import GHC.Generics-import GHC.Word                        (Word8)-import HaskellWorks.Ci.Assist.Location-import Network.AWS.Types               (Region)+import GHC.Word                         (Word8)+import HaskellWorks.CabalCache.Location+import Network.AWS.Types                (Region) +import qualified Antiope.Env as AWS+ data SyncToArchiveOptions = SyncToArchiveOptions   { region        :: Region   , archiveUri    :: Location   , storePath     :: FilePath   , storePathHash :: Maybe String   , threads       :: Int+  , awsLogLevel   :: Maybe AWS.LogLevel   } deriving (Eq, Show, Generic)  data SyncFromArchiveOptions = SyncFromArchiveOptions@@ -24,6 +27,7 @@   , storePath     :: FilePath   , storePathHash :: Maybe String   , threads       :: Int+  , awsLogLevel   :: Maybe AWS.LogLevel   } deriving (Eq, Show, Generic)  data VersionOptions = VersionOptions deriving (Eq, Show, Generic)

@@ -7,48 +7,49 @@   ( cmdSyncFromArchive   ) where -import Antiope.Core                    (runResAws, toText)-import Antiope.Env                     (LogLevel, mkEnv)-import App.Commands.Options.Parser     (optsSyncFromArchive)-import App.Static                      (homeDirectory)-import Control.Lens                    hiding ((<.>))-import Control.Monad                   (unless, void, when)+import Antiope.Core                     (runResAws, toText)+import Antiope.Env                      (LogLevel, mkEnv)+import App.Commands.Options.Parser      (optsSyncFromArchive)+import App.Static                       (homeDirectory)+import Control.Lens                     hiding ((<.>))+import Control.Monad                    (unless, void, when) import Control.Monad.Except-import Control.Monad.IO.Class          (liftIO)-import Control.Monad.Trans.Resource    (runResourceT)-import Data.ByteString.Lazy.Search     (replace)-import Data.Generics.Product.Any       (the)+import Control.Monad.IO.Class           (liftIO)+import Control.Monad.Trans.Resource     (runResourceT)+import Data.ByteString.Lazy.Search      (replace)+import Data.Generics.Product.Any        (the) import Data.Maybe-import Data.Semigroup                  ((<>))-import Data.Text                       (Text)-import HaskellWorks.Ci.Assist.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan)-import HaskellWorks.Ci.Assist.IO.Error (exceptWarn, maybeToExcept, maybeToExceptM)-import HaskellWorks.Ci.Assist.Location ((<.>), (</>))-import HaskellWorks.Ci.Assist.Metadata (deleteMetadata, loadMetadata)-import HaskellWorks.Ci.Assist.Show-import HaskellWorks.Ci.Assist.Version  (archiveVersion)-import Network.AWS.Types               (Region (Oregon))-import Options.Applicative             hiding (columns)-import System.Directory                (createDirectoryIfMissing, doesDirectoryExist)+import Data.Semigroup                   ((<>))+import Data.Text                        (Text)+import HaskellWorks.CabalCache.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan)+import HaskellWorks.CabalCache.IO.Error (exceptWarn, maybeToExcept, maybeToExceptM)+import HaskellWorks.CabalCache.Location ((<.>), (</>))+import HaskellWorks.CabalCache.Metadata (deleteMetadata, loadMetadata)+import HaskellWorks.CabalCache.Show+import HaskellWorks.CabalCache.Version  (archiveVersion)+import Network.AWS.Types                (Region (Oregon))+import Options.Applicative              hiding (columns)+import System.Directory                 (createDirectoryIfMissing, doesDirectoryExist) -import qualified App.Commands.Options.Types        as Z-import qualified Codec.Archive.Tar                 as F-import qualified Codec.Compression.GZip            as F-import qualified Data.ByteString                   as BS-import qualified Data.ByteString.Char8             as C8-import qualified Data.ByteString.Lazy              as LBS-import qualified Data.Map.Strict                   as Map-import qualified Data.Text                         as T-import qualified HaskellWorks.Ci.Assist.GhcPkg     as GhcPkg-import qualified HaskellWorks.Ci.Assist.Hash       as H-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO-import qualified HaskellWorks.Ci.Assist.IO.Lazy    as IO-import qualified HaskellWorks.Ci.Assist.IO.Tar     as IO-import qualified HaskellWorks.Ci.Assist.Types      as Z-import qualified System.Directory                  as IO-import qualified System.IO                         as IO-import qualified System.IO.Temp                    as IO-import qualified UnliftIO.Async                    as IO+import qualified App.Commands.Options.Types         as Z+import qualified Codec.Archive.Tar                  as F+import qualified Codec.Compression.GZip             as F+import qualified Data.ByteString                    as BS+import qualified Data.ByteString.Char8              as C8+import qualified Data.ByteString.Lazy               as LBS+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.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 UnliftIO.Async                     as IO  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} {-# ANN module ("HLint: ignore Redundant do"        :: String) #-}@@ -58,6 +59,7 @@   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@@ -67,13 +69,14 @@   CIO.putStrLn $ "Archive URI: "      <> toText archiveUri   CIO.putStrLn $ "Archive version: "  <> archiveVersion   CIO.putStrLn $ "Threads: "          <> tshow threads+  CIO.putStrLn $ "AWS Log level: "    <> tshow awsLogLevel    GhcPkg.testAvailability    mbPlan <- loadPlan   case mbPlan of     Right planJson -> do-      envAws <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())+      envAws <- mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)       let compilerId                  = planJson ^. the @"compilerId"       let archivePath                 = versionedArchiveUri </> compilerId       let storeCompilerPath           = storePath </> T.unpack compilerId

@@ -7,45 +7,47 @@   ( cmdSyncToArchive   ) where -import Antiope.Core                    (toText)-import Antiope.Env                     (LogLevel, mkEnv)-import App.Commands.Options.Parser     (optsSyncToArchive)-import App.Static                      (homeDirectory)-import Control.Lens                    hiding ((<.>))-import Control.Monad                   (unless, when)+import Antiope.Core                     (toText)+import Antiope.Env                      (LogLevel (..), mkEnv)+import App.Commands.Options.Parser      (optsSyncToArchive)+import App.Static                       (homeDirectory)+import Control.Lens                     hiding ((<.>))+import Control.Monad                    (unless, when) import Control.Monad.Except-import Control.Monad.Trans.Resource    (runResourceT)-import Data.Generics.Product.Any       (the)-import Data.List                       (isSuffixOf, (\\))+import Control.Monad.Trans.Resource     (runResourceT)+import Data.Generics.Product.Any        (the)+import Data.List                        (isSuffixOf, (\\)) import Data.Maybe-import Data.Semigroup                  ((<>))-import HaskellWorks.Ci.Assist.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths)-import HaskellWorks.Ci.Assist.Location ((<.>), (</>))-import HaskellWorks.Ci.Assist.Metadata (createMetadata)-import HaskellWorks.Ci.Assist.Show-import HaskellWorks.Ci.Assist.Version  (archiveVersion)-import Options.Applicative             hiding (columns)-import System.Directory                (createDirectoryIfMissing, doesDirectoryExist)+import Data.Semigroup                   ((<>))+import HaskellWorks.CabalCache.Core     (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths)+import HaskellWorks.CabalCache.Location ((<.>), (</>))+import HaskellWorks.CabalCache.Metadata (createMetadata)+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 Codec.Archive.Tar                 as F-import qualified Codec.Compression.GZip            as F-import qualified Data.ByteString.Lazy              as LBS-import qualified Data.ByteString.Lazy.Char8        as LC8-import qualified Data.Text                         as T-import qualified HaskellWorks.Ci.Assist.GhcPkg     as GhcPkg-import qualified HaskellWorks.Ci.Assist.Hash       as H-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO-import qualified HaskellWorks.Ci.Assist.IO.Error   as IO-import qualified HaskellWorks.Ci.Assist.IO.File    as IO-import qualified HaskellWorks.Ci.Assist.IO.Lazy    as IO-import qualified HaskellWorks.Ci.Assist.IO.Tar     as IO-import qualified HaskellWorks.Ci.Assist.Types      as Z-import qualified System.Directory                  as IO-import qualified System.FilePath.Posix             as FP-import qualified System.IO                         as IO-import qualified System.IO.Temp                    as IO-import qualified UnliftIO.Async                    as IO+import qualified App.Commands.Options.Types         as Z+import qualified Codec.Archive.Tar                  as F+import qualified Codec.Compression.GZip             as F+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.Encoding                 as T+import qualified HaskellWorks.CabalCache.AWS.Env    as AWS+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 HaskellWorks.CabalCache.Types      as Z+import qualified System.Directory                   as IO+import qualified System.FilePath.Posix              as FP+import qualified System.IO                          as IO+import qualified System.IO.Temp                     as IO+import qualified UnliftIO.Async                     as IO  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} {-# ANN module ("HLint: ignore Redundant do"        :: String) #-}@@ -55,6 +57,7 @@   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@@ -64,12 +67,13 @@   CIO.putStrLn $ "Archive URI: "      <> toText archiveUri   CIO.putStrLn $ "Archive version: "  <> archiveVersion   CIO.putStrLn $ "Threads: "          <> tshow threads+  CIO.putStrLn $ "AWS Log level: "    <> tshow awsLogLevel    mbPlan <- loadPlan   case mbPlan of     Right planJson -> do       let compilerId = planJson ^. the @"compilerId"-      envAws <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())+      envAws <- mkEnv (opts ^. the @"region") (AWS.awsLogger awsLogLevel)       let archivePath       = versionedArchiveUri </> compilerId       let scopedArchivePath = scopedArchiveUri </> compilerId       IO.createLocalDirectoryIfMissing archivePath

@@ -17,10 +17,10 @@ import Options.Applicative         hiding (columns) import Paths_cabal_cache -import qualified App.Commands.Options.Types        as Z-import qualified Data.Text                         as T-import qualified Data.Version                      as V-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO+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  {-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-} {-# ANN module ("HLint: ignore Redundant do"        :: String) #-}

@@ -0,0 +1,24 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.CabalCache.AWS.Env+  ( awsLogger+  ) where++import Antiope.Env                  (LogLevel (..))+import Control.Concurrent           (myThreadId)+import Control.Monad+import HaskellWorks.CabalCache.Show++import qualified Data.ByteString.Lazy               as LBS+import qualified Data.ByteString.Lazy.Char8         as LC8+import qualified Data.Text.Encoding                 as T+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified System.IO                          as IO++awsLogger :: Maybe LogLevel -> LogLevel -> LC8.ByteString -> IO ()+awsLogger maybeConfigLogLevel msgLogLevel message =+  forM_ maybeConfigLogLevel $ \configLogLevel ->+    when (msgLogLevel <= configLogLevel) $ do+      threadId <- myThreadId+      CIO.hPutStrLn IO.stderr $ "[" <> tshow msgLogLevel <> "] [tid: " <> tshow threadId <> "]"  <> text+  where text = T.decodeUtf8 $ LBS.toStrict message

@@ -0,0 +1,60 @@+{-# LANGUAGE DataKinds       #-}+{-# LANGUAGE RecordWildCards #-}++module HaskellWorks.CabalCache.Concurrent.DownloadQueue+  ( createDownloadQueue+  , anchor+  ) where++import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.Generics.Product.Any+import Data.Set                  ((\\))++import qualified Control.Concurrent.STM                  as STM+import qualified Data.Map                                as M+import qualified Data.Set                                as S+import qualified Data.Text                               as T+import qualified HaskellWorks.CabalCache.Concurrent.Type as Z+import qualified HaskellWorks.CabalCache.Data.Relation   as R++anchor :: Z.PackageId -> M.Map Z.ConsumerId Z.ProviderId -> M.Map Z.ConsumerId Z.ProviderId+anchor root dependencies = M.union dependencies $ M.singleton root (mconcat (M.elems dependencies))++createDownloadQueue :: [(Z.ProviderId, Z.ConsumerId)] -> STM.STM Z.DownloadQueue+createDownloadQueue dependencies = do+  tDependencies <- STM.newTVar (R.fromList dependencies)+  tUploading    <- STM.newTVar S.empty+  return Z.DownloadQueue {..}++takeReady :: Z.DownloadQueue -> STM.STM (Maybe Z.PackageId)+takeReady Z.DownloadQueue {..} = do+  dependencies  <- STM.readTVar tDependencies+  uploading     <- STM.readTVar tUploading++  let ready = R.range dependencies \\ R.domain dependencies \\ uploading++  case S.lookupMin ready of+    Just packageId -> do+      STM.writeTVar tUploading (S.insert packageId uploading)+      return (Just packageId)+    Nothing -> return Nothing++commit :: Z.DownloadQueue -> Z.PackageId -> STM.STM ()+commit Z.DownloadQueue {..} packageId = do+  dependencies  <- STM.readTVar tDependencies+  uploading     <- STM.readTVar tUploading++  STM.writeTVar tUploading    $ S.delete packageId uploading+  STM.writeTVar tDependencies $ R.withoutRange (S.singleton packageId) dependencies++runQueue :: MonadIO m => Z.DownloadQueue -> (Z.PackageId -> m ()) -> m ()+runQueue downloadQueue@Z.DownloadQueue {..} f = do+  maybePackageId <- liftIO $ STM.atomically $ takeReady downloadQueue++  case maybePackageId of+    Just packageId -> do+      f packageId+      liftIO $ STM.atomically $ commit downloadQueue packageId+    Nothing -> return ()

@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module HaskellWorks.CabalCache.Concurrent.Type+  ( DownloadQueue(..)+  , ConsumerId+  , ProviderId+  , PackageId+  ) where++import Data.Text                     (Text)+import GHC.Generics+import HaskellWorks.CabalCache.Types (PackageId)++import qualified Control.Concurrent.STM                as STM+import qualified Data.Map                              as M+import qualified Data.Set                              as S+import qualified Data.Text                             as T+import qualified HaskellWorks.CabalCache.Data.Relation as R++type ConsumerId = PackageId+type ProviderId = PackageId++data DownloadQueue = DownloadQueue+  { tDependencies :: STM.TVar (R.Relation ConsumerId ProviderId)+  , tUploading    :: STM.TVar (S.Set PackageId)+  } deriving Generic

@@ -0,0 +1,102 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeApplications      #-}+module HaskellWorks.CabalCache.Core+  ( PackageInfo(..)+  , Tagged(..)+  , Presence(..)+  , getPackages+  , relativePaths+  , loadPlan+  ) where++import Control.DeepSeq           (NFData)+import Control.Lens              hiding ((<.>))+import Control.Monad             (forM)+import Data.Aeson                (eitherDecode)+import Data.Bool                 (bool)+import Data.Generics.Product.Any (the)+import Data.Maybe                (maybeToList)+import Data.Semigroup            ((<>))+import Data.Text                 (Text)+import GHC.Generics              (Generic)+import System.FilePath           ((<.>), (</>))++import qualified Data.ByteString.Lazy           as LBS+import qualified Data.List                      as List+import qualified Data.Text                      as T+import qualified HaskellWorks.CabalCache.IO.Tar as IO+import qualified HaskellWorks.CabalCache.Types  as Z+import qualified System.Directory               as IO++type CompilerId = Text+type PackageId  = Text+type PackageDir = FilePath+type ConfPath   = FilePath+type Library    = FilePath++data Presence   = Present | Absent deriving (Eq, Show, NFData, Generic)++data Tagged a t = Tagged+  { value :: a+  , tag   :: t+  } deriving (Eq, Show, Generic, NFData)++data PackageInfo = PackageInfo+  { compilerId :: CompilerId+  , packageId  :: PackageId+  , packageDir :: PackageDir+  , confPath   :: Tagged ConfPath Presence+  , libs       :: [Library]+  } deriving (Show, Eq, Generic, NFData)++relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup]+relativePaths basePath pInfo =+  [ IO.TarGroup basePath $ mempty+      <> (pInfo ^. the @"libs")+      <> [packageDir pInfo]+  , IO.TarGroup basePath $ mempty+      <> ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value"))+  ]++getPackages :: FilePath -> Z.PlanJson -> IO [PackageInfo]+getPackages basePath planJson = forM packages (mkPackageInfo basePath compilerId)+  where compilerId :: Text+        compilerId = planJson ^. the @"compilerId"+        packages :: [Z.Package]+        packages = planJson ^.. the @"installPlan" . each . filtered predicate+        predicate :: Z.Package -> Bool+        predicate package = package ^. the @"packageType" /= "pre-existing" && package ^. the @"style" == Just "global"++loadPlan :: IO (Either String Z.PlanJson)+loadPlan =+  eitherDecode <$> LBS.readFile ("dist-newstyle" </> "cache" </> "plan.json")++-------------------------------------------------------------------------------+mkPackageInfo :: FilePath -> CompilerId -> Z.Package -> IO PackageInfo+mkPackageInfo basePath cid pkg = do+  let pid               = pkg ^. the @"id"+  let compilerPath      = basePath </> T.unpack cid+  let relativeConfPath  = T.unpack cid </> "package.db" </> T.unpack pid <.> ".conf"+  let absoluteConfPath  = basePath </> relativeConfPath+  let libPath           = compilerPath </> "lib"+  let relativeLibPath   = T.unpack cid </> "lib"+  let libPrefix         = "libHS" <> pid+  absoluteConfPathExists <- IO.doesFileExist absoluteConfPath+  libPathExists <- IO.doesDirectoryExist libPath+  libFiles <- getLibFiles relativeLibPath libPath libPrefix+  return PackageInfo+    { compilerId  = cid+    , packageId   = pid+    , packageDir  = T.unpack cid </> T.unpack pid+    , confPath    = Tagged relativeConfPath (bool Absent Present absoluteConfPathExists)+    , libs        = libFiles+    }++getLibFiles :: FilePath -> FilePath -> Text -> IO [Library]+getLibFiles relativeLibPath libPath libPrefix =+  fmap (relativeLibPath </>) . filter (List.isPrefixOf (T.unpack libPrefix)) <$> IO.listDirectory libPath

@@ -0,0 +1,94 @@+module HaskellWorks.CabalCache.Data.Relation+  ( Relation(Relation)+  , empty+  , null+  , fromList+  , toList+  , singleton+  , insert+  , delete+  , domain+  , range+  , restrictDomain+  , restrictRange+  , withoutDomain+  , withoutRange+  ) where++import GHC.Generics+import HaskellWorks.CabalCache.Data.Relation.Type (Relation (Relation))+import Prelude                                    hiding (null)++import qualified Data.Map                                   as M+import qualified Data.Set                                   as S+import qualified HaskellWorks.CabalCache.Data.Relation.Type as R++empty :: Relation a b+empty = Relation M.empty M.empty++null :: Relation a b -> Bool+null = M.null . R.domain++fromList :: (Ord a, Ord b) => [(a, b)] -> Relation a b+fromList rs = Relation+  { R.domain  = M.fromListWith S.union $ map (\(x, y) -> (x, S.singleton y)) rs+  , R.range   = M.fromListWith S.union $ map (\(x, y) -> (y, S.singleton x)) rs+  }++toList :: Relation a b -> [(a, b)]+toList r = concatMap+  (\(x, y) -> zip (repeat x) (S.toList y))+  (M.toList (R.domain  r))++singleton :: a -> b -> Relation a b+singleton x y = Relation+  { R.domain  = M.singleton x (S.singleton y)+  , R.range   = M.singleton y (S.singleton x)+  }++insert :: (Ord a, Ord b) => a -> b -> Relation a b -> Relation a b+insert x y r = Relation+  { R.domain  = M.insertWith S.union x (S.singleton y) (R.domain r)+  , R.range   = M.insertWith S.union y (S.singleton x) (R.range  r)+  }++delete :: (Ord a, Ord b) =>  a -> b -> Relation a b -> Relation a b+delete x y r = r+  { R.domain  = M.update (justUnlessEmpty . S.delete y) x (R.domain r)+  , R.range   = M.update (justUnlessEmpty . S.delete x) y (R.range  r)+  }++domain ::  Relation a b -> S.Set a+domain r = M.keysSet (R.domain r)++range ::  Relation a b -> S.Set b+range r = M.keysSet (R.range r)++restrictDomain :: (Ord a, Ord b) => S.Set a -> Relation a b -> Relation a b+restrictDomain s r = R.Relation+  { R.domain = M.restrictKeys (R.domain r) s+  , R.range  = M.mapMaybe (justUnlessEmpty . S.intersection s) (R.range r)+  }++restrictRange :: (Ord a, Ord b) => S.Set b -> Relation a b -> Relation a b+restrictRange s r = R.Relation+  { R.domain  = M.mapMaybe (justUnlessEmpty . S.intersection s) (R.domain r)+  , R.range   = M.restrictKeys (R.range r) s+  }++withoutDomain :: (Ord a, Ord b) => S.Set a -> Relation a b -> Relation a b+withoutDomain s r = R.Relation+  { R.domain = M.withoutKeys (R.domain r) s+  , R.range  = M.mapMaybe (justUnlessEmpty . flip S.difference s) (R.range r)+  }++withoutRange :: (Ord a, Ord b) => S.Set b -> Relation a b -> Relation a b+withoutRange s r = R.Relation+  { R.domain  = M.mapMaybe (justUnlessEmpty . flip S.difference s) (R.domain r)+  , R.range   = M.withoutKeys (R.range r) s+  }++------++justUnlessEmpty :: S.Set a -> Maybe (S.Set a)+justUnlessEmpty c = if S.null c then Nothing else Just c

@@ -0,0 +1,15 @@+{-# LANGUAGE DeriveGeneric #-}++module HaskellWorks.CabalCache.Data.Relation.Type+  ( Relation (..)+  ) where++import GHC.Generics++import qualified Data.Map as M+import qualified Data.Set as S++data Relation a b = Relation+  { domain :: M.Map a (S.Set b)+  , range  :: M.Map b (S.Set a)+  } deriving (Eq, Show, Ord, Generic)

@@ -0,0 +1,27 @@+module HaskellWorks.CabalCache.GhcPkg where++import Data.Text      (Text)+import System.Exit    (ExitCode (..), exitWith)+import System.Process (spawnProcess, waitForProcess)++import qualified Data.Text as Text+import qualified System.IO as IO++runGhcPkg :: [String] -> IO ()+runGhcPkg params = do+  hGhcPkg2 <- spawnProcess "ghc-pkg" params+  exitCodeGhcPkg2 <- waitForProcess hGhcPkg2+  case exitCodeGhcPkg2 of+    ExitFailure _ -> do+      IO.hPutStrLn IO.stderr "ERROR: Unable to recache package db"+      exitWith (ExitFailure 1)+    _ -> return ()++testAvailability :: IO ()+testAvailability = runGhcPkg ["--version"]++recache :: FilePath -> IO ()+recache packageDb = runGhcPkg ["recache", "--package-db", packageDb]++init :: FilePath -> IO ()+init packageDb = runGhcPkg ["init", packageDb]

@@ -0,0 +1,10 @@+module HaskellWorks.CabalCache.Hash+  ( hashStorePath+  ) where++import qualified Crypto.Hash        as CH+import qualified Data.Text          as T+import qualified Data.Text.Encoding as T++hashStorePath :: String -> String+hashStorePath = take 10 . show . CH.hashWith CH.SHA256 . T.encodeUtf8 . T.pack

@@ -0,0 +1,36 @@+module HaskellWorks.CabalCache.IO.Console+  ( putStrLn+  , print+  , hPutStrLn+  , hPrint+  ) where++import Control.Exception      (bracket_)+import Control.Monad.IO.Class (MonadIO, liftIO)+import Data.Text              (Text)+import Prelude                (IO, Show (..), ($), (.))++import qualified Control.Concurrent.QSem as IO+import qualified Data.Text               as T+import qualified Data.Text.IO            as T+import qualified System.IO               as IO+import qualified System.IO.Unsafe        as IO++sem :: IO.QSem+sem = IO.unsafePerformIO $ IO.newQSem 1+{-# NOINLINE sem #-}++consoleBracket :: IO a -> IO a+consoleBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)++putStrLn :: MonadIO m => Text -> m ()+putStrLn = liftIO . consoleBracket . T.putStrLn++print :: (MonadIO m, Show a) => a -> m ()+print = liftIO . consoleBracket . IO.print++hPutStrLn :: MonadIO m => IO.Handle -> Text -> m ()+hPutStrLn h = liftIO . consoleBracket . T.hPutStrLn h++hPrint :: (MonadIO m, Show a) => IO.Handle -> a -> m ()+hPrint h = liftIO . consoleBracket . IO.hPrint h

@@ -0,0 +1,35 @@+{-# LANGUAGE FlexibleContexts #-}++module HaskellWorks.CabalCache.IO.Error+  ( exceptFatal+  , exceptWarn+  , maybeToExcept+  , maybeToExceptM+  ) where++import Control.Monad.Except+import Control.Monad.IO.Class++import qualified Data.Text                          as T+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified System.Exit                        as IO+import qualified System.IO                          as IO++exceptFatal :: MonadIO m => ExceptT String m a -> ExceptT String m a+exceptFatal f = catchError f handler+  where handler e = do+          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Fatal Error: " <> e+          liftIO IO.exitFailure+          throwError e++exceptWarn :: MonadIO m => ExceptT String m a -> ExceptT String m a+exceptWarn f = catchError f handler+  where handler e = do+          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Warning: " <> e+          throwError e++maybeToExcept :: Monad m => String -> Maybe a -> ExceptT String m a+maybeToExcept message = maybe (throwError message) pure++maybeToExceptM :: Monad m => String -> m (Maybe a) -> ExceptT String m a+maybeToExceptM message = ExceptT . fmap (maybe (Left message) Right)

@@ -0,0 +1,32 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.CabalCache.IO.File+  ( copyDirectoryRecursive+  , listMaybeDirectory+  ) where++import Control.Monad.Except+import Control.Monad.IO.Class++import qualified Data.Text                          as T+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified System.Directory                   as IO+import qualified System.Exit                        as IO+import qualified System.IO                          as IO+import qualified System.Process                     as IO++copyDirectoryRecursive :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()+copyDirectoryRecursive source target = do+  CIO.putStrLn $ "Copying recursively from " <> T.pack source <> " to " <> T.pack target+  process <- liftIO $ IO.spawnProcess "cp" ["-r", source, target]+  exitCode <- liftIO $ IO.waitForProcess process+  case exitCode of+    IO.ExitSuccess   -> return ()+    IO.ExitFailure n -> throwError ""++listMaybeDirectory :: MonadIO m => FilePath -> ExceptT String m [FilePath]+listMaybeDirectory filepath = do+  exists <- liftIO $ IO.doesDirectoryExist filepath+  if exists+    then liftIO $ IO.listDirectory filepath+    else return []

@@ -0,0 +1,141 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module HaskellWorks.CabalCache.IO.Lazy+  ( readResource+  , resourceExists+  , firstExistingResource+  , headS3Uri+  , writeResource+  , createLocalDirectoryIfMissing+  , linkOrCopyResource+  ) where++import Antiope.Core+import Antiope.S3.Lazy+import Control.Lens+import Control.Monad                    (void)+import Control.Monad.Catch+import Control.Monad.Except+import Control.Monad.IO.Class+import Control.Monad.Trans.Resource+import Data.Conduit.Lazy                (lazyConsume)+import Data.Either                      (isRight)+import Data.Text                        (Text)+import HaskellWorks.CabalCache.Location (Location (..))+import HaskellWorks.CabalCache.Show+import Network.AWS                      (MonadAWS, chunkedFile)+import Network.AWS.Data.Body            (_streamBody)++import qualified Antiope.S3.Lazy                    as AWS+import qualified Antiope.S3.Types                   as AWS+import qualified Control.Concurrent                 as IO+import qualified Data.ByteString.Lazy               as LBS+import qualified Data.Text                          as T+import qualified Data.Text.IO                       as T+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified Network.AWS                        as AWS+import qualified Network.AWS.Data                   as AWS+import qualified Network.AWS.S3.CopyObject          as AWS+import qualified Network.AWS.S3.HeadObject          as AWS+import qualified Network.AWS.S3.PutObject           as AWS+import qualified Network.HTTP.Types                 as HTTP+import qualified System.Directory                   as IO+import qualified System.FilePath.Posix              as FP+import qualified System.IO                          as IO+import qualified System.IO.Error                    as IO++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++readResource :: MonadResource m => AWS.Env -> Location -> m (Maybe LBS.ByteString)+readResource envAws = \case+  S3 s3Uri    -> runAws envAws $ AWS.downloadFromS3Uri s3Uri+  Local path  -> liftIO $ Just <$> LBS.readFile path++safePathIsSymbolLink :: FilePath -> IO Bool+safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler+  where handler :: IOError -> IO Bool+        handler e = if IO.isDoesNotExistError e+          then return False+          else return True++resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool+resourceExists envAws = \case+  S3 s3Uri    -> isRight <$> runResourceT (headS3Uri envAws s3Uri)+  Local path  -> do+    fileExists <- liftIO $ IO.doesFileExist path+    if fileExists+      then return True+      else do+        symbolicLinkExists <- liftIO $ safePathIsSymbolLink path+        if symbolicLinkExists+          then do+            target <- liftIO $ IO.getSymbolicLinkTarget path+            resourceExists envAws (Local target)+          else return False++firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)+firstExistingResource envAws [] = return Nothing+firstExistingResource envAws (a:as) = do+  exists <- resourceExists envAws a+  if exists+    then return (Just a)+    else firstExistingResource envAws as++headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either String AWS.HeadObjectResponse)+headS3Uri envAws (AWS.S3Uri b k) =+  catch (Right <$> runAws envAws (AWS.send (AWS.headObject b k))) $ \(e :: AWS.Error) ->+    case e of+      (AWS.ServiceError (AWS.ServiceError' _ (HTTP.Status 404 _) _ _ _ _)) -> return (Left "Not found")+      _                                                                    -> throwM e++chunkSize :: AWS.ChunkSize+chunkSize = AWS.ChunkSize (1024 * 1024)++uploadToS3 :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m ()+uploadToS3 envAws (AWS.S3Uri b k) lbs = do+  let req = AWS.toBody lbs+  let po  = AWS.putObject b k req+  void $ runResAws envAws $ AWS.send po++writeResource :: MonadUnliftIO m => AWS.Env -> Location -> LBS.ByteString -> m ()+writeResource envAws loc lbs = case loc of+  S3 s3Uri   -> uploadToS3 envAws s3Uri lbs+  Local path -> liftIO $ LBS.writeFile path lbs++createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m ()+createLocalDirectoryIfMissing = \case+  S3 s3Uri   -> return ()+  Local path -> liftIO $ IO.createDirectoryIfMissing True path++copyS3Uri :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT String m ()+copyS3Uri envAws (AWS.S3Uri sourceBucket sourceObjectKey) (AWS.S3Uri targetBucket targetObjectKey) = ExceptT $ do+  response <- runResourceT $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)+  let responseCode = response ^. AWS.corsResponseStatus+  if 200 <= responseCode && responseCode < 300+    then return (Right ())+    else do+      liftIO $ CIO.hPutStrLn IO.stderr $ "Error in S3 copy: " <> tshow response+      return (Left "")++retry :: MonadIO m => Int -> ExceptT String m () -> ExceptT String m ()+retry n f = catchError f $ \e -> if n > 0+  then do+    liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> T.pack e <> " (retrying)"+    liftIO $ IO.threadDelay 1000000+    retry (n - 1) f+  else throwError e++linkOrCopyResource :: MonadUnliftIO m => AWS.Env -> Location -> Location -> ExceptT String m ()+linkOrCopyResource envAws source target = case source of+  S3 sourceS3Uri -> case target of+    S3 targetS3Uri -> retry 3 (copyS3Uri envAws sourceS3Uri targetS3Uri)+    Local _        -> throwError "Can't copy between different file backends"+  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

@@ -0,0 +1,51 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE DeriveAnyClass    #-}+{-# LANGUAGE DeriveGeneric     #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE TypeApplications  #-}++module HaskellWorks.CabalCache.IO.Tar+  ( TarGroup(..)+  , createTar+  , extractTar+  ) where++import Control.DeepSeq              (NFData)+import Control.Lens+import Control.Monad.Except+import Control.Monad.IO.Class       (MonadIO, liftIO)+import Data.Generics.Product.Any+import Data.List+import GHC.Generics+import HaskellWorks.CabalCache.Show++import qualified Data.Text                          as T+import qualified HaskellWorks.CabalCache.IO.Console as CIO+import qualified System.Exit                        as IO+import qualified System.IO                          as IO+import qualified System.Process                     as IO++data TarGroup = TarGroup+  { basePath   :: FilePath+  , entryPaths :: [FilePath]+  } deriving (Show, Eq, Generic, NFData)++createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT String m ()+createTar tarFile groups = do+  let args = ["-zcf", tarFile] <> foldMap tarGroupToArgs groups+  process <- liftIO $ IO.spawnProcess "tar" args+  exitCode <- liftIO $ IO.waitForProcess process+  case exitCode of+    IO.ExitSuccess   -> return ()+    IO.ExitFailure n -> throwError ""++extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()+extractTar tarFile targetPath = do+  process <- liftIO $ IO.spawnProcess "tar" ["-C", targetPath, "-zxf", tarFile]+  exitCode <- liftIO $ IO.waitForProcess process+  case exitCode of+    IO.ExitSuccess   -> return ()+    IO.ExitFailure n -> throwError ""++tarGroupToArgs :: TarGroup -> [String]+tarGroupToArgs tarGroup = ["-C", tarGroup ^. the @"basePath"] <> tarGroup ^. the @"entryPaths"

@@ -0,0 +1,74 @@+{-# LANGUAGE DeriveGeneric          #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiWayIf             #-}+{-# LANGUAGE OverloadedStrings      #-}+{-# LANGUAGE TypeFamilies           #-}+module HaskellWorks.CabalCache.Location+( IsPath(..)+, Location(..)+, toLocation+)+where++import Antiope.Core (ToText (..), fromText)+import Antiope.S3   (BucketName, ObjectKey (..), S3Uri (..))+import Data.Maybe   (fromMaybe)+import Data.Text    (Text)+import GHC.Generics (Generic)++import qualified Data.Text       as Text+import qualified System.FilePath as FP++class IsPath a s | a -> s where+  (</>) :: a -> s -> a+  (<.>) :: a -> s -> a++infixr 5 </>+infixr 7 <.>++data Location+  = S3 S3Uri+  | Local FilePath+  deriving (Show, Eq, Generic)++instance ToText Location where+  toText (S3 uri)   = toText uri+  toText (Local p)  = Text.pack p++instance IsPath Location Text where+  (S3 b)    </> p = S3    (b </> p)+  (Local b) </> p = Local (b </> Text.unpack p)++  (S3 b)    <.> e = S3    (b <.> e)+  (Local b) <.> e = Local (b <.> Text.unpack e)++instance IsPath Text Text where+  b </> p = Text.pack (Text.unpack b FP.</> Text.unpack p)+  b <.> e = Text.pack (Text.unpack b FP.<.> Text.unpack e)++instance (a ~ Char) => IsPath [a] [a] where+  b </> p = b FP.</> p+  b <.> e = b FP.<.> e++instance IsPath S3Uri Text where+  S3Uri b (ObjectKey k) </> p =+    S3Uri b (ObjectKey (stripEnd "/" k <> "/" <> stripStart "/" p))++  S3Uri b (ObjectKey k) <.> e =+    S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e))++toLocation :: Text -> Maybe Location+toLocation txt = if+  | Text.isPrefixOf "s3://" txt'    -> either (const Nothing) (Just . S3) (fromText txt')+  | Text.isPrefixOf "file://" txt'  -> Just (Local (Text.unpack txt'))+  | Text.isInfixOf  "://" txt'      -> Nothing+  | otherwise                       -> Just (Local (Text.unpack txt'))+  where+    txt' = Text.strip txt++-------------------------------------------------------------------------------+stripStart :: Text -> Text -> Text+stripStart what txt = fromMaybe txt (Text.stripPrefix what txt)++stripEnd :: Text -> Text -> Text+stripEnd what txt = fromMaybe txt (Text.stripSuffix what txt)

@@ -0,0 +1,40 @@+{-# LANGUAGE TupleSections #-}++module HaskellWorks.CabalCache.Metadata where++import Control.Lens                   ((<&>))+import Control.Monad                  (forM_)+import Control.Monad.IO.Class         (MonadIO, liftIO)+import HaskellWorks.CabalCache.Core   (PackageInfo (..))+import HaskellWorks.CabalCache.IO.Tar (TarGroup (..))+import System.FilePath                (makeRelative, takeFileName, (<.>), (</>))++import qualified Data.ByteString.Lazy as LBS+import qualified Data.Map.Strict      as Map+import qualified Data.Text            as T+import qualified System.Directory     as IO++metaDir :: String+metaDir = "_CC_METADATA"++createMetadata :: MonadIO m => FilePath -> PackageInfo -> [(T.Text, LBS.ByteString)] -> m TarGroup+createMetadata storePath pkg values = liftIO $ do+  let pkgMetaPath = storePath </> packageDir pkg </> metaDir+  IO.createDirectoryIfMissing True pkgMetaPath+  forM_ values $ \(k, v) -> LBS.writeFile (pkgMetaPath </> T.unpack k) v+  pure $ TarGroup storePath [packageDir pkg </> metaDir]++loadMetadata :: MonadIO m => FilePath -> m (Map.Map T.Text LBS.ByteString)+loadMetadata pkgStorePath = liftIO $ do+  let pkgMetaPath = pkgStorePath </> metaDir+  exists <- IO.doesDirectoryExist pkgMetaPath+  if not exists+    then pure Map.empty+    else IO.listDirectory pkgMetaPath+          <&> fmap (pkgMetaPath </>)+          >>= traverse (\mfile -> (T.pack (takeFileName mfile),) <$> LBS.readFile mfile)+          <&> Map.fromList++deleteMetadata :: MonadIO m => FilePath -> m ()+deleteMetadata pkgStorePath =+  liftIO $ IO.removeDirectoryRecursive (pkgStorePath </> metaDir)

@@ -0,0 +1,14 @@+module HaskellWorks.CabalCache.Options+  ( readOrFromTextOption+  ) where++import Network.AWS.Data.Text (FromText (..), fromText)+import Options.Applicative   hiding (columns)+import Text.Read             (readEither)++import qualified Data.Text as T++readOrFromTextOption :: (Read a, FromText a) => Mod OptionFields a -> Parser a+readOrFromTextOption =+  let fromStr s = readEither s <|> fromText (T.pack s)+  in option $ eitherReader fromStr

@@ -0,0 +1,10 @@+module HaskellWorks.CabalCache.Show+  ( tshow+  ) where++import Data.Text (Text)++import qualified Data.Text as T++tshow :: Show a => a -> Text+tshow = T.pack . show

@@ -0,0 +1,11 @@+module HaskellWorks.CabalCache.Text+  ( maybeStripPrefix+  ) where++import Data.Maybe+import Data.Text  (Text)++import qualified Data.Text as T++maybeStripPrefix :: Text -> Text -> Text+maybeStripPrefix prefix text = fromMaybe text (T.stripPrefix prefix text)

@@ -0,0 +1,41 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE OverloadedStrings     #-}++module HaskellWorks.CabalCache.Types where++import Data.Aeson+import Data.Text    (Text)+import GHC.Generics++type PackageId = Text++data PlanJson = PlanJson+  { compilerId  :: Text+  , installPlan :: [Package]+  } deriving (Eq, Show, Generic)++data Package = Package+  { packageType   :: Text+  , id            :: Text+  , name          :: Text+  , version       :: Text+  , style         :: Maybe Text+  , componentName :: Maybe Text+  , depends       :: Maybe [PackageId]+  } deriving (Eq, Show, Generic)++instance FromJSON PlanJson where+  parseJSON = withObject "PlanJson" $ \v -> PlanJson+    <$> v .: "compiler-id"+    <*> v .: "install-plan"++instance FromJSON Package where+  parseJSON = withObject "Package" $ \v -> Package+    <$> v .:  "type"+    <*> v .:  "id"+    <*> v .:  "pkg-name"+    <*> v .:  "pkg-version"+    <*> v .:? "style"+    <*> v .:? "component-name"+    <*> v .:? "depends"

@@ -0,0 +1,8 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.CabalCache.Version where++import Data.String++archiveVersion :: IsString s => s+archiveVersion = "v1"

@@ -1,102 +0,0 @@-{-# LANGUAGE DataKinds             #-}-{-# LANGUAGE DeriveAnyClass        #-}-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE FlexibleContexts      #-}-{-# LANGUAGE OverloadedStrings     #-}-{-# LANGUAGE TypeApplications      #-}-module HaskellWorks.Ci.Assist.Core-  ( PackageInfo(..)-  , Tagged(..)-  , Presence(..)-  , getPackages-  , relativePaths-  , loadPlan-  ) where--import Control.DeepSeq           (NFData)-import Control.Lens              hiding ((<.>))-import Control.Monad             (forM)-import Data.Aeson                (eitherDecode)-import Data.Bool                 (bool)-import Data.Generics.Product.Any (the)-import Data.Maybe                (maybeToList)-import Data.Semigroup            ((<>))-import Data.Text                 (Text)-import GHC.Generics              (Generic)-import System.FilePath           ((<.>), (</>))--import qualified Data.ByteString.Lazy          as LBS-import qualified Data.List                     as List-import qualified Data.Text                     as T-import qualified HaskellWorks.Ci.Assist.IO.Tar as IO-import qualified HaskellWorks.Ci.Assist.Types  as Z-import qualified System.Directory              as IO--type CompilerId = Text-type PackageId  = Text-type PackageDir = FilePath-type ConfPath   = FilePath-type Library    = FilePath--data Presence   = Present | Absent deriving (Eq, Show, NFData, Generic)--data Tagged a t = Tagged-  { value :: a-  , tag   :: t-  } deriving (Eq, Show, Generic, NFData)--data PackageInfo = PackageInfo-  { compilerId :: CompilerId-  , packageId  :: PackageId-  , packageDir :: PackageDir-  , confPath   :: Tagged ConfPath Presence-  , libs       :: [Library]-  } deriving (Show, Eq, Generic, NFData)--relativePaths :: FilePath -> PackageInfo -> [IO.TarGroup]-relativePaths basePath pInfo =-  [ IO.TarGroup basePath $ mempty-      <> (pInfo ^. the @"libs")-      <> [packageDir pInfo]-  , IO.TarGroup basePath $ mempty-      <> ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value"))-  ]--getPackages :: FilePath -> Z.PlanJson -> IO [PackageInfo]-getPackages basePath planJson = forM packages (mkPackageInfo basePath compilerId)-  where compilerId :: Text-        compilerId = planJson ^. the @"compilerId"-        packages :: [Z.Package]-        packages = planJson ^.. the @"installPlan" . each . filtered predicate-        predicate :: Z.Package -> Bool-        predicate package = package ^. the @"packageType" /= "pre-existing" && package ^. the @"style" == Just "global"--loadPlan :: IO (Either String Z.PlanJson)-loadPlan =-  eitherDecode <$> LBS.readFile ("dist-newstyle" </> "cache" </> "plan.json")----------------------------------------------------------------------------------mkPackageInfo :: FilePath -> CompilerId -> Z.Package -> IO PackageInfo-mkPackageInfo basePath cid pkg = do-  let pid               = pkg ^. the @"id"-  let compilerPath      = basePath </> T.unpack cid-  let relativeConfPath  = T.unpack cid </> "package.db" </> T.unpack pid <.> ".conf"-  let absoluteConfPath  = basePath </> relativeConfPath-  let libPath           = compilerPath </> "lib"-  let relativeLibPath   = T.unpack cid </> "lib"-  let libPrefix         = "libHS" <> pid-  absoluteConfPathExists <- IO.doesFileExist absoluteConfPath-  libPathExists <- IO.doesDirectoryExist libPath-  libFiles <- getLibFiles relativeLibPath libPath libPrefix-  return PackageInfo-    { compilerId  = cid-    , packageId   = pid-    , packageDir  = T.unpack cid </> T.unpack pid-    , confPath    = Tagged relativeConfPath (bool Absent Present absoluteConfPathExists)-    , libs        = libFiles-    }--getLibFiles :: FilePath -> FilePath -> Text -> IO [Library]-getLibFiles relativeLibPath libPath libPrefix =-  fmap (relativeLibPath </>) . filter (List.isPrefixOf (T.unpack libPrefix)) <$> IO.listDirectory libPath

@@ -1,28 +0,0 @@-module HaskellWorks.Ci.Assist.GhcPkg-where--import Data.Text      (Text)-import System.Exit    (ExitCode (..), exitWith)-import System.Process (spawnProcess, waitForProcess)--import qualified Data.Text as Text-import qualified System.IO as IO--runGhcPkg :: [String] -> IO ()-runGhcPkg params = do-  hGhcPkg2 <- spawnProcess "ghc-pkg" params-  exitCodeGhcPkg2 <- waitForProcess hGhcPkg2-  case exitCodeGhcPkg2 of-    ExitFailure _ -> do-      IO.hPutStrLn IO.stderr "ERROR: Unable to recache package db"-      exitWith (ExitFailure 1)-    _ -> return ()--testAvailability :: IO ()-testAvailability = runGhcPkg ["--version"]--recache :: FilePath -> IO ()-recache packageDb = runGhcPkg ["recache", "--package-db", packageDb]--init :: FilePath -> IO ()-init packageDb = runGhcPkg ["init", packageDb]

@@ -1,10 +0,0 @@-module HaskellWorks.Ci.Assist.Hash-  ( hashStorePath-  ) where--import qualified Crypto.Hash        as CH-import qualified Data.Text          as T-import qualified Data.Text.Encoding as T--hashStorePath :: String -> String-hashStorePath = take 10 . show . CH.hashWith CH.SHA256 . T.encodeUtf8 . T.pack

@@ -1,36 +0,0 @@-module HaskellWorks.Ci.Assist.IO.Console-  ( putStrLn-  , print-  , hPutStrLn-  , hPrint-  ) where--import Control.Exception      (bracket_)-import Control.Monad.IO.Class (MonadIO, liftIO)-import Data.Text              (Text)-import Prelude                (IO, Show (..), ($), (.))--import qualified Control.Concurrent.QSem as IO-import qualified Data.Text               as T-import qualified Data.Text.IO            as T-import qualified System.IO               as IO-import qualified System.IO.Unsafe        as IO--sem :: IO.QSem-sem = IO.unsafePerformIO $ IO.newQSem 1-{-# NOINLINE sem #-}--consoleBracket :: IO a -> IO a-consoleBracket = bracket_ (IO.waitQSem sem) (IO.signalQSem sem)--putStrLn :: MonadIO m => Text -> m ()-putStrLn = liftIO . consoleBracket . T.putStrLn--print :: (MonadIO m, Show a) => a -> m ()-print = liftIO . consoleBracket . IO.print--hPutStrLn :: MonadIO m => IO.Handle -> Text -> m ()-hPutStrLn h = liftIO . consoleBracket . T.hPutStrLn h--hPrint :: (MonadIO m, Show a) => IO.Handle -> a -> m ()-hPrint h = liftIO . consoleBracket . IO.hPrint h

@@ -1,35 +0,0 @@-{-# LANGUAGE FlexibleContexts #-}--module HaskellWorks.Ci.Assist.IO.Error-  ( exceptFatal-  , exceptWarn-  , maybeToExcept-  , maybeToExceptM-  ) where--import Control.Monad.Except-import Control.Monad.IO.Class--import qualified Data.Text                         as T-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO-import qualified System.Exit                       as IO-import qualified System.IO                         as IO--exceptFatal :: MonadIO m => ExceptT String m a -> ExceptT String m a-exceptFatal f = catchError f handler-  where handler e = do-          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Fatal Error: " <> e-          liftIO IO.exitFailure-          throwError e--exceptWarn :: MonadIO m => ExceptT String m a -> ExceptT String m a-exceptWarn f = catchError f handler-  where handler e = do-          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Warning: " <> e-          throwError e--maybeToExcept :: Monad m => String -> Maybe a -> ExceptT String m a-maybeToExcept message = maybe (throwError message) pure--maybeToExceptM :: Monad m => String -> m (Maybe a) -> ExceptT String m a-maybeToExceptM message = ExceptT . fmap (maybe (Left message) Right)

@@ -1,32 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.Ci.Assist.IO.File-  ( copyDirectoryRecursive-  , listMaybeDirectory-  ) where--import Control.Monad.Except-import Control.Monad.IO.Class--import qualified Data.Text                         as T-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO-import qualified System.Directory                  as IO-import qualified System.Exit                       as IO-import qualified System.IO                         as IO-import qualified System.Process                    as IO--copyDirectoryRecursive :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()-copyDirectoryRecursive source target = do-  CIO.putStrLn $ "Copying recursively from " <> T.pack source <> " to " <> T.pack target-  process <- liftIO $ IO.spawnProcess "cp" ["-r", source, target]-  exitCode <- liftIO $ IO.waitForProcess process-  case exitCode of-    IO.ExitSuccess   -> return ()-    IO.ExitFailure n -> throwError ""--listMaybeDirectory :: MonadIO m => FilePath -> ExceptT String m [FilePath]-listMaybeDirectory filepath = do-  exists <- liftIO $ IO.doesDirectoryExist filepath-  if exists-    then liftIO $ IO.listDirectory filepath-    else return []

@@ -1,139 +0,0 @@-{-# LANGUAGE LambdaCase          #-}-{-# LANGUAGE OverloadedStrings   #-}-{-# LANGUAGE ScopedTypeVariables #-}-module HaskellWorks.Ci.Assist.IO.Lazy-  ( readResource-  , resourceExists-  , firstExistingResource-  , headS3Uri-  , writeResource-  , createLocalDirectoryIfMissing-  , linkOrCopyResource-  ) where--import Antiope.Core-import Antiope.S3.Lazy-import Control.Lens-import Control.Monad                   (void)-import Control.Monad.Catch-import Control.Monad.Except-import Control.Monad.IO.Class-import Control.Monad.Trans.Resource-import Data.Conduit.Lazy               (lazyConsume)-import Data.Either                     (isRight)-import Data.Text                       (Text)-import HaskellWorks.Ci.Assist.Location (Location (..))-import HaskellWorks.Ci.Assist.Show-import Network.AWS                     (MonadAWS, chunkedFile)-import Network.AWS.Data.Body           (_streamBody)--import qualified Antiope.S3.Lazy                   as AWS-import qualified Antiope.S3.Types                  as AWS-import qualified Control.Concurrent                as IO-import qualified Data.ByteString.Lazy              as LBS-import qualified Data.Text                         as T-import qualified Data.Text.IO                      as T-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO-import qualified Network.AWS                       as AWS-import qualified Network.AWS.Data                  as AWS-import qualified Network.AWS.S3.CopyObject         as AWS-import qualified Network.AWS.S3.HeadObject         as AWS-import qualified Network.AWS.S3.PutObject          as AWS-import qualified Network.HTTP.Types                as HTTP-import qualified System.Directory                  as IO-import qualified System.FilePath.Posix             as FP-import qualified System.IO                         as IO-import qualified System.IO.Error                   as IO--{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}-{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}--readResource :: MonadResource m => AWS.Env -> Location -> m (Maybe LBS.ByteString)-readResource envAws = \case-  S3 s3Uri    -> runAws envAws $ AWS.downloadFromS3Uri s3Uri-  Local path  -> liftIO $ Just <$> LBS.readFile path--safePathIsSymbolLink :: FilePath -> IO Bool-safePathIsSymbolLink filePath = catch (IO.pathIsSymbolicLink filePath) handler-  where handler :: IOError -> IO Bool-        handler e = if IO.isDoesNotExistError e-          then return False-          else return True--resourceExists :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool-resourceExists envAws = \case-  S3 s3Uri    -> isRight <$> runResourceT (headS3Uri envAws s3Uri)-  Local path  -> do-    fileExists <- liftIO $ IO.doesFileExist path-    if fileExists-      then return True-      else do-        symbolicLinkExists <- liftIO $ safePathIsSymbolLink path-        if symbolicLinkExists-          then do-            target <- liftIO $ IO.getSymbolicLinkTarget path-            resourceExists envAws (Local target)-          else return False--firstExistingResource :: (MonadUnliftIO m, MonadCatch m, MonadIO m) => AWS.Env -> [Location] -> m (Maybe Location)-firstExistingResource envAws [] = return Nothing-firstExistingResource envAws (a:as) = do-  exists <- resourceExists envAws a-  if exists-    then return (Just a)-    else firstExistingResource envAws as--headS3Uri :: (MonadResource m, MonadCatch m) => AWS.Env -> AWS.S3Uri -> m (Either String AWS.HeadObjectResponse)-headS3Uri envAws (AWS.S3Uri b k) =-  catch (Right <$> runAws envAws (AWS.send (AWS.headObject b k))) $ \(e :: AWS.Error) ->-    case e of-      (AWS.ServiceError (AWS.ServiceError' _ (HTTP.Status 404 _) _ _ _ _)) -> return (Left "Not found")-      _                                                                    -> throwM e--chunkSize :: AWS.ChunkSize-chunkSize = AWS.ChunkSize (1024 * 1024)--uploadToS3 :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m ()-uploadToS3 envAws (AWS.S3Uri b k) lbs = do-  let req = AWS.toBody lbs-  let po  = AWS.putObject b k req-  void $ runResAws envAws $ AWS.send po--writeResource :: MonadUnliftIO m => AWS.Env -> Location -> LBS.ByteString -> m ()-writeResource envAws loc lbs = case loc of-  S3 s3Uri   -> uploadToS3 envAws s3Uri lbs-  Local path -> liftIO $ LBS.writeFile path lbs--createLocalDirectoryIfMissing :: (MonadCatch m, MonadIO m) => Location -> m ()-createLocalDirectoryIfMissing = \case-  S3 s3Uri   -> return ()-  Local path -> liftIO $ IO.createDirectoryIfMissing True path--copyS3Uri :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> AWS.S3Uri -> ExceptT String m ()-copyS3Uri envAws (AWS.S3Uri sourceBucket sourceObjectKey) (AWS.S3Uri targetBucket targetObjectKey) = ExceptT $ do-  response <- runResourceT $ runAws envAws $ AWS.send (AWS.copyObject targetBucket (toText sourceBucket <> "/" <> toText sourceObjectKey) targetObjectKey)-  let responseCode = response ^. AWS.corsResponseStatus-  if 200 <= responseCode && responseCode < 300-    then return (Right ())-    else return (Left "")--retry :: MonadIO m => Int -> ExceptT String m () -> ExceptT String m ()-retry n f = catchError f $ \e -> if n > 0-  then do-    liftIO $ CIO.hPutStrLn IO.stderr $ "WARNING: " <> T.pack e <> " (retrying)"-    liftIO $ IO.threadDelay 1000000-    retry (n - 1) f-  else throwError e--linkOrCopyResource :: MonadUnliftIO m => AWS.Env -> Location -> Location -> ExceptT String m ()-linkOrCopyResource envAws source target = case source of-  S3 sourceS3Uri -> case target of-    S3 targetS3Uri -> retry 3 (copyS3Uri envAws sourceS3Uri targetS3Uri)-    Local _        -> throwError "Can't copy between different file backends"-  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

@@ -1,51 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE DeriveAnyClass    #-}-{-# LANGUAGE DeriveGeneric     #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE TypeApplications  #-}--module HaskellWorks.Ci.Assist.IO.Tar-  ( TarGroup(..)-  , createTar-  , extractTar-  ) where--import Control.DeepSeq             (NFData)-import Control.Lens-import Control.Monad.Except-import Control.Monad.IO.Class      (MonadIO, liftIO)-import Data.Generics.Product.Any-import Data.List-import GHC.Generics-import HaskellWorks.Ci.Assist.Show--import qualified Data.Text                         as T-import qualified HaskellWorks.Ci.Assist.IO.Console as CIO-import qualified System.Exit                       as IO-import qualified System.IO                         as IO-import qualified System.Process                    as IO--data TarGroup = TarGroup-  { basePath   :: FilePath-  , entryPaths :: [FilePath]-  } deriving (Show, Eq, Generic, NFData)--createTar :: MonadIO m => FilePath -> [TarGroup] -> ExceptT String m ()-createTar tarFile groups = do-  let args = ["-zcf", tarFile] <> foldMap tarGroupToArgs groups-  process <- liftIO $ IO.spawnProcess "tar" args-  exitCode <- liftIO $ IO.waitForProcess process-  case exitCode of-    IO.ExitSuccess   -> return ()-    IO.ExitFailure n -> throwError ""--extractTar :: MonadIO m => FilePath -> FilePath -> ExceptT String m ()-extractTar tarFile targetPath = do-  process <- liftIO $ IO.spawnProcess "tar" ["-C", targetPath, "-zxf", tarFile]-  exitCode <- liftIO $ IO.waitForProcess process-  case exitCode of-    IO.ExitSuccess   -> return ()-    IO.ExitFailure n -> throwError ""--tarGroupToArgs :: TarGroup -> [String]-tarGroupToArgs tarGroup = ["-C", tarGroup ^. the @"basePath"] <> tarGroup ^. the @"entryPaths"

@@ -1,74 +0,0 @@-{-# LANGUAGE DeriveGeneric          #-}-{-# LANGUAGE FunctionalDependencies #-}-{-# LANGUAGE MultiWayIf             #-}-{-# LANGUAGE OverloadedStrings      #-}-{-# LANGUAGE TypeFamilies           #-}-module HaskellWorks.Ci.Assist.Location-( IsPath(..)-, Location(..)-, toLocation-)-where--import Antiope.Core (ToText (..), fromText)-import Antiope.S3   (BucketName, ObjectKey (..), S3Uri (..))-import Data.Maybe   (fromMaybe)-import Data.Text    (Text)-import GHC.Generics (Generic)--import qualified Data.Text       as Text-import qualified System.FilePath as FP--class IsPath a s | a -> s where-  (</>) :: a -> s -> a-  (<.>) :: a -> s -> a--infixr 5 </>-infixr 7 <.>--data Location-  = S3 S3Uri-  | Local FilePath-  deriving (Show, Eq, Generic)--instance ToText Location where-  toText (S3 uri)   = toText uri-  toText (Local p)  = Text.pack p--instance IsPath Location Text where-  (S3 b)    </> p = S3    (b </> p)-  (Local b) </> p = Local (b </> Text.unpack p)--  (S3 b)    <.> e = S3    (b <.> e)-  (Local b) <.> e = Local (b <.> Text.unpack e)--instance IsPath Text Text where-  b </> p = Text.pack (Text.unpack b FP.</> Text.unpack p)-  b <.> e = Text.pack (Text.unpack b FP.<.> Text.unpack e)--instance (a ~ Char) => IsPath [a] [a] where-  b </> p = b FP.</> p-  b <.> e = b FP.<.> e--instance IsPath S3Uri Text where-  S3Uri b (ObjectKey k) </> p =-    S3Uri b (ObjectKey (stripEnd "/" k <> "/" <> stripStart "/" p))--  S3Uri b (ObjectKey k) <.> e =-    S3Uri b (ObjectKey (stripEnd "." k <> "." <> stripStart "." e))--toLocation :: Text -> Maybe Location-toLocation txt = if-  | Text.isPrefixOf "s3://" txt'    -> either (const Nothing) (Just . S3) (fromText txt')-  | Text.isPrefixOf "file://" txt'  -> Just (Local (Text.unpack txt'))-  | Text.isInfixOf  "://" txt'      -> Nothing-  | otherwise                       -> Just (Local (Text.unpack txt'))-  where-    txt' = Text.strip txt----------------------------------------------------------------------------------stripStart :: Text -> Text -> Text-stripStart what txt = fromMaybe txt (Text.stripPrefix what txt)--stripEnd :: Text -> Text -> Text-stripEnd what txt = fromMaybe txt (Text.stripSuffix what txt)

@@ -1,40 +0,0 @@-{-# LANGUAGE TupleSections #-}-module HaskellWorks.Ci.Assist.Metadata-where--import Control.Lens                  ((<&>))-import Control.Monad                 (forM_)-import Control.Monad.IO.Class        (MonadIO, liftIO)-import HaskellWorks.Ci.Assist.Core   (PackageInfo (..))-import HaskellWorks.Ci.Assist.IO.Tar (TarGroup (..))-import System.FilePath               (makeRelative, takeFileName, (<.>), (</>))--import qualified Data.ByteString.Lazy as LBS-import qualified Data.Map.Strict      as Map-import qualified Data.Text            as T-import qualified System.Directory     as IO--metaDir :: String-metaDir = "_CC_METADATA"--createMetadata :: MonadIO m => FilePath -> PackageInfo -> [(T.Text, LBS.ByteString)] -> m TarGroup-createMetadata storePath pkg values = liftIO $ do-  let pkgMetaPath = storePath </> packageDir pkg </> metaDir-  IO.createDirectoryIfMissing True pkgMetaPath-  forM_ values $ \(k, v) -> LBS.writeFile (pkgMetaPath </> T.unpack k) v-  pure $ TarGroup storePath [packageDir pkg </> metaDir]--loadMetadata :: MonadIO m => FilePath -> m (Map.Map T.Text LBS.ByteString)-loadMetadata pkgStorePath = liftIO $ do-  let pkgMetaPath = pkgStorePath </> metaDir-  exists <- IO.doesDirectoryExist pkgMetaPath-  if not exists-    then pure Map.empty-    else IO.listDirectory pkgMetaPath-          <&> fmap (pkgMetaPath </>)-          >>= traverse (\mfile -> (T.pack (takeFileName mfile),) <$> LBS.readFile mfile)-          <&> Map.fromList--deleteMetadata :: MonadIO m => FilePath -> m ()-deleteMetadata pkgStorePath =-  liftIO $ IO.removeDirectoryRecursive (pkgStorePath </> metaDir)

@@ -1,14 +0,0 @@-module HaskellWorks.Ci.Assist.Options-  ( readOrFromTextOption-  ) where--import Network.AWS.Data.Text (FromText (..), fromText)-import Options.Applicative   hiding (columns)-import Text.Read             (readEither)--import qualified Data.Text as T--readOrFromTextOption :: (Read a, FromText a) => Mod OptionFields a -> Parser a-readOrFromTextOption =-  let fromStr s = readEither s <|> fromText (T.pack s)-  in option $ eitherReader fromStr

@@ -1,10 +0,0 @@-module HaskellWorks.Ci.Assist.Show-  ( tshow-  ) where--import Data.Text (Text)--import qualified Data.Text as T--tshow :: Show a => a -> Text-tshow = T.pack . show

@@ -1,11 +0,0 @@-module HaskellWorks.Ci.Assist.Text-  ( maybeStripPrefix-  ) where--import Data.Maybe-import Data.Text  (Text)--import qualified Data.Text as T--maybeStripPrefix :: Text -> Text -> Text-maybeStripPrefix prefix text = fromMaybe text (T.stripPrefix prefix text)

@@ -1,37 +0,0 @@-{-# LANGUAGE DeriveGeneric         #-}-{-# LANGUAGE DuplicateRecordFields #-}-{-# LANGUAGE OverloadedStrings     #-}--module HaskellWorks.Ci.Assist.Types where--import Data.Aeson-import Data.Text    (Text)-import GHC.Generics--data PlanJson = PlanJson-  { compilerId  :: Text-  , installPlan :: [Package]-  } deriving (Eq, Show, Generic)--data Package = Package-  { packageType   :: Text-  , id            :: Text-  , name          :: Text-  , version       :: Text-  , style         :: Maybe Text-  , componentName :: Maybe Text-  } deriving (Eq, Show, Generic)--instance FromJSON PlanJson where-  parseJSON = withObject "PlanJson" $ \v -> PlanJson-    <$> v .: "compiler-id"-    <*> v .: "install-plan"--instance FromJSON Package where-  parseJSON = withObject "Package" $ \v -> Package-    <$> v .:  "type"-    <*> v .:  "id"-    <*> v .:  "pkg-name"-    <*> v .:  "pkg-version"-    <*> v .:? "style"-    <*> v .:? "component-name"

@@ -1,8 +0,0 @@-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.Ci.Assist.Version where--import Data.String--archiveVersion :: IsString s => s-archiveVersion = "v1"

@@ -1,41 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedStrings #-}--module HaskellWorks.Assist.AwsSpec-  ( spec-  ) where--import Antiope.Core-import Antiope.Env-import Control.Lens-import Control.Monad-import Control.Monad.IO.Class-import Data.Generics.Product.Any-import Data.Maybe                     (fromJust, isJust)-import HaskellWorks.Ci.Assist.IO.Lazy-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import System.Environment             (lookupEnv)-import Test.Hspec-import Text.RawString.QQ--import qualified Antiope.S3.Lazy              as LBS-import qualified Antiope.S3.Types             as AWS-import qualified Data.Aeson                   as A-import qualified Data.ByteString.Lazy         as LBS-import qualified Data.ByteString.Lazy.Char8   as LBSC-import qualified HaskellWorks.Ci.Assist.Types as Z-import qualified System.Environment           as IO--{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}-{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}--spec :: Spec-spec = describe "HaskellWorks.Assist.QuerySpec" $ do-  it "stub" $ requireTest $ do-    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"-      result === Left "Not found"

@@ -1,67 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedStrings #-}-module HaskellWorks.Assist.LocationSpec-( spec-) where--import Antiope.Core                    (toText)-import Antiope.S3                      (BucketName (..), ObjectKey (..), S3Uri (..))-import Data.Text                       (Text)-import HaskellWorks.Ci.Assist.Location--import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec--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 System.FilePath as FP--{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}-{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}--s3Uri :: MonadGen m => m S3Uri-s3Uri = do-  let partGen = Gen.text (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))--localPath :: MonadGen m => m FilePath-localPath = do-  let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum-  parts <- Gen.list (Range.linear 1 5) partGen-  ext <- Gen.string (Range.linear 2 4) Gen.alphaNum-  pure $ "/" <> List.intercalate "/" parts <> "." <> ext--location :: MonadGen m => m Location-location =-  Gen.choice [S3 <$> s3Uri, Local <$> localPath]--spec :: Spec-spec = describe "HaskellWorks.Assist.LocationSpec" $ do-  it "S3 should roundtrip from and to text" $ require $ property $ do-    uri <- forAll s3Uri-    tripping (S3 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-    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--  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)-

@@ -1,63 +0,0 @@-{-# LANGUAGE DataKinds         #-}-{-# LANGUAGE OverloadedStrings #-}-{-# LANGUAGE QuasiQuotes       #-}--module HaskellWorks.Assist.QuerySpec-  ( spec-  ) where--import Control.Lens-import Data.Generics.Product.Any-import HaskellWorks.Hspec.Hedgehog-import Hedgehog-import Test.Hspec-import Text.RawString.QQ--import qualified Data.Aeson                   as A-import qualified Data.ByteString.Lazy         as LBS-import qualified HaskellWorks.Ci.Assist.Types as Z--{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}-{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}-{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}--spec :: Spec-spec = describe "HaskellWorks.Assist.QuerySpec" $ do-  it "stub" $ requireTest $ do-    let Right planJson = A.eitherDecode exampleJson-    planJson === Z.PlanJson-      { Z.compilerId  = "ghc-8.6.4"-      , Z.installPlan =-        [ Z.Package-          { Z.packageType   = "pre-existing"-          , Z.id            = "Cabal-2.4.0.1"-          , Z.name          = "Cabal"-          , Z.version       = "2.4.0.1"-          , Z.style         = Nothing-          , Z.componentName = Nothing-          }-        ]-      }--exampleJson :: LBS.ByteString-exampleJson = [r|-{-  "cabal-version": "2.4.1.0",-  "cabal-lib-version": "2.4.1.0",-  "compiler-id": "ghc-8.6.4",-  "os": "osx",-  "arch": "x86_64",-  "install-plan": [-    {-      "type": "pre-existing",-      "id": "Cabal-2.4.0.1",-      "pkg-name": "Cabal",-      "pkg-version": "2.4.0.1",-      "depends": [-        "array-0.5.3.0",-        "base-4.12.0.0"-      ]-    }-  ]-}-|]

@@ -0,0 +1,41 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.CabalCache.AwsSpec+  ( spec+  ) where++import Antiope.Core+import Antiope.Env+import Control.Lens+import Control.Monad+import Control.Monad.IO.Class+import Data.Generics.Product.Any+import Data.Maybe                      (fromJust, isJust)+import HaskellWorks.CabalCache.IO.Lazy+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import System.Environment              (lookupEnv)+import Test.Hspec+import Text.RawString.QQ++import qualified Antiope.S3.Lazy               as LBS+import qualified Antiope.S3.Types              as AWS+import qualified Data.Aeson                    as A+import qualified Data.ByteString.Lazy          as LBS+import qualified Data.ByteString.Lazy.Char8    as LBSC+import qualified HaskellWorks.CabalCache.Types as Z+import qualified System.Environment            as IO++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.CabalCache.QuerySpec" $ do+  it "stub" $ requireTest $ do+    ci <- liftIO $ IO.lookupEnv "CI" <&> isJust+    unless ci $ do+      envAws <- liftIO $ mkEnv Oregon (const LBSC.putStrLn)+      result <- liftIO $ runResourceT $ headS3Uri envAws $ AWS.S3Uri "jky-mayhem" "hjddhd"+      result === Left "Not found"

@@ -0,0 +1,79 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+module HaskellWorks.CabalCache.Data.RelationSpec+  ( spec+  ) where++import HaskellWorks.CabalCache.Data.Relation (Relation (Relation))+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++import qualified Data.List                             as L+import qualified Data.Map                              as M+import qualified Data.Set                              as S+import qualified HaskellWorks.CabalCache.Data.Relation as R+import qualified Hedgehog.Gen                          as G+import qualified Hedgehog.Range                        as R++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.Assist.Data.RelationSpec" $ do+  it "List roundtrip" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    L.sort (R.toList (R.fromList as)) === L.sort as+  it "Full domain restriction" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha++    R.restrictDomain S.empty (R.fromList as) === R.empty+  it "Full range restriction" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha++    R.restrictRange S.empty (R.fromList as) === R.empty+  it "No domain restriction" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    let r = R.fromList as++    R.restrictDomain (R.domain r) r === r+  it "No range restriction" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    let r = R.fromList as+    R.restrictRange (R.range r) r === r+  it "Full domain without" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    let r = R.fromList as+    R.withoutDomain S.empty r === r+  it "Full range without" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    let r = R.fromList as+    R.withoutRange S.empty r === r+  it "No domain without" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    let r = R.fromList as++    R.withoutDomain (R.domain r) r === R.empty+  it "No range without" $ require $ property $ do+    as <- forAll $ G.list (R.linear 0 10) $ (,)+      <$> G.int R.constantBounded+      <*> G.alpha+    let r = R.fromList as+    R.withoutRange (R.range r) r === R.empty

@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+module HaskellWorks.CabalCache.LocationSpec+( spec+) where++import Antiope.Core                     (toText)+import Antiope.S3                       (BucketName (..), ObjectKey (..), S3Uri (..))+import Data.Text                        (Text)+import HaskellWorks.CabalCache.Location++import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec++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 System.FilePath as FP++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++s3Uri :: MonadGen m => m S3Uri+s3Uri = do+  let partGen = Gen.text (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))++localPath :: MonadGen m => m FilePath+localPath = do+  let partGen = Gen.string (Range.linear 3 10) Gen.alphaNum+  parts <- Gen.list (Range.linear 1 5) partGen+  ext <- Gen.string (Range.linear 2 4) Gen.alphaNum+  pure $ "/" <> List.intercalate "/" parts <> "." <> ext++location :: MonadGen m => m Location+location =+  Gen.choice [S3 <$> s3Uri, Local <$> localPath]++spec :: Spec+spec = describe "HaskellWorks.Assist.LocationSpec" $ do+  it "S3 should roundtrip from and to text" $ require $ property $ do+    uri <- forAll s3Uri+    tripping (S3 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+    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++  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)+

@@ -0,0 +1,67 @@+{-# LANGUAGE DataKinds         #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE QuasiQuotes       #-}++module HaskellWorks.CabalCache.QuerySpec+  ( spec+  ) where++import Control.Lens+import Data.Generics.Product.Any+import HaskellWorks.Hspec.Hedgehog+import Hedgehog+import Test.Hspec+import Text.RawString.QQ++import qualified Data.Aeson                    as A+import qualified Data.ByteString.Lazy          as LBS+import qualified HaskellWorks.CabalCache.Types as Z++{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}+{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant bracket"   :: String) #-}++spec :: Spec+spec = describe "HaskellWorks.Assist.QuerySpec" $ do+  it "stub" $ requireTest $ do+    let Right planJson = A.eitherDecode exampleJson+    planJson === Z.PlanJson+      { Z.compilerId  = "ghc-8.6.4"+      , Z.installPlan =+        [ Z.Package+          { Z.packageType   = "pre-existing"+          , Z.id            = "Cabal-2.4.0.1"+          , Z.name          = "Cabal"+          , Z.version       = "2.4.0.1"+          , Z.style         = Nothing+          , Z.componentName = Nothing+          , Z.depends       = Just+            [ "array-0.5.3.0"+            , "base-4.12.0.0"+            ]+          }+        ]+      }++exampleJson :: LBS.ByteString+exampleJson = [r|+{+  "cabal-version": "2.4.1.0",+  "cabal-lib-version": "2.4.1.0",+  "compiler-id": "ghc-8.6.4",+  "os": "osx",+  "arch": "x86_64",+  "install-plan": [+    {+      "type": "pre-existing",+      "id": "Cabal-2.4.0.1",+      "pkg-name": "Cabal",+      "pkg-version": "2.4.0.1",+      "depends": [+        "array-0.5.3.0",+        "base-4.12.0.0"+      ]+    }+  ]+}+|]