{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiWayIf #-}
module Pantry.Types
( PantryConfig (..)
, HackageSecurityConfig (..)
, 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 (..)
, RawPackageLocation (..)
, PackageLocation (..)
, toRawPL
, RawPackageLocationImmutable (..)
, PackageLocationImmutable (..)
, toRawPLI
, RawArchive (..)
, Archive (..)
, toRawArchive
, Repo (..)
, 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 (..)
, ltsSnapshotLocation
, nightlySnapshotLocation
, RawSnapshotLocation (..)
, SnapshotLocation (..)
, toRawSL
, parseHackageText
, parseRawSnapshotLocation
, RawSnapshotLayer (..)
, SnapshotLayer (..)
, toRawSnapshotLayer
, RawSnapshot (..)
, Snapshot (..)
, RawSnapshotPackage (..)
, SnapshotPackage (..)
, parseWantedCompiler
, RawPackageMetadata (..)
, PackageMetadata (..)
, toRawPM
, cabalFileName
, SnapshotCacheHash (..)
, getGlobalHintsFile
, bsToBlobKey
) where
import RIO
import qualified Data.Conduit.Tar as Tar
import qualified RIO.Text as T
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import RIO.List (intersperse)
import RIO.Time (toGregorian, Day, fromGregorianValid, UTCTime)
import qualified RIO.Map as Map
import qualified RIO.HashMap as HM
import qualified Data.Map.Strict as Map (mapKeysMonotonic)
import qualified RIO.Set as Set
import Data.Aeson (ToJSON (..), FromJSON (..), withText, FromJSONKey (..))
import Data.Aeson.Types (ToJSONKey (..) ,toJSONKeyText, Parser)
import Pantry.Internal.AesonExtended
import Data.Aeson.Encoding.Internal (unsafeToEncoding)
import Data.ByteString.Builder (toLazyByteString, byteString, wordDec)
import Database.Persist
import Database.Persist.Sql
import Pantry.SHA256 (SHA256)
import qualified Pantry.SHA256 as SHA256
import qualified Distribution.Compat.CharParsing as Parse
import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest)
import Distribution.Parsec (PError (..), PWarning (..), showPos, parsec, explicitEitherParsec, ParsecParser)
import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName)
import Distribution.Types.VersionRange (VersionRange)
import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription)
import Distribution.Types.PackageId (PackageIdentifier (..))
import qualified Distribution.Pretty
import qualified Distribution.Text
import qualified Hpack.Config as Hpack
import Distribution.ModuleName (ModuleName)
import Distribution.Types.Version (Version, mkVersion, nullVersion)
import Network.HTTP.Client (parseRequest)
import Network.HTTP.Types (Status, statusCode)
import Data.Text.Read (decimal)
import Path (Path, Abs, Dir, File, toFilePath, filename, (</>), parseRelFile)
import Path.IO (resolveFile, resolveDir)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Casa.Client (CasaRepoPrefix)
data Package = Package
{ packageTreeKey :: !TreeKey
, packageTree :: !Tree
, packageCabalEntry :: !PackageCabal
, packageIdent :: !PackageIdentifier
}
deriving (Show, Eq)
data PHpack = PHpack
{
phOriginal :: !TreeEntry,
phGenerated :: !TreeEntry,
phVersion :: !Version
} deriving (Show, Eq)
data PackageCabal = PCCabalFile !TreeEntry
| PCHpack !PHpack
deriving (Show, Eq)
cabalFileName :: PackageName -> SafeFilePath
cabalFileName name =
case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of
Nothing -> error $ "cabalFileName: failed for " ++ show name
Just sfp -> sfp
newtype Revision = Revision Word
deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql)
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
}
data PantryConfig = PantryConfig
{ pcHackageSecurity :: !HackageSecurityConfig
, pcHpackExecutable :: !HpackExecutable
, pcRootDir :: !(Path Abs Dir)
, pcStorage :: !Storage
, pcUpdateRef :: !(MVar Bool)
, pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
, pcParsedCabalFilesMutable ::
!(IORef
(Map
(Path Abs Dir)
(PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File)
)
)
, pcConnectionCount :: !Int
, pcCasaRepoPrefix :: !CasaRepoPrefix
, pcCasaMaxPerRequest :: !Int
}
data PrintWarnings = YesPrintWarnings | NoPrintWarnings
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
resolvePaths
:: MonadIO m
=> Maybe (Path Abs Dir)
-> Unresolved a
-> m a
resolvePaths mdir (Unresolved f) = liftIO (f mdir)
data ResolvedPath t = ResolvedPath
{ resolvedRelative :: !RelFilePath
, resolvedAbsolute :: !(Path Abs t)
}
deriving (Show, Eq, Generic, Ord)
instance NFData (ResolvedPath t)
data RawPackageLocation
= RPLImmutable !RawPackageLocationImmutable
| RPLMutable !(ResolvedPath Dir)
deriving (Show, Eq, Generic)
instance NFData RawPackageLocation
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
toRawPL :: PackageLocation -> RawPackageLocation
toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im)
toRawPL (PLMutable m) = RPLMutable m
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))
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
pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash (PackageIdentifier name ver) (BlobKey sha size') =
let cfi = CFIHash sha (Just size')
in PackageIdentifierRevision name ver cfi
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)
data RawArchive = RawArchive
{ raLocation :: !ArchiveLocation
, raHash :: !(Maybe SHA256)
, raSize :: !(Maybe FileSize)
, raSubdir :: !Text
}
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData RawArchive
data Archive = Archive
{ archiveLocation :: !ArchiveLocation
, archiveHash :: !SHA256
, archiveSize :: !FileSize
, archiveSubdir :: !Text
}
deriving (Generic, Show, Eq, Ord, Typeable)
instance NFData Archive
toRawArchive :: Archive -> RawArchive
toRawArchive archive =
RawArchive (archiveLocation archive) (Just $ archiveHash archive)
(Just $ archiveSize archive) (archiveSubdir archive)
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
data Repo = Repo
{ repoUrl :: !Text
, repoCommit :: !Text
, repoType :: !RepoType
, repoSubdir :: !Text
}
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)
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) -> return (GitHubRepo s)
_ -> fail "expecting \"user/repo\""
data HackageSecurityConfig = HackageSecurityConfig
{ hscKeyIds :: ![Text]
, hscKeyThreshold :: !Int
, hscDownloadPrefix :: !Text
, hscIgnoreExpiry :: !Bool
}
deriving Show
instance FromJSON (WithJSONWarnings HackageSecurityConfig) where
parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o' -> do
hscDownloadPrefix <- o' ..: "download-prefix"
Object o <- o' ..: "hackage-security"
hscKeyIds <- o ..: "keyids"
hscKeyThreshold <- o ..: "key-threshold"
hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True
pure HackageSecurityConfig {..}
class HasPantryConfig env where
pantryConfigL :: Lens' env PantryConfig
newtype FileSize = FileSize Word
deriving (Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData, PersistField, PersistFieldSql, ToJSON, FromJSON)
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 -> [(Text, 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
(T.pack . 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
data CabalFileInfo
= CFILatest
| CFIHash !SHA256 !(Maybe FileSize)
| CFIRevision !Revision
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
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
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
pure (ident, BlobKey sha (FileSize size'))
splitColon :: Text -> Maybe (Text, Text)
splitColon t' =
let (x, y) = T.break (== ':') t'
in (x, ) <$> T.stripPrefix ":" y
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
}
data PantryException
= PackageIdentifierRevisionParseFail !Text
| InvalidCabalFile
!(Either RawPackageLocationImmutable (Path Abs File))
!(Maybe Version)
![PError]
![PWarning]
| TreeWithoutCabalFile !RawPackageLocationImmutable
| TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath]
| MismatchedCabalName !(Path Abs File) !PackageName
| 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)
| 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 !Repo
| 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
| InvalidTreeFromCasa !BlobKey !ByteString
deriving Typeable
instance Exception PantryException where
instance Show PantryException where
show = T.unpack . utf8BuilderToText . display
instance Display PantryException where
display (InvalidTreeFromCasa blobKey _bs) = "Invalid tree from casa: " <> display blobKey
display (PackageIdentifierRevisionParseFail text) =
"Invalid package identifier (with optional revision): " <>
display text
display (InvalidCabalFile loc mversion errs warnings) =
"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) = "No cabal file found for " <> display pl
display (TreeWithMultipleCabalFiles pl sfps) =
"Multiple cabal files found for " <> display pl <> ": " <>
fold (intersperse ", " (map display sfps))
display (MismatchedCabalName fp name) =
"cabal file path " <>
fromString (toFilePath fp) <>
" does not match the package name it defines.\n" <>
"Please rename the file to: " <>
fromString (packageNameString name) <>
".cabal\n" <>
"For more information, see: https://github.com/commercialhaskell/stack/issues/317"
display (NoCabalFileFound dir) =
"Stack looks for packages in the directories configured in\n" <>
"the 'packages' and 'extra-deps' fields defined in your 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) =
"Multiple .cabal files found in directory " <>
fromString (toFilePath dir) <>
":\n" <>
fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files))
display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t
display (InvalidSnapshotLocation dir t) =
"Invalid snapshot location " <>
displayShow t <>
" relative to directory " <>
displayShow (toFilePath dir)
display (InvalidOverrideCompiler x y) =
"Specified compiler for a resolver (" <>
display x <>
"), but also specified an override compiler (" <>
display y <>
")"
display (InvalidFilePathSnapshot t) =
"Specified snapshot as file path with " <>
displayShow t <>
", but not reading from a local file"
display (InvalidSnapshot loc e) =
"Exception while reading snapshot from " <>
display loc <>
":\n" <>
displayShow e
display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
"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) =
"Unexpected non-200 HTTP status code: " <>
displayShow (statusCode status)
display (InvalidBlobKey Mismatch{..}) =
"Invalid blob key found, expected: " <>
display mismatchExpected <>
", actual: " <>
display mismatchActual
display (Couldn'tParseSnapshot sl e) =
"Couldn't parse snapshot from " <> display sl <> ": " <> fromString e
display (WrongCabalFileName pl sfp name) =
"Wrong cabal file name for package " <> display pl <>
"\nCabal 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 {..}) =
"Mismatched SHA256 hash from " <> display url <>
"\nExpected: " <> display mismatchExpected <>
"\nActual: " <> display mismatchActual
display (DownloadInvalidSize url Mismatch {..}) =
"Mismatched download size from " <> display url <>
"\nExpected: " <> display mismatchExpected <>
"\nActual: " <> display mismatchActual
display (DownloadTooLarge url Mismatch {..}) =
"Download from " <> display url <> " was too large.\n" <>
"Expected: " <> display mismatchExpected <> ", stopped after receiving: " <>
display mismatchActual
display (LocalInvalidSHA256 path Mismatch {..}) =
"Mismatched SHA256 hash from " <> fromString (toFilePath path) <>
"\nExpected: " <> display mismatchExpected <>
"\nActual: " <> display mismatchActual
display (LocalInvalidSize path Mismatch {..}) =
"Mismatched file size from " <> fromString (toFilePath path) <>
"\nExpected: " <> display mismatchExpected <>
"\nActual: " <> display mismatchActual
display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc
display (InvalidTarFileType loc fp x) =
"Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x
display (UnsupportedTarball loc e) =
"Unsupported tarball from " <> display loc <> ": " <> display e
display (NoHackageCryptographicHash ident) =
"Not cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident)
display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo
display (TreeReferencesMissingBlob loc sfp key) =
"The package " <> display loc <>
" needs blob " <> display key <>
" for file path " <> display sfp <>
", but the blob is not available"
display (CompletePackageMetadataMismatch loc pm) =
"When completing package metadata for " <> display loc <>
", some values changed in the new package metadata: " <>
display pm
display (CRC32Mismatch loc fp Mismatch {..}) =
"CRC32 mismatch in ZIP file from " <> display loc <>
" on internal file " <> fromString fp <>
"\n.Expected: " <> display mismatchExpected <>
"\n.Actual: " <> display mismatchActual
display (UnknownHackagePackage pir fuzzy) =
"Could not find " <> display pir <> " on Hackage" <>
displayFuzzy fuzzy
display (CannotCompleteRepoNonSHA1 repo) =
"Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <>
display repo
display (MutablePackageLocationFromUrl t) =
"Cannot refer to a mutable package location from a URL: " <> display t
display (MismatchedCabalFileForHackage pir Mismatch{..}) =
"When processing cabal file for Hackage package " <> display pir <>
":\nMismatched package identifier." <>
"\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <>
"\nActual: " <> fromString (packageIdentifierString mismatchActual)
display (PackageNameParseFail t) =
"Invalid package name: " <> display t
display (PackageVersionParseFail t) =
"Invalid version: " <> display t
display (InvalidCabalFilePath fp) =
"File path contains a name which is not a valid package name: " <>
fromString (toFilePath fp)
display (DuplicatePackageNames source pairs') =
"Duplicate package names (" <> source <> "):\n" <>
foldMap
(\(name, locs) ->
fromString (packageNameString name) <> ":\n" <>
foldMap
(\loc -> "- " <> display loc <> "\n")
locs
)
pairs'
display (MigrationFailure desc fp ex) =
"Encountered error while migrating " <> display desc <> " database:" <>
"\n " <> displayShow ex <>
"\nPlease report this on https://github.com/commercialhaskell/stack/issues" <>
"\nAs a workaround you may delete " <> display desc <> " database in " <>
fromString (toFilePath fp) <> " triggering its recreation."
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) <>
"."
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 =
case cabalSpecLatest of
CabalSpecV1_0 -> error "this cannot happen"
CabalSpecV1_2 -> error "this cannot happen"
CabalSpecV1_4 -> error "this cannot happen"
CabalSpecV1_6 -> error "this cannot happen"
CabalSpecV1_8 -> error "this cannot happen"
CabalSpecV1_10 -> error "this cannot happen"
CabalSpecV1_12 -> error "this cannot happen"
CabalSpecV1_18 -> error "this cannot happen"
CabalSpecV1_20 -> error "this cannot happen"
CabalSpecV1_22 -> error "this cannot happen"
CabalSpecV1_24 -> error "this cannot happen"
CabalSpecV2_0 -> error "this cannot happen"
CabalSpecV2_2 -> error "this cannot happen"
CabalSpecV2_4 -> error "this cannot happen"
CabalSpecV3_0 -> mkVersion [3, 0]
data BuildFile = BFCabal !SafeFilePath !TreeEntry
| BFHpack !TreeEntry
deriving (Show, Eq)
data FileType = FTNormal | FTExecutable
deriving (Show, Eq, Enum, Bounded)
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)
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)
return $ 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 $ all (not . T.all (== '.')) $ T.split (== '/') t
Just $ SafeFilePath t
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
newtype TreeKey = TreeKey BlobKey
deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display)
newtype Tree
= TreeMap (Map SafeFilePath TreeEntry)
deriving (Show, Eq)
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
88 -> Just FTExecutable
_ -> 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
parsePackageIdentifier :: String -> Maybe PackageIdentifier
parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof)
packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec = do
ident@(PackageIdentifier _ v) <- parsec
guard (v /= nullVersion)
pure ident
parsePackageName :: String -> Maybe PackageName
parsePackageName = Distribution.Text.simpleParse
parsePackageNameThrowing :: MonadThrow m => String -> m PackageName
parsePackageNameThrowing str =
case parsePackageName str of
Nothing -> throwM $ PackageNameParseFail $ T.pack str
Just pn -> pure pn
parseVersion :: String -> Maybe Version
parseVersion = Distribution.Text.simpleParse
parseVersionThrowing :: MonadThrow m => String -> m Version
parseVersionThrowing str =
case parseVersion str of
Nothing -> throwM $ PackageVersionParseFail $ T.pack str
Just v -> pure v
parseVersionRange :: String -> Maybe VersionRange
parseVersionRange = Distribution.Text.simpleParse
parseModuleName :: String -> Maybe ModuleName
parseModuleName = Distribution.Text.simpleParse
parseFlagName :: String -> Maybe FlagName
parseFlagName = Distribution.Text.simpleParse
packageNameString :: PackageName -> String
packageNameString = unPackageName
packageIdentifierString :: PackageIdentifier -> String
packageIdentifierString = Distribution.Text.display
versionString :: Version -> String
versionString = Distribution.Text.display
flagNameString :: FlagName -> String
flagNameString = unFlagName
moduleNameString :: ModuleName -> String
moduleNameString = Distribution.Text.display
data OptionalSubdirs
= OSSubdirs !(NonEmpty Text)
| OSPackageMetadata !Text !RawPackageMetadata
deriving (Show, Eq, Generic)
instance NFData OptionalSubdirs
data RawPackageMetadata = RawPackageMetadata
{ rpmName :: !(Maybe PackageName)
, rpmVersion :: !(Maybe Version)
, rpmTreeKey :: !(Maybe TreeKey)
}
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
]
data PackageMetadata = PackageMetadata
{ pmIdent :: !PackageIdentifier
, pmTreeKey :: !TreeKey
}
deriving (Show, Eq, Ord, Generic, Typeable)
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 {..}
toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm)
where
PackageIdentifier name version = pmIdent pm
newtype RelFilePath = RelFilePath Text
deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display)
data ArchiveLocation
= ALUrl !Text
| ALFilePath !(ResolvedPath File)
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
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 (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz")
then pure $ Unresolved $ \mdir ->
case mdir of
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 $ concat
[ ["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
, if T.null subdir then [] else ["subdir" .= subdir]
, rpmToPairs rpm
]
toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat
[ [ urlKey .= url
, "commit" .= commit
]
, if T.null subdir then [] else ["subdir" .= subdir]
, rpmToPairs rpm
]
where
urlKey =
case typ of
RepoGit -> "git"
RepoHg -> "hg"
rpmToPairs :: RawPackageMetadata -> [(Text, 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 value =
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) value
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 =
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)
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 CabalString a = CabalString { unCabalString :: a }
deriving (Show, Eq, Ord, Typeable)
toCabalStringMap :: Map a v -> Map (CabalString a) v
toCabalStringMap = Map.mapKeysMonotonic CabalString
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
data HpackExecutable
= HpackBundled
| HpackCommand !FilePath
deriving (Show, Read, Eq, Ord)
data WantedCompiler
= WCGhc !Version
| WCGhcGit !Text !Text
| WCGhcjs
!Version
!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 WantedComiler " ++ show t ++ ": " ++ show e
Right x -> pure x
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) =
fromMaybe (display url) (specialRawSnapshotLocation url) <>
" (" <> display blob <> ")"
display (SLFilePath resolved) = display (resolvedRelative resolved)
parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $
(either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|>
parseLts <|>
parseNightly <|>
parseGithub <|>
parseUrl
where
parseLts = do
t1 <- T.stripPrefix "lts-" t0
Right (x, t2) <- Just $ decimal t1
t3 <- T.stripPrefix "." t2
Right (y, "") <- Just $ decimal t3
Just $ pure $ ltsSnapshotLocation x y
parseNightly = do
t1 <- T.stripPrefix "nightly-" t0
date <- readMaybe (T.unpack t1)
Just $ pure $ nightlySnapshotLocation date
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 $ \mdir ->
case mdir of
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"
ltsSnapshotLocation
:: Int
-> Int
-> RawSnapshotLocation
ltsSnapshotLocation x y =
githubSnapshotLocation defUser defRepo $
utf8BuilderToText $
"lts/" <> display x <> "/" <> display y <> ".yaml"
nightlySnapshotLocation :: Day -> RawSnapshotLocation
nightlySnapshotLocation date =
githubSnapshotLocation defUser defRepo $
utf8BuilderToText $
"nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml"
where
(year, month, day) = toGregorian date
data RawSnapshotLocation
= RSLCompiler !WantedCompiler
| RSLUrl !Text !(Maybe BlobKey)
| RSLFilePath !(ResolvedPath File)
deriving (Show, Eq, Ord, Generic)
instance NFData RawSnapshotLocation
instance Display RawSnapshotLocation where
display (RSLCompiler compiler) = display compiler
display (RSLUrl url Nothing) = fromMaybe (display url) $ specialRawSnapshotLocation url
display (RSLUrl url (Just blob)) =
fromMaybe (display url) (specialRawSnapshotLocation url) <>
" (" <> display blob <> ")"
display (RSLFilePath resolved) = display (resolvedRelative resolved)
specialRawSnapshotLocation :: Text -> Maybe Utf8Builder
specialRawSnapshotLocation url = do
t1 <- T.stripPrefix "https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/" url
parseLTS t1 <|> parseNightly t1
where
popInt :: Text -> Maybe (Int, Text)
popInt t0 =
case decimal t0 of
Left _ -> Nothing
Right (x, rest) -> (, rest) <$> do
if (x :: Integer) > fromIntegral (maxBound :: Int)
then Nothing
else Just (fromIntegral x)
parseLTS t1 = do
t2 <- T.stripPrefix "lts/" t1
(major, t3) <- popInt t2
(minor, ".yaml") <- T.stripPrefix "/" t3 >>= popInt
Just $ "lts-" <> display major <> "." <> display minor
parseNightly t1 = do
t2 <- T.stripPrefix "nightly/" t1
(year, t3) <- popInt t2
(month, t4) <- T.stripPrefix "/" t3 >>= popInt
(day, ".yaml") <- T.stripPrefix "/" t4 >>= popInt
date <- fromGregorianValid (fromIntegral year) month day
Just $ "nightly-" <> displayShow date
instance ToJSON RawSnapshotLocation where
toJSON (RSLCompiler compiler) = object ["compiler" .= compiler]
toJSON (RSLUrl url Nothing)
| Just x <- specialRawSnapshotLocation url = String $ utf8BuilderToText x
toJSON (RSLUrl url mblob) = object
$ "url" .= url
: maybe [] blobKeyPairs mblob
toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved]
data SnapshotLocation
= SLCompiler !WantedCompiler
| SLUrl !Text !BlobKey
| SLFilePath !(ResolvedPath File)
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 $ \mdir ->
case mdir of
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
toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL (SLCompiler c) = RSLCompiler c
toRawSL (SLUrl url blob) = RSLUrl url (Just blob)
toRawSL (SLFilePath fp) = RSLFilePath fp
data RawSnapshot = RawSnapshot
{ rsCompiler :: !WantedCompiler
, rsPackages :: !(Map PackageName RawSnapshotPackage)
, rsDrop :: !(Set PackageName)
}
data Snapshot = Snapshot
{ snapshotCompiler :: !WantedCompiler
, snapshotPackages :: !(Map PackageName SnapshotPackage)
, snapshotDrop :: !(Set PackageName)
}
data RawSnapshotPackage = RawSnapshotPackage
{ rspLocation :: !RawPackageLocationImmutable
, rspFlags :: !(Map FlagName Bool)
, rspHidden :: !Bool
, rspGhcOptions :: ![Text]
}
data SnapshotPackage = SnapshotPackage
{ spLocation :: !PackageLocationImmutable
, spFlags :: !(Map FlagName Bool)
, spHidden :: !Bool
, spGhcOptions :: ![Text]
}
deriving Show
data RawSnapshotLayer = RawSnapshotLayer
{ rslParent :: !RawSnapshotLocation
, rslCompiler :: !(Maybe WantedCompiler)
, rslLocations :: ![RawPackageLocationImmutable]
, rslDropPackages :: !(Set PackageName)
, rslFlags :: !(Map PackageName (Map FlagName Bool))
, rslHidden :: !(Map PackageName Bool)
, rslGhcOptions :: !(Map PackageName [Text])
, rslPublishTime :: !(Maybe UTCTime)
}
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]
, if Set.null (rslDropPackages rsnap)
then []
else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)]
, if Map.null (rslFlags rsnap)
then []
else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))]
, if Map.null (rslHidden rsnap)
then []
else ["hidden" .= toCabalStringMap (rslHidden rsnap)]
, if Map.null (rslGhcOptions rsnap)
then []
else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)]
, maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap)
]
instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where
parseJSON = withObjectWarnings "Snapshot" $ \o -> do
_ :: Maybe Text <- o ..:? "name"
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 {..})
<$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs)
<*> unresolvedSnapshotParent
data SnapshotLayer = SnapshotLayer
{ slParent :: !SnapshotLocation
, slCompiler :: !(Maybe WantedCompiler)
, slLocations :: ![PackageLocationImmutable]
, slDropPackages :: !(Set PackageName)
, slFlags :: !(Map PackageName (Map FlagName Bool))
, slHidden :: !(Map PackageName Bool)
, slGhcOptions :: !(Map PackageName [Text])
, slPublishTime :: !(Maybe UTCTime)
}
deriving (Show, Eq, Generic)
instance ToJSON SnapshotLayer where
toJSON snap = object $ concat
[ ["resolver" .= slParent snap]
, maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap)
, ["packages" .= slLocations snap]
, if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)]
, if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))]
, if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)]
, if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)]
, maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap)
]
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
}
newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256}
deriving (Show)
getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile = do
root <- view $ pantryConfigL.to pcRootDir
globalHintsRelFile <- parseRelFile "global-hints-cache.yaml"
pure $ root </> globalHintsRelFile
bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey bs =
BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs)))