mirror of
https://github.com/input-output-hk/foliage.git
synced 2024-10-05 16:37:48 +03:00
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>
This commit is contained in:
parent
1c06741cc8
commit
cbd0c5da8f
2
.github/workflows/nix.yml
vendored
2
.github/workflows/nix.yml
vendored
@ -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
|
||||
|
4
.gitignore
vendored
4
.gitignore
vendored
@ -31,4 +31,6 @@ cabal.project.local~
|
||||
_cache
|
||||
_keys
|
||||
_repo
|
||||
_sources
|
||||
|
||||
# only at the root since we need to check-in testcases _sources
|
||||
./_sources
|
||||
|
@ -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"]
|
||||
|
@ -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 = []
|
||||
|
@ -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,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" $
|
||||
cmd
|
||||
Shell
|
||||
traced "curl" $ cmd Shell curlInvocation
|
||||
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 $ 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
|
||||
|
@ -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
|
||||
|
@ -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)
|
||||
|
@ -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
|
||||
]
|
||||
|
@ -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
|
||||
|
18
flake.lock
18
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": {
|
||||
|
@ -32,7 +32,7 @@
|
||||
|
||||
project = pkgs.haskell-nix.cabalProject' {
|
||||
src = ./.;
|
||||
compiler-nix-name = "ghc926";
|
||||
compiler-nix-name = "ghc94";
|
||||
shell.tools = {
|
||||
cabal = "latest";
|
||||
hlint = "latest";
|
||||
|
@ -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
|
||||
|
32
tests/Foliage/Tests/Tar.hs
Normal file
32
tests/Foliage/Tests/Tar.hs
Normal file
@ -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}
|
53
tests/Foliage/Tests/Utils.hs
Normal file
53
tests/Foliage/Tests/Utils.hs
Normal file
@ -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
|
55
tests/Tests.hs
Normal file
55
tests/Tests.hs
Normal file
@ -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"
|
||||
]
|
2
tests/fixtures/simple/_sources/pkg-a/2.3.4.5/meta.toml
vendored
Normal file
2
tests/fixtures/simple/_sources/pkg-a/2.3.4.5/meta.toml
vendored
Normal file
@ -0,0 +1,2 @@
|
||||
timestamp = 2022-03-29T06:19:50+00:00
|
||||
url = "file:tarballs/pkg-a-2.3.4.5.tar.gz"
|
BIN
tests/fixtures/simple/tarballs/pkg-a-2.3.4.5.tar.gz
vendored
Normal file
BIN
tests/fixtures/simple/tarballs/pkg-a-2.3.4.5.tar.gz
vendored
Normal file
Binary file not shown.
17
tests/fixtures/simple/tarballs/pkg-a/pkg-a.cabal
vendored
Normal file
17
tests/fixtures/simple/tarballs/pkg-a/pkg-a.cabal
vendored
Normal file
@ -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
|
4
tests/fixtures/simple/tarballs/pkg-a/src/MyLib.hs
vendored
Normal file
4
tests/fixtures/simple/tarballs/pkg-a/src/MyLib.hs
vendored
Normal file
@ -0,0 +1,4 @@
|
||||
module MyLib (someFunc) where
|
||||
|
||||
someFunc :: IO ()
|
||||
someFunc = putStrLn "someFunc"
|
Loading…
Reference in New Issue
Block a user