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 <[email protected]> * 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 <[email protected]>
input-output-hk · Sep 15, 2023 · cbd0c5d · cbd0c5d
1 parent 1c06741
commit cbd0c5d
Show file tree

Hide file tree

Showing 19 changed files with 361 additions and 137 deletions.
diff --git 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
@@ -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
@@ -15,14 +15,14 @@ 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
 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,19 +31,17 @@ 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 ()
 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
@@ -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 → app/Foliage/FetchURL.hs b/app/Foliage/RemoteAsset.hs → 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 <file> 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 <file> 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
@@ -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
@@ -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)