diff --git a/cabal-cache.cabal b/cabal-cache.cabal --- a/cabal-cache.cabal +++ b/cabal-cache.cabal @@ -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 diff --git a/src/App/Commands/Options/Parser.hs b/src/App/Commands/Options/Parser.hs --- a/src/App/Commands/Options/Parser.hs +++ b/src/App/Commands/Options/Parser.hs @@ -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 diff --git a/src/App/Commands/Options/Types.hs b/src/App/Commands/Options/Types.hs --- a/src/App/Commands/Options/Types.hs +++ b/src/App/Commands/Options/Types.hs @@ -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) diff --git a/src/App/Commands/SyncFromArchive.hs b/src/App/Commands/SyncFromArchive.hs --- a/src/App/Commands/SyncFromArchive.hs +++ b/src/App/Commands/SyncFromArchive.hs @@ -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 diff --git a/src/App/Commands/SyncToArchive.hs b/src/App/Commands/SyncToArchive.hs --- a/src/App/Commands/SyncToArchive.hs +++ b/src/App/Commands/SyncToArchive.hs @@ -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 diff --git a/src/App/Commands/Version.hs b/src/App/Commands/Version.hs --- a/src/App/Commands/Version.hs +++ b/src/App/Commands/Version.hs @@ -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) #-} diff --git a/src/HaskellWorks/CabalCache/AWS/Env.hs b/src/HaskellWorks/CabalCache/AWS/Env.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/AWS/Env.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Concurrent/DownloadQueue.hs @@ -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 () diff --git a/src/HaskellWorks/CabalCache/Concurrent/Type.hs b/src/HaskellWorks/CabalCache/Concurrent/Type.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Concurrent/Type.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Core.hs b/src/HaskellWorks/CabalCache/Core.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Core.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Data/Relation.hs b/src/HaskellWorks/CabalCache/Data/Relation.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Data/Relation.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Data/Relation/Type.hs b/src/HaskellWorks/CabalCache/Data/Relation/Type.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Data/Relation/Type.hs @@ -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) diff --git a/src/HaskellWorks/CabalCache/GhcPkg.hs b/src/HaskellWorks/CabalCache/GhcPkg.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/GhcPkg.hs @@ -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] diff --git a/src/HaskellWorks/CabalCache/Hash.hs b/src/HaskellWorks/CabalCache/Hash.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Hash.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/IO/Console.hs b/src/HaskellWorks/CabalCache/IO/Console.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/IO/Console.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/IO/Error.hs b/src/HaskellWorks/CabalCache/IO/Error.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/IO/Error.hs @@ -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) diff --git a/src/HaskellWorks/CabalCache/IO/File.hs b/src/HaskellWorks/CabalCache/IO/File.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/IO/File.hs @@ -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 [] diff --git a/src/HaskellWorks/CabalCache/IO/Lazy.hs b/src/HaskellWorks/CabalCache/IO/Lazy.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/IO/Lazy.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/IO/Tar.hs b/src/HaskellWorks/CabalCache/IO/Tar.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/IO/Tar.hs @@ -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" diff --git a/src/HaskellWorks/CabalCache/Location.hs b/src/HaskellWorks/CabalCache/Location.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Location.hs @@ -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) diff --git a/src/HaskellWorks/CabalCache/Metadata.hs b/src/HaskellWorks/CabalCache/Metadata.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Metadata.hs @@ -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) diff --git a/src/HaskellWorks/CabalCache/Options.hs b/src/HaskellWorks/CabalCache/Options.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Options.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Show.hs b/src/HaskellWorks/CabalCache/Show.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Show.hs @@ -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 diff --git a/src/HaskellWorks/CabalCache/Text.hs b/src/HaskellWorks/CabalCache/Text.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Text.hs @@ -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) diff --git a/src/HaskellWorks/CabalCache/Types.hs b/src/HaskellWorks/CabalCache/Types.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Types.hs @@ -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" diff --git a/src/HaskellWorks/CabalCache/Version.hs b/src/HaskellWorks/CabalCache/Version.hs new file mode 100644 --- /dev/null +++ b/src/HaskellWorks/CabalCache/Version.hs @@ -0,0 +1,8 @@ +{-# LANGUAGE OverloadedStrings #-} + +module HaskellWorks.CabalCache.Version where + +import Data.String + +archiveVersion :: IsString s => s +archiveVersion = "v1" diff --git a/src/HaskellWorks/Ci/Assist/Core.hs b/src/HaskellWorks/Ci/Assist/Core.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Core.hs +++ /dev/null @@ -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 diff --git a/src/HaskellWorks/Ci/Assist/GhcPkg.hs b/src/HaskellWorks/Ci/Assist/GhcPkg.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/GhcPkg.hs +++ /dev/null @@ -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] diff --git a/src/HaskellWorks/Ci/Assist/Hash.hs b/src/HaskellWorks/Ci/Assist/Hash.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Hash.hs +++ /dev/null @@ -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 diff --git a/src/HaskellWorks/Ci/Assist/IO/Console.hs b/src/HaskellWorks/Ci/Assist/IO/Console.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/IO/Console.hs +++ /dev/null @@ -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 diff --git a/src/HaskellWorks/Ci/Assist/IO/Error.hs b/src/HaskellWorks/Ci/Assist/IO/Error.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/IO/Error.hs +++ /dev/null @@ -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) diff --git a/src/HaskellWorks/Ci/Assist/IO/File.hs b/src/HaskellWorks/Ci/Assist/IO/File.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/IO/File.hs +++ /dev/null @@ -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 [] diff --git a/src/HaskellWorks/Ci/Assist/IO/Lazy.hs b/src/HaskellWorks/Ci/Assist/IO/Lazy.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/IO/Lazy.hs +++ /dev/null @@ -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 diff --git a/src/HaskellWorks/Ci/Assist/IO/Tar.hs b/src/HaskellWorks/Ci/Assist/IO/Tar.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/IO/Tar.hs +++ /dev/null @@ -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" diff --git a/src/HaskellWorks/Ci/Assist/Location.hs b/src/HaskellWorks/Ci/Assist/Location.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Location.hs +++ /dev/null @@ -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) diff --git a/src/HaskellWorks/Ci/Assist/Metadata.hs b/src/HaskellWorks/Ci/Assist/Metadata.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Metadata.hs +++ /dev/null @@ -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) diff --git a/src/HaskellWorks/Ci/Assist/Options.hs b/src/HaskellWorks/Ci/Assist/Options.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Options.hs +++ /dev/null @@ -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 diff --git a/src/HaskellWorks/Ci/Assist/Show.hs b/src/HaskellWorks/Ci/Assist/Show.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Show.hs +++ /dev/null @@ -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 diff --git a/src/HaskellWorks/Ci/Assist/Text.hs b/src/HaskellWorks/Ci/Assist/Text.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Text.hs +++ /dev/null @@ -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) diff --git a/src/HaskellWorks/Ci/Assist/Types.hs b/src/HaskellWorks/Ci/Assist/Types.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Types.hs +++ /dev/null @@ -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" diff --git a/src/HaskellWorks/Ci/Assist/Version.hs b/src/HaskellWorks/Ci/Assist/Version.hs deleted file mode 100644 --- a/src/HaskellWorks/Ci/Assist/Version.hs +++ /dev/null @@ -1,8 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module HaskellWorks.Ci.Assist.Version where - -import Data.String - -archiveVersion :: IsString s => s -archiveVersion = "v1" diff --git a/test/HaskellWorks/Assist/AwsSpec.hs b/test/HaskellWorks/Assist/AwsSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Assist/AwsSpec.hs +++ /dev/null @@ -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" diff --git a/test/HaskellWorks/Assist/LocationSpec.hs b/test/HaskellWorks/Assist/LocationSpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Assist/LocationSpec.hs +++ /dev/null @@ -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) - diff --git a/test/HaskellWorks/Assist/QuerySpec.hs b/test/HaskellWorks/Assist/QuerySpec.hs deleted file mode 100644 --- a/test/HaskellWorks/Assist/QuerySpec.hs +++ /dev/null @@ -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" - ] - } - ] -} -|] diff --git a/test/HaskellWorks/CabalCache/AwsSpec.hs b/test/HaskellWorks/CabalCache/AwsSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/CabalCache/AwsSpec.hs @@ -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" diff --git a/test/HaskellWorks/CabalCache/Data/RelationSpec.hs b/test/HaskellWorks/CabalCache/Data/RelationSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/CabalCache/Data/RelationSpec.hs @@ -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 diff --git a/test/HaskellWorks/CabalCache/LocationSpec.hs b/test/HaskellWorks/CabalCache/LocationSpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/CabalCache/LocationSpec.hs @@ -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) + diff --git a/test/HaskellWorks/CabalCache/QuerySpec.hs b/test/HaskellWorks/CabalCache/QuerySpec.hs new file mode 100644 --- /dev/null +++ b/test/HaskellWorks/CabalCache/QuerySpec.hs @@ -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" + ] + } + ] +} +|]