pantry-0.9.3: int/Pantry/Types.hs
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
module Pantry.Types
( PantryConfig (..)
, PackageIndexConfig (..)
, HackageSecurityConfig (..)
, defaultHackageSecurityConfig
, Storage (..)
, HasPantryConfig (..)
, BlobKey (..)
, PackageName
, Version
, PackageIdentifier (..)
, Revision (..)
, ModuleName
, CabalFileInfo (..)
, PrintWarnings (..)
, PackageNameP (..)
, VersionP (..)
, ModuleNameP (..)
, PackageIdentifierRevision (..)
, pirForHash
, FileType (..)
, BuildFile (..)
, FileSize (..)
, TreeEntry (..)
, SafeFilePath
, unSafeFilePath
, mkSafeFilePath
, safeFilePathToPath
, hpackSafeFilePath
, TreeKey (..)
, Tree (..)
, renderTree
, parseTree
, parseTreeM
, SHA256
, Unresolved
, resolvePaths
, Package (..)
, PackageCabal (..)
, PHpack (..)
-- , PackageTarball (..)
, RawPackageLocation (..)
, PackageLocation (..)
, toRawPL
, RawPackageLocationImmutable (..)
, PackageLocationImmutable (..)
, toRawPLI
, RawArchive (..)
, Archive (..)
, toRawArchive
, Repo (..)
, AggregateRepo (..)
, SimpleRepo (..)
, toAggregateRepos
, rToSimpleRepo
, arToSimpleRepo
, RepoType (..)
, parsePackageIdentifier
, parsePackageName
, parsePackageNameThrowing
, parseFlagName
, parseVersion
, parseVersionThrowing
, packageIdentifierString
, packageNameString
, flagNameString
, versionString
, moduleNameString
, OptionalSubdirs (..)
, ArchiveLocation (..)
, RelFilePath (..)
, CabalString (..)
, toCabalStringMap
, unCabalStringMap
, parsePackageIdentifierRevision
, Mismatch (..)
, PantryException (..)
, FuzzyResults (..)
, ResolvedPath (..)
, HpackExecutable (..)
, WantedCompiler (..)
--, resolveSnapshotLocation
, snapshotLocation
, defaultSnapshotLocation
, SnapName (..)
, parseSnapName
, RawSnapshotLocation (..)
, SnapshotLocation (..)
, toRawSL
, parseHackageText
, parseRawSnapshotLocation
, RawSnapshotLayer (..)
, SnapshotLayer (..)
, toRawSnapshotLayer
, RawSnapshot (..)
, Snapshot (..)
, RawSnapshotPackage (..)
, SnapshotPackage (..)
, parseWantedCompiler
, RawPackageMetadata (..)
, PackageMetadata (..)
, toRawPM
, cabalFileName
, SnapshotCacheHash (..)
, getGlobalHintsFile
, bsToBlobKey
, warnMissingCabalFile
, connRDBMS
) where
import Casa.Client ( CasaRepoPrefix )
import Database.Persist.Class.PersistField ( PersistField (..) )
import Database.Persist.PersistValue ( PersistValue (..) )
import Database.Persist.Sql ( PersistFieldSql (..), SqlBackend )
#if MIN_VERSION_persistent(2, 13, 0)
import Database.Persist.SqlBackend.Internal ( connRDBMS )
#endif
import Database.Persist.Types ( SqlType (..) )
import Data.Aeson.Encoding.Internal ( unsafeToEncoding )
import Data.Aeson.Types
( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..)
, Object, Parser, ToJSON (..), ToJSONKey (..)
, ToJSONKeyFunction (..), Value (..), (.=), object
, toJSONKeyText, withObject, withText
)
import Data.Aeson.WarningParser
( WarningParser, WithJSONWarnings, (..:), (..:?), (..!=)
, (.:), (...:?), jsonSubWarnings, jsonSubWarningsT
, noJSONWarnings, tellJSONField, withObjectWarnings
)
import Data.ByteString.Builder
( byteString, toLazyByteString, wordDec )
import qualified Data.Conduit.Tar as Tar
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map ( mapKeysMonotonic )
import Data.Text.Read ( decimal )
import Distribution.CabalSpecVersion ( cabalSpecLatest )
#if MIN_VERSION_Cabal(3,4,0)
import Distribution.CabalSpecVersion ( cabalSpecToVersionDigits )
#else
import Distribution.CabalSpecVersion ( CabalSpecVersion (..) )
#endif
import qualified Distribution.Compat.CharParsing as Parse
import Distribution.ModuleName ( ModuleName )
import Distribution.PackageDescription
( FlagName, GenericPackageDescription, unFlagName )
import Distribution.Parsec
( PError (..), PWarning (..), ParsecParser
, explicitEitherParsec, parsec, showPos
)
import qualified Distribution.Pretty
import qualified Distribution.Text
import Distribution.Types.PackageId ( PackageIdentifier (..) )
import Distribution.Types.PackageName
( PackageName, mkPackageName, unPackageName )
import Distribution.Types.Version ( Version, mkVersion, nullVersion )
import Distribution.Types.VersionRange ( VersionRange )
import qualified Hpack.Config as Hpack
import Network.HTTP.Client ( parseRequest )
import Network.HTTP.Types ( Status, statusCode )
import Pantry.SHA256 ( SHA256 )
import qualified Pantry.SHA256 as SHA256
import Path
( Abs, Dir, File, Path, (</>), filename, parseRelFile
, toFilePath
)
import Path.IO ( resolveDir, resolveFile )
import qualified RIO.Set as Set
import RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import RIO.List ( groupBy, intersperse )
import qualified RIO.Text as T
import RIO.Time ( Day, UTCTime, toGregorian )
import qualified RIO.Map as Map
import RIO.PrettyPrint
( blankLine, bulletedList, fillSep, flow, hang, line
, mkNarrativeList, parens, string, style
)
import RIO.PrettyPrint.Types ( Style (..) )
import Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc )
#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as HM
import qualified Data.Aeson.Key
type AesonKey = Data.Aeson.Key.Key
#else
import qualified RIO.HashMap as HM
type AesonKey = Text
#endif
-- | Parsed tree with more information on the Haskell package it contains.
--
-- @since 0.1.0.0
data Package = Package
{ packageTreeKey :: !TreeKey
-- ^ The 'TreeKey' containing this package.
--
-- This is a hash of the binary representation of 'packageTree'.
--
-- @since 0.1.0.0
, packageTree :: !Tree
-- ^ The 'Tree' containing this package.
--
-- @since 0.1.0.0
, packageCabalEntry :: !PackageCabal
-- ^ Information on the cabal file inside this package.
--
-- @since 0.1.0.0
, packageIdent :: !PackageIdentifier
-- ^ The package name and version in this package.
--
-- @since 0.1.0.0
}
deriving (Show, Eq, Ord)
data PHpack = PHpack
{ phOriginal :: !TreeEntry
-- ^ Original hpack file
, phGenerated :: !TreeEntry
-- ^ Generated Cabal file
, phVersion :: !Version
-- ^ Version of Hpack used
}
deriving (Show, Eq, Ord)
data PackageCabal
= PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file
| PCHpack !PHpack
deriving (Show, Eq, Ord)
cabalFileName :: PackageName -> SafeFilePath
cabalFileName name =
case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of
Nothing -> error $ "cabalFileName: failed for " ++ show name
Just sfp -> sfp
-- | The revision number of a package from Hackage, counting upwards from 0 (the
-- original cabal file).
--
-- See caveats on 'CFIRevision'.
--
-- @since 0.1.0.0
newtype Revision = Revision Word
deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql)
-- | Represents a SQL database connection.
-- This used to be a newtype wrapper around a connection pool. However, when
-- investigating <https://github.com/commercialhaskell/stack/issues/4471>, it
-- appeared that holding a pool resulted in overly long write locks being held
-- on the database. As a result, we now abstract away whether a pool is used,
-- and the default implementation in "Pantry.Storage" does not use a pool.
data Storage = Storage
{ withStorage_ ::
forall env a. HasLogFunc env
=> ReaderT SqlBackend (RIO env) a
-> RIO env a
, withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a
}
-- | Configuration value used by the entire pantry package. Create one using
-- 'withPantryConfig' or 'withPantryConfig''. See also 'PantryApp' for a
-- convenience approach to using pantry.
--
-- @since 0.1.0.0
data PantryConfig = PantryConfig
{ pcPackageIndex :: !PackageIndexConfig
, pcHpackExecutable :: !HpackExecutable
, pcRootDir :: !(Path Abs Dir)
, pcStorage :: !Storage
, pcUpdateRef :: !(MVar Bool)
-- ^ Want to try updating the index once during a single run for missing
-- package identifiers. We also want to ensure we only update once at a
-- time. Start at @True@.
, pcParsedCabalFilesRawImmutable ::
!(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
-- ^ Cache of previously parsed cabal files, to save on slow parsing time.
, pcParsedCabalFilesMutable ::
!( IORef
( Map
(Path Abs Dir)
( PrintWarnings -> IO GenericPackageDescription
, PackageName
, Path Abs File
)
)
)
-- ^ Cache for mutable packages. We want to allow for an optimization:
-- deferring parsing of the 'GenericPackageDescription' until its actually
-- needed. Therefore, we keep the filepath and the 'PackageName' derived
-- from that filepath. When the @IO GenericPackageDescription@ is run, it
-- will ensure that the @PackageName@ matches the value inside the cabal
-- file, and print out any warnings that still need to be printed.
, pcConnectionCount :: !Int
-- ^ concurrently open downloads
, pcCasaConfig :: !(Maybe (CasaRepoPrefix, Int))
-- ^ Optionally, the Casa pull URL e.g. @https://casa.stackage.org@ and
-- the maximum number of Casa keys to pull per request.
, pcSnapshotLocation :: SnapName -> RawSnapshotLocation
-- ^ The location of snapshot synonyms
}
-- | Get the location of a snapshot synonym from the 'PantryConfig'.
--
-- @since 0.5.0.0
snapshotLocation ::
HasPantryConfig env
=> SnapName
-> RIO env RawSnapshotLocation
snapshotLocation name = do
loc <- view $ pantryConfigL.to pcSnapshotLocation
pure $ loc name
-- | Should we print warnings when loading a cabal file?
--
-- @since 0.1.0.0
data PrintWarnings = YesPrintWarnings | NoPrintWarnings
-- | Wraps a value which potentially contains relative paths. Needs to be
-- provided with a base directory to resolve these paths.
--
-- Unwrap this using 'resolvePaths'.
--
-- @since 0.1.0.0
newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a)
deriving Functor
instance Applicative Unresolved where
pure = Unresolved . const . pure
Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir
-- | Resolve all of the file paths in an 'Unresolved' relative to the given
-- directory.
--
-- @since 0.1.0.0
resolvePaths ::
MonadIO m
=> Maybe (Path Abs Dir) -- ^ directory to use for relative paths
-> Unresolved a
-> m a
resolvePaths mdir (Unresolved f) = liftIO (f mdir)
-- | A combination of the relative path provided in a config file, together with
-- the resolved absolute path.
--
-- @since 0.1.0.0
data ResolvedPath t = ResolvedPath
{ resolvedRelative :: !RelFilePath
-- ^ Original value parsed from a config file.
, resolvedAbsolute :: !(Path Abs t)
-- ^ Absolute path resolved against base directory loaded from.
}
deriving (Show, Eq, Generic, Ord)
instance NFData (ResolvedPath t)
-- | Location to load a package from. Can either be immutable (see
-- 'PackageLocationImmutable') or a local directory which is expected to change
-- over time. Raw version doesn't include exact package version (e.g. could
-- refer to the latest revision on Hackage)
--
-- @since 0.1.0.0
data RawPackageLocation
= RPLImmutable !RawPackageLocationImmutable
| RPLMutable !(ResolvedPath Dir)
deriving (Show, Eq, Generic)
instance NFData RawPackageLocation
-- | Location to load a package from. Can either be immutable (see
-- 'PackageLocationImmutable') or a local directory which is expected to change
-- over time.
--
-- @since 0.1.0.0
data PackageLocation
= PLImmutable !PackageLocationImmutable
| PLMutable !(ResolvedPath Dir)
deriving (Show, Eq, Generic)
instance NFData PackageLocation
instance Display PackageLocation where
display (PLImmutable loc) = display loc
display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp
-- | Convert `PackageLocation` to its "raw" equivalent
--
-- @since 0.1.0.0
toRawPL :: PackageLocation -> RawPackageLocation
toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im)
toRawPL (PLMutable m) = RPLMutable m
-- | Location for remote packages or archives assumed to be immutable.
-- as user specifies it i.e. not an exact location
--
-- @since 0.1.0.0
data RawPackageLocationImmutable
= RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey)
| RPLIArchive !RawArchive !RawPackageMetadata
| RPLIRepo !Repo !RawPackageMetadata
deriving (Show, Eq, Ord, Generic)
instance NFData RawPackageLocationImmutable
instance Display RawPackageLocationImmutable where
display (RPLIHackage pir _tree) = display pir <> " (from Hackage)"
display (RPLIArchive archive _pm) =
"Archive from " <> display (raLocation archive) <>
(if T.null $ raSubdir archive
then mempty
else " in subdir " <> display (raSubdir archive))
display (RPLIRepo repo _pm) =
"Repo from " <> display (repoUrl repo) <>
", commit " <> display (repoCommit repo) <>
(if T.null $ repoSubdir repo
then mempty
else " in subdir " <> display (repoSubdir repo))
instance Pretty RawPackageLocationImmutable where
pretty (RPLIHackage pir _tree) = fillSep
[ fromString . T.unpack $ textDisplay pir
, parens (flow "from Hackage")
]
pretty (RPLIArchive archive _pm) = fillSep
[ flow "Archive from"
, pretty (raLocation archive)
, if T.null $ raSubdir archive
then mempty
else fillSep
[ flow "in subdir"
, style Dir (fromString $ T.unpack (raSubdir archive))
]
]
pretty (RPLIRepo repo _pm) = fillSep
[ flow "Repo from"
, style Url (fromString $ T.unpack (repoUrl repo)) <> ","
, "commit"
, fromString $ T.unpack (repoCommit repo)
, if T.null $ repoSubdir repo
then mempty
else fillSep
[ flow "in subdir"
, style Dir (fromString $ T.unpack (repoSubdir repo))
]
]
-- | Location for remote packages or archives assumed to be immutable.
--
-- @since 0.1.0.0
data PackageLocationImmutable
= PLIHackage !PackageIdentifier !BlobKey !TreeKey
| PLIArchive !Archive !PackageMetadata
| PLIRepo !Repo !PackageMetadata
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData PackageLocationImmutable
instance Display PackageLocationImmutable where
display (PLIHackage ident _cabalHash _tree) =
fromString (packageNameString $ pkgName ident) <> " (from Hackage)"
display (PLIArchive archive _pm) =
"Archive from " <> display (archiveLocation archive) <>
(if T.null $ archiveSubdir archive
then mempty
else " in subdir " <> display (archiveSubdir archive))
display (PLIRepo repo _pm) =
"Repo from " <> display (repoUrl repo) <>
", commit " <> display (repoCommit repo) <>
(if T.null $ repoSubdir repo
then mempty
else " in subdir " <> display (repoSubdir repo))
instance ToJSON PackageLocationImmutable where
toJSON = toJSON . toRawPLI
-- | Package identifier and revision with a specified cabal file hash
--
-- @since 0.1.0.0
pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash (PackageIdentifier name ver) (BlobKey sha size') =
let cfi = CFIHash sha (Just size')
in PackageIdentifierRevision name ver cfi
-- | Convert `PackageLocationImmutable` to its "raw" equivalent
--
-- @since 0.1.0.0
toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (PLIHackage ident cfKey treeKey) =
RPLIHackage (pirForHash ident cfKey) (Just treeKey)
toRawPLI (PLIArchive archive pm) =
RPLIArchive (toRawArchive archive) (toRawPM pm)
toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm)
-- | A raw package archive, specified by a user, could have no
-- hash and file size information.
--
-- @since 0.1.0.0
data RawArchive = RawArchive
{ raLocation :: !ArchiveLocation
-- ^ Location of the archive
--
-- @since 0.1.0.0
, raHash :: !(Maybe SHA256)
-- ^ Cryptographic hash of the archive file
--
-- @since 0.1.0.0
, raSize :: !(Maybe FileSize)
-- ^ Size of the archive file
--
-- @since 0.1.0.0
, raSubdir :: !Text
-- ^ Subdirectory within the archive to get the package from.
--
-- @since 0.1.0.0
}
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData RawArchive
-- | A package archive, could be from a URL or a local file path. Local file
-- path archives are assumed to be unchanging over time, and so are allowed in
-- custom snapshots.
--
-- @since 0.1.0.0
data Archive = Archive
{ archiveLocation :: !ArchiveLocation
-- ^ Location of the archive
--
-- @since 0.1.0.0
, archiveHash :: !SHA256
-- ^ Cryptographic hash of the archive file
--
-- @since 0.1.0.0
, archiveSize :: !FileSize
-- ^ Size of the archive file
--
-- @since 0.1.0.0
, archiveSubdir :: !Text
-- ^ Subdirectory within the archive to get the package from.
--
-- @since 0.1.0.0
}
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData Archive
-- | Convert archive to its "raw" equivalent.
--
-- @since 0.1.0.0
toRawArchive :: Archive -> RawArchive
toRawArchive archive =
RawArchive (archiveLocation archive) (Just $ archiveHash archive)
(Just $ archiveSize archive) (archiveSubdir archive)
-- | The type of a source control repository.
--
-- @since 0.1.0.0
data RepoType = RepoGit | RepoHg
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData RepoType
instance PersistField RepoType where
toPersistValue RepoGit = toPersistValue (1 :: Int32)
toPersistValue RepoHg = toPersistValue (2 :: Int32)
fromPersistValue v = do
i <- fromPersistValue v
case i :: Int32 of
1 -> pure RepoGit
2 -> pure RepoHg
_ -> Left $ fromString $ "Invalid RepoType: " ++ show i
instance PersistFieldSql RepoType where
sqlType _ = SqlInt32
-- | Information on packages stored in a source control repository.
--
-- @since 0.1.0.0
data Repo = Repo
{ repoUrl :: !Text
-- ^ Location of the repo
--
-- @since 0.1.0.0
, repoCommit :: !Text
-- ^ Commit to use from the repo. It's strongly recommended to use
-- a hash instead of a tag or branch name.
--
-- @since 0.1.0.0
, repoType :: !RepoType
-- ^ The type of the repo
--
-- @since 0.1.0.0
, repoSubdir :: !Text
-- ^ Subdirectory within the archive to get the package from.
--
-- @since 0.1.0.0
}
deriving (Generic, Eq, Ord, Typeable)
instance NFData Repo
instance Show Repo where
show = T.unpack . utf8BuilderToText . display
instance Display Repo where
display (Repo url commit typ subdir) =
(case typ of
RepoGit -> "Git"
RepoHg -> "Mercurial") <>
" repo at " <>
display url <>
", commit " <>
display commit <>
(if T.null subdir
then mempty
else " in subdirectory " <> display subdir)
rToSimpleRepo :: Repo -> SimpleRepo
rToSimpleRepo Repo {..} = SimpleRepo
{ sRepoUrl = repoUrl
, sRepoCommit = repoCommit
, sRepoType = repoType
}
data AggregateRepo = AggregateRepo
{ aRepo :: !SimpleRepo
, aRepoSubdirs :: [(Text, RawPackageMetadata)]
}
deriving (Show, Generic, Eq, Ord, Typeable)
-- | Group input repositories by non-subdir values.
toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir
where
toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
toAggregateRepo [] = Nothing
toAggregateRepo xs@((repo, _):_) =
Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs)
matchRepoExclSubdir x1 x2 =
let (Repo url1 commit1 type1 _, _) = x1
(Repo url2 commit2 type2 _, _) = x2
in (url1, commit1, type1) == (url2, commit2, type2)
arToSimpleRepo :: AggregateRepo -> SimpleRepo
arToSimpleRepo AggregateRepo {..} = aRepo
-- | Repository without subdirectory information.
--
-- @since 0.5.3
data SimpleRepo = SimpleRepo
{ sRepoUrl :: !Text
, sRepoCommit :: !Text
, sRepoType :: !RepoType
}
deriving (Show, Generic, Eq, Ord, Typeable)
instance Display SimpleRepo where
display (SimpleRepo url commit typ) =
(case typ of
RepoGit -> "Git"
RepoHg -> "Mercurial") <>
" repo at " <>
display url <>
", commit " <>
display commit
-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains
-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar".
newtype GitHubRepo = GitHubRepo Text
instance FromJSON GitHubRepo where
parseJSON = withText "GitHubRepo" $ \s -> do
case T.split (== '/') s of
[x, y] | not (T.null x || T.null y) -> pure (GitHubRepo s)
_ -> fail "expecting \"user/repo\""
-- | Configuration to securely download package metadata and contents. For most
-- purposes, you'll want to use the default Hackage settings via
-- @defaultPackageIndexConfig@.
--
-- /NOTE/ It's highly recommended to only use the official Hackage
-- server or a mirror. See
-- <https://github.com/commercialhaskell/stack/issues/4137>.
--
-- @since 0.6.0
data PackageIndexConfig = PackageIndexConfig
{ picDownloadPrefix :: !Text
, picHackageSecurityConfig :: !HackageSecurityConfig
}
deriving Show
-- | If the @hackage-security@ key is absent from the JSON object, assigns
-- default value 'defaultHackageSecurityConfig'.
--
-- @since 0.6.0
instance FromJSON (WithJSONWarnings PackageIndexConfig) where
parseJSON = withObjectWarnings "PackageIndexConfig" $ \o -> do
picDownloadPrefix <- o ..: "download-prefix"
picHackageSecurityConfig <- jsonSubWarnings $
o ..:? "hackage-security" ..!= noJSONWarnings defaultHackageSecurityConfig
pure PackageIndexConfig {..}
-- | Default 'HackageSecurityConfig' value using the official Hackage server.
-- The value of the 'hscIgnoreExpiry' field is 'True'.
--
-- @since 0.7.0
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig = HackageSecurityConfig
{ hscKeyIds =
-- Key owners and public keys are provided as a convenience to readers.
-- The canonical source for this mapping data is the hackage-root-keys
-- repository and Hackage's root.json file.
--
-- Links:
-- * https://github.com/haskell-infra/hackage-root-keys
-- * https://hackage.haskell.org/root.json
-- Please consult root.json on Hackage to map key IDs to public keys,
-- and the hackage-root-keys repository to map public keys to their
-- owners.
[ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)
"fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
, -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
"1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
, -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
"0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
, -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
"51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
, -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)
"be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"
, -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)
"d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"
]
, hscKeyThreshold = 3
, hscIgnoreExpiry = True
}
-- | Configuration for Hackage Security to securely download package metadata
-- and contents. For most purposes, you'll want to use the default Hackage
-- settings via @defaultHackageSecurityConfig@.
--
-- /NOTE/ It's highly recommended to only use the official Hackage
-- server or a mirror. See
-- <https://github.com/commercialhaskell/stack/issues/4137>.
--
-- @since 0.6.0
data HackageSecurityConfig = HackageSecurityConfig
{ hscKeyIds :: ![Text]
, hscKeyThreshold :: !Int
, hscIgnoreExpiry :: !Bool
}
deriving Show
-- | If the @ignore-expiry@ key is absent from the JSON object, assigns default
-- value 'True'.
--
-- @since 0.1.1.0
instance FromJSON (WithJSONWarnings HackageSecurityConfig) where
parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o -> do
hscKeyIds <- o ..: "keyids"
hscKeyThreshold <- o ..: "key-threshold"
hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True
pure HackageSecurityConfig {..}
-- | An environment which contains a 'PantryConfig'.
--
-- @since 0.1.0.0
class HasPantryConfig env where
-- | Lens to get or set the 'PantryConfig'
--
-- @since 0.1.0.0
pantryConfigL :: Lens' env PantryConfig
-- | File size in bytes
--
-- @since 0.1.0.0
newtype FileSize = FileSize Word
deriving ( Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData
, PersistField, PersistFieldSql, ToJSON, FromJSON
)
-- | A key for looking up a blob, which combines the SHA256 hash of the contents
-- and the file size.
--
-- The file size may seem redundant with the hash. However, it is necessary for
-- safely downloading blobs from an untrusted source. See
-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>.
--
-- @since 0.1.0.0
data BlobKey = BlobKey !SHA256 !FileSize
deriving (Eq, Ord, Typeable, Generic)
instance NFData BlobKey
instance Show BlobKey where
show = T.unpack . utf8BuilderToText . display
instance Display BlobKey where
display (BlobKey sha size') = display sha <> "," <> display size'
blobKeyPairs :: BlobKey -> [(AesonKey, Value)]
blobKeyPairs (BlobKey sha size') =
[ "sha256" .= sha
, "size" .= size'
]
instance ToJSON BlobKey where
toJSON = object . blobKeyPairs
instance FromJSON BlobKey where
parseJSON = withObject "BlobKey" $ \o -> BlobKey
<$> o .: "sha256"
<*> o .: "size"
newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName }
deriving (Eq, Ord, Show, Read, NFData)
instance Display PackageNameP where
display = fromString . packageNameString . unPackageNameP
instance PersistField PackageNameP where
toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn
fromPersistValue v = do
str <- fromPersistValue v
case parsePackageName str of
Nothing -> Left $ "Invalid package name: " <> T.pack str
Just pn -> Right $ PackageNameP pn
instance PersistFieldSql PackageNameP where
sqlType _ = SqlString
instance ToJSON PackageNameP where
toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn
instance FromJSON PackageNameP where
parseJSON =
withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack
instance ToJSONKey PackageNameP where
toJSONKey =
ToJSONKeyText
(fromString . packageNameString . unPackageNameP)
(unsafeToEncoding . getUtf8Builder . display)
instance FromJSONKey PackageNameP where
fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack
newtype VersionP = VersionP { unVersionP :: Version }
deriving (Eq, Ord, Show, Read, NFData)
instance PersistField VersionP where
toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v
fromPersistValue v = do
str <- fromPersistValue v
case parseVersion str of
Nothing -> Left $ "Invalid version number: " <> T.pack str
Just ver -> Right $ VersionP ver
instance PersistFieldSql VersionP where
sqlType _ = SqlString
instance Display VersionP where
display (VersionP v) = fromString $ versionString v
instance ToJSON VersionP where
toJSON (VersionP v) = String $ T.pack $ versionString v
instance FromJSON VersionP where
parseJSON =
withText "VersionP" $
either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack
newtype ModuleNameP = ModuleNameP
{ unModuleNameP :: ModuleName
}
deriving (Eq, Ord, Show, NFData)
instance Display ModuleNameP where
display = fromString . moduleNameString . unModuleNameP
instance PersistField ModuleNameP where
toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn
fromPersistValue v = do
str <- fromPersistValue v
case parseModuleName str of
Nothing -> Left $ "Invalid module name: " <> T.pack str
Just pn -> Right $ ModuleNameP pn
instance PersistFieldSql ModuleNameP where
sqlType _ = SqlString
-- | How to choose a cabal file for a package from Hackage. This is to work with
-- Hackage cabal file revisions, which makes @PackageIdentifier@ insufficient
-- for specifying a package from Hackage.
--
-- @since 0.1.0.0
data CabalFileInfo
= CFILatest
-- ^ Take the latest revision of the cabal file available. This
-- isn't reproducible at all, but the running assumption (not
-- necessarily true) is that cabal file revisions do not change
-- semantics of the build.
--
-- @since 0.1.0.0
| CFIHash !SHA256 !(Maybe FileSize)
-- ^ Identify by contents of the cabal file itself. Only reason for
-- @Maybe@ on @FileSize@ is for compatibility with input that
-- doesn't include the file size.
--
-- @since 0.1.0.0
| CFIRevision !Revision
-- ^ Identify by revision number, with 0 being the original and
-- counting upward. This relies on Hackage providing consistent
-- versioning. @CFIHash@ should be preferred wherever possible for
-- reproducibility.
--
-- @since 0.1.0.0
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData CabalFileInfo
instance Hashable CabalFileInfo
instance Display CabalFileInfo where
display CFILatest = mempty
display (CFIHash hash' msize) =
"@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize
display (CFIRevision rev) = "@rev:" <> display rev
-- | A full specification for a package from Hackage, including the package
-- name, version, and how to load up the correct cabal file revision.
--
-- @since 0.1.0.0
data PackageIdentifierRevision
= PackageIdentifierRevision !PackageName !Version !CabalFileInfo
deriving (Generic, Eq, Ord, Typeable)
instance NFData PackageIdentifierRevision
instance Show PackageIdentifierRevision where
show = T.unpack . utf8BuilderToText . display
instance Display PackageIdentifierRevision where
display (PackageIdentifierRevision name version cfi) =
fromString (packageNameString name)
<> "-"
<> fromString (versionString version)
<> display cfi
instance ToJSON PackageIdentifierRevision where
toJSON = toJSON . utf8BuilderToText . display
instance FromJSON PackageIdentifierRevision where
parseJSON = withText "PackageIdentifierRevision" $ \t ->
case parsePackageIdentifierRevision t of
Left e -> fail $ show e
Right pir -> pure pir
-- | Parse a hackage text.
--
-- @since 0.1.0.0
parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText t =
either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $
explicitEitherParsec (hackageTextParsec <* Parse.eof) $
T.unpack t
hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec = do
ident <- packageIdentifierParsec
_ <- Parse.string "@sha256:"
shaT <- Parse.munch (/= ',')
sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT
_ <- Parse.char ','
size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't
pure (ident, BlobKey sha (FileSize size'))
splitColon :: Text -> Maybe (Text, Text)
splitColon t' =
let (x, y) = T.break (== ':') t'
in (x, ) <$> T.stripPrefix ":" y
-- | Parse a 'PackageIdentifierRevision'
--
-- @since 0.1.0.0
parsePackageIdentifierRevision ::
Text
-> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision t =
maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do
let (identT, cfiT) = T.break (== '@') t
PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT
cfi <-
case splitColon cfiT of
Just ("@sha256", shaSizeT) -> do
let (shaT, sizeT) = T.break (== ',') shaSizeT
sha <- either (const Nothing) Just $ SHA256.fromHexText shaT
msize <-
case T.stripPrefix "," sizeT of
Nothing -> Just Nothing
Just sizeT' ->
case decimal sizeT' of
Right (size', "") -> Just $ Just $ FileSize size'
_ -> Nothing
pure $ CFIHash sha msize
Just ("@rev", revT) ->
case decimal revT of
Right (rev, "") -> pure $ CFIRevision $ Revision rev
_ -> Nothing
Nothing -> pure CFILatest
_ -> Nothing
pure $ PackageIdentifierRevision name version cfi
data Mismatch a = Mismatch
{ mismatchExpected :: !a
, mismatchActual :: !a
}
-- | Things that can go wrong in pantry. Note two things:
--
-- * Many other exception types may be thrown from underlying libraries. Pantry
-- does not attempt to wrap these underlying exceptions.
--
-- * We may add more constructors to this data type in minor version bumps of
-- pantry. This technically breaks the PVP. You should not be writing pattern
-- matches against this type that expect total matching.
--
-- @since 0.1.0.0
data PantryException
= PackageIdentifierRevisionParseFail !Text
| InvalidCabalFile
!(Either RawPackageLocationImmutable (Path Abs File))
!(Maybe Version)
![PError]
![PWarning]
| TreeWithoutCabalFile !RawPackageLocationImmutable
| TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath]
| MismatchedCabalName !(Path Abs File) !PackageName
| NoLocalPackageDirFound !(Path Abs Dir)
| NoCabalFileFound !(Path Abs Dir)
| MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File]
| InvalidWantedCompiler !Text
| InvalidSnapshotLocation !(Path Abs Dir) !Text
| InvalidOverrideCompiler !WantedCompiler !WantedCompiler
| InvalidFilePathSnapshot !Text
| InvalidSnapshot !RawSnapshotLocation !SomeException
| MismatchedPackageMetadata
!RawPackageLocationImmutable
!RawPackageMetadata
!(Maybe TreeKey)
!PackageIdentifier
| Non200ResponseStatus !Status
| InvalidBlobKey !(Mismatch BlobKey)
| Couldn'tParseSnapshot !RawSnapshotLocation !String
| WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName
| DownloadInvalidSHA256 !Text !(Mismatch SHA256)
| DownloadInvalidSize !Text !(Mismatch FileSize)
| DownloadTooLarge !Text !(Mismatch FileSize)
-- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is
-- a lower bound on the size from the server.
| LocalNoArchiveFileFound !(Path Abs File)
| LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256)
| LocalInvalidSize !(Path Abs File) !(Mismatch FileSize)
| UnknownArchiveType !ArchiveLocation
| InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType
| UnsupportedTarball !ArchiveLocation !Text
| NoHackageCryptographicHash !PackageIdentifier
| FailedToCloneRepo !SimpleRepo
| TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey
| CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata
| CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32)
| UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults
| CannotCompleteRepoNonSHA1 !Repo
| MutablePackageLocationFromUrl !Text
| MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier)
| PackageNameParseFail !Text
| PackageVersionParseFail !Text
| InvalidCabalFilePath !(Path Abs File)
| DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])]
| MigrationFailure !Text !(Path Abs File) !SomeException
| NoCasaConfig
| InvalidTreeFromCasa !BlobKey !ByteString
| ParseSnapNameException !Text
| HpackLibraryException !(Path Abs File) !String
| HpackExeException !FilePath !(Path Abs Dir) !SomeException
deriving Typeable
instance Exception PantryException where
instance Show PantryException where
show = T.unpack . utf8BuilderToText . display
-- To support the Haskell Foundation's
-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry
-- error messages generated by Pantry itself begin with an unique code in the
-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999.
-- The numbers are selected at random, not in sequence.
--
-- Prettier versions of these error messages are also provided. See the instance
-- of Pretty.
instance Display PantryException where
display NoCasaConfig =
"Error: [S-889]\n"
<> "The Pantry configuration has no Casa configuration."
display (InvalidTreeFromCasa blobKey _bs) =
"Error: [S-258]\n"
<> "Invalid tree from casa: "
<> display blobKey
display (PackageIdentifierRevisionParseFail text) =
"Error: [S-360]\n"
<> "Invalid package identifier (with optional revision): "
<> display text
display (InvalidCabalFile loc mversion errs warnings) =
"Error: [S-242]\n"
<> "Unable to parse cabal file from package "
<> either display (fromString . toFilePath) loc
<> "\n\n"
<> foldMap
( \(PError pos msg) ->
"- "
<> fromString (showPos pos)
<> ": "
<> fromString msg
<> "\n"
)
errs
<> foldMap
( \(PWarning _ pos msg) ->
"- "
<> fromString (showPos pos)
<> ": "
<> fromString msg
<> "\n"
)
warnings
<> ( case mversion of
Just version
| version > cabalSpecLatestVersion ->
"\n\nThe cabal file uses the cabal specification version "
<> fromString (versionString version)
<> ", but we only support up to version "
<> fromString (versionString cabalSpecLatestVersion)
<> ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)."
_ -> mempty
)
display (TreeWithoutCabalFile pl) =
"Error: [S-654]\n"
<> "No cabal file found for "
<> display pl
display (TreeWithMultipleCabalFiles pl sfps) =
"Error: [S-500]\n"
<> "Multiple cabal files found for "
<> display pl
<> ": "
<> fold (intersperse ", " (map display sfps))
display (MismatchedCabalName fp name) =
"Error: [S-910]\n"
<> "The Cabal file:\n"
<> fromString (toFilePath fp)
<> "\nis not named after the package that it defines.\n"
<> "Please rename the file to: "
<> fromString (packageNameString name)
<> ".cabal\n"
<> "Hackage rejects packages where the first part of the Cabal file name "
<> "is not the package name."
display (NoLocalPackageDirFound dir) =
"Error: [S-395]\n"
<> "Stack looks for packages in the directories configured in the\n"
<> "'packages' and 'extra-deps' fields defined in its project-level\n"
<> "configuration file (usually stack.yaml)\n"
<> "The current entry points to "
<> fromString (toFilePath dir)
<> ",\nbut no such directory could be found. If, alternatively, a package\n"
<> "in the package index was intended, its name and version must be\n"
<> "specified as an extra-dep."
display (NoCabalFileFound dir) =
"Error: [S-636]\n"
<> "Stack looks for packages in the directories configured in the\n"
<> "'packages' and 'extra-deps' fields defined in its project-level\n"
<> "configuration file (usually stack.yaml)\n"
<> "The current entry points to "
<> fromString (toFilePath dir)
<> ",\nbut no .cabal or package.yaml file could be found there."
display (MultipleCabalFilesFound dir files) =
"Error: [S-368]\n"
<> "Multiple .cabal files found in directory "
<> fromString (toFilePath dir)
<> ":\n"
<> fold
( intersperse
"\n"
(map (\x -> "- " <> fromString (toFilePath (filename x))) files)
)
display (InvalidWantedCompiler t) =
"Error: [S-204]\n"
<> "Invalid wanted compiler: "
<> display t
display (InvalidSnapshotLocation dir t) =
"Error: [S-935]\n"
<> "Invalid snapshot location "
<> displayShow t
<> " relative to directory "
<> displayShow (toFilePath dir)
display (InvalidOverrideCompiler x y) =
"Error: [S-287]\n"
<> "Specified compiler for a resolver ("
<> display x
<> "), but also specified an override compiler ("
<> display y
<> ")"
display (InvalidFilePathSnapshot t) =
"Error: [S-617]\n"
<> "Specified snapshot as file path with "
<> displayShow t
<> ", but not reading from a local file"
display (InvalidSnapshot loc err) =
"Error: [S-775]\n"
<> "Exception while reading snapshot from "
<> display loc
<> ":\n"
<> displayShow err
display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
"Error: [S-427]\n"
<> "Mismatched package metadata for "
<> display loc
<> "\nFound: "
<> fromString (packageIdentifierString foundIdent)
<> ( case mtreeKey of
Nothing -> mempty
Just treeKey -> " with tree " <> display treeKey
)
<> "\nExpected: "
<> display pm
display (Non200ResponseStatus status) =
"Error: [S-571]\n"
<> "Unexpected non-200 HTTP status code: "
<> displayShow (statusCode status)
display (InvalidBlobKey Mismatch{..}) =
"Error: [S-236]\n"
<> "Invalid blob key found, expected: "
<> display mismatchExpected
<> ", actual: "
<> display mismatchActual
display (Couldn'tParseSnapshot sl err) =
"Error: [S-645]\n"
<> "Couldn't parse snapshot from "
<> display sl
<> ": "
<> fromString err
display (WrongCabalFileName pl sfp name) =
"Error: [S-575]\n"
<> "Wrong cabal file name for package "
<> display pl
<> "\nThe cabal file is named "
<> display sfp
<> ", but package name is "
<> fromString (packageNameString name)
<> "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895"
display (DownloadInvalidSHA256 url Mismatch {..}) =
"Error: [S-394]\n"
<> "Mismatched SHA256 hash from "
<> display url
<> "\nExpected: "
<> display mismatchExpected
<> "\nActual: "
<> display mismatchActual
display (DownloadInvalidSize url Mismatch {..}) =
"Error: [S-401]\n"
<> "Mismatched download size from "
<> display url
<> "\nExpected: "
<> display mismatchExpected
<> "\nActual: "
<> display mismatchActual
display (DownloadTooLarge url Mismatch {..}) =
"Error: [S-113]\n"
<> "Download from "
<> display url
<> " was too large.\n"
<> "Expected: "
<> display mismatchExpected
<> ", stopped after receiving: "
<> display mismatchActual
display (LocalNoArchiveFileFound path) =
"Error: [S-628]\n"
<> "Stack looks for packages in the archive files configured in the\n"
<> "'extra-deps' field defined in its project-level configuration file\n"
<> "(usually stack.yaml)\n"
<> "An entry points to "
<> fromString (toFilePath path)
<> ",\nbut no such archive file could be found."
display (LocalInvalidSHA256 path Mismatch {..}) =
"Error: [S-834]\n"
<> "Mismatched SHA256 hash from "
<> fromString (toFilePath path)
<> "\nExpected: "
<> display mismatchExpected
<> "\nActual: "
<> display mismatchActual
display (LocalInvalidSize path Mismatch {..}) =
"Error: [S-713]\n"
<> "Mismatched file size from "
<> fromString (toFilePath path)
<> "\nExpected: "
<> display mismatchExpected
<> "\nActual: "
<> display mismatchActual
display (UnknownArchiveType loc) =
"Error: [S-372]\n"
<> "Unable to determine archive type of: "
<> display loc
display (InvalidTarFileType loc fp x) =
"Error: [S-950]\n"
<> "Unsupported tar file type in archive "
<> display loc
<> " at file "
<> fromString fp
<> ": "
<> displayShow x
display (UnsupportedTarball loc err) =
"Error: [S-760]\n"
<> "Unsupported tarball from "
<> display loc
<> ": "
<> display err
display (NoHackageCryptographicHash ident) =
"Error: [S-922]\n"
<> "No cryptographic hash found for Hackage package "
<> fromString (packageIdentifierString ident)
display (FailedToCloneRepo repo) =
"Error: [S-109]\n"
<> "Failed to clone repo "
<> display repo
display (TreeReferencesMissingBlob loc sfp key) =
"Error: [S-237]\n"
<> "The package "
<> display loc
<> " needs blob "
<> display key
<> " for file path "
<> display sfp
<> ", but the blob is not available"
display (CompletePackageMetadataMismatch loc pm) =
"Error: [S-984]\n"
<> "When completing package metadata for "
<> display loc
<> ", some values changed in the new package metadata: "
<> display pm
display (CRC32Mismatch loc fp Mismatch {..}) =
"Error: [S-607]\n"
<> "CRC32 mismatch in ZIP file from "
<> display loc
<> " on internal file "
<> fromString fp
<> "\nExpected: "
<> display mismatchExpected
<> "\nActual: "
<> display mismatchActual
display (UnknownHackagePackage pir fuzzy) =
"Error: [S-476]\n"
<> "Could not find "
<> display pir
<> " on Hackage"
<> displayFuzzy fuzzy
display (CannotCompleteRepoNonSHA1 repo) =
"Error: [S-112]\n"
<> "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: "
<> display repo
display (MutablePackageLocationFromUrl t) =
"Error: [S-321]\n"
<> "Cannot refer to a mutable package location from a URL: "
<> display t
display (MismatchedCabalFileForHackage pir Mismatch{..}) =
"Error: [S-377]\n"
<> "When processing cabal file for Hackage package "
<> display pir
<> ":\nMismatched package identifier."
<> "\nExpected: "
<> fromString (packageIdentifierString mismatchExpected)
<> "\nActual: "
<> fromString (packageIdentifierString mismatchActual)
display (PackageNameParseFail t) =
"Error: [S-580]\n"
<> "Invalid package name: "
<> display t
display (PackageVersionParseFail t) =
"Error: [S-479]\n"
<> "Invalid version: "
<> display t
display (InvalidCabalFilePath fp) =
"Error: [S-824]\n"
<> "File path contains a name which is not a valid package name: "
<> fromString (toFilePath fp)
display (DuplicatePackageNames source pairs') =
"Error: [S-674]\n"
<> "Duplicate package names ("
<> source
<> "):\n"
<> foldMap
( \(name, locs) ->
fromString (packageNameString name)
<> ":\n"
<> foldMap (\loc -> "- " <> display loc <> "\n") locs
)
pairs'
display (MigrationFailure desc fp err) =
"Error: [S-536]\n"
<> "Encountered error while migrating database "
<> display desc
<> "\nlocated at "
<> fromString (toFilePath fp)
<> ":"
<> "\n "
<> displayShow err
display (ParseSnapNameException t) =
"Error: [S-994]\n"
<> "Invalid snapshot name: "
<> display t
display (HpackLibraryException file err) =
"Error: [S-305]\n"
<> "Failed to generate a Cabal file using the Hpack library on file:\n"
<> fromString (toFilePath file)
<> "\n\n"
<> "The error encountered was:\n\n"
<> fromString err
display (HpackExeException fp dir err) =
"Error: [S-720]\n"
<> "Failed to generate a Cabal file using the Hpack executable:\n"
<> fromString fp
<> "in directory: "
<> fromString (toFilePath dir)
<> "\n\n"
<> "The error encountered was:\n\n"
<> fromString (show err)
-- See also the instance of Display. Although prettier, these messages are
-- intended to be substantively the same as the corresponding 'black and white'
-- versions.
instance Pretty PantryException where
pretty NoCasaConfig =
"[S-889]"
<> line
<> flow "The Pantry configuration has no Casa configuration."
pretty (InvalidTreeFromCasa blobKey _bs) =
"[S-258]"
<> line
<> fillSep
[ flow "Invalid tree from casa:"
, fromString . T.unpack $ textDisplay blobKey
]
pretty (PackageIdentifierRevisionParseFail text) =
"[S-360]"
<> line
<> fillSep
[ flow "Invalid package identifier (with optional revision):"
, fromString $ T.unpack text
]
pretty (InvalidCabalFile loc mversion errs warnings) =
"[S-242]"
<> line
<> fillSep
[ flow "Unable to parse Cabal file from package"
, either pretty pretty loc <> ":"
]
<> line
<> bulletedList
( map (\(PError pos msg) -> fillSep
[ fromString (showPos pos) <> ":"
, fromString msg
])
errs
)
<> line
<> bulletedList
( map (\(PWarning _ pos msg) -> fillSep
[ fromString (showPos pos) <> ":"
, fromString msg
])
warnings
)
<> ( case mversion of
Just version | version > cabalSpecLatestVersion ->
line
<> fillSep
[ flow "The Cabal file uses the Cabal specification version"
, style Current (fromString $ versionString version) <> ","
, flow "but we only support up to version"
, fromString (versionString cabalSpecLatestVersion) <> "."
, flow "Recommended action: upgrade your build tool"
, parens (fillSep
[ "e.g."
, style Shell (flow "stack upgrade")
]) <> "."
]
_ -> mempty
)
pretty (TreeWithoutCabalFile loc) =
"[S-654]"
<> line
<> fillSep
[ flow "No Cabal file found for"
, pretty loc <> "."
]
pretty (TreeWithMultipleCabalFiles loc sfps) =
"[S-500]"
<> line
<> fillSep
( flow "Multiple Cabal files found for"
: (pretty loc <> ":")
: mkNarrativeList (Just File) False
(map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc])
)
pretty (MismatchedCabalName fp name) =
"[S-910]"
<> line
<> fillSep
[ flow "The Cabal file"
, pretty fp
, flow "is not named after the package that it defines. Please rename"
, flow "the file to"
, style File (fromString $ packageNameString name <> ".cabal") <> "."
, flow "Hackage rejects packages where the first part of the Cabal"
, flow "file name is not the package name."
]
pretty (NoLocalPackageDirFound dir) =
"[S-395]"
<> line
<> fillSep
[ flow "Stack looks for packages in the directories configured in the"
, style Shell "packages"
, "and"
, style Shell "extra-deps"
, flow "fields defined in its project-level configuration file"
, parens (fillSep ["usually", style File "stack.yaml"]) <> "."
, flow "The current entry points to"
, pretty dir
, flow "but no such directory could be found. If, alternatively, a"
, flow "package in the package index was intended, its name and"
, flow "version must be specified as an extra-dep."
]
pretty (NoCabalFileFound dir) =
"[S-636]"
<> line
<> fillSep
[ flow "Stack looks for packages in the directories configured in the"
, style Shell "packages"
, "and"
, style Shell "extra-deps"
, flow "fields defined in its project-level configuration file"
, parens (fillSep ["usually", style File "stack.yaml"]) <> "."
, flow "The current entry points to"
, pretty dir
, flow "but no Cabal file or"
, style File "package.yaml"
, flow "could be found there."
]
pretty (MultipleCabalFilesFound dir files) =
"[S-368]"
<> line
<> fillSep
( flow "Multiple Cabal files found in directory"
: (pretty dir <> ":")
: mkNarrativeList (Just File) False
(map (pretty . filename) files)
)
pretty (InvalidWantedCompiler t) =
"[S-204]"
<> line
<> fillSep
[ flow "Invalid wanted compiler:"
, style Current (fromString $ T.unpack t) <> "."
]
pretty (InvalidSnapshotLocation dir t) =
"[S-935]"
<> line
<> fillSep
[ flow "Invalid snapshot location"
, style Current (fromString $ T.unpack t)
, flow "relative to directory"
, pretty dir <> "."
]
pretty (InvalidOverrideCompiler x y) =
"[S-287]"
<> line
<> fillSep
[ flow "Specified compiler for a resolver"
, parens (style Shell (fromString . T.unpack $ textDisplay x))
, flow "but also specified an override compiler"
, parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "."
]
pretty (InvalidFilePathSnapshot t) =
"[S-617]"
<> line
<> fillSep
[ flow "Specified snapshot as file path with"
, style File (fromString $ T.unpack t) <> ","
, flow "but not reading from a local file."
]
pretty (InvalidSnapshot loc err) =
"[S-775]"
<> line
<> fillSep
[ flow "Exception while reading snapshot from"
, pretty loc <> ":"
]
<> blankLine
<> string (displayException err)
pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
"[S-427]"
<> line
<> fillSep
[ flow "Mismatched package metadata for"
, pretty loc <> "."
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, let t = textDisplay pm
in if T.null t
then "nothing."
else fromString $ T.unpack t <> "."
])
<> line
<> hang 10 (fillSep
[ "Found: "
, fromString $ packageIdentifierString foundIdent <> case mtreeKey of
Nothing -> "."
_ -> mempty
, case mtreeKey of
Nothing -> mempty
Just treeKey -> fillSep
[ "with tree"
, fromString . T.unpack $ textDisplay treeKey <> "."
]
])
pretty (Non200ResponseStatus status) =
"[S-571]"
<> line
<> fillSep
[ flow "Unexpected non-200 HTTP status code:"
, (fromString . show $ statusCode status) <> "."
]
pretty (InvalidBlobKey Mismatch{..}) =
"[S-236]"
<> line
<> fillSep
[ flow "Invalid blob key found, expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> ","
, "actual:"
, fromString . T.unpack $ textDisplay mismatchActual <> "."
]
pretty (Couldn'tParseSnapshot sl err) =
"[S-645]"
<> line
<> fillSep
[ flow "Couldn't parse snapshot from"
, pretty sl <> ":"
]
<> blankLine
<> string err
pretty (WrongCabalFileName loc sfp name) =
"[S-575]"
<> line
<> fillSep
[ flow "Wrong Cabal file name for package"
, pretty loc <> "."
, flow "The Cabal file is named"
, style File (fromString . T.unpack $ textDisplay sfp) <> ","
, flow "but package name is"
, fromString (packageNameString name) <> "."
, flow "For more information, see"
, style Url "https://github.com/commercialhaskell/stack/issues/317"
, "and"
, style Url "https://github.com/commercialhaskell/stack/issues/895" <> "."
]
pretty (DownloadInvalidSHA256 url Mismatch {..}) =
"[S-394]"
<> line
<> fillSep
[ flow "Mismatched SHA256 hash from"
, style Url (fromString $ T.unpack url) <> "."
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> "."
])
<> line
<> hang 10 (fillSep
[ "Actual: "
, fromString . T.unpack $ textDisplay mismatchActual <> "."
])
pretty (DownloadInvalidSize url Mismatch {..}) =
"[S-401]"
<> line
<> fillSep
[ flow "Mismatched download size from"
, style Url (fromString $ T.unpack url) <> "."
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> "."
])
<> line
<> hang 10 (fillSep
[ "Actual: "
, fromString . T.unpack $ textDisplay mismatchActual <> "."
])
pretty (DownloadTooLarge url Mismatch {..}) =
"[S-113]"
<> line
<> fillSep
[ flow "Download from"
, style Url (fromString $ T.unpack url)
, flow "was too large. Expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> ","
, flow "stopped after receiving:"
, fromString . T.unpack $ textDisplay mismatchActual <> "."
]
pretty (LocalNoArchiveFileFound path) =
"[S-628]"
<> line
<> fillSep
[ flow "Stack looks for packages in the archive files configured in"
, "the"
, style Shell "extra-deps"
, flow "field defined in its project-level configuration file"
, parens (fillSep ["usually", style File "stack.yaml"]) <> "."
, flow "An entry points to"
, pretty path
, flow "but no such archive file could be found."
]
pretty (LocalInvalidSHA256 path Mismatch {..}) =
"[S-834]"
<> line
<> fillSep
[ flow "Mismatched SHA256 hash from"
, pretty path <> "."
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> "."
])
<> line
<> hang 10 (fillSep
[ "Actual: "
, fromString . T.unpack $ textDisplay mismatchActual <> "."
])
pretty (LocalInvalidSize path Mismatch {..}) =
"[S-713]"
<> line
<> fillSep
[ flow "Mismatched file size from"
, pretty path <> "."
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> "."
])
<> line
<> hang 10 (fillSep
[ "Actual: "
, fromString . T.unpack $ textDisplay mismatchActual <> "."
])
pretty (UnknownArchiveType loc) =
"[S-372]"
<> line
<> fillSep
[ flow "Unable to determine archive type of:"
, pretty loc <> "."
]
pretty (InvalidTarFileType loc fp x) =
"[S-950]"
<> line
<> fillSep
[ flow "Unsupported tar file type in archive"
, pretty loc
, flow "at file"
, style File (fromString fp) <> ":"
, fromString $ show x <> "."
]
pretty (UnsupportedTarball loc err) =
"[S-760]"
<> line
<> fillSep
[ flow "Unsupported tarball from"
, pretty loc <> ":"
]
<> blankLine
<> string (T.unpack err)
pretty (NoHackageCryptographicHash ident) =
"[S-922]"
<> line
<> fillSep
[ flow "No cryptographic hash found for Hackage package"
, fromString (packageIdentifierString ident) <> "."
]
pretty (FailedToCloneRepo repo) =
"[S-109]"
<> line
<> fillSep
[ flow "Failed to clone repository"
, fromString . T.unpack $ textDisplay repo
]
pretty (TreeReferencesMissingBlob loc sfp key) =
"[S-237]"
<> line
<> fillSep
[ flow "The package"
, pretty loc
, flow "needs blob"
, fromString . T.unpack $ textDisplay key
, flow "for file path"
, style File (fromString . T.unpack $ textDisplay sfp) <> ","
, flow "but the blob is not available."
]
pretty (CompletePackageMetadataMismatch loc pm) =
"[S-984]"
<> line
<> fillSep
[ flow "When completing package metadata for"
, pretty loc <> ","
, flow "some values changed in the new package metadata:"
, fromString . T.unpack $ textDisplay pm <> "."
]
pretty (CRC32Mismatch loc fp Mismatch {..}) =
"[S-607]"
<> line
<> fillSep
[ flow "CRC32 mismatch in Zip file from"
, pretty loc
, flow "on internal file"
, style File (fromString fp)
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, fromString . T.unpack $ textDisplay mismatchExpected <> "."
])
<> line
<> hang 10 (fillSep
[ "Actual: "
, fromString . T.unpack $ textDisplay mismatchActual <> "."
])
pretty (UnknownHackagePackage pir fuzzy) =
"[S-476]"
<> line
<> fillSep
[ flow "Could not find"
, style Error (fromString . T.unpack $ textDisplay pir)
, flow "on Hackage."
]
<> prettyFuzzy fuzzy
pretty (CannotCompleteRepoNonSHA1 repo) =
"[S-112]"
<> line
<> fillSep
[ flow "Cannot complete repo information for a non SHA1 commit due to"
, "non-reproducibility:"
, fromString . T.unpack $ textDisplay repo <> "."
]
pretty (MutablePackageLocationFromUrl t) =
"[S-321]"
<> line
<> fillSep
[ flow "Cannot refer to a mutable package location from a URL:"
, style Url (fromString $ T.unpack t) <> "."
]
pretty (MismatchedCabalFileForHackage pir Mismatch{..}) =
"[S-377]"
<> line
<> fillSep
[ flow "When processing Cabal file for Hackage package"
, fromString . T.unpack $ textDisplay pir <> ","
, flow "mismatched package identifier."
]
<> blankLine
<> hang 10 (fillSep
[ "Expected:"
, fromString (packageIdentifierString mismatchExpected) <> "."
])
<> line
<> hang 10 (fillSep
[ "Actual: "
, fromString (packageIdentifierString mismatchActual) <> "."
])
pretty (PackageNameParseFail t) =
"[S-580]"
<> line
<> fillSep
[ flow "Invalid package name:"
, fromString $ T.unpack t <> "."
]
pretty (PackageVersionParseFail t) =
"[S-479]"
<> line
<> fillSep
[ flow "Invalid version:"
, fromString $ T.unpack t <> "."
]
pretty (InvalidCabalFilePath fp) =
"[S-824]"
<> line
<> fillSep
[ flow "File path contains a name which is not a valid package name:"
, pretty fp <> "."
]
pretty (DuplicatePackageNames source pairs') =
"[S-674]"
<> line
<> fillSep
[ flow "Duplicate package names"
, parens (fromString . T.unpack $ textDisplay source) <> ":"
]
<> line
<> foldMap
( \(name, locs) ->
fromString (packageNameString name) <> ":"
<> line
<> bulletedList (map pretty locs)
<> line
)
pairs'
pretty (MigrationFailure desc fp err) =
"[S-536]"
<> line
<> fillSep
[ flow "Encountered error while migrating database"
, fromString $ T.unpack desc
, flow "located at"
, pretty fp <> ":"
]
<> blankLine
<> string (displayException err)
pretty (ParseSnapNameException t) =
"[S-994]"
<> line
<> fillSep
[ flow "Invalid snapshot name:"
, fromString $ T.unpack t <> "."
]
pretty (HpackLibraryException file err) =
"[S-305]"
<> line
<> fillSep
[ flow "Failed to generate a Cabal file using the Hpack library on"
, "file:"
, pretty file <> "."
, flow "The error encountered was:"
]
<> blankLine
<> string err
pretty (HpackExeException fp dir err) =
"[S-720]"
<> line
<> fillSep
[ flow "Failed to generate a Cabal file using the Hpack executable:"
, style File (fromString fp)
, flow "in directory:"
, pretty dir <> "."
, flow "The error encountered was:"
]
<> blankLine
<> string (displayException err)
data FuzzyResults
= FRNameNotFound ![PackageName]
| FRVersionNotFound !(NonEmpty PackageIdentifierRevision)
| FRRevisionNotFound !(NonEmpty PackageIdentifierRevision)
displayFuzzy :: FuzzyResults -> Utf8Builder
displayFuzzy (FRNameNotFound names) =
case NE.nonEmpty names of
Nothing -> ""
Just names' ->
"\nPerhaps you meant " <>
orSeparated (NE.map (fromString . packageNameString) names') <>
"?"
displayFuzzy (FRVersionNotFound pirs) =
"\nPossible candidates: " <>
commaSeparated (NE.map display pirs) <>
"."
displayFuzzy (FRRevisionNotFound pirs) =
"\nThe specified revision was not found.\nPossible candidates: " <>
commaSeparated (NE.map display pirs) <>
"."
prettyFuzzy :: FuzzyResults -> StyleDoc
prettyFuzzy (FRNameNotFound names) =
case NE.nonEmpty names of
Nothing -> mempty
Just names' ->
line
<> fillSep
( flow "Perhaps you meant one of"
: mkNarrativeList Nothing False
(NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc])
)
prettyFuzzy (FRVersionNotFound pirs) =
line
<> fillSep
( flow "Possible candidates:"
: mkNarrativeList Nothing False
(NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc])
)
prettyFuzzy (FRRevisionNotFound pirs) =
line
<> fillSep
( flow "The specified revision was not found. Possible candidates:"
: mkNarrativeList Nothing False
(NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc])
)
orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
orSeparated xs
| NE.length xs == 1 = NE.head xs
| NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs
| otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs
commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder
commaSeparated = fold . NE.intersperse ", "
cabalSpecLatestVersion :: Version
cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest
#if !MIN_VERSION_Cabal(3,4,0)
cabalSpecToVersionDigits :: CabalSpecVersion -> [Int]
cabalSpecToVersionDigits CabalSpecV3_0 = [3,0]
cabalSpecToVersionDigits CabalSpecV2_4 = [2,4]
cabalSpecToVersionDigits CabalSpecV2_2 = [2,2]
cabalSpecToVersionDigits CabalSpecV2_0 = [2,0]
cabalSpecToVersionDigits CabalSpecV1_24 = [1,24]
cabalSpecToVersionDigits CabalSpecV1_22 = [1,22]
cabalSpecToVersionDigits CabalSpecV1_20 = [1,20]
cabalSpecToVersionDigits CabalSpecV1_18 = [1,18]
cabalSpecToVersionDigits CabalSpecV1_12 = [1,12]
cabalSpecToVersionDigits CabalSpecV1_10 = [1,10]
cabalSpecToVersionDigits CabalSpecV1_8 = [1,8]
cabalSpecToVersionDigits CabalSpecV1_6 = [1,6]
cabalSpecToVersionDigits CabalSpecV1_4 = [1,4]
cabalSpecToVersionDigits CabalSpecV1_2 = [1,2]
cabalSpecToVersionDigits CabalSpecV1_0 = [1,0]
#endif
data BuildFile
= BFCabal !SafeFilePath !TreeEntry
| BFHpack !TreeEntry
-- We don't need SafeFilePath for Hpack since it has to be package.yaml file
deriving (Show, Eq)
data FileType = FTNormal | FTExecutable
deriving (Show, Eq, Enum, Bounded, Ord)
instance PersistField FileType where
toPersistValue FTNormal = PersistInt64 1
toPersistValue FTExecutable = PersistInt64 2
fromPersistValue v = do
i <- fromPersistValue v
case i :: Int64 of
1 -> Right FTNormal
2 -> Right FTExecutable
_ -> Left $ "Invalid FileType: " <> tshow i
instance PersistFieldSql FileType where
sqlType _ = SqlInt32
data TreeEntry = TreeEntry
{ teBlob :: !BlobKey
, teType :: !FileType
}
deriving (Show, Eq, Ord)
newtype SafeFilePath = SafeFilePath Text
deriving (Show, Eq, Ord, Display)
instance PersistField SafeFilePath where
toPersistValue = toPersistValue . unSafeFilePath
fromPersistValue v = do
t <- fromPersistValue v
maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t
instance PersistFieldSql SafeFilePath where
sqlType _ = SqlString
unSafeFilePath :: SafeFilePath -> Text
unSafeFilePath (SafeFilePath t) = t
safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File)
safeFilePathToPath dir (SafeFilePath path) = do
fpath <- parseRelFile (T.unpack path)
pure $ dir </> fpath
mkSafeFilePath :: Text -> Maybe SafeFilePath
mkSafeFilePath t = do
guard $ not $ "\\" `T.isInfixOf` t
guard $ not $ "//" `T.isInfixOf` t
guard $ not $ "\n" `T.isInfixOf` t
guard $ not $ "\0" `T.isInfixOf` t
(c, _) <- T.uncons t
guard $ c /= '/'
guard $ (not . any (T.all (== '.'))) $ T.split (== '/') t
Just $ SafeFilePath t
-- | SafeFilePath for `package.yaml` file.
hpackSafeFilePath :: SafeFilePath
hpackSafeFilePath =
let fpath = mkSafeFilePath (T.pack Hpack.packageConfig)
in case fpath of
Nothing -> error $
"hpackSafeFilePath: Not able to encode " <> Hpack.packageConfig
Just sfp -> sfp
-- | The hash of the binary representation of a 'Tree'.
--
-- @since 0.1.0.0
newtype TreeKey = TreeKey BlobKey
deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display)
-- | Represents the contents of a tree, which is a mapping from
-- relative file paths to 'TreeEntry's.
--
-- @since 0.1.0.0
newtype Tree
= TreeMap (Map SafeFilePath TreeEntry)
-- In the future, consider allowing more lax parsing
-- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys
-- TreeTarball !PackageTarball
deriving (Show, Eq, Ord)
renderTree :: Tree -> ByteString
renderTree = BL.toStrict . toLazyByteString . go
where
go :: Tree -> Builder
go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m
goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) =
netstring (unSafeFilePath sfp) <>
byteString (SHA256.toRaw sha) <>
netword size' <>
(case ft of
FTNormal -> "N"
FTExecutable -> "X")
netstring :: Text -> Builder
netstring t =
let bs = encodeUtf8 t
in netword (fromIntegral (B.length bs)) <> byteString bs
netword :: Word -> Builder
netword w = wordDec w <> ":"
parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM (blobKey, blob) =
case parseTree blob of
Nothing -> throwM (InvalidTreeFromCasa blobKey blob)
Just tree -> pure (TreeKey blobKey, tree)
parseTree :: ByteString -> Maybe Tree
parseTree bs1 = do
tree <- parseTree' bs1
let bs2 = renderTree tree
guard $ bs1 == bs2
Just tree
parseTree' :: ByteString -> Maybe Tree
parseTree' bs0 = do
entriesBS <- B.stripPrefix "map:" bs0
TreeMap <$> loop Map.empty entriesBS
where
loop !m bs1
| B.null bs1 = pure m
| otherwise = do
(sfpBS, bs2) <- takeNetstring bs1
sfp <-
case decodeUtf8' sfpBS of
Left _ -> Nothing
Right sfpT -> mkSafeFilePath sfpT
(sha, bs3) <- takeSha bs2
(size', bs4) <- takeNetword bs3
(typeW, bs5) <- B.uncons bs4
ft <-
case typeW of
78 -> Just FTNormal -- 'N'
88 -> Just FTExecutable -- 'X'
_ -> Nothing
let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft
loop (Map.insert sfp entry m) bs5
takeNetstring bs1 = do
(size', bs2) <- takeNetword bs1
guard $ B.length bs2 >= size'
Just $ B.splitAt size' bs2
takeSha bs = do
let (x, y) = B.splitAt 32 bs
x' <- either (const Nothing) Just (SHA256.fromRaw x)
Just (x', y)
takeNetword =
go 0
where
go !accum bs = do
(next, rest) <- B.uncons bs
if
| next == 58 -> pure (accum, rest) -- ':'
| next >= 48 && next <= 57 ->
go
(accum * 10 + fromIntegral (next - 48))
rest
| otherwise -> Nothing
{-
data PackageTarball = PackageTarball
{ ptBlob :: !BlobKey
-- ^ Contains the tarball itself
, ptCabal :: !BlobKey
-- ^ Contains the cabal file contents
, ptSubdir :: !FilePath
-- ^ Subdir containing the files we want for this package.
--
-- There must be precisely one file with a @.cabal@ file extension
-- located there. Thanks to Hackage revisions, its contents will be
-- overwritten by the value of @ptCabal@.
}
deriving Show
-}
-- | This is almost a copy of Cabal's parser for package identifiers,
-- the main difference is in the fact that Stack requires version to be
-- present while Cabal uses "null version" as a default value
--
-- @since 0.1.0.0
parsePackageIdentifier :: String -> Maybe PackageIdentifier
parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof)
packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec = do
ident@(PackageIdentifier _ v) <- parsec
-- version is a required component of a package identifier for Stack
guard (v /= nullVersion)
pure ident
-- | Parse a package name from a 'String'.
--
-- @since 0.1.0.0
parsePackageName :: String -> Maybe PackageName
parsePackageName = Distribution.Text.simpleParse
-- | Parse a package name from a 'String' throwing on failure
--
-- @since 0.1.0.0
parsePackageNameThrowing :: MonadThrow m => String -> m PackageName
parsePackageNameThrowing str =
case parsePackageName str of
Nothing -> throwM $ PackageNameParseFail $ T.pack str
Just pn -> pure pn
-- | Parse a version from a 'String'.
--
-- @since 0.1.0.0
parseVersion :: String -> Maybe Version
parseVersion = Distribution.Text.simpleParse
-- | Parse a package version from a 'String' throwing on failure
--
-- @since 0.1.0.0
parseVersionThrowing :: MonadThrow m => String -> m Version
parseVersionThrowing str =
case parseVersion str of
Nothing -> throwM $ PackageVersionParseFail $ T.pack str
Just v -> pure v
-- | Parse a version range from a 'String'.
--
-- @since 0.1.0.0
parseVersionRange :: String -> Maybe VersionRange
parseVersionRange = Distribution.Text.simpleParse
-- | Parse a module name from a 'String'.
--
-- @since 0.1.0.0
parseModuleName :: String -> Maybe ModuleName
parseModuleName = Distribution.Text.simpleParse
-- | Parse a flag name from a 'String'.
--
-- @since 0.1.0.0
parseFlagName :: String -> Maybe FlagName
parseFlagName = Distribution.Text.simpleParse
-- | Render a package name as a 'String'.
--
-- @since 0.1.0.0
packageNameString :: PackageName -> String
packageNameString = unPackageName
-- | Render a package identifier as a 'String'.
--
-- @since 0.1.0.0
packageIdentifierString :: PackageIdentifier -> String
packageIdentifierString = Distribution.Text.display
-- | Render a version as a 'String'.
--
-- @since 0.1.0.0
versionString :: Version -> String
versionString = Distribution.Text.display
-- | Render a flag name as a 'String'.
--
-- @since 0.1.0.0
flagNameString :: FlagName -> String
flagNameString = unFlagName
-- | Render a module name as a 'String'.
--
-- @since 0.1.0.0
moduleNameString :: ModuleName -> String
moduleNameString = Distribution.Text.display
data OptionalSubdirs
= OSSubdirs !(NonEmpty Text)
| OSPackageMetadata !Text !RawPackageMetadata
-- ^ subdirectory and package metadata
deriving (Show, Eq, Generic)
instance NFData OptionalSubdirs
-- | Metadata provided by a config file for archives and repos. This information
-- can be used for optimized lookups of information like package identifiers, or
-- for validating that the user configuration has the expected information.
--
-- @since 0.1.0.0
data RawPackageMetadata = RawPackageMetadata
{ rpmName :: !(Maybe PackageName)
-- ^ Package name in the cabal file
--
-- @since 0.1.0.0
, rpmVersion :: !(Maybe Version)
-- ^ Package version in the cabal file
--
-- @since 0.1.0.0
, rpmTreeKey :: !(Maybe TreeKey)
-- ^ Tree key of the loaded up package
--
-- @since 0.1.0.0
}
deriving (Show, Eq, Ord, Generic, Typeable)
instance NFData RawPackageMetadata
instance Display RawPackageMetadata where
display rpm = fold $ intersperse ", " $ catMaybes
[ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm
, (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm
, (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm
]
-- | Exact metadata specifying concrete package
--
-- @since 0.1.0.0
data PackageMetadata = PackageMetadata
{ pmIdent :: !PackageIdentifier
-- ^ Package identifier in the cabal file
--
-- @since 0.1.0.0
, pmTreeKey :: !TreeKey
-- ^ Tree key of the loaded up package
--
-- @since 0.1.0.0
}
deriving (Show, Eq, Ord, Generic, Typeable)
-- i PackageMetadata
instance NFData PackageMetadata
instance Display PackageMetadata where
display pm = fold $ intersperse ", "
[ "ident == " <> fromString (packageIdentifierString $ pmIdent pm)
, "tree == " <> display (pmTreeKey pm)
]
parsePackageMetadata :: Object -> WarningParser PackageMetadata
parsePackageMetadata o = do
_oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file"
pantryTree :: BlobKey <- o ..: "pantry-tree"
CabalString pkgName <- o ..: "name"
CabalString pkgVersion <- o ..: "version"
let pmTreeKey = TreeKey pantryTree
pmIdent = PackageIdentifier {..}
pure PackageMetadata {..}
-- | Convert package metadata to its "raw" equivalent.
--
-- @since 0.1.0.0
toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm)
where
PackageIdentifier name version = pmIdent pm
-- | File path relative to the configuration file it was parsed from
--
-- @since 0.1.0.0
newtype RelFilePath = RelFilePath Text
deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display)
-- | Location that an archive is stored at
--
-- @since 0.1.0.0
data ArchiveLocation
= ALUrl !Text
-- ^ Archive stored at an HTTP(S) URL
--
-- @since 0.1.0.0
| ALFilePath !(ResolvedPath File)
-- ^ Archive stored at a local file path
--
-- @since 0.1.0.0
deriving (Show, Eq, Ord, Generic, Typeable)
instance NFData ArchiveLocation
instance Display ArchiveLocation where
display (ALUrl url) = display url
display (ALFilePath resolved) =
fromString $ toFilePath $ resolvedAbsolute resolved
instance Pretty ArchiveLocation where
pretty (ALUrl url) = style Url (fromString $ T.unpack url)
pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved
parseArchiveLocationObject ::
Object
-> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject o =
((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl)
<|> ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath)
<|> ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText)
<|> ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText)
parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText t =
case validateUrl t of
Left e1 ->
case validateFilePath t of
Left e2 -> Left $ T.unlines
[ "Invalid archive location, neither a URL nor a file path"
, " URL error: " <> e1
, " File path error: " <> e2
]
Right x -> Right x
Right x -> Right x
validateUrl :: Text -> Either Text (Unresolved ArchiveLocation)
validateUrl t =
case parseRequest $ T.unpack t of
Left _ -> Left $ "Could not parse URL: " <> t
Right _ -> pure $ pure $ ALUrl t
validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath t =
if any (`T.isSuffixOf` t) (T.words ".zip .tar .tar.gz")
then pure $ Unresolved $ \case
Nothing -> throwIO $ InvalidFilePathSnapshot t
Just dir -> do
abs' <- resolveFile dir $ T.unpack t
pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs'
else Left $ "Does not have an archive file extension: " <> t
instance ToJSON RawPackageLocation where
toJSON (RPLImmutable rpli) = toJSON rpli
toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved)
instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where
parseJSON v =
(fmap . fmap . fmap . fmap) RPLImmutable (parseJSON v) <|>
(noJSONWarnings . mkMutable <$> parseJSON v)
where
mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation)
mkMutable t = Unresolved $ \mdir -> do
case mdir of
Nothing -> throwIO $ MutablePackageLocationFromUrl t
Just dir -> do
abs' <- resolveDir dir $ T.unpack t
pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs'
instance ToJSON RawPackageLocationImmutable where
toJSON (RPLIHackage pir mtree) = object $
("hackage" .= pir) : maybe [] (\tree -> ["pantry-tree" .= tree]) mtree
toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat
[ case loc of
ALUrl url -> ["url" .= url]
ALFilePath resolved -> ["filepath" .= resolvedRelative resolved]
, maybe [] (\sha -> ["sha256" .= sha]) msha
, maybe [] (\size' -> ["size" .= size']) msize
, [ "subdir" .= subdir | not (T.null subdir) ]
, rpmToPairs rpm
]
toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat
[ [ urlKey .= url
, "commit" .= commit
]
, ["subdir" .= subdir | not (T.null subdir) ]
, rpmToPairs rpm
]
where
urlKey =
case typ of
RepoGit -> "git"
RepoHg -> "hg"
rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs (RawPackageMetadata mname mversion mtree) = concat
[ maybe [] (\name -> ["name" .= CabalString name]) mname
, maybe [] (\version -> ["version" .= CabalString version]) mversion
, maybe [] (\tree -> ["pantry-tree" .= tree]) mtree
]
instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where
parseJSON v =
repoObject v
<|> archiveObject v
<|> hackageObject v
<|> github v
<|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v)
where
repoObject ::
Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
repoObject =
withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do
pm <- parsePackageMetadata o
repoSubdir <- o ..:? "subdir" ..!= ""
repoCommit <- o ..: "commit"
(repoType, repoUrl) <-
(o ..: "git" >>= \url -> pure (RepoGit, url)) <|>
(o ..: "hg" >>= \url -> pure (RepoHg, url))
pure $ pure $ PLIRepo Repo {..} pm
archiveObject =
withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do
pm <- parsePackageMetadata o
Unresolved mkArchiveLocation <- parseArchiveLocationObject o
archiveHash <- o ..: "sha256"
archiveSize <- o ..: "size"
archiveSubdir <- o ..:? "subdir" ..!= ""
pure $ Unresolved $ \mdir -> do
archiveLocation <- mkArchiveLocation mdir
pure $ PLIArchive Archive {..} pm
hackageObject =
withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do
treeKey <- o ..: "pantry-tree"
htxt <- o ..: "hackage"
case parseHackageText htxt of
Left e -> fail $ show e
Right (pkgIdentifier, blobKey) ->
pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)
github =
withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do
pm <- parsePackageMetadata o
GitHubRepo ghRepo <- o ..: "github"
commit <- o ..: "commit"
let archiveLocation = ALUrl $ T.concat
[ "https://github.com/"
, ghRepo
, "/archive/"
, commit
, ".tar.gz"
]
archiveHash <- o ..: "sha256"
archiveSize <- o ..: "size"
archiveSubdir <- o ..:? "subdir" ..!= ""
pure $ pure $ PLIArchive Archive {..} pm)
instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where
parseJSON v =
http v
<|> hackageText v
<|> hackageObject v
<|> repo v
<|> archiveObject v
<|> github v
<|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v)
where
http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable)))
http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t ->
case parseArchiveLocationText t of
Left _ -> fail $ "Invalid archive location: " ++ T.unpack t
Right (Unresolved mkArchiveLocation) ->
pure $ noJSONWarnings $ Unresolved $ \mdir -> do
raLocation <- mkArchiveLocation mdir
let raHash = Nothing
raSize = Nothing
raSubdir = T.empty
pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty
hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t ->
case parsePackageIdentifierRevision t of
Left e -> fail $ show e
Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing
hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> pure . pure <$> (RPLIHackage
<$> o ..: "hackage"
<*> o ..:? "pantry-tree")
optionalSubdirs :: Object -> WarningParser OptionalSubdirs
optionalSubdirs o =
-- if subdirs exists, it needs to be valid
case HM.lookup "subdirs" o of
Just v' -> do
tellJSONField "subdirs"
subdirs <- lift $ parseJSON v'
case NE.nonEmpty subdirs of
Nothing -> fail "Invalid empty subdirs"
Just x -> pure $ OSSubdirs x
Nothing -> OSPackageMetadata
<$> o ..:? "subdir" ..!= T.empty
<*> ( rawPackageMetadataHelper
<$> (fmap unCabalString <$> (o ..:? "name"))
<*> (fmap unCabalString <$> (o ..:? "version"))
<*> o ..:? "pantry-tree"
<*> o ..:? "cabal-file"
)
rawPackageMetadataHelper ::
Maybe PackageName
-> Maybe Version
-> Maybe TreeKey
-> Maybe BlobKey
-> RawPackageMetadata
rawPackageMetadataHelper name version pantryTree _ignoredCabalFile =
RawPackageMetadata name version pantryTree
repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do
(repoType, repoUrl) <-
((RepoGit, ) <$> o ..: "git") <|>
((RepoHg, ) <$> o ..: "hg")
repoCommit <- o ..: "commit"
os <- optionalSubdirs o
pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os)
archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do
Unresolved mkArchiveLocation <- parseArchiveLocationObject o
raHash <- o ..:? "sha256"
raSize <- o ..:? "size"
os <- optionalSubdirs o
pure $ Unresolved $ \mdir -> do
raLocation <- mkArchiveLocation mdir
pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os)
github = withObjectWarnings "PLArchive:github" $ \o -> do
GitHubRepo ghRepo <- o ..: "github"
commit <- o ..: "commit"
let raLocation = ALUrl $ T.concat
[ "https://github.com/"
, ghRepo
, "/archive/"
, commit
, ".tar.gz"
]
raHash <- o ..:? "sha256"
raSize <- o ..:? "size"
os <- optionalSubdirs o
pure $ pure $
NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os)
-- | Returns pairs of subdirectory and 'PackageMetadata'.
osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs
osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm)
rpmEmpty :: RawPackageMetadata
rpmEmpty = RawPackageMetadata Nothing Nothing Nothing
-- | Newtype wrapper for easier JSON integration with Cabal types.
--
-- @since 0.1.0.0
newtype CabalString a = CabalString { unCabalString :: a }
deriving (Show, Eq, Ord, Typeable)
-- I'd like to use coerce here, but can't due to roles. unsafeCoerce
-- could work, but let's avoid unsafe code.
-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON'
-- instance.
--
-- @since 0.1.0.0
toCabalStringMap :: Map a v -> Map (CabalString a) v
toCabalStringMap = Map.mapKeysMonotonic CabalString
-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a
-- 'FromJSON' instance.
--
-- @since 0.1.0.0
unCabalStringMap :: Map (CabalString a) v -> Map a v
unCabalStringMap = Map.mapKeysMonotonic unCabalString
instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where
toJSON = toJSON . Distribution.Text.display . unCabalString
instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where
toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString
instance forall a. IsCabalString a => FromJSON (CabalString a) where
parseJSON = withText name $ \t ->
case cabalStringParser $ T.unpack t of
Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t
Just x -> pure $ CabalString x
where
name = cabalStringName (Nothing :: Maybe a)
instance forall a. IsCabalString a => FromJSONKey (CabalString a) where
fromJSONKey =
FromJSONKeyTextParser $ \t ->
case cabalStringParser $ T.unpack t of
Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t
Just x -> pure $ CabalString x
where
name = cabalStringName (Nothing :: Maybe a)
class IsCabalString a where
cabalStringName :: proxy a -> String
cabalStringParser :: String -> Maybe a
instance IsCabalString PackageName where
cabalStringName _ = "package name"
cabalStringParser = parsePackageName
instance IsCabalString Version where
cabalStringName _ = "version"
cabalStringParser = parseVersion
instance IsCabalString VersionRange where
cabalStringName _ = "version range"
cabalStringParser = parseVersionRange
instance IsCabalString PackageIdentifier where
cabalStringName _ = "package identifier"
cabalStringParser = parsePackageIdentifier
instance IsCabalString FlagName where
cabalStringName _ = "flag name"
cabalStringParser = parseFlagName
-- | What to use for running hpack
--
-- @since 0.1.0.0
data HpackExecutable
= HpackBundled
-- ^ Compiled in library
| HpackCommand !FilePath
-- ^ Executable at the provided path
deriving (Show, Read, Eq, Ord)
-- | Which compiler a snapshot wants to use. The build tool may elect to do some
-- fuzzy matching of versions (e.g., allowing different patch versions).
--
-- @since 0.1.0.0
data WantedCompiler
= WCGhc !Version
| WCGhcGit !Text !Text
| WCGhcjs
!Version
!Version
-- ^ GHCJS version followed by GHC version
deriving (Show, Eq, Ord, Generic)
instance NFData WantedCompiler
instance Display WantedCompiler where
display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc)
display (WCGhcjs vghcjs vghc) =
"ghcjs-"
<> fromString (versionString vghcjs)
<> "_ghc-" <> fromString (versionString vghc)
display (WCGhcGit commit flavour) =
"ghc-git-" <> display commit <> "-" <> display flavour
instance ToJSON WantedCompiler where
toJSON = toJSON . utf8BuilderToText . display
instance FromJSON WantedCompiler where
parseJSON =
withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler
instance FromJSONKey WantedCompiler where
fromJSONKey =
FromJSONKeyTextParser $ \t ->
case parseWantedCompiler t of
Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e
Right x -> pure x
-- | Parse a 'Text' into a 'WantedCompiler' value.
--
-- @since 0.1.0.0
parseWantedCompiler :: Text -> Either PantryException WantedCompiler
parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $
case T.stripPrefix "ghcjs-" t0 of
Just t1 -> parseGhcjs t1
Nothing -> case T.stripPrefix "ghc-git-" t0 of
Just t1 -> parseGhcGit t1
Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc
where
parseGhcjs t1 = do
let (ghcjsVT, t2) = T.break (== '_') t1
ghcjsV <- parseVersion $ T.unpack ghcjsVT
ghcVT <- T.stripPrefix "_ghc-" t2
ghcV <- parseVersion $ T.unpack ghcVT
pure $ WCGhcjs ghcjsV ghcV
parseGhcGit t1 = do
let (commit, flavour) = T.break (== '-') t1
pure $ WCGhcGit commit (T.drop 1 flavour)
parseGhc = fmap WCGhc . parseVersion . T.unpack
instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where
parseJSON v = text v <|> obj v
where
text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
text =
withText "UnresolvedSnapshotLocation (Text)" $
pure . noJSONWarnings . parseRawSnapshotLocation
obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o ->
(pure . RSLCompiler <$> o ..: "compiler") <|>
((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|>
(parseRawSnapshotLocationPath <$> o ..: "filepath")
blobKey o = do
msha <- o ..:? "sha256"
msize <- o ..:? "size"
case (msha, msize) of
(Nothing, Nothing) -> pure Nothing
(Just sha, Just size') -> pure $ Just $ BlobKey sha size'
(Just _sha, Nothing) -> fail "You must also specify the file size"
(Nothing, Just _) -> fail "You must also specify the file's SHA256"
instance Display SnapshotLocation where
display (SLCompiler compiler) = display compiler
display (SLUrl url blob) = display url <> " (" <> display blob <> ")"
display (SLFilePath resolved) = display (resolvedRelative resolved)
-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'.
--
-- @since 0.1.0.0
parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $
either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0) <|>
(pure . RSLSynonym <$> parseSnapName t0) <|>
parseGitHub <|>
parseUrl
where
parseGitHub = do
t1 <- T.stripPrefix "github:" t0
let (user, t2) = T.break (== '/') t1
t3 <- T.stripPrefix "/" t2
let (repo, t4) = T.break (== ':') t3
path <- T.stripPrefix ":" t4
Just $ pure $ githubSnapshotLocation user repo path
parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing)
parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath t =
Unresolved $ \case
Nothing -> throwIO $ InvalidFilePathSnapshot t
Just dir -> do
abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t)
pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs'
githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation user repo path =
let url = T.concat
[ "https://raw.githubusercontent.com/"
, user
, "/"
, repo
, "/master/"
, path
]
in RSLUrl url Nothing
defUser :: Text
defUser = "commercialhaskell"
defRepo :: Text
defRepo = "stackage-snapshots"
-- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub
-- repository.
--
-- @since 0.5.0.0
defaultSnapshotLocation ::
SnapName
-> RawSnapshotLocation
defaultSnapshotLocation (LTS x y) =
githubSnapshotLocation defUser defRepo $
utf8BuilderToText $
"lts/" <> display x <> "/" <> display y <> ".yaml"
defaultSnapshotLocation (Nightly date) =
githubSnapshotLocation defUser defRepo
$ utf8BuilderToText
$ "nightly/"
<> display year
<> "/"
<> display month
<> "/"
<> display day
<> ".yaml"
where
(year, month, day) = toGregorian date
-- | A snapshot synonym. It is expanded according to the field
-- 'snapshotLocation' of a 'PantryConfig'.
--
-- @ since 0.5.0.0
data SnapName
= LTS
!Int -- ^ Major version
!Int -- ^ Minor version
-- ^ LTS Haskell snapshot, displayed as @"lts-maj.min"@.
--
-- @since 0.5.0.0
| Nightly !Day
-- ^ Stackage Nightly snapshot, displayed as @"nighly-YYYY-MM-DD"@.
--
-- @since 0.5.0.0
deriving (Eq, Ord, Generic)
instance NFData SnapName
instance Display SnapName where
display (LTS x y) = "lts-" <> display x <> "." <> display y
display (Nightly date) = "nightly-" <> displayShow date
instance Show SnapName where
show = T.unpack . utf8BuilderToText . display
instance ToJSON SnapName where
toJSON syn = String $ utf8BuilderToText $ display syn
-- | Parse the short representation of a 'SnapName'.
--
-- @since 0.5.0.0
parseSnapName :: MonadThrow m => Text -> m SnapName
parseSnapName t0 =
case lts <|> nightly of
Nothing -> throwM $ ParseSnapNameException t0
Just sn -> pure sn
where
lts = do
t1 <- T.stripPrefix "lts-" t0
Right (x, t2) <- Just $ decimal t1
t3 <- T.stripPrefix "." t2
Right (y, "") <- Just $ decimal t3
pure $ LTS x y
nightly = do
t1 <- T.stripPrefix "nightly-" t0
Nightly <$> readMaybe (T.unpack t1)
-- | Where to load a snapshot from in raw form (RSUrl could have a missing
-- BlobKey)
--
-- @since 0.1.0.0
data RawSnapshotLocation
= RSLCompiler !WantedCompiler
-- ^ Don't use an actual snapshot, just a version of the compiler with its
-- shipped packages.
--
-- @since 0.1.0.0
| RSLUrl !Text !(Maybe BlobKey)
-- ^ Download the snapshot from the given URL. The optional 'BlobKey' is
-- used for reproducibility.
--
-- @since 0.1.0.0
| RSLFilePath !(ResolvedPath File)
-- ^ Snapshot at a local file path.
--
-- @since 0.1.0.0
| RSLSynonym !SnapName
-- ^ Snapshot synonym (LTS/Nightly).
--
-- @since 0.5.0.0
deriving (Show, Eq, Ord, Generic)
instance NFData RawSnapshotLocation
instance Display RawSnapshotLocation where
display (RSLCompiler compiler) = display compiler
display (RSLUrl url Nothing) = display url
display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")"
display (RSLFilePath resolved) = display (resolvedRelative resolved)
display (RSLSynonym syn) = display syn
instance Pretty RawSnapshotLocation where
pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler
pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url)
pretty (RSLUrl url (Just blob)) = fillSep
[ style Url (fromString $ T.unpack url)
, parens (fromString . T.unpack $ textDisplay blob)
]
pretty (RSLFilePath resolved) =
style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved))
pretty (RSLSynonym syn) =
style Shell (fromString . T.unpack $ textDisplay syn)
instance ToJSON RawSnapshotLocation where
toJSON (RSLCompiler compiler) = object ["compiler" .= compiler]
toJSON (RSLUrl url mblob) = object
$ "url" .= url
: maybe [] blobKeyPairs mblob
toJSON (RSLFilePath resolved) =
object ["filepath" .= resolvedRelative resolved]
toJSON (RSLSynonym syn) = toJSON syn
-- | Where to load a snapshot from.
--
-- @since 0.1.0.0
data SnapshotLocation
= SLCompiler !WantedCompiler
-- ^ Don't use an actual snapshot, just a version of the compiler
-- with its shipped packages.
--
-- @since 0.1.0.0
| SLUrl !Text !BlobKey
-- ^ Download the snapshot from the given URL. The optional
-- 'BlobKey' is used for reproducibility.
--
-- @since 0.1.0.0
| SLFilePath !(ResolvedPath File)
-- ^ Snapshot at a local file path.
--
-- @since 0.1.0.0
deriving (Show, Eq, Ord, Generic)
instance NFData SnapshotLocation
instance ToJSON SnapshotLocation where
toJSON sl = toJSON (toRawSL sl)
instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where
parseJSON v = file v <|> url v <|> compiler v
where
file = withObjectWarnings "SLFilepath" $ \o -> do
ufp <- o ..: "filepath"
pure $ Unresolved $ \case
Nothing -> throwIO $ InvalidFilePathSnapshot ufp
Just dir -> do
absolute <- resolveFile dir (T.unpack ufp)
let fp = ResolvedPath (RelFilePath ufp) absolute
pure $ SLFilePath fp
url = withObjectWarnings "SLUrl" $ \o -> do
url' <- o ..: "url"
sha <- o ..: "sha256"
size <- o ..: "size"
pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size)
compiler = withObjectWarnings "SLCompiler" $ \o -> do
c <- o ..: "compiler"
pure $ Unresolved $ \_ -> pure $ SLCompiler c
-- | Convert snapshot location to its "raw" equivalent.
--
-- @since 0.1.0.0
toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL (SLCompiler c) = RSLCompiler c
toRawSL (SLUrl url blob) = RSLUrl url (Just blob)
toRawSL (SLFilePath fp) = RSLFilePath fp
-- | A flattened representation of all the layers in a snapshot.
--
-- @since 0.1.0.0
data RawSnapshot = RawSnapshot
{ rsCompiler :: !WantedCompiler
-- ^ The compiler wanted for this snapshot.
, rsPackages :: !(Map PackageName RawSnapshotPackage)
-- ^ Packages available in this snapshot for installation. This will be
-- applied on top of any globally available packages.
, rsDrop :: !(Set PackageName)
-- ^ Global packages that should be dropped/ignored.
}
-- | A flattened representation of all the layers in a snapshot.
--
-- @since 0.1.0.0
data Snapshot = Snapshot
{ snapshotCompiler :: !WantedCompiler
-- ^ The compiler wanted for this snapshot.
, snapshotPackages :: !(Map PackageName SnapshotPackage)
-- ^ Packages available in this snapshot for installation. This will be
-- applied on top of any globally available packages.
, snapshotDrop :: !(Set PackageName)
-- ^ Global packages that should be dropped/ignored.
}
-- | Settings for a package found in a snapshot.
--
-- @since 0.1.0.0
data RawSnapshotPackage = RawSnapshotPackage
{ rspLocation :: !RawPackageLocationImmutable
-- ^ Where to get the package from
, rspFlags :: !(Map FlagName Bool)
-- ^ Same as 'slFlags'
, rspHidden :: !Bool
-- ^ Same as 'slHidden'
, rspGhcOptions :: ![Text]
-- ^ Same as 'slGhcOptions'
}
-- | Settings for a package found in a snapshot.
--
-- @since 0.1.0.0
data SnapshotPackage = SnapshotPackage
{ spLocation :: !PackageLocationImmutable
-- ^ Where to get the package from
, spFlags :: !(Map FlagName Bool)
-- ^ Same as 'slFlags'
, spHidden :: !Bool
-- ^ Same as 'slHidden'
, spGhcOptions :: ![Text]
-- ^ Same as 'slGhcOptions'
}
deriving Show
-- | A single layer of a snapshot, i.e. a specific YAML configuration file.
--
-- @since 0.1.0.0
data RawSnapshotLayer = RawSnapshotLayer
{ rslParent :: !RawSnapshotLocation
-- ^ The sl to extend from. This is either a specific compiler, or a
-- @SnapshotLocation@ which gives us more information (like packages).
-- Ultimately, we'll end up with a @CompilerVersion@.
--
-- @since 0.1.0.0
, rslCompiler :: !(Maybe WantedCompiler)
-- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if
-- using 'SLCompiler'.
--
-- @since 0.1.0.0
, rslLocations :: ![RawPackageLocationImmutable]
-- ^ Where to grab all of the packages from.
--
-- @since 0.1.0.0
, rslDropPackages :: !(Set PackageName)
-- ^ Packages present in the parent which should not be included here.
--
-- @since 0.1.0.0
, rslFlags :: !(Map PackageName (Map FlagName Bool))
-- ^ Flag values to override from the defaults
--
-- @since 0.1.0.0
, rslHidden :: !(Map PackageName Bool)
-- ^ Packages which should be hidden when registering. This will affect, for
-- example, the import parser in the script command. We use a 'Map' instead
-- of just a 'Set' to allow overriding the hidden settings in a parent sl.
--
-- @since 0.1.0.0
, rslGhcOptions :: !(Map PackageName [Text])
-- ^ GHC options per package
--
-- @since 0.1.0.0
, rslPublishTime :: !(Maybe UTCTime)
-- ^ See 'slPublishTime'
--
-- @since 0.1.0.0
}
deriving (Show, Eq, Generic)
instance NFData RawSnapshotLayer
instance ToJSON RawSnapshotLayer where
toJSON rsnap = object $ concat
[ ["resolver" .= rslParent rsnap]
, maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap)
, ["packages" .= rslLocations rsnap]
, [ "drop-packages" .= Set.map CabalString (rslDropPackages rsnap)
| not (Set.null (rslDropPackages rsnap))
]
, [ "flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))
| not(Map.null (rslFlags rsnap))
]
, [ "hidden" .= toCabalStringMap (rslHidden rsnap)
| not (Map.null (rslHidden rsnap))
]
, [ "ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)
| not (Map.null (rslGhcOptions rsnap))
]
, maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap)
]
instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where
parseJSON = withObjectWarnings "Snapshot" $ \o -> do
_ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format
mcompiler <- o ..:? "compiler"
mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"]
unresolvedSnapshotParent <-
case (mcompiler, mresolver) of
(Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler"
(Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing)
(_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do
sl <- usl mdir
case (sl, mcompiler) of
(RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2
_ -> pure (sl, mcompiler)
unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= [])
rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty)
rslFlags <- unCabalStringMap . fmap unCabalStringMap <$> (o ..:? "flags" ..!= Map.empty)
rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty)
rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty)
rslPublishTime <- o ..:? "publish-time"
pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..})
<$> (concatMap NE.toList <$> sequenceA unresolvedLocs)
<*> unresolvedSnapshotParent
-- | A single layer of a snapshot, i.e. a specific YAML configuration file.
--
-- @since 0.1.0.0
data SnapshotLayer = SnapshotLayer
{ slParent :: !SnapshotLocation
-- ^ The sl to extend from. This is either a specific compiler, or a
-- @SnapshotLocation@ which gives us more information (like packages).
-- Ultimately, we'll end up with a @CompilerVersion@.
--
-- @since 0.1.0.0
, slCompiler :: !(Maybe WantedCompiler)
-- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if
-- using 'SLCompiler'.
--
-- @since 0.1.0.0
, slLocations :: ![PackageLocationImmutable]
-- ^ Where to grab all of the packages from.
--
-- @since 0.1.0.0
, slDropPackages :: !(Set PackageName)
-- ^ Packages present in the parent which should not be included here.
--
-- @since 0.1.0.0
, slFlags :: !(Map PackageName (Map FlagName Bool))
-- ^ Flag values to override from the defaults
--
-- @since 0.1.0.0
, slHidden :: !(Map PackageName Bool)
-- ^ Packages which should be hidden when registering. This will affect, for
-- example, the import parser in the script command. We use a 'Map' instead
-- of just a 'Set' to allow overriding the hidden settings in a parent sl.
--
-- @since 0.1.0.0
, slGhcOptions :: !(Map PackageName [Text])
-- ^ GHC options per package
--
-- @since 0.1.0.0
, slPublishTime :: !(Maybe UTCTime)
-- ^ Publication timestamp for this snapshot. This field is optional, and is
-- for informational purposes only.
--
-- @since 0.1.0.0
}
deriving (Show, Eq, Generic)
instance ToJSON SnapshotLayer where
toJSON snap = object $ concat
[ ["resolver" .= slParent snap]
, maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap)
, ["packages" .= slLocations snap]
, [ "drop-packages" .= Set.map CabalString (slDropPackages snap)
| not (Set.null (slDropPackages snap))
]
, [ "flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))
| not (Map.null (slFlags snap))
]
, [ "hidden" .= toCabalStringMap (slHidden snap)
| not (Map.null (slHidden snap))
]
, [ "ghc-options" .= toCabalStringMap (slGhcOptions snap)
| not (Map.null (slGhcOptions snap))
]
, maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap)
]
-- | Convert snapshot layer into its "raw" equivalent.
--
-- @since 0.1.0.0
toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer
toRawSnapshotLayer sl = RawSnapshotLayer
{ rslParent = toRawSL (slParent sl)
, rslCompiler = slCompiler sl
, rslLocations = map toRawPLI (slLocations sl)
, rslDropPackages = slDropPackages sl
, rslFlags = slFlags sl
, rslHidden = slHidden sl
, rslGhcOptions = slGhcOptions sl
, rslPublishTime = slPublishTime sl
}
-- | An arbitrary hash for a snapshot, used for finding module names in a
-- snapshot. Mostly intended for Stack's usage.
--
-- @since 0.1.0.0
newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256}
deriving (Show)
-- | Get the path to the global hints cache file
getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile = do
root <- view $ pantryConfigL.to pcRootDir
globalHintsRelFile <- parseRelFile "global-hints-cache.yaml"
pure $ root </> globalHintsRelFile
-- | Creates BlobKey for an input ByteString
--
-- @since 0.1.0.0
bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey bs =
BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs)))
-- | Warn if the package uses 'PCHpack'.
--
-- @since 0.4.0.0
warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile loc =
logWarn $
"DEPRECATED: The package at "
<> display loc
<> " does not include a cabal file.\n"
<> "Instead, it includes an hpack package.yaml file for generating a cabal file.\n"
<> "This usage is deprecated; please see "
<> "https://github.com/commercialhaskell/stack/issues/5210.\n"
<> "Support for this workflow will be removed in the future.\n"