Minimal test suite (#81)

* Minimal test suite

- Add support for urls with file: schema; both absolute (file:/path) and
  relative (file:path) paths are supported.

- Log curl invocation in case of failure

- Rename fetchRemoteAsset to fetchURL

- Add verbosity flag

- Bump GHC to 9.4.7

- Bump flake inputs

* Apply suggestions from code review

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>

* Add short option '-v' for '--verbosity'

* Whitespace

* Add comment explaining why the dot

* Rename withFixture to inTemporaryDirectoryWithFixture

* Small refactor of PrepareSource

* Rename TarballSource to URISource

- Move sourceUrl to Foliage.Meta.packageVersionSourceToUri

* Simplify inTemporaryDirectoryWithFixture

* Document tar and cp flags

* Reformat

---------

Co-authored-by: Michael Peyton Jones <me@michaelpj.com>

.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

.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

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"]

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 = []

app/Foliage/FetchURL.hs

@@ -2,9 +2,9 @@
 {-# LANGUAGE DerivingVia #-}
 {-# LANGUAGE TypeFamilies #-}
 
-module Foliage.RemoteAsset (
+module Foliage.FetchURL (
-  fetchRemoteAsset,
+  fetchURL,
-  addFetchRemoteAssetRule,
+  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
+instance Show FetchURL where
-  show (RemoteAsset uri) = "fetchRemoteAsset " ++ show uri
+  show (FetchURL uri) = "fetchURL " ++ show uri
 
-type instance RuleResult RemoteAsset = FilePath
+type instance RuleResult FetchURL = FilePath
 
-fetchRemoteAsset :: URI -> Action FilePath
+fetchURL :: URI -> Action FilePath
-fetchRemoteAsset = apply1 . RemoteAsset
+fetchURL = apply1 . FetchURL
 
-addFetchRemoteAssetRule :: FilePath -> Rules ()
+addFetchURLRule :: FilePath -> Rules ()
-addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
+addFetchURLRule cacheDir = addBuiltinRule noLint noIdentity run
  where
-  run :: BuiltinRun RemoteAsset FilePath
+  run :: BuiltinRun FetchURL FilePath
-  run (RemoteAsset uri) old _mode = do
+  run (FetchURL uri) old _mode = do
     unless (uriQuery uri == "") $
       error ("Query elements in URI are not supported: " <> show uri)
 
@@ -68,9 +68,24 @@ addFetchRemoteAssetRule cacheDir = addBuiltinRule noLint noIdentity run
 runCurl :: URI -> String -> String -> Action ETag
 runCurl uri path etagFile = do
   (Exit exitCode, Stdout out) <-
-    traced "curl" $
+    traced "curl" $ cmd Shell curlInvocation
-      cmd
+  case exitCode of
-        Shell
+    ExitSuccess -> liftIO $ BS.readFile etagFile
+    ExitFailure c -> do
+      -- We show the curl exit code only if we cannot parse curl's write-out.
+      -- If we can parse it, we can craft a better error message.
+      case Aeson.eitherDecode out :: Either String CurlWriteOut of
+        Left err ->
+          error $
+            unlines
+              [ "curl failed with return code " ++ show c ++ " while fetching " ++ show uri
+              , "Error while reading curl diagnostic: " ++ err
+              ]
+        -- We can consider displaying different messages based on some fields (e.g. response_code)
+        Right CurlWriteOut{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"
@@ -98,21 +113,6 @@ runCurl uri path etagFile = do
     , -- URL to fetch
       show uri
     ]
-  case exitCode of
-    ExitSuccess -> liftIO $ BS.readFile etagFile
-    ExitFailure c -> do
-      -- We show the curl exit code only if we cannot parse curl's write-out.
-      -- If we can parse it, we can craft a better error message.
-      case Aeson.eitherDecode out :: Either String CurlWriteOut of
-        Left err ->
-          error $
-            unlines
-              [ "curl failed with return code " ++ show c ++ " while fetching " ++ show uri
-              , "Error while reading curl diagnostic: " ++ err
-              ]
-        -- We can consider displaying different messages based on some fields (e.g. response_code)
-        Right CurlWriteOut{errormsg} ->
-          error errormsg
 
 type ETag = BS.ByteString
 

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
+  = URISource
-      { tarballSourceURI :: URI
+      { 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
+uriCodec :: Toml.Key -> TomlCodec URI
-uri = Toml.textBy to from
+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

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)

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
+          URISource (URI{uriScheme, uriPath}) mSubdir | uriScheme == "file:" -> do
-            tarballPath <- fetchRemoteAsset url
+            tarballPath <- liftIO $ IO.makeAbsolute uriPath
-
+            extractFromTarball tarballPath mSubdir srcDir
-            withTempDir $ \tmpDir -> do
+          URISource uri mSubdir -> do
-              cmd_ "tar xzf" [tarballPath] "-C" [tmpDir]
+            tarballPath <- fetchURL uri
-
+            extractFromTarball tarballPath mSubdir srcDir
-              -- 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.
-          --
           GitHubSource repo rev mSubdir -> do
-            let url = githubRepoTarballUrl repo rev
+            tarballPath <- fetchURL (githubRepoTarballUrl repo rev)
-
+            extractFromTarball tarballPath mSubdir srcDir
-            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]
 
         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
+        ]

cabal.project

@@ -1,3 +1,6 @@
 packages: .
-index-state: 2023-03-17T03:33:00Z
+index-state: 2023-09-10T21:31:08Z
-with-compiler: ghc-9.2
+with-compiler: ghc-9.4.7
+
+tests: True
+test-show-details: direct

flake.lock

@@ -175,11 +175,11 @@
     "hackage-nix": {
       "flake": false,
       "locked": {
-        "lastModified": 1694564562,
+        "lastModified": 1694651084,
-        "narHash": "sha256-DgxhNZzolntRrxNtxz6juCRGJKI3Xw3UtN9zOvK1Z0A=",
+        "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,
+        "lastModified": 1694652616,
-        "narHash": "sha256-Fu9pbaQiA6IxKKJ1v4f8O+r8EEKp/UMxbqdRyIjRz7o=",
+        "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,
+        "lastModified": 1694650147,
-        "narHash": "sha256-vs31FW287tu1z0Wtq0C6+K85wD36sRGeAeFuPSFZ7PY=",
+        "narHash": "sha256-eEx6FjSWKY7cVLvmDOJ2iPue42X8zedsYDY7Byaiz6I=",
         "owner": "input-output-hk",
         "repo": "stackage.nix",
-        "rev": "26e9f75a4775f37ef73ffdde706ca65a2be2151f",
+        "rev": "a59f88d7837f0c537efc7de53dad276e3d9da4ba",
         "type": "github"
       },
       "original": {

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";

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

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}

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

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"
+      ]

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"

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

tests/fixtures/simple/tarballs/pkg-a/src/MyLib.hs

@@ -0,0 +1,4 @@
+module MyLib (someFunc) where
+
+someFunc :: IO ()
+someFunc = putStrLn "someFunc"