packages feed

cabal-cache (empty) → 0.2.0.2

raw patch · 31 files changed

+1329/−0 lines, 31 filesdep +aesondep +amazonkadep +amazonka-coresetup-changed

Dependencies added: aeson, amazonka, amazonka-core, amazonka-s3, antiope-core, antiope-s3, base, bytestring, cabal-cache, conduit-extra, deepseq, directory, exceptions, filepath, generic-lens, hedgehog, hspec, http-types, hw-hedgehog, hw-hspec-hedgehog, lens, mtl, optparse-applicative, process, raw-strings-qq, resourcet, selective, stringsearch, tar, temporary, text, time, unliftio, zlib

Files

+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# Revision history for cabal-cache++## 0.1.0.0 -- YYYY-mm-dd++* First version. Released on an unsuspecting world.
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright (c) 2019, John Ky++All rights reserved.++Redistribution and use in source and binary forms, with or without+modification, are permitted provided that the following conditions are met:++    * Redistributions of source code must retain the above copyright+      notice, this list of conditions and the following disclaimer.++    * Redistributions in binary form must reproduce the above+      copyright notice, this list of conditions and the following+      disclaimer in the documentation and/or other materials provided+      with the distribution.++    * Neither the name of John Ky nor the names of other+      contributors may be used to endorse or promote products derived+      from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS+"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT+LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR+A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT+OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL,+SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT+LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,+DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY+THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT+(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE+OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,2 @@+# cabal-cache+Tool for caching built cabal new-build packages.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,11 @@+module Main where++import App.Commands+import Control.Monad+import Data.Semigroup      ((<>))+import Options.Applicative++main :: IO ()+main = join $ customExecParser+  (prefs $ showHelpOnEmpty <> showHelpOnError)+  (info (commands <**> helper) idm)
+ cabal-cache.cabal view
@@ -0,0 +1,146 @@+cabal-version:          2.2++name:                   cabal-cache+version:                0.2.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+license:                BSD-3-Clause+license-file:           LICENSE+author:                 John Ky+maintainer:             newhoggy@gmail.com+copyright:              John Ky 2019+category:               Development+extra-source-files:     CHANGELOG.md, README.md++source-repository head+  type: git+  location: https://github.com/haskell-works/cabal-cache++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 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 config+  default-language:     Haskell2010++library+  import: base, config+          , aeson+          , amazonka+          , amazonka-core+          , amazonka-s3+          , antiope-core+          , antiope-s3+          , bytestring+          , conduit-extra+          , deepseq+          , directory+          , exceptions+          , filepath+          , generic-lens+          , http-types+          , lens+          , lens+          , mtl+          , optparse-applicative+          , process+          , resourcet+          , selective+          , stringsearch+          , tar+          , temporary+          , text+          , time+          , unliftio+          , zlib+  other-modules:        Paths_cabal_cache+  autogen-modules:      Paths_cabal_cache+  hs-source-dirs:       src+  exposed-modules:+      App.Commands+      App.Commands.Options.Parser+      App.Commands.Options.Types+      App.Commands.SyncFromArchive+      App.Commands.SyncToArchive+      App.Commands.Version+      App.Static+      HaskellWorks.Ci.Assist.Core+      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.Options+      HaskellWorks.Ci.Assist.PackageConfig+      HaskellWorks.Ci.Assist.Show+      HaskellWorks.Ci.Assist.Tar+      HaskellWorks.Ci.Assist.Text+      HaskellWorks.Ci.Assist.Types++executable cabal-cache+  import:   base, config+          , optparse-applicative+  build-depends:        cabal-cache+  main-is:              Main.hs+  hs-source-dirs:       app+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N++test-suite cabal-cache-test+  import:   base, config+          , aeson+          , antiope-core+          , antiope-s3+          , bytestring+          , filepath+          , generic-lens+          , hedgehog+          , hspec+          , hw-hedgehog+          , hw-hspec-hedgehog+          , lens+          , raw-strings-qq+          , text+  type:                 exitcode-stdio-1.0+  main-is:              Spec.hs+  build-depends:        cabal-cache+  hs-source-dirs:       test+  ghc-options:          -threaded -rtsopts -with-rtsopts=-N+  build-tools:          hspec-discover+  other-modules:+      HaskellWorks.Assist.AwsSpec+      HaskellWorks.Assist.LocationSpec+      HaskellWorks.Assist.QuerySpec
+ src/App/Commands.hs view
@@ -0,0 +1,17 @@+module App.Commands where++import App.Commands.SyncFromArchive+import App.Commands.SyncToArchive+import App.Commands.Version+import Data.Semigroup               ((<>))+import Options.Applicative++commands :: Parser (IO ())+commands = commandsGeneral++commandsGeneral :: Parser (IO ())+commandsGeneral = subparser $ mempty+  <>  commandGroup "Commands:"+  <>  cmdSyncFromArchive+  <>  cmdSyncToArchive+  <>  cmdVersion
+ src/App/Commands/Options/Parser.hs view
@@ -0,0 +1,71 @@+{-# 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 HaskellWorks.Ci.Assist.Location (Location (..), toLocation, (</>))+import Options.Applicative++import qualified Data.Text as Text++optsSyncFromArchive :: Parser SyncFromArchiveOptions+optsSyncFromArchive = SyncFromArchiveOptions+  <$> option (auto <|> text)+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> help "The AWS region in which to operate"+      )+  <*> option (maybeReader (toLocation . Text.pack))+      (   long "archive-uri"+      <>  help "Archive URI to sync to"+      <>  metavar "S3_URI"+      <>  value (Local $ homeDirectory </> ".cabal" </> "archive")+      )+  <*> strOption+      (   long "store-path"+      <>  help "Path to cabal store"+      <>  metavar "DIRECTORY"+      <>  value (homeDirectory </> ".cabal" </> "store")+      )+  <*> option auto+      (   long "threads"+      <>  help "Number of concurrent threads"+      <>  metavar "NUM_THREADS"+      <>  value 4+      )++optsSyncToArchive :: Parser SyncToArchiveOptions+optsSyncToArchive = SyncToArchiveOptions+  <$> option (auto <|> text)+      (  long "region"+      <> metavar "AWS_REGION"+      <> showDefault <> value Oregon+      <> help "The AWS region in which to operate"+      )+  <*> option (maybeReader (toLocation . Text.pack))+      (   long "archive-uri"+      <>  help "Archive URI to sync to"+      <>  metavar "S3_URI"+      <>  value (Local $ homeDirectory </> ".cabal" </> "archive")+      )+  <*> strOption+      (   long "store-path"+      <>  help "Path to cabal store"+      <>  metavar "DIRECTORY"+      <>  value (homeDirectory </> ".cabal" </> "store")+      )+  <*> option auto+      (   long "threads"+      <>  help "Number of concurrent threads"+      <>  metavar "NUM_THREADS"+      <>  value 4+      )++optsVersion :: Parser VersionOptions+optsVersion = pure VersionOptions++text :: FromText a => ReadM a+text = eitherReader (fromText . Text.pack)
+ src/App/Commands/Options/Types.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}++module App.Commands.Options.Types where++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)++data SyncToArchiveOptions = SyncToArchiveOptions+  { region     :: Region+  , archiveUri :: Location+  , storePath  :: FilePath+  , threads    :: Int+  } deriving (Eq, Show, Generic)++data SyncFromArchiveOptions = SyncFromArchiveOptions+  { region     :: Region+  , archiveUri :: Location+  , storePath  :: FilePath+  , threads    :: Int+  } deriving (Eq, Show, Generic)++data VersionOptions = VersionOptions deriving (Eq, Show, Generic)
+ src/App/Commands/SyncFromArchive.hs view
@@ -0,0 +1,128 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.SyncFromArchive+  ( 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 Control.Monad.Except+import Control.Monad.IO.Class               (liftIO)+import Control.Monad.Trans.Resource         (runResourceT)+import Data.Generics.Product.Any            (the)+import Data.Semigroup                       ((<>))+import Data.Text                            (Text)+import HaskellWorks.Ci.Assist.Core          (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan)+import HaskellWorks.Ci.Assist.Location      ((<.>), (</>))+import HaskellWorks.Ci.Assist.PackageConfig (unTemplateConfig)+import HaskellWorks.Ci.Assist.Show+import HaskellWorks.Ci.Assist.Tar           (mapEntriesWith)+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.Lazy              as LBS+import qualified Data.Text                         as T+import qualified HaskellWorks.Ci.Assist.GhcPkg     as GhcPkg+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++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++runSyncFromArchive :: Z.SyncFromArchiveOptions -> IO ()+runSyncFromArchive opts = do+  let storePath   = opts ^. the @"storePath"+  let archiveUri  = opts ^. the @"archiveUri"+  let threads     = opts ^. the @"threads"++  CIO.putStrLn $ "Store path: "   <> toText storePath+  CIO.putStrLn $ "Archive URI: "  <> toText archiveUri+  CIO.putStrLn $ "Threads: "      <> tshow threads++  GhcPkg.testAvailability++  mbPlan <- loadPlan+  case mbPlan of+    Right planJson -> do+      env <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())+      let compilerId                  = planJson ^. the @"compilerId"+      let archivePath                 = archiveUri </> compilerId+      let baseDir                     = opts ^. the @"storePath"+      let storeCompilerPath           = baseDir </> T.unpack compilerId+      let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"+      let storeCompilerLibPath        = storeCompilerPath </> "lib"++      CIO.putStrLn "Creating store directories"+      createDirectoryIfMissing True baseDir+      createDirectoryIfMissing True storeCompilerPath+      createDirectoryIfMissing True storeCompilerLibPath++      storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath++      unless storeCompilerPackageDbPathExists $ do+        CIO.putStrLn "Package DB missing. Creating Package DB"+        GhcPkg.init storeCompilerPackageDbPath++      packages <- getPackages baseDir planJson++      IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+        IO.createDirectoryIfMissing True (tempPath </> T.unpack compilerId </> "package.db")++        IO.pooledForConcurrentlyN_ threads packages $ \pInfo -> do+          let archiveBaseName = packageDir pInfo <.> ".tar.gz"+          let archiveFile = archiveUri </> T.pack archiveBaseName+          let packageStorePath = baseDir </> packageDir pInfo+          storeDirectoryExists <- doesDirectoryExist packageStorePath+          unless storeDirectoryExists $ do+            arhiveFileExists <- runResourceT $ IO.resourceExists env archiveFile+            when arhiveFileExists $ do+              CIO.putStrLn $ "Extracting: " <> T.pack archiveBaseName+              runResAws env $ do+                maybeArchiveFileContents <- IO.readResource env archiveFile++                case maybeArchiveFileContents of+                  Just archiveFileContents -> do+                    let tempArchiveFile = tempPath </> archiveBaseName :: FilePath+                    liftIO $ LBS.writeFile tempArchiveFile archiveFileContents+                    liftIO $ runExceptT $ IO.extractTar tempArchiveFile storePath++                    case confPath pInfo of+                      Tagged conf _ -> do+                        let theConfPath = storePath </> conf+                        let tempConfPath = tempPath </> conf+                        confPathExists <- liftIO $ IO.doesFileExist theConfPath+                        when confPathExists $ do+                          confContents <- liftIO $ LBS.readFile theConfPath+                          liftIO $ LBS.writeFile tempConfPath (unTemplateConfig baseDir confContents)+                          liftIO $ IO.renamePath tempConfPath theConfPath++                  Nothing -> do+                    CIO.putStrLn $ "Archive unavailable: " <> toText archiveFile++      CIO.putStrLn "Recaching package database"+      GhcPkg.recache storeCompilerPackageDbPath++    Left errorMessage -> do+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage++  return ()++cmdSyncFromArchive :: Mod CommandFields (IO ())+cmdSyncFromArchive = command "sync-from-archive"  $ flip info idm $ runSyncFromArchive <$> optsSyncFromArchive
+ src/App/Commands/SyncToArchive.hs view
@@ -0,0 +1,125 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+{-# LANGUAGE TypeApplications    #-}++module App.Commands.SyncToArchive+  ( 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 Control.Monad.Except+import Control.Monad.Trans.Resource         (runResourceT)+import Data.Generics.Product.Any            (the)+import Data.List                            (isSuffixOf)+import Data.Semigroup                       ((<>))+import HaskellWorks.Ci.Assist.Core          (PackageInfo (..), Presence (..), Tagged (..), getPackages, loadPlan, relativePaths, relativePaths2)+import HaskellWorks.Ci.Assist.Location      ((<.>), (</>))+import HaskellWorks.Ci.Assist.PackageConfig (templateConfig)+import HaskellWorks.Ci.Assist.Show+import HaskellWorks.Ci.Assist.Tar           (updateEntryWith)+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.Text                         as T+import qualified HaskellWorks.Ci.Assist.GhcPkg     as GhcPkg+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.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) #-}++runSyncToArchive :: Z.SyncToArchiveOptions -> IO ()+runSyncToArchive opts = do+  let storePath   = opts ^. the @"storePath"+  let archiveUri  = opts ^. the @"archiveUri"+  let threads     = opts ^. the @"threads"++  CIO.putStrLn $ "Store path: "   <> toText storePath+  CIO.putStrLn $ "Archive URI: "  <> toText archiveUri+  CIO.putStrLn $ "Threads: "      <> tshow threads++  mbPlan <- loadPlan+  case mbPlan of+    Right planJson -> do+      let compilerId = planJson ^. the @"compilerId"+      envAws <- mkEnv (opts ^. the @"region") (\_ _ -> pure ())+      let archivePath = archiveUri </> compilerId+      IO.createLocalDirectoryIfMissing archivePath+      let baseDir = opts ^. the @"storePath"+      CIO.putStrLn "Extracting package list"++      packages <- getPackages baseDir planJson++      let storeCompilerPath           = baseDir </> T.unpack compilerId+      let storeCompilerPackageDbPath  = storeCompilerPath </> "package.db"++      storeCompilerPackageDbPathExists <- doesDirectoryExist storeCompilerPackageDbPath++      unless storeCompilerPackageDbPathExists $+        GhcPkg.init storeCompilerPackageDbPath++      CIO.putStrLn $ "Syncing " <> tshow (length packages) <> " packages"++      IO.withSystemTempDirectory "cabal-cache" $ \tempPath -> do+        CIO.putStrLn $ "Temp path: " <> tshow tempPath++        CIO.putStrLn "Copying package.db directory for transformation"+        let workingStoreCompilerPath = tempPath </> T.unpack compilerId+        let workingStoreCompilerPackageDbPath = tempPath </> T.unpack compilerId </> "package.db"++        runExceptT $ IO.exceptFatal "Fatal error" $ do+          liftIO $ IO.createDirectoryIfMissing True workingStoreCompilerPackageDbPath++        packageDbFiles <- IO.listDirectory storeCompilerPackageDbPath+        let confFiles = filter (isSuffixOf ".conf") packageDbFiles++        forM_ confFiles $ \confFile -> do+          stream <- LBS.readFile (storeCompilerPackageDbPath </> confFile)+          LBS.writeFile (workingStoreCompilerPackageDbPath </> confFile) (templateConfig baseDir stream)++        IO.pooledForConcurrentlyN_ (opts ^. the @"threads") packages $ \pInfo -> do+          let archiveFileBasename = packageDir pInfo <.> ".tar.gz"+          let archiveFile = archiveUri </> T.pack archiveFileBasename+          let packageStorePath = baseDir </> packageDir pInfo+          archiveFileExists <- runResourceT $ IO.resourceExists envAws archiveFile++          unless archiveFileExists $ do+            packageStorePathExists <- doesDirectoryExist packageStorePath++            when packageStorePathExists $ void $ runExceptT $ IO.exceptWarn "Warning" $ do+              let rp2 = relativePaths2 storePath tempPath pInfo+              CIO.putStrLn $ "Creating " <> toText archiveFile++              let tempArchiveFile = tempPath </> archiveFileBasename++              IO.createTar tempArchiveFile rp2++              liftIO (LBS.readFile tempArchiveFile >>= IO.writeResource envAws archiveFile)++              return ()++    Left errorMessage -> do+      CIO.hPutStrLn IO.stderr $ "ERROR: Unable to parse plan.json file: " <> T.pack errorMessage++  return ()++cmdSyncToArchive :: Mod CommandFields (IO ())+cmdSyncToArchive = command "sync-to-archive"  $ flip info idm $ runSyncToArchive <$> optsSyncToArchive
+ src/App/Commands/Version.hs view
@@ -0,0 +1,37 @@+{-# LANGUAGE DataKinds           #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE RecordWildCards     #-}+{-# LANGUAGE ScopedTypeVariables #-}++module App.Commands.Version+  ( cmdVersion+  ) where++import App.Commands.Options.Parser (optsVersion)+import App.Static                  (homeDirectory)+import Control.Lens                hiding ((<.>))+import Control.Monad               (unless, when)+import Data.Generics.Product.Any   (the)+import Data.List+import Data.Semigroup              ((<>))+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++{-# ANN module ("HLint: ignore Reduce duplication"  :: String) #-}+{-# ANN module ("HLint: ignore Redundant do"        :: String) #-}++runVersion :: Z.VersionOptions -> IO ()+runVersion _ = do+  let V.Version {..} = Paths_cabal_cache.version++  let version = intercalate "." $ fmap show versionBranch++  CIO.putStrLn $ "cabal-cache " <> T.pack version++cmdVersion :: Mod CommandFields (IO ())+cmdVersion = command "version"  $ flip info idm $ runVersion <$> optsVersion
+ src/App/Static.hs view
@@ -0,0 +1,11 @@+module App.Static where++import Data.Text (Text)++import qualified Data.Text        as T+import qualified System.Directory as IO+import qualified System.IO.Unsafe as IO++homeDirectory :: FilePath+homeDirectory = IO.unsafePerformIO $ IO.getHomeDirectory+{-# NOINLINE homeDirectory #-}
+ src/HaskellWorks/Ci/Assist/Core.hs view
@@ -0,0 +1,109 @@+{-# LANGUAGE DataKinds             #-}+{-# LANGUAGE DeriveAnyClass        #-}+{-# LANGUAGE DeriveGeneric         #-}+{-# LANGUAGE DuplicateRecordFields #-}+{-# LANGUAGE FlexibleContexts      #-}+{-# LANGUAGE OverloadedStrings     #-}+{-# LANGUAGE TypeApplications      #-}+module HaskellWorks.Ci.Assist.Core+  ( PackageInfo(..)+  , Tagged(..)+  , Presence(..)+  , getPackages+  , relativePaths+  , relativePaths2+  , 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)++relativePaths2 :: FilePath -> FilePath -> PackageInfo -> [IO.TarGroup]+relativePaths2 basePath tmpPath pInfo =+  [ IO.TarGroup basePath $ mempty+      <> (pInfo ^. the @"libs")+      <> [packageDir pInfo]+  , IO.TarGroup tmpPath $ mempty+      <> ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value"))+  ]++relativePaths :: PackageInfo -> [FilePath]+relativePaths pInfo = mempty+  <>  ([pInfo ^. the @"confPath"] & filter ((== Present) . (^. the @"tag")) <&> (^. the @"value"))+  <>  [packageDir pInfo]+  <>  (pInfo ^. the @"libs")++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
+ src/HaskellWorks/Ci/Assist/GhcPkg.hs view
@@ -0,0 +1,28 @@+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]
+ src/HaskellWorks/Ci/Assist/IO/Console.hs view
@@ -0,0 +1,36 @@+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
+ src/HaskellWorks/Ci/Assist/IO/Error.hs view
@@ -0,0 +1,27 @@+{-# LANGUAGE FlexibleContexts #-}++module HaskellWorks.Ci.Assist.IO.Error+  ( exceptFatal+  , exceptWarn+  ) 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 => String -> ExceptT String m a -> ExceptT String m a+exceptFatal message 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 => String -> ExceptT String m a -> ExceptT String m a+exceptWarn message f = catchError f handler+  where handler e = do+          liftIO . CIO.hPutStrLn IO.stderr . T.pack $ "Warning: " <> e+          throwError e
+ src/HaskellWorks/Ci/Assist/IO/File.hs view
@@ -0,0 +1,23 @@+{-# LANGUAGE OverloadedStrings #-}++module HaskellWorks.Ci.Assist.IO.File+  ( copyDirectoryRecursive+  ) 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+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 ""
+ src/HaskellWorks/Ci/Assist/IO/Lazy.hs view
@@ -0,0 +1,79 @@+{-# LANGUAGE LambdaCase          #-}+{-# LANGUAGE OverloadedStrings   #-}+{-# LANGUAGE ScopedTypeVariables #-}+module HaskellWorks.Ci.Assist.IO.Lazy+  ( readResource+  , resourceExists+  , headS3Uri+  , writeResource+  , createLocalDirectoryIfMissing+  ) 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 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 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.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.IO                         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++resourceExists :: (MonadResource m, MonadCatch m, MonadIO m) => AWS.Env -> Location -> m Bool+resourceExists envAws = \case+  S3 s3Uri    -> isRight <$> headS3Uri envAws s3Uri+  Local path  -> liftIO $ IO.doesFileExist path++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)++uploadeToS3 :: MonadUnliftIO m => AWS.Env -> AWS.S3Uri -> LBS.ByteString -> m ()+uploadeToS3 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   -> uploadeToS3 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
+ src/HaskellWorks/Ci/Assist/IO/Tar.hs view
@@ -0,0 +1,50 @@+{-# 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 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 :: FilePath -> [TarGroup] -> ExceptT String IO ()+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 :: FilePath -> FilePath -> ExceptT String IO ()+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"
+ src/HaskellWorks/Ci/Assist/Location.hs view
@@ -0,0 +1,74 @@+{-# 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)
+ src/HaskellWorks/Ci/Assist/Options.hs view
@@ -0,0 +1,14 @@+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
+ src/HaskellWorks/Ci/Assist/PackageConfig.hs view
@@ -0,0 +1,20 @@+{-# LANGUAGE OverloadedStrings #-}+module HaskellWorks.Ci.Assist.PackageConfig+where+++import Data.ByteString.Char8       (pack)+import Data.ByteString.Lazy.Search (replace)+import HaskellWorks.Ci.Assist.Tar++import qualified Data.ByteString      as BS+import qualified Data.ByteString.Lazy as LBS++storePathMacro :: BS.ByteString+storePathMacro = "${STORE_PATH}"++templateConfig :: FilePath -> LBS.ByteString -> LBS.ByteString+templateConfig storePath = replace (pack storePath) storePathMacro++unTemplateConfig :: FilePath -> LBS.ByteString -> LBS.ByteString+unTemplateConfig storePath = replace storePathMacro (pack storePath)
+ src/HaskellWorks/Ci/Assist/Show.hs view
@@ -0,0 +1,10 @@+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
+ src/HaskellWorks/Ci/Assist/Tar.hs view
@@ -0,0 +1,27 @@+module HaskellWorks.Ci.Assist.Tar+where++import Codec.Archive.Tar+import Codec.Archive.Tar.Entry++import qualified Data.ByteString.Lazy as LBS++updateEntryWith :: (FilePath -> Bool)+  -> (LBS.ByteString -> LBS.ByteString)+  -> Entry+  -> Entry+updateEntryWith pred transform entry =+  if pred (entryPath entry)+    then case entryContent entry of+        NormalFile bs size ->+          let bs' = transform bs+          in entry { entryContent = NormalFile bs' (LBS.length bs') }+        _ -> entry+    else entry++mapEntriesWith :: (FilePath -> Bool)+  -> (LBS.ByteString -> LBS.ByteString)+  -> Entries e+  -> Entries e+mapEntriesWith pred transform =+  mapEntriesNoFail (updateEntryWith pred transform)
+ src/HaskellWorks/Ci/Assist/Text.hs view
@@ -0,0 +1,11 @@+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)
+ src/HaskellWorks/Ci/Assist/Types.hs view
@@ -0,0 +1,37 @@+{-# 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"
+ test/HaskellWorks/Assist/AwsSpec.hs view
@@ -0,0 +1,41 @@+{-# 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"
+ test/HaskellWorks/Assist/LocationSpec.hs view
@@ -0,0 +1,67 @@+{-# 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)+
+ test/HaskellWorks/Assist/QuerySpec.hs view
@@ -0,0 +1,63 @@+{-# 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"+      ]+    }+  ]+}+|]
+ test/Spec.hs view
@@ -0,0 +1,1 @@+{-# OPTIONS_GHC -F -pgmF hspec-discover #-}