diff --git a/.github/workflows/nix.yml b/.github/workflows/nix.yml index e12c257..360e76c 100644 --- a/.github/workflows/nix.yml +++ b/.github/workflows/nix.yml @@ -48,3 +48,5 @@ jobs: authToken: '${{ secrets.CACHIX_AUTH_TOKEN }}' - run: nix build --accept-flake-config + + - run: nix build --accept-flake-config .#checks.x86_64-linux.foliage:test:foliage-test-suite diff --git a/.gitignore b/.gitignore index 9711bf6..7d73510 100644 --- a/.gitignore +++ b/.gitignore @@ -31,4 +31,6 @@ cabal.project.local~ _cache _keys _repo -_sources + +# only at the root since we need to check-in testcases _sources +./_sources diff --git a/app/Foliage/CmdBuild.hs b/app/Foliage/CmdBuild.hs index 69bf4c6..c44b4ad 100644 --- a/app/Foliage/CmdBuild.hs +++ b/app/Foliage/CmdBuild.hs @@ -15,7 +15,6 @@ import Data.ByteString.Lazy.Char8 qualified as BL import Data.List (sortOn) import Data.List.NonEmpty qualified as NE import Data.Maybe (fromMaybe) -import Data.Text qualified as T import Data.Time.Clock.POSIX (posixSecondsToUTCTime) import Data.Traversable (for) import Development.Shake @@ -23,6 +22,7 @@ import Development.Shake.FilePath import Distribution.Package import Distribution.Pretty (prettyShow) import Distribution.Version +import Foliage.FetchURL (addFetchURLRule) import Foliage.HackageSecurity hiding (ToJSON, toJSON) import Foliage.Meta import Foliage.Meta.Aeson () @@ -31,11 +31,9 @@ import Foliage.Pages import Foliage.PreparePackageVersion (PreparedPackageVersion (..), preparePackageVersion) import Foliage.PrepareSdist (addPrepareSdistRule) import Foliage.PrepareSource (addPrepareSourceRule) -import Foliage.RemoteAsset (addFetchRemoteAssetRule) import Foliage.Shake import Foliage.Time qualified as Time import Hackage.Security.Util.Path (castRoot, toFilePath) -import Network.URI (URI (uriPath, uriQuery, uriScheme), nullURI) import System.Directory (createDirectoryIfMissing) cmdBuild :: BuildOptions -> IO () @@ -43,7 +41,7 @@ cmdBuild buildOptions = do outputDirRoot <- makeAbsolute (fromFilePath (buildOptsOutputDir buildOptions)) shake opts $ do - addFetchRemoteAssetRule cacheDir + addFetchURLRule cacheDir addPrepareSourceRule (buildOptsInputDir buildOptions) cacheDir addPrepareSdistRule outputDirRoot phony "buildAction" (buildAction buildOptions) @@ -53,7 +51,7 @@ cmdBuild buildOptions = do opts = shakeOptions { shakeFiles = cacheDir - , shakeVerbosity = Verbose + , shakeVerbosity = buildOptsVerbosity buildOptions , shakeThreads = buildOptsNumThreads buildOptions } @@ -247,27 +245,12 @@ makeMetadataFile outputDir packageVersions = traced "writing metadata" $ do Aeson.object ( [ "pkg-name" Aeson..= pkgName , "pkg-version" Aeson..= pkgVersion - , "url" Aeson..= sourceUrl pkgVersionSource + , "url" Aeson..= packageVersionSourceToUri pkgVersionSource ] ++ ["forced-version" Aeson..= True | pkgVersionForce] ++ (case pkgTimestamp of Nothing -> []; Just t -> ["timestamp" Aeson..= t]) ) - sourceUrl :: PackageVersionSource -> URI - sourceUrl (TarballSource uri Nothing) = uri - sourceUrl (TarballSource uri (Just subdir)) = uri{uriQuery = "?dir=" ++ subdir} - sourceUrl (GitHubSource repo rev Nothing) = - nullURI - { uriScheme = "github:" - , uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) - } - sourceUrl (GitHubSource repo rev (Just subdir)) = - nullURI - { uriScheme = "github:" - , uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) - , uriQuery = "?dir=" ++ subdir - } - getPackageVersions :: FilePath -> Action [PreparedPackageVersion] getPackageVersions inputDir = do metaFiles <- getDirectoryFiles inputDir ["*/*/meta.toml"] diff --git a/app/Foliage/CmdImportIndex.hs b/app/Foliage/CmdImportIndex.hs index 3949789..9829a1a 100644 --- a/app/Foliage/CmdImportIndex.hs +++ b/app/Foliage/CmdImportIndex.hs @@ -62,7 +62,7 @@ importIndex f (Tar.Next e es) m = pure $ Just $ PackageVersionSpec - { packageVersionSource = TarballSource (pkgIdToHackageUrl pkgId) Nothing + { packageVersionSource = URISource (pkgIdToHackageUrl pkgId) Nothing , packageVersionTimestamp = Just time , packageVersionRevisions = [] , packageVersionDeprecations = [] diff --git a/app/Foliage/RemoteAsset.hs b/app/Foliage/FetchURL.hs similarity index 58% rename from app/Foliage/RemoteAsset.hs rename to app/Foliage/FetchURL.hs index 16e790b..c368836 100644 --- a/app/Foliage/RemoteAsset.hs +++ b/app/Foliage/FetchURL.hs @@ -2,9 +2,9 @@ {-# LANGUAGE DerivingVia #-} {-# LANGUAGE TypeFamilies #-} -module Foliage.RemoteAsset ( - fetchRemoteAsset, - addFetchRemoteAssetRule, +module Foliage.FetchURL ( + fetchURL, + addFetchURLRule, ) where @@ -24,23 +24,23 @@ import Network.URI.Orphans () import System.Directory (createDirectoryIfMissing) import System.Exit (ExitCode (..)) -newtype RemoteAsset = RemoteAsset URI +newtype FetchURL = FetchURL URI deriving (Eq) deriving (Hashable, Binary, NFData) via URI -instance Show RemoteAsset where - show (RemoteAsset uri) = "fetchRemoteAsset " ++ show uri +instance Show FetchURL where + show (FetchURL uri) = "fetchURL " ++ show uri -type instance RuleResult RemoteAsset = FilePath +type instance RuleResult FetchURL = FilePath -fetchRemoteAsset :: URI -> Action FilePath -fetchRemoteAsset = apply1 . RemoteAsset +fetchURL :: URI -> Action FilePath +fetchURL = apply1 . FetchURL -addFetchRemoteAssetRule :: FilePath -> Rules () -addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run +addFetchURLRule :: FilePath -> Rules () +addFetchURLRule cacheDir = addBuiltinRule noLint noIdentity run where - run :: BuiltinRun RemoteAsset FilePath - run (RemoteAsset uri) old _mode = do + run :: BuiltinRun FetchURL FilePath + run (FetchURL uri) old _mode = do unless (uriQuery uri == "") $ error ("Query elements in URI are not supported: " <> show uri) @@ -68,36 +68,7 @@ addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run runCurl :: URI -> String -> String -> Action ETag runCurl uri path etagFile = do (Exit exitCode, Stdout out) <- - traced "curl" $ - cmd - Shell - [ "curl" - , -- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute. - "--silent" - , -- Fail fast with no output at all on server errors. - "--fail" - , -- If the server reports that the requested page has moved to a different location this - -- option will make curl redo the request on the new place. - -- NOTE: This is needed because github always replies with a redirect - "--location" - , -- This option makes a conditional HTTP request for the specific ETag read from the - -- given file by sending a custom If-None-Match header using the stored ETag. - -- For correct results, make sure that the specified file contains only a single line - -- with the desired ETag. An empty file is parsed as an empty ETag. - "--etag-compare" - , etagFile - , -- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server, - -- an empty file is created. - "--etag-save" - , etagFile - , -- Write output to instead of stdout. - "--output" - , path - , "--write-out" - , "%{json}" - , -- URL to fetch - show uri - ] + traced "curl" $ cmd Shell curlInvocation case exitCode of ExitSuccess -> liftIO $ BS.readFile etagFile ExitFailure c -> do @@ -112,7 +83,36 @@ runCurl uri path etagFile = do ] -- We can consider displaying different messages based on some fields (e.g. response_code) Right CurlWriteOut{errormsg} -> - error errormsg + error $ unlines ["calling", unwords curlInvocation, "failed with", errormsg] + where + curlInvocation = + [ "curl" + , -- Silent or quiet mode. Do not show progress meter or error messages. Makes Curl mute. + "--silent" + , -- Fail fast with no output at all on server errors. + "--fail" + , -- If the server reports that the requested page has moved to a different location this + -- option will make curl redo the request on the new place. + -- NOTE: This is needed because github always replies with a redirect + "--location" + , -- This option makes a conditional HTTP request for the specific ETag read from the + -- given file by sending a custom If-None-Match header using the stored ETag. + -- For correct results, make sure that the specified file contains only a single line + -- with the desired ETag. An empty file is parsed as an empty ETag. + "--etag-compare" + , etagFile + , -- This option saves an HTTP ETag to the specified file. If no ETag is sent by the server, + -- an empty file is created. + "--etag-save" + , etagFile + , -- Write output to instead of stdout. + "--output" + , path + , "--write-out" + , "%{json}" + , -- URL to fetch + show uri + ] type ETag = BS.ByteString diff --git a/app/Foliage/Meta.hs b/app/Foliage/Meta.hs index 3a6794c..71d7942 100644 --- a/app/Foliage/Meta.hs +++ b/app/Foliage/Meta.hs @@ -21,12 +21,13 @@ module Foliage.Meta ( deprecationTimestamp, deprecationIsDeprecated, PackageVersionSource, - pattern TarballSource, + pattern URISource, pattern GitHubSource, GitHubRepo (..), GitHubRev (..), UTCTime, latestRevisionNumber, + packageVersionSourceToUri, ) where @@ -43,8 +44,9 @@ import Distribution.Aeson () import Distribution.Types.Orphans () import Foliage.Time (UTCTime) import GHC.Generics (Generic) -import Network.URI (URI, parseURI) +import Network.URI (URI (..), nullURI, parseURI) import Network.URI.Orphans () +import System.FilePath (()) import Toml (TomlCodec, (.=)) import Toml qualified @@ -55,8 +57,8 @@ newtype GitHubRev = GitHubRev {unGitHubRev :: Text} deriving (Show, Eq, Binary, Hashable, NFData) via Text data PackageVersionSource - = TarballSource - { tarballSourceURI :: URI + = URISource + { sourceURI :: URI , subdir :: Maybe String } | GitHubSource @@ -67,13 +69,28 @@ data PackageVersionSource deriving (Show, Eq, Generic) deriving anyclass (Binary, Hashable, NFData) +packageVersionSourceToUri :: PackageVersionSource -> URI +packageVersionSourceToUri (URISource uri Nothing) = uri +packageVersionSourceToUri (URISource uri (Just subdir)) = uri{uriQuery = "?dir=" ++ subdir} +packageVersionSourceToUri (GitHubSource repo rev Nothing) = + nullURI + { uriScheme = "github:" + , uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) + } +packageVersionSourceToUri (GitHubSource repo rev (Just subdir)) = + nullURI + { uriScheme = "github:" + , uriPath = T.unpack (unGitHubRepo repo) T.unpack (unGitHubRev rev) + , uriQuery = "?dir=" ++ subdir + } + packageSourceCodec :: TomlCodec PackageVersionSource packageSourceCodec = - Toml.dimatch matchTarballSource (uncurry TarballSource) tarballSourceCodec + Toml.dimatch matchTarballSource (uncurry URISource) tarballSourceCodec <|> Toml.dimatch matchGitHubSource (\((repo, rev), mSubdir) -> GitHubSource repo rev mSubdir) githubSourceCodec -uri :: Toml.Key -> TomlCodec URI -uri = Toml.textBy to from +uriCodec :: Toml.Key -> TomlCodec URI +uriCodec = Toml.textBy to from where to = T.pack . show from t = case parseURI (T.unpack t) of @@ -83,11 +100,11 @@ uri = Toml.textBy to from tarballSourceCodec :: TomlCodec (URI, Maybe String) tarballSourceCodec = Toml.pair - (uri "url") + (uriCodec "url") (Toml.dioptional $ Toml.string "subdir") matchTarballSource :: PackageVersionSource -> Maybe (URI, Maybe String) -matchTarballSource (TarballSource url mSubdir) = Just (url, mSubdir) +matchTarballSource (URISource url mSubdir) = Just (url, mSubdir) matchTarballSource _ = Nothing gitHubRepo :: Toml.Key -> TomlCodec GitHubRepo diff --git a/app/Foliage/Options.hs b/app/Foliage/Options.hs index e3c85a9..4d1a3aa 100644 --- a/app/Foliage/Options.hs +++ b/app/Foliage/Options.hs @@ -12,10 +12,15 @@ module Foliage.Options ( ) where +import Data.Bifunctor (Bifunctor (..)) +import Data.Char qualified as Char +import Data.List (uncons) +import Development.Shake (Verbosity (..)) import Development.Shake.Classes (Binary, Hashable, NFData) import Foliage.Time import GHC.Generics import Options.Applicative +import Text.Read (readMaybe) data Command = CreateKeys FilePath @@ -54,6 +59,7 @@ data BuildOptions = BuildOptions , buildOptsOutputDir :: FilePath , buildOptsNumThreads :: Int , buildOptsWriteMetadata :: Bool + , buildOptsVerbosity :: Verbosity } buildCommand :: Parser Command @@ -106,6 +112,15 @@ buildCommand = <> help "Write metadata in the output-directory" <> showDefault ) + <*> option + (maybeReader (readMaybe . toUppercase)) + ( short 'v' + <> long "verbosity" + <> metavar "VERBOSITY" + <> help "What level of messages should be printed out [silent, error, warn, info, verbose, diagnostic]" + <> showDefaultWith (toLowercase . show) + <> value Info + ) ) where signOpts = @@ -141,7 +156,8 @@ newtype ImportIndexOptions = ImportIndexOptions importIndexCommand :: Parser Command importIndexCommand = - ImportIndex . ImportIndexOptions + ImportIndex + . ImportIndexOptions <$> optional ( ImportFilter <$> strOption @@ -157,3 +173,11 @@ importIndexCommand = ) ) ) + +toUppercase :: [Char] -> String +toUppercase s = + maybe "" (uncurry (:) . first Char.toUpper) (uncons s) + +toLowercase :: [Char] -> String +toLowercase s = + maybe "" (uncurry (:) . first Char.toLower) (uncons s) diff --git a/app/Foliage/PrepareSource.hs b/app/Foliage/PrepareSource.hs index d4ca097..2c6762e 100644 --- a/app/Foliage/PrepareSource.hs +++ b/app/Foliage/PrepareSource.hs @@ -14,11 +14,12 @@ import Development.Shake.Rule import Distribution.Pretty (prettyShow) import Distribution.Types.PackageId import Distribution.Types.PackageName (unPackageName) +import Foliage.FetchURL (fetchURL) import Foliage.Meta -import Foliage.RemoteAsset (fetchRemoteAsset) import Foliage.UpdateCabalFile (rewritePackageVersion) import Foliage.Utils.GitHub (githubRepoTarballUrl) import GHC.Generics +import Network.URI (URI (..)) import System.Directory qualified as IO import System.FilePath ((<.>), ()) @@ -62,48 +63,15 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run IO.createDirectoryIfMissing True srcDir case packageVersionSource of - TarballSource url mSubdir -> do - tarballPath <- fetchRemoteAsset url - - withTempDir $ \tmpDir -> do - cmd_ "tar xzf" [tarballPath] "-C" [tmpDir] - - -- Special treatment of top-level directory: we remove it - -- - -- Note: Don't let shake look into tmpDir! it will cause - -- unnecessary rework because tmpDir is always new - ls <- liftIO $ IO.getDirectoryContents tmpDir - let ls' = filter (not . all (== '.')) ls - - let fix1 = case ls' of [l] -> ( l); _ -> id - fix2 = case mSubdir of Just s -> ( s); _ -> id - tdir = fix2 $ fix1 tmpDir - - cmd_ "cp --recursive --no-target-directory --dereference" [tdir, srcDir] - -- - -- This is almost identical to the above but we get to keep the - -- metadata. - -- + URISource (URI{uriScheme, uriPath}) mSubdir | uriScheme == "file:" -> do + tarballPath <- liftIO $ IO.makeAbsolute uriPath + extractFromTarball tarballPath mSubdir srcDir + URISource uri mSubdir -> do + tarballPath <- fetchURL uri + extractFromTarball tarballPath mSubdir srcDir GitHubSource repo rev mSubdir -> do - let url = githubRepoTarballUrl repo rev - - tarballPath <- fetchRemoteAsset url - - withTempDir $ \tmpDir -> do - cmd_ "tar xzf" [tarballPath] "-C" [tmpDir] - - -- Special treatment of top-level directory: we remove it - -- - -- Note: Don't let shake look into tmpDir! it will cause - -- unnecessary rework because tmpDir is always new - ls <- liftIO $ IO.getDirectoryContents tmpDir - let ls' = filter (not . all (== '.')) ls - - let fix1 = case ls' of [l] -> ( l); _ -> id - fix2 = case mSubdir of Just s -> ( s); _ -> id - tdir = fix2 $ fix1 tmpDir - - cmd_ "cp --recursive --no-target-directory --dereference" [tdir, srcDir] + tarballPath <- fetchURL (githubRepoTarballUrl repo rev) + extractFromTarball tarballPath mSubdir srcDir let patchesDir = inputDir unPackageName pkgName prettyShow pkgVersion "patches" hasPatches <- doesDirectoryExist patchesDir @@ -120,3 +88,45 @@ addPrepareSourceRule inputDir cacheDir = addBuiltinRule noLint noIdentity run liftIO $ rewritePackageVersion cabalFilePath pkgVersion return $ RunResult ChangedRecomputeDiff BS.empty srcDir + + extractFromTarball tarballPath mSubdir outDir = do + withTempDir $ \tmpDir -> do + cmd_ + [ "tar" + , -- Extract files from an archive + "--extract" + , -- Filter the archive through gunzip + "--gunzip" + , -- Use archive file + "--file" + , tarballPath + , -- Change to DIR before performing any operations + "--directory" + , tmpDir + ] + + ls <- + -- remove "." and ".." + filter (not . all (== '.')) + -- NOTE: Don't let shake look into tmpDir! it will cause + -- unnecessary rework because tmpDir is always new + <$> liftIO (IO.getDirectoryContents tmpDir) + + -- Special treatment of top-level directory: we remove it + let byPassSingleTopLevelDir = case ls of [l] -> ( l); _ -> id + applyMSubdir = case mSubdir of Just s -> ( s); _ -> id + srcDir = applyMSubdir $ byPassSingleTopLevelDir tmpDir + + cmd_ + [ "cp" + , -- copy directories recursively + "--recursive" + , -- treat DEST as a normal file + "--no-target-directory" + , -- always follow symbolic links in SOURCE + "--dereference" + , -- SOURCE + srcDir + , -- DEST + outDir + ] diff --git a/cabal.project b/cabal.project index 765e054..59532f9 100644 --- a/cabal.project +++ b/cabal.project @@ -1,3 +1,6 @@ packages: . -index-state: 2023-03-17T03:33:00Z -with-compiler: ghc-9.2 +index-state: 2023-09-10T21:31:08Z +with-compiler: ghc-9.4.7 + +tests: True +test-show-details: direct diff --git a/flake.lock b/flake.lock index 33bc1c4..c93459c 100644 --- a/flake.lock +++ b/flake.lock @@ -175,11 +175,11 @@ "hackage-nix": { "flake": false, "locked": { - "lastModified": 1694564562, - "narHash": "sha256-DgxhNZzolntRrxNtxz6juCRGJKI3Xw3UtN9zOvK1Z0A=", + "lastModified": 1694651084, + "narHash": "sha256-N8ka3ijqX5jRMilQz0w1T9f3OJriabCVNaY/J0HQJ94=", "owner": "input-output-hk", "repo": "hackage.nix", - "rev": "95db9af6d46446fef04c08243a4ab42389019a5c", + "rev": "fe2ea45b10e70de695c00ca83986760e6dcd6948", "type": "github" }, "original": { @@ -223,11 +223,11 @@ "stackage": "stackage" }, "locked": { - "lastModified": 1694579628, - "narHash": "sha256-Fu9pbaQiA6IxKKJ1v4f8O+r8EEKp/UMxbqdRyIjRz7o=", + "lastModified": 1694652616, + "narHash": "sha256-aqXxf4cR026lL/J9OEPWigPLEqVCCgN1UxaFx+7m7CI=", "owner": "input-output-hk", "repo": "haskell.nix", - "rev": "692ca9900b8d5c3c699f181af22cb7794d209916", + "rev": "8a9dfba4f51e0b3d0b426a1ae787926821993ec6", "type": "github" }, "original": { @@ -555,11 +555,11 @@ "stackage": { "flake": false, "locked": { - "lastModified": 1694304585, - "narHash": "sha256-vs31FW287tu1z0Wtq0C6+K85wD36sRGeAeFuPSFZ7PY=", + "lastModified": 1694650147, + "narHash": "sha256-eEx6FjSWKY7cVLvmDOJ2iPue42X8zedsYDY7Byaiz6I=", "owner": "input-output-hk", "repo": "stackage.nix", - "rev": "26e9f75a4775f37ef73ffdde706ca65a2be2151f", + "rev": "a59f88d7837f0c537efc7de53dad276e3d9da4ba", "type": "github" }, "original": { diff --git a/flake.nix b/flake.nix index b4e6111..c84e4cd 100644 --- a/flake.nix +++ b/flake.nix @@ -32,7 +32,7 @@ project = pkgs.haskell-nix.cabalProject' { src = ./.; - compiler-nix-name = "ghc926"; + compiler-nix-name = "ghc94"; shell.tools = { cabal = "latest"; hlint = "latest"; diff --git a/foliage.cabal b/foliage.cabal index b694cd6..d817eea 100644 --- a/foliage.cabal +++ b/foliage.cabal @@ -1,4 +1,4 @@ -cabal-version: 2.4 +cabal-version: 3.8 name: foliage description: Foliage is a tool to create custom Haskell package repositories, in a fully reproducible way. version: 0.6.0.0 @@ -12,7 +12,12 @@ source-repository head type: git location: https://github.com/andreabedini/foliage +common common-settings + ghc-options: -Wall -threaded + default-language: GHC2021 + executable foliage + import: common-settings main-is: Main.hs hs-source-dirs: app other-modules: @@ -21,6 +26,7 @@ executable foliage Foliage.CmdBuild Foliage.CmdCreateKeys Foliage.CmdImportIndex + Foliage.FetchURL Foliage.HackageSecurity Foliage.Meta Foliage.Meta.Aeson @@ -29,7 +35,6 @@ executable foliage Foliage.PreparePackageVersion Foliage.PrepareSource Foliage.PrepareSdist - Foliage.RemoteAsset Foliage.Shake Foliage.Time Foliage.UpdateCabalFile @@ -37,10 +42,6 @@ executable foliage Foliage.Utils.GitHub Network.URI.Orphans - default-language: GHC2021 - - ghc-options: -Wall - ghc-options: -threaded build-depends: base >=4.14.3.0 && <4.18, aeson >=2.0.3.0 && <2.2, @@ -68,3 +69,22 @@ executable foliage vector >=0.13.0.0 && <0.14, with-utf8 >=1.0.2.3 && <1.1, zlib >=0.6.2.3 && <0.7, + +test-suite foliage-test-suite + import: common-settings + main-is: Tests.hs + other-modules: Foliage.Tests.Utils + , Foliage.Tests.Tar + build-depends: base + , bytestring + , containers + , directory + , filepath + , network + , process + , tasty + , tasty-hunit + , tar + , unix + build-tool-depends: foliage:foliage + hs-source-dirs: tests diff --git a/tests/Foliage/Tests/Tar.hs b/tests/Foliage/Tests/Tar.hs new file mode 100644 index 0000000..e85f4a9 --- /dev/null +++ b/tests/Foliage/Tests/Tar.hs @@ -0,0 +1,32 @@ +module Foliage.Tests.Tar where + +import Codec.Archive.Tar qualified as Tar +import Codec.Archive.Tar.Entry (Entry (..)) +import Codec.Archive.Tar.Index (TarIndexEntry (..)) +import Codec.Archive.Tar.Index qualified as Tar +import Control.Monad (when) +import Data.ByteString.Lazy qualified as B +import System.IO +import Test.Tasty.HUnit + +newtype TarballAccessFn = TarballAccessFn + { lookupEntry :: FilePath -> IO (Maybe Entry) + } + +withTarball :: (HasCallStack) => FilePath -> (TarballAccessFn -> IO r) -> IO r +withTarball path action = do + eIdx <- Tar.build . Tar.read <$> B.readFile path + case eIdx of + Left err -> + assertFailure (show err) + Right idx -> + withFile path ReadMode $ \handle -> do + hIsClosed handle >>= flip when (putStrLn "[after reading] it's closed!") + let lookupEntry :: FilePath -> IO (Maybe Entry) + lookupEntry filepath = + case Tar.lookup idx filepath of + Just (TarFileEntry offset) -> do + Just <$> Tar.hReadEntry handle offset + _otherwise -> + return Nothing + action $ TarballAccessFn{lookupEntry} diff --git a/tests/Foliage/Tests/Utils.hs b/tests/Foliage/Tests/Utils.hs new file mode 100644 index 0000000..b3cffa2 --- /dev/null +++ b/tests/Foliage/Tests/Utils.hs @@ -0,0 +1,53 @@ +module Foliage.Tests.Utils ( + checkRequiredProgram, + callCommand, + readCommand, + inTemporaryDirectoryWithFixture, +) +where + +import Control.Exception (finally) +import Control.Monad (when) +import Data.Foldable (for_) +import Data.Functor (void) +import Data.Maybe (isNothing) +import System.Directory +import System.FilePath +import System.Posix.Temp (mkdtemp) +import System.Process (readCreateProcess, shell) + +{- | Set up a temporary directory prepopulated with symlinks to the fixture +files and change the current directory to it before running the given +action. The previous working directory is restored after the action is +finished or an exception is raised. + +The first argument should be a relative path from the current directory +to the directory containing the fixture files. +-} +inTemporaryDirectoryWithFixture :: FilePath -> IO () -> IO () +inTemporaryDirectoryWithFixture name action = do + fixtureDir <- makeAbsolute name + -- Adding a dot to the prefix to make it look nicer (tests/fixtures/simple123423 vs tests/fixtures/simple.123423) + let prefix = fixtureDir ++ "." + withTempDir prefix $ \workDir -> do + fixtureFiles <- listDirectory fixtureDir + for_ fixtureFiles $ \p -> createFileLink (fixtureDir p) (workDir p) + withCurrentDirectory workDir action + +-- | Ensures the given program is available in PATH +checkRequiredProgram :: String -> IO () +checkRequiredProgram progName = + findExecutable progName >>= \mpath -> + when (isNothing mpath) $ fail (progName ++ " is missing") + +callCommand :: String -> IO () +callCommand = void . readCommand + +-- | Run a shell command and capture its standard output +readCommand :: String -> IO String +readCommand cmd = readCreateProcess (shell cmd) "" + +withTempDir :: String -> (FilePath -> IO a) -> IO a +withTempDir prefix action = do + tmpDir <- mkdtemp prefix + action tmpDir `finally` removeDirectoryRecursive tmpDir diff --git a/tests/Tests.hs b/tests/Tests.hs new file mode 100644 index 0000000..20119ea --- /dev/null +++ b/tests/Tests.hs @@ -0,0 +1,55 @@ +{-# LANGUAGE LambdaCase #-} + +import Codec.Archive.Tar.Entry (Entry (..)) +import Foliage.Tests.Tar +import Foliage.Tests.Utils +import System.Directory +import System.IO +import Test.Tasty +import Test.Tasty.HUnit +import Prelude hiding (EQ) + +main :: IO () +main = do + checkRequiredProgram "foliage" + defaultMain $ + testGroup + "foliage-test-suite" + [ testCaseSteps "one" $ \step -> + inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do + step "Building repository" + callCommand "foliage build" + + step "Running checks" + doesDirectoryExist "_keys" @? "_keys does not exist" + doesFileExist "_repo/01-index.tar" @? "01-index.tar does not exist" + doesFileExist "_repo/01-index.tar.gz" @? "01-index.tar.gz does not exist" + doesFileExist "_repo/mirrors.json" @? "mirrors.json does not exist" + doesFileExist "_repo/root.json" @? "root.json does not exist" + doesFileExist "_repo/snapshot.json" @? "snapshot.json does not exist" + doesFileExist "_repo/timestamp.json" @? "timestamp.json does not exist" + + withTarball "_repo/01-index.tar" $ \TarballAccessFn{lookupEntry} -> do + lookupEntry "pkg-a/2.3.4.5/pkg-a.cabal" >>= \case + Nothing -> + assertFailure "entry for pkg-a-2.3.4.5 is missing" + Just entry -> do + entryTime entry @?= 1648534790 + , --- + testCaseSteps "accepts --no-signatures" $ \step -> + inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do + step "Building repository" + callCommand "foliage build --no-signatures" + + step "Running checks" + doesExist <- doesDirectoryExist "_keys" + doesExist @?= False + , --- + testCaseSteps "accepts --write-metadata" $ \step -> + inTemporaryDirectoryWithFixture "tests/fixtures/simple" $ do + step "Building repository" + callCommand "foliage build --write-metadata" + + step "Running checks" + doesFileExist "_repo/foliage/packages.json" @? "foliage/packages.json does not exist" + ] diff --git a/tests/fixtures/simple/_sources/pkg-a/2.3.4.5/meta.toml b/tests/fixtures/simple/_sources/pkg-a/2.3.4.5/meta.toml new file mode 100644 index 0000000..e41882b --- /dev/null +++ b/tests/fixtures/simple/_sources/pkg-a/2.3.4.5/meta.toml @@ -0,0 +1,2 @@ +timestamp = 2022-03-29T06:19:50+00:00 +url = "file:tarballs/pkg-a-2.3.4.5.tar.gz" diff --git a/tests/fixtures/simple/tarballs/pkg-a-2.3.4.5.tar.gz b/tests/fixtures/simple/tarballs/pkg-a-2.3.4.5.tar.gz new file mode 100644 index 0000000..b943cb2 Binary files /dev/null and b/tests/fixtures/simple/tarballs/pkg-a-2.3.4.5.tar.gz differ diff --git a/tests/fixtures/simple/tarballs/pkg-a/pkg-a.cabal b/tests/fixtures/simple/tarballs/pkg-a/pkg-a.cabal new file mode 100644 index 0000000..84c06c0 --- /dev/null +++ b/tests/fixtures/simple/tarballs/pkg-a/pkg-a.cabal @@ -0,0 +1,17 @@ +cabal-version: 3.0 +name: pkg-a +version: 2.3.4.5 +license: NONE +author: andrea.bedini@tweag.io +maintainer: Andrea Bedini +build-type: Simple + +common warnings + ghc-options: -Wall + +library + import: warnings + exposed-modules: MyLib + build-depends: base ^>=4.17.2.0 + hs-source-dirs: src + default-language: Haskell2010 diff --git a/tests/fixtures/simple/tarballs/pkg-a/src/MyLib.hs b/tests/fixtures/simple/tarballs/pkg-a/src/MyLib.hs new file mode 100644 index 0000000..e657c44 --- /dev/null +++ b/tests/fixtures/simple/tarballs/pkg-a/src/MyLib.hs @@ -0,0 +1,4 @@ +module MyLib (someFunc) where + +someFunc :: IO () +someFunc = putStrLn "someFunc"