1{-# LANGUAGE BangPatterns #-} 2{-# LANGUAGE CPP #-} 3{-# LANGUAGE DeriveFunctor #-} 4{-# LANGUAGE DeriveGeneric #-} 5{-# LANGUAGE FlexibleInstances #-} 6{-# LANGUAGE GeneralizedNewtypeDeriving #-} 7{-# LANGUAGE DeriveDataTypeable #-} 8{-# LANGUAGE NoImplicitPrelude #-} 9{-# LANGUAGE OverloadedStrings #-} 10{-# LANGUAGE RankNTypes #-} 11{-# LANGUAGE RecordWildCards #-} 12{-# LANGUAGE ScopedTypeVariables #-} 13{-# LANGUAGE TupleSections #-} 14{-# LANGUAGE MultiWayIf #-} 15module Pantry.Types 16 ( PantryConfig (..) 17 , HackageSecurityConfig (..) 18 , Storage (..) 19 , HasPantryConfig (..) 20 , BlobKey (..) 21 , PackageName 22 , Version 23 , PackageIdentifier (..) 24 , Revision (..) 25 , ModuleName 26 , CabalFileInfo (..) 27 , PrintWarnings (..) 28 , PackageNameP (..) 29 , VersionP (..) 30 , ModuleNameP (..) 31 , PackageIdentifierRevision (..) 32 , pirForHash 33 , FileType (..) 34 , BuildFile (..) 35 , FileSize (..) 36 , TreeEntry (..) 37 , SafeFilePath 38 , unSafeFilePath 39 , mkSafeFilePath 40 , safeFilePathtoPath 41 , hpackSafeFilePath 42 , TreeKey (..) 43 , Tree (..) 44 , renderTree 45 , parseTree 46 , parseTreeM 47 , SHA256 48 , Unresolved 49 , resolvePaths 50 , Package (..) 51 , PackageCabal (..) 52 , PHpack (..) 53 -- , PackageTarball (..) 54 , RawPackageLocation (..) 55 , PackageLocation (..) 56 , toRawPL 57 , RawPackageLocationImmutable (..) 58 , PackageLocationImmutable (..) 59 , toRawPLI 60 , RawArchive (..) 61 , Archive (..) 62 , toRawArchive 63 , Repo (..) 64 , RepoType (..) 65 , parsePackageIdentifier 66 , parsePackageName 67 , parsePackageNameThrowing 68 , parseFlagName 69 , parseVersion 70 , parseVersionThrowing 71 , packageIdentifierString 72 , packageNameString 73 , flagNameString 74 , versionString 75 , moduleNameString 76 , OptionalSubdirs (..) 77 , ArchiveLocation (..) 78 , RelFilePath (..) 79 , CabalString (..) 80 , toCabalStringMap 81 , unCabalStringMap 82 , parsePackageIdentifierRevision 83 , Mismatch (..) 84 , PantryException (..) 85 , FuzzyResults (..) 86 , ResolvedPath (..) 87 , HpackExecutable (..) 88 , WantedCompiler (..) 89 --, resolveSnapshotLocation 90 , snapshotLocation 91 , defaultSnapshotLocation 92 , SnapName (..) 93 , parseSnapName 94 , RawSnapshotLocation (..) 95 , SnapshotLocation (..) 96 , toRawSL 97 , parseHackageText 98 , parseRawSnapshotLocation 99 , RawSnapshotLayer (..) 100 , SnapshotLayer (..) 101 , toRawSnapshotLayer 102 , RawSnapshot (..) 103 , Snapshot (..) 104 , RawSnapshotPackage (..) 105 , SnapshotPackage (..) 106 , parseWantedCompiler 107 , RawPackageMetadata (..) 108 , PackageMetadata (..) 109 , toRawPM 110 , cabalFileName 111 , SnapshotCacheHash (..) 112 , getGlobalHintsFile 113 , bsToBlobKey 114 , warnMissingCabalFile 115 , connRDBMS 116 ) where 117 118import RIO 119import qualified Data.Conduit.Tar as Tar 120import qualified RIO.Text as T 121import qualified RIO.ByteString as B 122import qualified RIO.ByteString.Lazy as BL 123import RIO.List (intersperse) 124import RIO.Time (toGregorian, Day, UTCTime) 125import qualified RIO.Map as Map 126import qualified RIO.HashMap as HM 127import qualified Data.Map.Strict as Map (mapKeysMonotonic) 128import qualified RIO.Set as Set 129import Data.Aeson.Types (toJSONKeyText, Parser) 130import Pantry.Internal.AesonExtended 131import Data.Aeson.Encoding.Internal (unsafeToEncoding) 132import Data.ByteString.Builder (toLazyByteString, byteString, wordDec) 133import Database.Persist 134import Database.Persist.Sql 135import Pantry.SHA256 (SHA256) 136import qualified Pantry.SHA256 as SHA256 137import qualified Distribution.Compat.CharParsing as Parse 138import Distribution.CabalSpecVersion (CabalSpecVersion (..), cabalSpecLatest) 139import Distribution.Parsec (PError (..), PWarning (..), showPos, parsec, explicitEitherParsec, ParsecParser) 140import Distribution.Types.PackageName (PackageName, unPackageName, mkPackageName) 141import Distribution.Types.VersionRange (VersionRange) 142import Distribution.PackageDescription (FlagName, unFlagName, GenericPackageDescription) 143import Distribution.Types.PackageId (PackageIdentifier (..)) 144import qualified Distribution.Pretty 145import qualified Distribution.Text 146import qualified Hpack.Config as Hpack 147import Distribution.ModuleName (ModuleName) 148import Distribution.Types.Version (Version, mkVersion, nullVersion) 149import Network.HTTP.Client (parseRequest) 150import Network.HTTP.Types (Status, statusCode) 151import Data.Text.Read (decimal) 152import Path (Path, Abs, Dir, File, toFilePath, filename, (</>), parseRelFile) 153import Path.IO (resolveFile, resolveDir) 154import qualified Data.List.NonEmpty as NE 155import Casa.Client (CasaRepoPrefix) 156 157#if MIN_VERSION_persistent(2, 13, 0) 158import Database.Persist.SqlBackend.Internal (connRDBMS) 159#endif 160 161-- | Parsed tree with more information on the Haskell package it contains. 162-- 163-- @since 0.1.0.0 164data Package = Package 165 { packageTreeKey :: !TreeKey 166 -- ^ The 'TreeKey' containing this package. 167 -- 168 -- This is a hash of the binary representation of 'packageTree'. 169 -- 170 -- @since 0.1.0.0 171 , packageTree :: !Tree 172 -- ^ The 'Tree' containing this package. 173 -- 174 -- @since 0.1.0.0 175 , packageCabalEntry :: !PackageCabal 176 -- ^ Information on the cabal file inside this package. 177 -- 178 -- @since 0.1.0.0 179 , packageIdent :: !PackageIdentifier 180 -- ^ The package name and version in this package. 181 -- 182 -- @since 0.1.0.0 183 } 184 deriving (Show, Eq) 185 186data PHpack = PHpack 187 { 188 phOriginal :: !TreeEntry, -- ^ Original hpack file 189 phGenerated :: !TreeEntry, -- ^ Generated Cabal file 190 phVersion :: !Version -- ^ Version of Hpack used 191 } deriving (Show, Eq) 192 193data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file 194 | PCHpack !PHpack 195 deriving (Show, Eq) 196 197cabalFileName :: PackageName -> SafeFilePath 198cabalFileName name = 199 case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of 200 Nothing -> error $ "cabalFileName: failed for " ++ show name 201 Just sfp -> sfp 202 203-- | The revision number of a package from Hackage, counting upwards 204-- from 0 (the original cabal file). 205-- 206-- See caveats on 'CFIRevision'. 207-- 208-- @since 0.1.0.0 209newtype Revision = Revision Word 210 deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql) 211 212-- | Represents a SQL database connection. This used to be a newtype 213-- wrapper around a connection pool. However, when investigating 214-- <https://github.com/commercialhaskell/stack/issues/4471>, it 215-- appeared that holding a pool resulted in overly long write locks 216-- being held on the database. As a result, we now abstract away 217-- whether a pool is used, and the default implementation in 218-- "Pantry.Storage" does not use a pool. 219data Storage = Storage 220 { withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a 221 , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a 222 } 223 224-- | Configuration value used by the entire pantry package. Create one 225-- using @withPantryConfig@. See also @PantryApp@ for a convenience 226-- approach to using pantry. 227-- 228-- @since 0.1.0.0 229data PantryConfig = PantryConfig 230 { pcHackageSecurity :: !HackageSecurityConfig 231 , pcHpackExecutable :: !HpackExecutable 232 , pcRootDir :: !(Path Abs Dir) 233 , pcStorage :: !Storage 234 , pcUpdateRef :: !(MVar Bool) 235 -- ^ Want to try updating the index once during a single run for missing 236 -- package identifiers. We also want to ensure we only update once at a 237 -- time. Start at @True@. 238 , pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription)) 239 -- ^ Cache of previously parsed cabal files, to save on slow parsing time. 240 , pcParsedCabalFilesMutable :: 241 !(IORef 242 (Map 243 (Path Abs Dir) 244 (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File) 245 ) 246 ) 247 -- ^ Cache for mutable packages. We want to allow for an optimization: 248 -- deferring parsing of the 'GenericPackageDescription' until its actually 249 -- needed. Therefore, we keep the filepath and the 'PackageName' derived from 250 -- that filepath. When the @IO GenericPackageDescription@ is run, it will 251 -- ensure that the @PackageName@ matches the value inside the cabal file, and 252 -- print out any warnings that still need to be printed. 253 , pcConnectionCount :: !Int 254 -- ^ concurrently open downloads 255 , pcCasaRepoPrefix :: !CasaRepoPrefix 256 -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@ 257 , pcCasaMaxPerRequest :: !Int 258 -- ^ Maximum blobs sent per pull request. 259 , pcSnapshotLocation :: SnapName -> RawSnapshotLocation 260 -- ^ The location of snapshot synonyms 261 } 262 263-- | Get the location of a snapshot synonym from the 'PantryConfig'. 264-- 265-- @since 0.5.0.0 266snapshotLocation :: HasPantryConfig env => SnapName -> RIO env RawSnapshotLocation 267snapshotLocation name = do 268 loc <- view $ pantryConfigL.to pcSnapshotLocation 269 pure $ loc name 270 271-- | Should we print warnings when loading a cabal file? 272-- 273-- @since 0.1.0.0 274data PrintWarnings = YesPrintWarnings | NoPrintWarnings 275 276-- | Wraps a value which potentially contains relative paths. Needs to 277-- be provided with a base directory to resolve these paths. 278-- 279-- Unwrap this using 'resolvePaths'. 280-- 281-- @since 0.1.0.0 282newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a) 283 deriving Functor 284instance Applicative Unresolved where 285 pure = Unresolved . const . pure 286 Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir 287 288-- | Resolve all of the file paths in an 'Unresolved' relative to the 289-- given directory. 290-- 291-- @since 0.1.0.0 292resolvePaths 293 :: MonadIO m 294 => Maybe (Path Abs Dir) -- ^ directory to use for relative paths 295 -> Unresolved a 296 -> m a 297resolvePaths mdir (Unresolved f) = liftIO (f mdir) 298 299-- | A combination of the relative path provided in a config file, 300-- together with the resolved absolute path. 301-- 302-- @since 0.1.0.0 303data ResolvedPath t = ResolvedPath 304 { resolvedRelative :: !RelFilePath 305 -- ^ Original value parsed from a config file. 306 , resolvedAbsolute :: !(Path Abs t) 307 -- ^ Absolute path resolved against base directory loaded from. 308 } 309 deriving (Show, Eq, Generic, Ord) 310instance NFData (ResolvedPath t) 311 312-- | Location to load a package from. Can either be immutable (see 313-- 'PackageLocationImmutable') or a local directory which is expected 314-- to change over time. Raw version doesn't include exact package 315-- version (e.g. could refer to the latest revision on Hackage) 316-- 317-- @since 0.1.0.0 318data RawPackageLocation 319 = RPLImmutable !RawPackageLocationImmutable 320 | RPLMutable !(ResolvedPath Dir) 321 deriving (Show, Eq, Generic) 322instance NFData RawPackageLocation 323 324-- | Location to load a package from. Can either be immutable (see 325-- 'PackageLocationImmutable') or a local directory which is expected 326-- to change over time. 327-- 328-- @since 0.1.0.0 329data PackageLocation 330 = PLImmutable !PackageLocationImmutable 331 | PLMutable !(ResolvedPath Dir) 332 deriving (Show, Eq, Generic) 333instance NFData PackageLocation 334 335instance Display PackageLocation where 336 display (PLImmutable loc) = display loc 337 display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp 338 339-- | Convert `PackageLocation` to its "raw" equivalent 340-- 341-- @since 0.1.0.0 342toRawPL :: PackageLocation -> RawPackageLocation 343toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im) 344toRawPL (PLMutable m) = RPLMutable m 345 346-- | Location for remote packages or archives assumed to be immutable. 347-- as user specifies it i.e. not an exact location 348-- 349-- @since 0.1.0.0 350data RawPackageLocationImmutable 351 = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey) 352 | RPLIArchive !RawArchive !RawPackageMetadata 353 | RPLIRepo !Repo !RawPackageMetadata 354 deriving (Show, Eq, Ord, Generic) 355 356instance NFData RawPackageLocationImmutable 357 358instance Display RawPackageLocationImmutable where 359 display (RPLIHackage pir _tree) = display pir <> " (from Hackage)" 360 display (RPLIArchive archive _pm) = 361 "Archive from " <> display (raLocation archive) <> 362 (if T.null $ raSubdir archive 363 then mempty 364 else " in subdir " <> display (raSubdir archive)) 365 display (RPLIRepo repo _pm) = 366 "Repo from " <> display (repoUrl repo) <> 367 ", commit " <> display (repoCommit repo) <> 368 (if T.null $ repoSubdir repo 369 then mempty 370 else " in subdir " <> display (repoSubdir repo)) 371 372-- | Location for remote packages or archives assumed to be immutable. 373-- 374-- @since 0.1.0.0 375data PackageLocationImmutable 376 = PLIHackage !PackageIdentifier !BlobKey !TreeKey 377 | PLIArchive !Archive !PackageMetadata 378 | PLIRepo !Repo !PackageMetadata 379 deriving (Generic, Show, Eq, Ord, Typeable) 380instance NFData PackageLocationImmutable 381 382instance Display PackageLocationImmutable where 383 display (PLIHackage ident _cabalHash _tree) = 384 fromString (packageNameString $ pkgName ident) <> " (from Hackage)" 385 display (PLIArchive archive _pm) = 386 "Archive from " <> display (archiveLocation archive) <> 387 (if T.null $ archiveSubdir archive 388 then mempty 389 else " in subdir " <> display (archiveSubdir archive)) 390 display (PLIRepo repo _pm) = 391 "Repo from " <> display (repoUrl repo) <> 392 ", commit " <> display (repoCommit repo) <> 393 (if T.null $ repoSubdir repo 394 then mempty 395 else " in subdir " <> display (repoSubdir repo)) 396 397instance ToJSON PackageLocationImmutable where 398 toJSON = toJSON . toRawPLI 399 400-- | Package identifier and revision with a specified cabal file hash 401-- 402-- @since 0.1.0.0 403pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision 404pirForHash (PackageIdentifier name ver) (BlobKey sha size') = 405 let cfi = CFIHash sha (Just size') 406 in PackageIdentifierRevision name ver cfi 407 408-- | Convert `PackageLocationImmutable` to its "raw" equivalent 409-- 410-- @since 0.1.0.0 411toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable 412toRawPLI (PLIHackage ident cfKey treeKey) = RPLIHackage (pirForHash ident cfKey) (Just treeKey) 413toRawPLI (PLIArchive archive pm) = RPLIArchive (toRawArchive archive) (toRawPM pm) 414toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm) 415 416-- | A raw package archive, specified by a user, could have no 417-- hash and file size information. 418-- 419-- @since 0.1.0.0 420data RawArchive = RawArchive 421 { raLocation :: !ArchiveLocation 422 -- ^ Location of the archive 423 -- 424 -- @since 0.1.0.0 425 , raHash :: !(Maybe SHA256) 426 -- ^ Cryptographic hash of the archive file 427 -- 428 -- @since 0.1.0.0 429 , raSize :: !(Maybe FileSize) 430 -- ^ Size of the archive file 431 -- 432 -- @since 0.1.0.0 433 , raSubdir :: !Text 434 -- ^ Subdirectory within the archive to get the package from. 435 -- 436 -- @since 0.1.0.0 437 } 438 deriving (Generic, Show, Eq, Ord, Typeable) 439 440instance NFData RawArchive 441 442-- | A package archive, could be from a URL or a local file 443-- path. Local file path archives are assumed to be unchanging 444-- over time, and so are allowed in custom snapshots. 445-- 446-- @since 0.1.0.0 447data Archive = Archive 448 { archiveLocation :: !ArchiveLocation 449 -- ^ Location of the archive 450 -- 451 -- @since 0.1.0.0 452 , archiveHash :: !SHA256 453 -- ^ Cryptographic hash of the archive file 454 -- 455 -- @since 0.1.0.0 456 , archiveSize :: !FileSize 457 -- ^ Size of the archive file 458 -- 459 -- @since 0.1.0.0 460 , archiveSubdir :: !Text 461 -- ^ Subdirectory within the archive to get the package from. 462 -- 463 -- @since 0.1.0.0 464 } 465 deriving (Generic, Show, Eq, Ord, Typeable) 466instance NFData Archive 467 468-- | Convert archive to its "raw" equivalent. 469-- 470-- @since 0.1.0.0 471toRawArchive :: Archive -> RawArchive 472toRawArchive archive = 473 RawArchive (archiveLocation archive) (Just $ archiveHash archive) 474 (Just $ archiveSize archive) (archiveSubdir archive) 475 476-- | The type of a source control repository. 477-- 478-- @since 0.1.0.0 479data RepoType = RepoGit | RepoHg 480 deriving (Generic, Show, Eq, Ord, Typeable) 481instance NFData RepoType 482instance PersistField RepoType where 483 toPersistValue RepoGit = toPersistValue (1 :: Int32) 484 toPersistValue RepoHg = toPersistValue (2 :: Int32) 485 fromPersistValue v = do 486 i <- fromPersistValue v 487 case i :: Int32 of 488 1 -> pure RepoGit 489 2 -> pure RepoHg 490 _ -> Left $ fromString $ "Invalid RepoType: " ++ show i 491instance PersistFieldSql RepoType where 492 sqlType _ = SqlInt32 493 494-- | Information on packages stored in a source control repository. 495-- 496-- @since 0.1.0.0 497data Repo = Repo 498 { repoUrl :: !Text 499 -- ^ Location of the repo 500 -- 501 -- @since 0.1.0.0 502 , repoCommit :: !Text 503 -- ^ Commit to use from the repo. It's strongly recommended to use 504 -- a hash instead of a tag or branch name. 505 -- 506 -- @since 0.1.0.0 507 , repoType :: !RepoType 508 -- ^ The type of the repo 509 -- 510 -- @since 0.1.0.0 511 , repoSubdir :: !Text 512 -- ^ Subdirectory within the archive to get the package from. 513 -- 514 -- @since 0.1.0.0 515 } 516 deriving (Generic, Eq, Ord, Typeable) 517instance NFData Repo 518instance Show Repo where 519 show = T.unpack . utf8BuilderToText . display 520instance Display Repo where 521 display (Repo url commit typ subdir) = 522 (case typ of 523 RepoGit -> "Git" 524 RepoHg -> "Mercurial") <> 525 " repo at " <> 526 display url <> 527 ", commit " <> 528 display commit <> 529 (if T.null subdir 530 then mempty 531 else " in subdirectory " <> display subdir) 532 533 534-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains 535-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar". 536newtype GitHubRepo = GitHubRepo Text 537 538instance FromJSON GitHubRepo where 539 parseJSON = withText "GitHubRepo" $ \s -> do 540 case T.split (== '/') s of 541 [x, y] | not (T.null x || T.null y) -> return (GitHubRepo s) 542 _ -> fail "expecting \"user/repo\"" 543 544-- | Configuration for Hackage Security to securely download package 545-- metadata and contents from Hackage. For most purposes, you'll want 546-- to use the default Hackage settings via 547-- @defaultHackageSecurityConfig@. 548-- 549-- /NOTE/ It's highly recommended to only use the official Hackage 550-- server or a mirror. See 551-- <https://github.com/commercialhaskell/stack/issues/4137>. 552-- 553-- @since 0.1.0.0 554data HackageSecurityConfig = HackageSecurityConfig 555 { hscKeyIds :: ![Text] 556 , hscKeyThreshold :: !Int 557 , hscDownloadPrefix :: !Text 558 , hscIgnoreExpiry :: !Bool 559 } 560 deriving Show 561instance FromJSON (WithJSONWarnings HackageSecurityConfig) where 562 parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o' -> do 563 hscDownloadPrefix <- o' ..: "download-prefix" 564 Object o <- o' ..: "hackage-security" 565 hscKeyIds <- o ..: "keyids" 566 hscKeyThreshold <- o ..: "key-threshold" 567 hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True 568 pure HackageSecurityConfig {..} 569 570 571-- | An environment which contains a 'PantryConfig'. 572-- 573-- @since 0.1.0.0 574class HasPantryConfig env where 575 -- | Lens to get or set the 'PantryConfig' 576 -- 577 -- @since 0.1.0.0 578 pantryConfigL :: Lens' env PantryConfig 579 580 581-- | File size in bytes 582-- 583-- @since 0.1.0.0 584newtype FileSize = FileSize Word 585 deriving (Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData, PersistField, PersistFieldSql, ToJSON, FromJSON) 586 587-- | A key for looking up a blob, which combines the SHA256 hash of 588-- the contents and the file size. 589-- 590-- The file size may seem redundant with the hash. However, it is 591-- necessary for safely downloading blobs from an untrusted 592-- source. See 593-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>. 594-- 595-- @since 0.1.0.0 596data BlobKey = BlobKey !SHA256 !FileSize 597 deriving (Eq, Ord, Typeable, Generic) 598instance NFData BlobKey 599 600instance Show BlobKey where 601 show = T.unpack . utf8BuilderToText . display 602instance Display BlobKey where 603 display (BlobKey sha size') = display sha <> "," <> display size' 604 605blobKeyPairs :: BlobKey -> [(Text, Value)] 606blobKeyPairs (BlobKey sha size') = 607 [ "sha256" .= sha 608 , "size" .= size' 609 ] 610 611instance ToJSON BlobKey where 612 toJSON = object . blobKeyPairs 613instance FromJSON BlobKey where 614 parseJSON = withObject "BlobKey" $ \o -> BlobKey 615 <$> o .: "sha256" 616 <*> o .: "size" 617 618newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName } 619 deriving (Eq, Ord, Show, Read, NFData) 620instance Display PackageNameP where 621 display = fromString . packageNameString . unPackageNameP 622instance PersistField PackageNameP where 623 toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn 624 fromPersistValue v = do 625 str <- fromPersistValue v 626 case parsePackageName str of 627 Nothing -> Left $ "Invalid package name: " <> T.pack str 628 Just pn -> Right $ PackageNameP pn 629instance PersistFieldSql PackageNameP where 630 sqlType _ = SqlString 631instance ToJSON PackageNameP where 632 toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn 633instance FromJSON PackageNameP where 634 parseJSON = withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack 635instance ToJSONKey PackageNameP where 636 toJSONKey = 637 ToJSONKeyText 638 (T.pack . packageNameString . unPackageNameP) 639 (unsafeToEncoding . getUtf8Builder . display) 640instance FromJSONKey PackageNameP where 641 fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack 642 643newtype VersionP = VersionP { unVersionP :: Version } 644 deriving (Eq, Ord, Show, Read, NFData) 645instance PersistField VersionP where 646 toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v 647 fromPersistValue v = do 648 str <- fromPersistValue v 649 case parseVersion str of 650 Nothing -> Left $ "Invalid version number: " <> T.pack str 651 Just ver -> Right $ VersionP ver 652instance PersistFieldSql VersionP where 653 sqlType _ = SqlString 654instance Display VersionP where 655 display (VersionP v) = fromString $ versionString v 656instance ToJSON VersionP where 657 toJSON (VersionP v) = String $ T.pack $ versionString v 658instance FromJSON VersionP where 659 parseJSON = 660 withText "VersionP" $ 661 either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack 662 663newtype ModuleNameP = ModuleNameP 664 { unModuleNameP :: ModuleName 665 } deriving (Eq, Ord, Show, NFData) 666instance Display ModuleNameP where 667 display = fromString . moduleNameString . unModuleNameP 668instance PersistField ModuleNameP where 669 toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn 670 fromPersistValue v = do 671 str <- fromPersistValue v 672 case parseModuleName str of 673 Nothing -> Left $ "Invalid module name: " <> T.pack str 674 Just pn -> Right $ ModuleNameP pn 675instance PersistFieldSql ModuleNameP where 676 sqlType _ = SqlString 677 678-- | How to choose a cabal file for a package from Hackage. This is to 679-- work with Hackage cabal file revisions, which makes 680-- @PackageIdentifier@ insufficient for specifying a package from 681-- Hackage. 682-- 683-- @since 0.1.0.0 684data CabalFileInfo 685 = CFILatest 686 -- ^ Take the latest revision of the cabal file available. This 687 -- isn't reproducible at all, but the running assumption (not 688 -- necessarily true) is that cabal file revisions do not change 689 -- semantics of the build. 690 -- 691 -- @since 0.1.0.0 692 | CFIHash !SHA256 !(Maybe FileSize) 693 -- ^ Identify by contents of the cabal file itself. Only reason for 694 -- @Maybe@ on @FileSize@ is for compatibility with input that 695 -- doesn't include the file size. 696 -- 697 -- @since 0.1.0.0 698 | CFIRevision !Revision 699 -- ^ Identify by revision number, with 0 being the original and 700 -- counting upward. This relies on Hackage providing consistent 701 -- versioning. @CFIHash@ should be preferred wherever possible for 702 -- reproducibility. 703 -- 704 -- @since 0.1.0.0 705 deriving (Generic, Show, Eq, Ord, Typeable) 706instance NFData CabalFileInfo 707instance Hashable CabalFileInfo 708 709instance Display CabalFileInfo where 710 display CFILatest = mempty 711 display (CFIHash hash' msize) = 712 "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize 713 display (CFIRevision rev) = "@rev:" <> display rev 714 715-- | A full specification for a package from Hackage, including the 716-- package name, version, and how to load up the correct cabal file 717-- revision. 718-- 719-- @since 0.1.0.0 720data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo 721 deriving (Generic, Eq, Ord, Typeable) 722instance NFData PackageIdentifierRevision 723 724instance Show PackageIdentifierRevision where 725 show = T.unpack . utf8BuilderToText . display 726 727instance Display PackageIdentifierRevision where 728 display (PackageIdentifierRevision name version cfi) = 729 fromString (packageNameString name) <> "-" <> fromString (versionString version) <> display cfi 730 731instance ToJSON PackageIdentifierRevision where 732 toJSON = toJSON . utf8BuilderToText . display 733instance FromJSON PackageIdentifierRevision where 734 parseJSON = withText "PackageIdentifierRevision" $ \t -> 735 case parsePackageIdentifierRevision t of 736 Left e -> fail $ show e 737 Right pir -> pure pir 738 739-- | Parse a hackage text. 740-- 741-- @since 0.1.0.0 742parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey) 743parseHackageText t = 744 either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $ 745 explicitEitherParsec (hackageTextParsec <* Parse.eof) $ 746 T.unpack t 747 748hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey) 749hackageTextParsec = do 750 ident <- packageIdentifierParsec 751 _ <- Parse.string "@sha256:" 752 753 shaT <- Parse.munch (/= ',') 754 sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT 755 756 _ <- Parse.char ',' 757 size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't 758 pure (ident, BlobKey sha (FileSize size')) 759 760splitColon :: Text -> Maybe (Text, Text) 761splitColon t' = 762 let (x, y) = T.break (== ':') t' 763 in (x, ) <$> T.stripPrefix ":" y 764 765-- | Parse a 'PackageIdentifierRevision' 766-- 767-- @since 0.1.0.0 768parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision 769parsePackageIdentifierRevision t = maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do 770 let (identT, cfiT) = T.break (== '@') t 771 PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT 772 cfi <- 773 case splitColon cfiT of 774 Just ("@sha256", shaSizeT) -> do 775 let (shaT, sizeT) = T.break (== ',') shaSizeT 776 sha <- either (const Nothing) Just $ SHA256.fromHexText shaT 777 msize <- 778 case T.stripPrefix "," sizeT of 779 Nothing -> Just Nothing 780 Just sizeT' -> 781 case decimal sizeT' of 782 Right (size', "") -> Just $ Just $ FileSize size' 783 _ -> Nothing 784 pure $ CFIHash sha msize 785 Just ("@rev", revT) -> 786 case decimal revT of 787 Right (rev, "") -> pure $ CFIRevision $ Revision rev 788 _ -> Nothing 789 Nothing -> pure CFILatest 790 _ -> Nothing 791 pure $ PackageIdentifierRevision name version cfi 792 793data Mismatch a = Mismatch 794 { mismatchExpected :: !a 795 , mismatchActual :: !a 796 } 797 798-- | Things that can go wrong in pantry. Note two things: 799-- 800-- * Many other exception types may be thrown from underlying 801-- libraries. Pantry does not attempt to wrap these underlying 802-- exceptions. 803-- 804-- * We may add more constructors to this data type in minor version 805-- bumps of pantry. This technically breaks the PVP. You should not 806-- be writing pattern matches against this type that expect total 807-- matching. 808-- 809-- @since 0.1.0.0 810data PantryException 811 = PackageIdentifierRevisionParseFail !Text 812 | InvalidCabalFile 813 !(Either RawPackageLocationImmutable (Path Abs File)) 814 !(Maybe Version) 815 ![PError] 816 ![PWarning] 817 | TreeWithoutCabalFile !RawPackageLocationImmutable 818 | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath] 819 | MismatchedCabalName !(Path Abs File) !PackageName 820 | NoCabalFileFound !(Path Abs Dir) 821 | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File] 822 | InvalidWantedCompiler !Text 823 | InvalidSnapshotLocation !(Path Abs Dir) !Text 824 | InvalidOverrideCompiler !WantedCompiler !WantedCompiler 825 | InvalidFilePathSnapshot !Text 826 | InvalidSnapshot !RawSnapshotLocation !SomeException 827 | MismatchedPackageMetadata 828 !RawPackageLocationImmutable 829 !RawPackageMetadata 830 !(Maybe TreeKey) 831 !PackageIdentifier 832 | Non200ResponseStatus !Status 833 | InvalidBlobKey !(Mismatch BlobKey) 834 | Couldn'tParseSnapshot !RawSnapshotLocation !String 835 | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName 836 | DownloadInvalidSHA256 !Text !(Mismatch SHA256) 837 | DownloadInvalidSize !Text !(Mismatch FileSize) 838 | DownloadTooLarge !Text !(Mismatch FileSize) 839 -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is 840 -- a lower bound on the size from the server. 841 | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256) 842 | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize) 843 | UnknownArchiveType !ArchiveLocation 844 | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType 845 | UnsupportedTarball !ArchiveLocation !Text 846 | NoHackageCryptographicHash !PackageIdentifier 847 | FailedToCloneRepo !Repo 848 | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey 849 | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata 850 | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32) 851 | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults 852 | CannotCompleteRepoNonSHA1 !Repo 853 | MutablePackageLocationFromUrl !Text 854 | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier) 855 | PackageNameParseFail !Text 856 | PackageVersionParseFail !Text 857 | InvalidCabalFilePath !(Path Abs File) 858 | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])] 859 | MigrationFailure !Text !(Path Abs File) !SomeException 860 | InvalidTreeFromCasa !BlobKey !ByteString 861 | ParseSnapNameException !Text 862 863 deriving Typeable 864instance Exception PantryException where 865instance Show PantryException where 866 show = T.unpack . utf8BuilderToText . display 867instance Display PantryException where 868 display (InvalidTreeFromCasa blobKey _bs) = "Invalid tree from casa: " <> display blobKey 869 display (PackageIdentifierRevisionParseFail text) = 870 "Invalid package identifier (with optional revision): " <> 871 display text 872 display (InvalidCabalFile loc mversion errs warnings) = 873 "Unable to parse cabal file from package " <> 874 either display (fromString . toFilePath) loc <> 875 "\n\n" <> 876 foldMap 877 (\(PError pos msg) -> 878 "- " <> 879 fromString (showPos pos) <> 880 ": " <> 881 fromString msg <> 882 "\n") 883 errs <> 884 foldMap 885 (\(PWarning _ pos msg) -> 886 "- " <> 887 fromString (showPos pos) <> 888 ": " <> 889 fromString msg <> 890 "\n") 891 warnings <> 892 893 (case mversion of 894 Just version 895 | version > cabalSpecLatestVersion -> 896 "\n\nThe cabal file uses the cabal specification version " <> 897 fromString (versionString version) <> 898 ", but we only support up to version " <> 899 fromString (versionString cabalSpecLatestVersion) <> 900 ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)." 901 _ -> mempty) 902 display (TreeWithoutCabalFile pl) = "No cabal file found for " <> display pl 903 display (TreeWithMultipleCabalFiles pl sfps) = 904 "Multiple cabal files found for " <> display pl <> ": " <> 905 fold (intersperse ", " (map display sfps)) 906 display (MismatchedCabalName fp name) = 907 "cabal file path " <> 908 fromString (toFilePath fp) <> 909 " does not match the package name it defines.\n" <> 910 "Please rename the file to: " <> 911 fromString (packageNameString name) <> 912 ".cabal\n" <> 913 "For more information, see: https://github.com/commercialhaskell/stack/issues/317" 914 display (NoCabalFileFound dir) = 915 "Stack looks for packages in the directories configured in\n" <> 916 "the 'packages' and 'extra-deps' fields defined in your stack.yaml\n" <> 917 "The current entry points to " <> 918 fromString (toFilePath dir) <> 919 ",\nbut no .cabal or package.yaml file could be found there." 920 display (MultipleCabalFilesFound dir files) = 921 "Multiple .cabal files found in directory " <> 922 fromString (toFilePath dir) <> 923 ":\n" <> 924 fold (intersperse "\n" (map (\x -> "- " <> fromString (toFilePath (filename x))) files)) 925 display (InvalidWantedCompiler t) = "Invalid wanted compiler: " <> display t 926 display (InvalidSnapshotLocation dir t) = 927 "Invalid snapshot location " <> 928 displayShow t <> 929 " relative to directory " <> 930 displayShow (toFilePath dir) 931 display (InvalidOverrideCompiler x y) = 932 "Specified compiler for a resolver (" <> 933 display x <> 934 "), but also specified an override compiler (" <> 935 display y <> 936 ")" 937 display (InvalidFilePathSnapshot t) = 938 "Specified snapshot as file path with " <> 939 displayShow t <> 940 ", but not reading from a local file" 941 display (InvalidSnapshot loc e) = 942 "Exception while reading snapshot from " <> 943 display loc <> 944 ":\n" <> 945 displayShow e 946 display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) = 947 "Mismatched package metadata for " <> display loc <> 948 "\nFound: " <> fromString (packageIdentifierString foundIdent) <> 949 (case mtreeKey of 950 Nothing -> mempty 951 Just treeKey -> " with tree " <> display treeKey) <> 952 "\nExpected: " <> display pm 953 display (Non200ResponseStatus status) = 954 "Unexpected non-200 HTTP status code: " <> 955 displayShow (statusCode status) 956 display (InvalidBlobKey Mismatch{..}) = 957 "Invalid blob key found, expected: " <> 958 display mismatchExpected <> 959 ", actual: " <> 960 display mismatchActual 961 display (Couldn'tParseSnapshot sl e) = 962 "Couldn't parse snapshot from " <> display sl <> ": " <> fromString e 963 display (WrongCabalFileName pl sfp name) = 964 "Wrong cabal file name for package " <> display pl <> 965 "\nCabal file is named " <> display sfp <> 966 ", but package name is " <> fromString (packageNameString name) <> 967 "\nFor more information, see:\n - https://github.com/commercialhaskell/stack/issues/317\n -https://github.com/commercialhaskell/stack/issues/895" 968 display (DownloadInvalidSHA256 url Mismatch {..}) = 969 "Mismatched SHA256 hash from " <> display url <> 970 "\nExpected: " <> display mismatchExpected <> 971 "\nActual: " <> display mismatchActual 972 display (DownloadInvalidSize url Mismatch {..}) = 973 "Mismatched download size from " <> display url <> 974 "\nExpected: " <> display mismatchExpected <> 975 "\nActual: " <> display mismatchActual 976 display (DownloadTooLarge url Mismatch {..}) = 977 "Download from " <> display url <> " was too large.\n" <> 978 "Expected: " <> display mismatchExpected <> ", stopped after receiving: " <> 979 display mismatchActual 980 display (LocalInvalidSHA256 path Mismatch {..}) = 981 "Mismatched SHA256 hash from " <> fromString (toFilePath path) <> 982 "\nExpected: " <> display mismatchExpected <> 983 "\nActual: " <> display mismatchActual 984 display (LocalInvalidSize path Mismatch {..}) = 985 "Mismatched file size from " <> fromString (toFilePath path) <> 986 "\nExpected: " <> display mismatchExpected <> 987 "\nActual: " <> display mismatchActual 988 display (UnknownArchiveType loc) = "Unable to determine archive type of: " <> display loc 989 display (InvalidTarFileType loc fp x) = 990 "Unsupported tar filetype in archive " <> display loc <> " at file " <> fromString fp <> ": " <> displayShow x 991 display (UnsupportedTarball loc e) = 992 "Unsupported tarball from " <> display loc <> ": " <> display e 993 display (NoHackageCryptographicHash ident) = 994 "Not cryptographic hash found for Hackage package " <> fromString (packageIdentifierString ident) 995 display (FailedToCloneRepo repo) = "Failed to clone repo " <> display repo 996 display (TreeReferencesMissingBlob loc sfp key) = 997 "The package " <> display loc <> 998 " needs blob " <> display key <> 999 " for file path " <> display sfp <> 1000 ", but the blob is not available" 1001 display (CompletePackageMetadataMismatch loc pm) = 1002 "When completing package metadata for " <> display loc <> 1003 ", some values changed in the new package metadata: " <> 1004 display pm 1005 display (CRC32Mismatch loc fp Mismatch {..}) = 1006 "CRC32 mismatch in ZIP file from " <> display loc <> 1007 " on internal file " <> fromString fp <> 1008 "\n.Expected: " <> display mismatchExpected <> 1009 "\n.Actual: " <> display mismatchActual 1010 display (UnknownHackagePackage pir fuzzy) = 1011 "Could not find " <> display pir <> " on Hackage" <> 1012 displayFuzzy fuzzy 1013 display (CannotCompleteRepoNonSHA1 repo) = 1014 "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: " <> 1015 display repo 1016 display (MutablePackageLocationFromUrl t) = 1017 "Cannot refer to a mutable package location from a URL: " <> display t 1018 display (MismatchedCabalFileForHackage pir Mismatch{..}) = 1019 "When processing cabal file for Hackage package " <> display pir <> 1020 ":\nMismatched package identifier." <> 1021 "\nExpected: " <> fromString (packageIdentifierString mismatchExpected) <> 1022 "\nActual: " <> fromString (packageIdentifierString mismatchActual) 1023 display (PackageNameParseFail t) = 1024 "Invalid package name: " <> display t 1025 display (PackageVersionParseFail t) = 1026 "Invalid version: " <> display t 1027 display (InvalidCabalFilePath fp) = 1028 "File path contains a name which is not a valid package name: " <> 1029 fromString (toFilePath fp) 1030 display (DuplicatePackageNames source pairs') = 1031 "Duplicate package names (" <> source <> "):\n" <> 1032 foldMap 1033 (\(name, locs) -> 1034 fromString (packageNameString name) <> ":\n" <> 1035 foldMap 1036 (\loc -> "- " <> display loc <> "\n") 1037 locs 1038 ) 1039 pairs' 1040 display (MigrationFailure desc fp ex) = 1041 "Encountered error while migrating " <> display desc <> " database:" <> 1042 "\n " <> displayShow ex <> 1043 "\nPlease report this on https://github.com/commercialhaskell/stack/issues" <> 1044 "\nAs a workaround you may delete " <> display desc <> " database in " <> 1045 fromString (toFilePath fp) <> " triggering its recreation." 1046 display (ParseSnapNameException t) = "Invalid snapshot name: " <> display t 1047 1048data FuzzyResults 1049 = FRNameNotFound ![PackageName] 1050 | FRVersionNotFound !(NonEmpty PackageIdentifierRevision) 1051 | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision) 1052 1053displayFuzzy :: FuzzyResults -> Utf8Builder 1054displayFuzzy (FRNameNotFound names) = 1055 case NE.nonEmpty names of 1056 Nothing -> "" 1057 Just names' -> 1058 "\nPerhaps you meant " <> 1059 orSeparated (NE.map (fromString . packageNameString) names') <> 1060 "?" 1061displayFuzzy (FRVersionNotFound pirs) = 1062 "\nPossible candidates: " <> 1063 commaSeparated (NE.map display pirs) <> 1064 "." 1065displayFuzzy (FRRevisionNotFound pirs) = 1066 "\nThe specified revision was not found.\nPossible candidates: " <> 1067 commaSeparated (NE.map display pirs) <> 1068 "." 1069 1070orSeparated :: NonEmpty Utf8Builder -> Utf8Builder 1071orSeparated xs 1072 | NE.length xs == 1 = NE.head xs 1073 | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs 1074 | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs 1075 1076commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder 1077commaSeparated = fold . NE.intersperse ", " 1078 1079-- You'd really think there'd be a better way to do this in Cabal. 1080cabalSpecLatestVersion :: Version 1081cabalSpecLatestVersion = 1082 case cabalSpecLatest of 1083 CabalSpecV1_0 -> error "this cannot happen" 1084 CabalSpecV1_2 -> error "this cannot happen" 1085 CabalSpecV1_4 -> error "this cannot happen" 1086 CabalSpecV1_6 -> error "this cannot happen" 1087 CabalSpecV1_8 -> error "this cannot happen" 1088 CabalSpecV1_10 -> error "this cannot happen" 1089 CabalSpecV1_12 -> error "this cannot happen" 1090 CabalSpecV1_18 -> error "this cannot happen" 1091 CabalSpecV1_20 -> error "this cannot happen" 1092 CabalSpecV1_22 -> error "this cannot happen" 1093 CabalSpecV1_24 -> error "this cannot happen" 1094 CabalSpecV2_0 -> error "this cannot happen" 1095 CabalSpecV2_2 -> error "this cannot happen" 1096 CabalSpecV2_4 -> error "this cannot happen" 1097 CabalSpecV3_0 -> mkVersion [3, 0] 1098 1099data BuildFile = BFCabal !SafeFilePath !TreeEntry 1100 | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file 1101 deriving (Show, Eq) 1102 1103data FileType = FTNormal | FTExecutable 1104 deriving (Show, Eq, Enum, Bounded) 1105instance PersistField FileType where 1106 toPersistValue FTNormal = PersistInt64 1 1107 toPersistValue FTExecutable = PersistInt64 2 1108 1109 fromPersistValue v = do 1110 i <- fromPersistValue v 1111 case i :: Int64 of 1112 1 -> Right FTNormal 1113 2 -> Right FTExecutable 1114 _ -> Left $ "Invalid FileType: " <> tshow i 1115instance PersistFieldSql FileType where 1116 sqlType _ = SqlInt32 1117 1118data TreeEntry = TreeEntry 1119 { teBlob :: !BlobKey 1120 , teType :: !FileType 1121 } 1122 deriving (Show, Eq) 1123 1124newtype SafeFilePath = SafeFilePath Text 1125 deriving (Show, Eq, Ord, Display) 1126 1127instance PersistField SafeFilePath where 1128 toPersistValue = toPersistValue . unSafeFilePath 1129 fromPersistValue v = do 1130 t <- fromPersistValue v 1131 maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t 1132instance PersistFieldSql SafeFilePath where 1133 sqlType _ = SqlString 1134 1135unSafeFilePath :: SafeFilePath -> Text 1136unSafeFilePath (SafeFilePath t) = t 1137 1138safeFilePathtoPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File) 1139safeFilePathtoPath dir (SafeFilePath path) = do 1140 fpath <- parseRelFile (T.unpack path) 1141 return $ dir </> fpath 1142 1143mkSafeFilePath :: Text -> Maybe SafeFilePath 1144mkSafeFilePath t = do 1145 guard $ not $ "\\" `T.isInfixOf` t 1146 guard $ not $ "//" `T.isInfixOf` t 1147 guard $ not $ "\n" `T.isInfixOf` t 1148 guard $ not $ "\0" `T.isInfixOf` t 1149 1150 (c, _) <- T.uncons t 1151 guard $ c /= '/' 1152 1153 guard $ all (not . T.all (== '.')) $ T.split (== '/') t 1154 1155 Just $ SafeFilePath t 1156 1157-- | SafeFilePath for `package.yaml` file. 1158hpackSafeFilePath :: SafeFilePath 1159hpackSafeFilePath = 1160 let fpath = mkSafeFilePath (T.pack Hpack.packageConfig) 1161 in case fpath of 1162 Nothing -> error $ "hpackSafeFilePath: Not able to encode " <> (Hpack.packageConfig) 1163 Just sfp -> sfp 1164 1165-- | The hash of the binary representation of a 'Tree'. 1166-- 1167-- @since 0.1.0.0 1168newtype TreeKey = TreeKey BlobKey 1169 deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display) 1170 1171-- | Represents the contents of a tree, which is a mapping from 1172-- relative file paths to 'TreeEntry's. 1173-- 1174-- @since 0.1.0.0 1175newtype Tree 1176 = TreeMap (Map SafeFilePath TreeEntry) 1177 -- In the future, consider allowing more lax parsing 1178 -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys 1179 -- TreeTarball !PackageTarball 1180 deriving (Show, Eq) 1181 1182renderTree :: Tree -> ByteString 1183renderTree = BL.toStrict . toLazyByteString . go 1184 where 1185 go :: Tree -> Builder 1186 go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m 1187 1188 goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) = 1189 netstring (unSafeFilePath sfp) <> 1190 byteString (SHA256.toRaw sha) <> 1191 netword size' <> 1192 (case ft of 1193 FTNormal -> "N" 1194 FTExecutable -> "X") 1195 1196netstring :: Text -> Builder 1197netstring t = 1198 let bs = encodeUtf8 t 1199 in netword (fromIntegral (B.length bs)) <> byteString bs 1200 1201netword :: Word -> Builder 1202netword w = wordDec w <> ":" 1203 1204parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree) 1205parseTreeM (blobKey, blob) = 1206 case parseTree blob of 1207 Nothing -> throwM (InvalidTreeFromCasa blobKey blob) 1208 Just tree -> pure (TreeKey blobKey, tree) 1209 1210parseTree :: ByteString -> Maybe Tree 1211parseTree bs1 = do 1212 tree <- parseTree' bs1 1213 let bs2 = renderTree tree 1214 guard $ bs1 == bs2 1215 Just tree 1216 1217parseTree' :: ByteString -> Maybe Tree 1218parseTree' bs0 = do 1219 entriesBS <- B.stripPrefix "map:" bs0 1220 TreeMap <$> loop Map.empty entriesBS 1221 where 1222 loop !m bs1 1223 | B.null bs1 = pure m 1224 | otherwise = do 1225 (sfpBS, bs2) <- takeNetstring bs1 1226 sfp <- 1227 case decodeUtf8' sfpBS of 1228 Left _ -> Nothing 1229 Right sfpT -> mkSafeFilePath sfpT 1230 (sha, bs3) <- takeSha bs2 1231 (size', bs4) <- takeNetword bs3 1232 (typeW, bs5) <- B.uncons bs4 1233 ft <- 1234 case typeW of 1235 78 -> Just FTNormal -- 'N' 1236 88 -> Just FTExecutable -- 'X' 1237 _ -> Nothing 1238 let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft 1239 loop (Map.insert sfp entry m) bs5 1240 1241 takeNetstring bs1 = do 1242 (size', bs2) <- takeNetword bs1 1243 guard $ B.length bs2 >= size' 1244 Just $ B.splitAt size' bs2 1245 1246 takeSha bs = do 1247 let (x, y) = B.splitAt 32 bs 1248 x' <- either (const Nothing) Just (SHA256.fromRaw x) 1249 Just (x', y) 1250 1251 takeNetword = 1252 go 0 1253 where 1254 go !accum bs = do 1255 (next, rest) <- B.uncons bs 1256 if 1257 | next == 58 -> pure (accum, rest) -- ':' 1258 | next >= 48 && next <= 57 -> 1259 go 1260 (accum * 10 + fromIntegral (next - 48)) 1261 rest 1262 | otherwise -> Nothing 1263 1264 {- 1265data PackageTarball = PackageTarball 1266 { ptBlob :: !BlobKey 1267 -- ^ Contains the tarball itself 1268 , ptCabal :: !BlobKey 1269 -- ^ Contains the cabal file contents 1270 , ptSubdir :: !FilePath 1271 -- ^ Subdir containing the files we want for this package. 1272 -- 1273 -- There must be precisely one file with a @.cabal@ file extension 1274 -- located there. Thanks to Hackage revisions, its contents will be 1275 -- overwritten by the value of @ptCabal@. 1276 } 1277 deriving Show 1278 -} 1279 1280-- | This is almost a copy of Cabal's parser for package identifiers, 1281-- the main difference is in the fact that Stack requires version to be 1282-- present while Cabal uses "null version" as a default value 1283-- 1284-- @since 0.1.0.0 1285parsePackageIdentifier :: String -> Maybe PackageIdentifier 1286parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof) 1287 1288packageIdentifierParsec :: ParsecParser PackageIdentifier 1289packageIdentifierParsec = do 1290 ident@(PackageIdentifier _ v) <- parsec 1291 1292 -- version is a required component of a package identifier for Stack 1293 guard (v /= nullVersion) 1294 1295 pure ident 1296 1297-- | Parse a package name from a 'String'. 1298-- 1299-- @since 0.1.0.0 1300parsePackageName :: String -> Maybe PackageName 1301parsePackageName = Distribution.Text.simpleParse 1302 1303-- | Parse a package name from a 'String' throwing on failure 1304-- 1305-- @since 0.1.0.0 1306parsePackageNameThrowing :: MonadThrow m => String -> m PackageName 1307parsePackageNameThrowing str = 1308 case parsePackageName str of 1309 Nothing -> throwM $ PackageNameParseFail $ T.pack str 1310 Just pn -> pure pn 1311 1312-- | Parse a version from a 'String'. 1313-- 1314-- @since 0.1.0.0 1315parseVersion :: String -> Maybe Version 1316parseVersion = Distribution.Text.simpleParse 1317 1318-- | Parse a package version from a 'String' throwing on failure 1319-- 1320-- @since 0.1.0.0 1321parseVersionThrowing :: MonadThrow m => String -> m Version 1322parseVersionThrowing str = 1323 case parseVersion str of 1324 Nothing -> throwM $ PackageVersionParseFail $ T.pack str 1325 Just v -> pure v 1326 1327-- | Parse a version range from a 'String'. 1328-- 1329-- @since 0.1.0.0 1330parseVersionRange :: String -> Maybe VersionRange 1331parseVersionRange = Distribution.Text.simpleParse 1332 1333-- | Parse a module name from a 'String'. 1334-- 1335-- @since 0.1.0.0 1336parseModuleName :: String -> Maybe ModuleName 1337parseModuleName = Distribution.Text.simpleParse 1338 1339-- | Parse a flag name from a 'String'. 1340-- 1341-- @since 0.1.0.0 1342parseFlagName :: String -> Maybe FlagName 1343parseFlagName = Distribution.Text.simpleParse 1344 1345-- | Render a package name as a 'String'. 1346-- 1347-- @since 0.1.0.0 1348packageNameString :: PackageName -> String 1349packageNameString = unPackageName 1350 1351-- | Render a package identifier as a 'String'. 1352-- 1353-- @since 0.1.0.0 1354packageIdentifierString :: PackageIdentifier -> String 1355packageIdentifierString = Distribution.Text.display 1356 1357-- | Render a version as a 'String'. 1358-- 1359-- @since 0.1.0.0 1360versionString :: Version -> String 1361versionString = Distribution.Text.display 1362 1363-- | Render a flag name as a 'String'. 1364-- 1365-- @since 0.1.0.0 1366flagNameString :: FlagName -> String 1367flagNameString = unFlagName 1368 1369-- | Render a module name as a 'String'. 1370-- 1371-- @since 0.1.0.0 1372moduleNameString :: ModuleName -> String 1373moduleNameString = Distribution.Text.display 1374 1375data OptionalSubdirs 1376 = OSSubdirs !(NonEmpty Text) 1377 | OSPackageMetadata !Text !RawPackageMetadata 1378 -- ^ subdirectory and package metadata 1379 deriving (Show, Eq, Generic) 1380instance NFData OptionalSubdirs 1381 1382-- | Metadata provided by a config file for archives and repos. This 1383-- information can be used for optimized lookups of information like 1384-- package identifiers, or for validating that the user configuration 1385-- has the expected information. 1386-- 1387-- @since 0.1.0.0 1388data RawPackageMetadata = RawPackageMetadata 1389 { rpmName :: !(Maybe PackageName) 1390 -- ^ Package name in the cabal file 1391 -- 1392 -- @since 0.1.0.0 1393 , rpmVersion :: !(Maybe Version) 1394 -- ^ Package version in the cabal file 1395 -- 1396 -- @since 0.1.0.0 1397 , rpmTreeKey :: !(Maybe TreeKey) 1398 -- ^ Tree key of the loaded up package 1399 -- 1400 -- @since 0.1.0.0 1401 } 1402 deriving (Show, Eq, Ord, Generic, Typeable) 1403instance NFData RawPackageMetadata 1404 1405instance Display RawPackageMetadata where 1406 display rpm = fold $ intersperse ", " $ catMaybes 1407 [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm 1408 , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm 1409 , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm 1410 ] 1411 1412-- | Exact metadata specifying concrete package 1413-- 1414-- @since 0.1.0.0 1415data PackageMetadata = PackageMetadata 1416 { pmIdent :: !PackageIdentifier 1417 -- ^ Package identifier in the cabal file 1418 -- 1419 -- @since 0.1.0.0 1420 , pmTreeKey :: !TreeKey 1421 -- ^ Tree key of the loaded up package 1422 -- 1423 -- @since 0.1.0.0 1424 } 1425 deriving (Show, Eq, Ord, Generic, Typeable) 1426-- i PackageMetadata 1427instance NFData PackageMetadata 1428 1429instance Display PackageMetadata where 1430 display pm = fold $ intersperse ", " $ 1431 [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm) 1432 , "tree == " <> display (pmTreeKey pm) 1433 ] 1434 1435parsePackageMetadata :: Object -> WarningParser PackageMetadata 1436parsePackageMetadata o = do 1437 _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file" 1438 pantryTree :: BlobKey <- o ..: "pantry-tree" 1439 CabalString pkgName <- o ..: "name" 1440 CabalString pkgVersion <- o ..: "version" 1441 let pmTreeKey = TreeKey pantryTree 1442 pmIdent = PackageIdentifier {..} 1443 pure PackageMetadata {..} 1444 1445 1446-- | Conver package metadata to its "raw" equivalent. 1447-- 1448-- @since 0.1.0.0 1449toRawPM :: PackageMetadata -> RawPackageMetadata 1450toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm) 1451 where 1452 PackageIdentifier name version = pmIdent pm 1453 1454-- | File path relative to the configuration file it was parsed from 1455-- 1456-- @since 0.1.0.0 1457newtype RelFilePath = RelFilePath Text 1458 deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display) 1459 1460-- | Location that an archive is stored at 1461-- 1462-- @since 0.1.0.0 1463data ArchiveLocation 1464 = ALUrl !Text 1465 -- ^ Archive stored at an HTTP(S) URL 1466 -- 1467 -- @since 0.1.0.0 1468 | ALFilePath !(ResolvedPath File) 1469 -- ^ Archive stored at a local file path 1470 -- 1471 -- @since 0.1.0.0 1472 deriving (Show, Eq, Ord, Generic, Typeable) 1473instance NFData ArchiveLocation 1474 1475instance Display ArchiveLocation where 1476 display (ALUrl url) = display url 1477 display (ALFilePath resolved) = fromString $ toFilePath $ resolvedAbsolute resolved 1478 1479parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation) 1480parseArchiveLocationObject o = 1481 ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl) <|> 1482 ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath) <|> 1483 ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText) <|> 1484 ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText) 1485 1486parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation) 1487parseArchiveLocationText t = 1488 case validateUrl t of 1489 Left e1 -> 1490 case validateFilePath t of 1491 Left e2 -> Left $ T.unlines 1492 [ "Invalid archive location, neither a URL nor a file path" 1493 , " URL error: " <> e1 1494 , " File path error: " <> e2 1495 ] 1496 Right x -> Right x 1497 Right x -> Right x 1498 1499validateUrl :: Text -> Either Text (Unresolved ArchiveLocation) 1500validateUrl t = 1501 case parseRequest $ T.unpack t of 1502 Left _ -> Left $ "Could not parse URL: " <> t 1503 Right _ -> pure $ pure $ ALUrl t 1504 1505validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation) 1506validateFilePath t = 1507 if any (\ext -> ext `T.isSuffixOf` t) (T.words ".zip .tar .tar.gz") 1508 then pure $ Unresolved $ \mdir -> 1509 case mdir of 1510 Nothing -> throwIO $ InvalidFilePathSnapshot t 1511 Just dir -> do 1512 abs' <- resolveFile dir $ T.unpack t 1513 pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs' 1514 else Left $ "Does not have an archive file extension: " <> t 1515 1516instance ToJSON RawPackageLocation where 1517 toJSON (RPLImmutable rpli) = toJSON rpli 1518 toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved) 1519instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where 1520 parseJSON v = 1521 ((fmap.fmap.fmap.fmap) RPLImmutable (parseJSON v)) <|> 1522 ((noJSONWarnings . mkMutable) <$> parseJSON v) 1523 where 1524 mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation) 1525 mkMutable t = Unresolved $ \mdir -> do 1526 case mdir of 1527 Nothing -> throwIO $ MutablePackageLocationFromUrl t 1528 Just dir -> do 1529 abs' <- resolveDir dir $ T.unpack t 1530 pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs' 1531 1532instance ToJSON RawPackageLocationImmutable where 1533 toJSON (RPLIHackage pir mtree) = object $ concat 1534 [ ["hackage" .= pir] 1535 , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree 1536 ] 1537 toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat 1538 [ case loc of 1539 ALUrl url -> ["url" .= url] 1540 ALFilePath resolved -> ["filepath" .= resolvedRelative resolved] 1541 , maybe [] (\sha -> ["sha256" .= sha]) msha 1542 , maybe [] (\size' -> ["size" .= size']) msize 1543 , if T.null subdir then [] else ["subdir" .= subdir] 1544 , rpmToPairs rpm 1545 ] 1546 toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat 1547 [ [ urlKey .= url 1548 , "commit" .= commit 1549 ] 1550 , if T.null subdir then [] else ["subdir" .= subdir] 1551 , rpmToPairs rpm 1552 ] 1553 where 1554 urlKey = 1555 case typ of 1556 RepoGit -> "git" 1557 RepoHg -> "hg" 1558 1559rpmToPairs :: RawPackageMetadata -> [(Text, Value)] 1560rpmToPairs (RawPackageMetadata mname mversion mtree) = concat 1561 [ maybe [] (\name -> ["name" .= CabalString name]) mname 1562 , maybe [] (\version -> ["version" .= CabalString version]) mversion 1563 , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree 1564 ] 1565 1566instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where 1567 parseJSON v = repoObject v <|> archiveObject v <|> hackageObject v <|> github v 1568 <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v) 1569 where 1570 repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable)) 1571 repoObject = withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do 1572 pm <- parsePackageMetadata o 1573 repoSubdir <- o ..:? "subdir" ..!= "" 1574 repoCommit <- o ..: "commit" 1575 (repoType, repoUrl) <- 1576 (o ..: "git" >>= \url -> pure (RepoGit, url)) <|> 1577 (o ..: "hg" >>= \url -> pure (RepoHg, url)) 1578 pure $ pure $ PLIRepo Repo {..} pm 1579 1580 archiveObject = 1581 withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do 1582 pm <- parsePackageMetadata o 1583 Unresolved mkArchiveLocation <- parseArchiveLocationObject o 1584 archiveHash <- o ..: "sha256" 1585 archiveSize <- o ..: "size" 1586 archiveSubdir <- o ..:? "subdir" ..!= "" 1587 pure $ Unresolved $ \mdir -> do 1588 archiveLocation <- mkArchiveLocation mdir 1589 pure $ PLIArchive Archive {..} pm 1590 1591 hackageObject = 1592 withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do 1593 treeKey <- o ..: "pantry-tree" 1594 htxt <- o ..: "hackage" 1595 case parseHackageText htxt of 1596 Left e -> fail $ show e 1597 Right (pkgIdentifier, blobKey) -> 1598 pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey) 1599 1600 github value = 1601 withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do 1602 pm <- parsePackageMetadata o 1603 GitHubRepo ghRepo <- o ..: "github" 1604 commit <- o ..: "commit" 1605 let archiveLocation = ALUrl $ T.concat 1606 [ "https://github.com/" 1607 , ghRepo 1608 , "/archive/" 1609 , commit 1610 , ".tar.gz" 1611 ] 1612 archiveHash <- o ..: "sha256" 1613 archiveSize <- o ..: "size" 1614 archiveSubdir <- o ..:? "subdir" ..!= "" 1615 pure $ pure $ PLIArchive Archive {..} pm) value 1616 1617instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where 1618 parseJSON v 1619 = http v 1620 <|> hackageText v 1621 <|> hackageObject v 1622 <|> repo v 1623 <|> archiveObject v 1624 <|> github v 1625 <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v) 1626 where 1627 http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) 1628 http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t -> 1629 case parseArchiveLocationText t of 1630 Left _ -> fail $ "Invalid archive location: " ++ T.unpack t 1631 Right (Unresolved mkArchiveLocation) -> 1632 pure $ noJSONWarnings $ Unresolved $ \mdir -> do 1633 raLocation <- mkArchiveLocation mdir 1634 let raHash = Nothing 1635 raSize = Nothing 1636 raSubdir = T.empty 1637 pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty 1638 1639 hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t -> 1640 case parsePackageIdentifierRevision t of 1641 Left e -> fail $ show e 1642 Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing 1643 1644 hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> (pure.pure) <$> (RPLIHackage 1645 <$> o ..: "hackage" 1646 <*> o ..:? "pantry-tree") 1647 1648 optionalSubdirs :: Object -> WarningParser OptionalSubdirs 1649 optionalSubdirs o = 1650 -- if subdirs exists, it needs to be valid 1651 case HM.lookup "subdirs" o of 1652 Just v' -> do 1653 tellJSONField "subdirs" 1654 subdirs <- lift $ parseJSON v' 1655 case NE.nonEmpty subdirs of 1656 Nothing -> fail "Invalid empty subdirs" 1657 Just x -> pure $ OSSubdirs x 1658 Nothing -> OSPackageMetadata 1659 <$> o ..:? "subdir" ..!= T.empty 1660 <*> (rawPackageMetadataHelper 1661 <$> (fmap unCabalString <$> (o ..:? "name")) 1662 <*> (fmap unCabalString <$> (o ..:? "version")) 1663 <*> o ..:? "pantry-tree" 1664 <*> o ..:? "cabal-file") 1665 1666 rawPackageMetadataHelper 1667 :: Maybe PackageName 1668 -> Maybe Version 1669 -> Maybe TreeKey 1670 -> Maybe BlobKey 1671 -> RawPackageMetadata 1672 rawPackageMetadataHelper name version pantryTree _ignoredCabalFile = 1673 RawPackageMetadata name version pantryTree 1674 1675 repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do 1676 (repoType, repoUrl) <- 1677 ((RepoGit, ) <$> o ..: "git") <|> 1678 ((RepoHg, ) <$> o ..: "hg") 1679 repoCommit <- o ..: "commit" 1680 os <- optionalSubdirs o 1681 pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os) 1682 1683 archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do 1684 Unresolved mkArchiveLocation <- parseArchiveLocationObject o 1685 raHash <- o ..:? "sha256" 1686 raSize <- o ..:? "size" 1687 os <- optionalSubdirs o 1688 pure $ Unresolved $ \mdir -> do 1689 raLocation <- mkArchiveLocation mdir 1690 pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) 1691 1692 github = withObjectWarnings "PLArchive:github" $ \o -> do 1693 GitHubRepo ghRepo <- o ..: "github" 1694 commit <- o ..: "commit" 1695 let raLocation = ALUrl $ T.concat 1696 [ "https://github.com/" 1697 , ghRepo 1698 , "/archive/" 1699 , commit 1700 , ".tar.gz" 1701 ] 1702 raHash <- o ..:? "sha256" 1703 raSize <- o ..:? "size" 1704 os <- optionalSubdirs o 1705 pure $ pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os) 1706 1707-- | Returns pairs of subdirectory and 'PackageMetadata'. 1708osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata) 1709osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs 1710osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm) 1711 1712rpmEmpty :: RawPackageMetadata 1713rpmEmpty = RawPackageMetadata Nothing Nothing Nothing 1714 1715-- | Newtype wrapper for easier JSON integration with Cabal types. 1716-- 1717-- @since 0.1.0.0 1718newtype CabalString a = CabalString { unCabalString :: a } 1719 deriving (Show, Eq, Ord, Typeable) 1720 1721-- I'd like to use coerce here, but can't due to roles. unsafeCoerce 1722-- could work, but let's avoid unsafe code. 1723 1724-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON' 1725-- instance. 1726-- 1727-- @since 0.1.0.0 1728toCabalStringMap :: Map a v -> Map (CabalString a) v 1729toCabalStringMap = Map.mapKeysMonotonic CabalString 1730 1731-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a 1732-- 'FromJSON' instance. 1733-- 1734-- @since 0.1.0.0 1735unCabalStringMap :: Map (CabalString a) v -> Map a v 1736unCabalStringMap = Map.mapKeysMonotonic unCabalString 1737 1738instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where 1739 toJSON = toJSON . Distribution.Text.display . unCabalString 1740instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where 1741 toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString 1742 1743instance forall a. IsCabalString a => FromJSON (CabalString a) where 1744 parseJSON = withText name $ \t -> 1745 case cabalStringParser $ T.unpack t of 1746 Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t 1747 Just x -> pure $ CabalString x 1748 where 1749 name = cabalStringName (Nothing :: Maybe a) 1750instance forall a. IsCabalString a => FromJSONKey (CabalString a) where 1751 fromJSONKey = 1752 FromJSONKeyTextParser $ \t -> 1753 case cabalStringParser $ T.unpack t of 1754 Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t 1755 Just x -> pure $ CabalString x 1756 where 1757 name = cabalStringName (Nothing :: Maybe a) 1758 1759class IsCabalString a where 1760 cabalStringName :: proxy a -> String 1761 cabalStringParser :: String -> Maybe a 1762instance IsCabalString PackageName where 1763 cabalStringName _ = "package name" 1764 cabalStringParser = parsePackageName 1765instance IsCabalString Version where 1766 cabalStringName _ = "version" 1767 cabalStringParser = parseVersion 1768instance IsCabalString VersionRange where 1769 cabalStringName _ = "version range" 1770 cabalStringParser = parseVersionRange 1771instance IsCabalString PackageIdentifier where 1772 cabalStringName _ = "package identifier" 1773 cabalStringParser = parsePackageIdentifier 1774instance IsCabalString FlagName where 1775 cabalStringName _ = "flag name" 1776 cabalStringParser = parseFlagName 1777 1778-- | What to use for running hpack 1779-- 1780-- @since 0.1.0.0 1781data HpackExecutable 1782 = HpackBundled 1783 -- ^ Compiled in library 1784 | HpackCommand !FilePath 1785 -- ^ Executable at the provided path 1786 deriving (Show, Read, Eq, Ord) 1787 1788 1789-- | Which compiler a snapshot wants to use. The build tool may elect 1790-- to do some fuzzy matching of versions (e.g., allowing different 1791-- patch versions). 1792-- 1793-- @since 0.1.0.0 1794data WantedCompiler 1795 = WCGhc !Version 1796 | WCGhcGit !Text !Text 1797 | WCGhcjs 1798 !Version 1799 !Version 1800 -- ^ GHCJS version followed by GHC version 1801 deriving (Show, Eq, Ord, Generic) 1802 1803instance NFData WantedCompiler 1804instance Display WantedCompiler where 1805 display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc) 1806 display (WCGhcjs vghcjs vghc) = 1807 "ghcjs-" <> fromString (versionString vghcjs) <> "_ghc-" <> fromString (versionString vghc) 1808 display (WCGhcGit commit flavour) = 1809 "ghc-git-" <> display commit <> "-" <> display flavour 1810instance ToJSON WantedCompiler where 1811 toJSON = toJSON . utf8BuilderToText . display 1812instance FromJSON WantedCompiler where 1813 parseJSON = withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler 1814instance FromJSONKey WantedCompiler where 1815 fromJSONKey = 1816 FromJSONKeyTextParser $ \t -> 1817 case parseWantedCompiler t of 1818 Left e -> fail $ "Invalid WantedComiler " ++ show t ++ ": " ++ show e 1819 Right x -> pure x 1820 1821-- | Parse a 'Text' into a 'WantedCompiler' value. 1822-- 1823-- @since 0.1.0.0 1824parseWantedCompiler :: Text -> Either PantryException WantedCompiler 1825parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $ 1826 case T.stripPrefix "ghcjs-" t0 of 1827 Just t1 -> parseGhcjs t1 1828 Nothing -> case T.stripPrefix "ghc-git-" t0 of 1829 Just t1 -> parseGhcGit t1 1830 Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc 1831 where 1832 parseGhcjs t1 = do 1833 let (ghcjsVT, t2) = T.break (== '_') t1 1834 ghcjsV <- parseVersion $ T.unpack ghcjsVT 1835 ghcVT <- T.stripPrefix "_ghc-" t2 1836 ghcV <- parseVersion $ T.unpack ghcVT 1837 pure $ WCGhcjs ghcjsV ghcV 1838 parseGhcGit t1 = do 1839 let (commit, flavour) = T.break (== '-') t1 1840 pure $ WCGhcGit commit (T.drop 1 flavour) 1841 parseGhc = fmap WCGhc . parseVersion . T.unpack 1842 1843instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where 1844 parseJSON v = text v <|> obj v 1845 where 1846 text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) 1847 text = withText "UnresolvedSnapshotLocation (Text)" $ pure . noJSONWarnings . parseRawSnapshotLocation 1848 1849 obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation)) 1850 obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o -> 1851 ((pure . RSLCompiler) <$> o ..: "compiler") <|> 1852 ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|> 1853 (parseRawSnapshotLocationPath <$> o ..: "filepath") 1854 1855 blobKey o = do 1856 msha <- o ..:? "sha256" 1857 msize <- o ..:? "size" 1858 case (msha, msize) of 1859 (Nothing, Nothing) -> pure Nothing 1860 (Just sha, Just size') -> pure $ Just $ BlobKey sha size' 1861 (Just _sha, Nothing) -> fail "You must also specify the file size" 1862 (Nothing, Just _) -> fail "You must also specify the file's SHA256" 1863 1864instance Display SnapshotLocation where 1865 display (SLCompiler compiler) = display compiler 1866 display (SLUrl url blob) = display url <> " (" <> display blob <> ")" 1867 display (SLFilePath resolved) = display (resolvedRelative resolved) 1868 1869-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'. 1870-- 1871-- @since 0.1.0.0 1872parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation 1873parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $ 1874 (either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0)) <|> 1875 (pure <$> RSLSynonym <$> parseSnapName t0) <|> 1876 parseGithub <|> 1877 parseUrl 1878 where 1879 parseGithub = do 1880 t1 <- T.stripPrefix "github:" t0 1881 let (user, t2) = T.break (== '/') t1 1882 t3 <- T.stripPrefix "/" t2 1883 let (repo, t4) = T.break (== ':') t3 1884 path <- T.stripPrefix ":" t4 1885 Just $ pure $ githubSnapshotLocation user repo path 1886 1887 parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing) 1888 1889parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation 1890parseRawSnapshotLocationPath t = 1891 Unresolved $ \mdir -> 1892 case mdir of 1893 Nothing -> throwIO $ InvalidFilePathSnapshot t 1894 Just dir -> do 1895 abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t) 1896 pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs' 1897 1898githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation 1899githubSnapshotLocation user repo path = 1900 let url = T.concat 1901 [ "https://raw.githubusercontent.com/" 1902 , user 1903 , "/" 1904 , repo 1905 , "/master/" 1906 , path 1907 ] 1908 in RSLUrl url Nothing 1909 1910defUser :: Text 1911defUser = "commercialhaskell" 1912 1913defRepo :: Text 1914defRepo = "stackage-snapshots" 1915 1916-- | Default location of snapshot synonyms 1917-- , i.e. commercialhaskell's GitHub repository. 1918-- 1919-- @since 0.5.0.0 1920defaultSnapshotLocation 1921 :: SnapName 1922 -> RawSnapshotLocation 1923defaultSnapshotLocation (LTS x y) = 1924 githubSnapshotLocation defUser defRepo $ 1925 utf8BuilderToText $ 1926 "lts/" <> display x <> "/" <> display y <> ".yaml" 1927defaultSnapshotLocation (Nightly date) = 1928 githubSnapshotLocation defUser defRepo $ 1929 utf8BuilderToText $ 1930 "nightly/" <> display year <> "/" <> display month <> "/" <> display day <> ".yaml" 1931 where 1932 (year, month, day) = toGregorian date 1933 1934-- | A snapshot synonym. 1935-- It is expanded according to the field 'snapshotLocation' 1936-- of a 'PantryConfig'. 1937-- 1938-- @ since 0.5.0.0 1939data SnapName 1940 -- | LTS Haskell snapshot, 1941 -- displayed as @"lts-maj.min"@. 1942 -- 1943 -- @since 0.5.0.0 1944 = LTS 1945 !Int -- ^ Major version 1946 !Int -- ^ Minor version 1947 -- | Stackage Nightly snapshot, 1948 -- displayed as @"nighly-YYYY-MM-DD"@. 1949 -- 1950 -- @since 0.5.0.0 1951 | Nightly !Day 1952 deriving (Eq, Ord, Generic) 1953 1954instance NFData SnapName 1955 1956instance Display SnapName where 1957 display (LTS x y) = "lts-" <> display x <> "." <> display y 1958 display (Nightly date) = "nightly-" <> displayShow date 1959 1960instance Show SnapName where 1961 show = T.unpack . utf8BuilderToText . display 1962 1963instance ToJSON SnapName where 1964 toJSON syn = String $ utf8BuilderToText $ display syn 1965 1966-- | Parse the short representation of a 'SnapName'. 1967-- 1968-- @since 0.5.0.0 1969parseSnapName :: MonadThrow m => Text -> m SnapName 1970parseSnapName t0 = 1971 case lts <|> nightly of 1972 Nothing -> throwM $ ParseSnapNameException t0 1973 Just sn -> return sn 1974 where 1975 lts = do 1976 t1 <- T.stripPrefix "lts-" t0 1977 Right (x, t2) <- Just $ decimal t1 1978 t3 <- T.stripPrefix "." t2 1979 Right (y, "") <- Just $ decimal t3 1980 return $ LTS x y 1981 nightly = do 1982 t1 <- T.stripPrefix "nightly-" t0 1983 Nightly <$> readMaybe (T.unpack t1) 1984 1985-- | Where to load a snapshot from in raw form 1986-- (RSUrl could have a missing BlobKey) 1987-- 1988-- @since 0.1.0.0 1989data RawSnapshotLocation 1990 = RSLCompiler !WantedCompiler 1991 -- ^ Don't use an actual snapshot, just a version of the compiler 1992 -- with its shipped packages. 1993 -- 1994 -- @since 0.1.0.0 1995 | RSLUrl !Text !(Maybe BlobKey) 1996 -- ^ Download the snapshot from the given URL. The optional 1997 -- 'BlobKey' is used for reproducibility. 1998 -- 1999 -- @since 0.1.0.0 2000 | RSLFilePath !(ResolvedPath File) 2001 -- ^ Snapshot at a local file path. 2002 -- 2003 -- @since 0.1.0.0 2004 | RSLSynonym !SnapName 2005 -- ^ Snapshot synonym (LTS/Nightly). 2006 -- 2007 -- @since 0.5.0.0 2008 deriving (Show, Eq, Ord, Generic) 2009 2010instance NFData RawSnapshotLocation 2011 2012instance Display RawSnapshotLocation where 2013 display (RSLCompiler compiler) = display compiler 2014 display (RSLUrl url Nothing) = display url 2015 display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")" 2016 display (RSLFilePath resolved) = display (resolvedRelative resolved) 2017 display (RSLSynonym syn) = display syn 2018 2019 2020instance ToJSON RawSnapshotLocation where 2021 toJSON (RSLCompiler compiler) = object ["compiler" .= compiler] 2022 toJSON (RSLUrl url mblob) = object 2023 $ "url" .= url 2024 : maybe [] blobKeyPairs mblob 2025 toJSON (RSLFilePath resolved) = object ["filepath" .= resolvedRelative resolved] 2026 toJSON (RSLSynonym syn) = toJSON syn 2027 2028-- | Where to load a snapshot from. 2029-- 2030-- @since 0.1.0.0 2031data SnapshotLocation 2032 = SLCompiler !WantedCompiler 2033 -- ^ Don't use an actual snapshot, just a version of the compiler 2034 -- with its shipped packages. 2035 -- 2036 -- @since 0.1.0.0 2037 | SLUrl !Text !BlobKey 2038 -- ^ Download the snapshot from the given URL. The optional 2039 -- 'BlobKey' is used for reproducibility. 2040 -- 2041 -- @since 0.1.0.0 2042 | SLFilePath !(ResolvedPath File) 2043 -- ^ Snapshot at a local file path. 2044 -- 2045 -- @since 0.1.0.0 2046 deriving (Show, Eq, Ord, Generic) 2047instance NFData SnapshotLocation 2048 2049instance ToJSON SnapshotLocation where 2050 toJSON sl = toJSON (toRawSL sl) 2051 2052instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where 2053 parseJSON v = file v <|> url v <|> compiler v 2054 where 2055 file = withObjectWarnings "SLFilepath" $ \o -> do 2056 ufp <- o ..: "filepath" 2057 pure $ Unresolved $ \mdir -> 2058 case mdir of 2059 Nothing -> throwIO $ InvalidFilePathSnapshot ufp 2060 Just dir -> do 2061 absolute <- resolveFile dir (T.unpack ufp) 2062 let fp = ResolvedPath (RelFilePath ufp) absolute 2063 pure $ SLFilePath fp 2064 url = withObjectWarnings "SLUrl" $ \o -> do 2065 url' <- o ..: "url" 2066 sha <- o ..: "sha256" 2067 size <- o ..: "size" 2068 pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size) 2069 compiler = withObjectWarnings "SLCompiler" $ \o -> do 2070 c <- o ..: "compiler" 2071 pure $ Unresolved $ \_ -> pure $ SLCompiler c 2072 2073-- | Convert snapshot location to its "raw" equivalent. 2074-- 2075-- @since 0.1.0.0 2076toRawSL :: SnapshotLocation -> RawSnapshotLocation 2077toRawSL (SLCompiler c) = RSLCompiler c 2078toRawSL (SLUrl url blob) = RSLUrl url (Just blob) 2079toRawSL (SLFilePath fp) = RSLFilePath fp 2080 2081-- | A flattened representation of all the layers in a snapshot. 2082-- 2083-- @since 0.1.0.0 2084data RawSnapshot = RawSnapshot 2085 { rsCompiler :: !WantedCompiler 2086 -- ^ The compiler wanted for this snapshot. 2087 , rsPackages :: !(Map PackageName RawSnapshotPackage) 2088 -- ^ Packages available in this snapshot for installation. This will be 2089 -- applied on top of any globally available packages. 2090 , rsDrop :: !(Set PackageName) 2091 -- ^ Global packages that should be dropped/ignored. 2092 } 2093 2094-- | A flattened representation of all the layers in a snapshot. 2095-- 2096-- @since 0.1.0.0 2097data Snapshot = Snapshot 2098 { snapshotCompiler :: !WantedCompiler 2099 -- ^ The compiler wanted for this snapshot. 2100 , snapshotPackages :: !(Map PackageName SnapshotPackage) 2101 -- ^ Packages available in this snapshot for installation. This will be 2102 -- applied on top of any globally available packages. 2103 , snapshotDrop :: !(Set PackageName) 2104 -- ^ Global packages that should be dropped/ignored. 2105 } 2106 2107-- | Settings for a package found in a snapshot. 2108-- 2109-- @since 0.1.0.0 2110data RawSnapshotPackage = RawSnapshotPackage 2111 { rspLocation :: !RawPackageLocationImmutable 2112 -- ^ Where to get the package from 2113 , rspFlags :: !(Map FlagName Bool) 2114 -- ^ Same as 'slFlags' 2115 , rspHidden :: !Bool 2116 -- ^ Same as 'slHidden' 2117 , rspGhcOptions :: ![Text] 2118 -- ^ Same as 'slGhcOptions' 2119 } 2120 2121-- | Settings for a package found in a snapshot. 2122-- 2123-- @since 0.1.0.0 2124data SnapshotPackage = SnapshotPackage 2125 { spLocation :: !PackageLocationImmutable 2126 -- ^ Where to get the package from 2127 , spFlags :: !(Map FlagName Bool) 2128 -- ^ Same as 'slFlags' 2129 , spHidden :: !Bool 2130 -- ^ Same as 'slHidden' 2131 , spGhcOptions :: ![Text] 2132 -- ^ Same as 'slGhcOptions' 2133 } 2134 deriving Show 2135 2136-- | A single layer of a snapshot, i.e. a specific YAML configuration file. 2137-- 2138-- @since 0.1.0.0 2139data RawSnapshotLayer = RawSnapshotLayer 2140 { rslParent :: !RawSnapshotLocation 2141 -- ^ The sl to extend from. This is either a specific 2142 -- compiler, or a @SnapshotLocation@ which gives us more information 2143 -- (like packages). Ultimately, we'll end up with a 2144 -- @CompilerVersion@. 2145 -- 2146 -- @since 0.1.0.0 2147 , rslCompiler :: !(Maybe WantedCompiler) 2148 -- ^ Override the compiler specified in 'slParent'. Must be 2149 -- 'Nothing' if using 'SLCompiler'. 2150 -- 2151 -- @since 0.1.0.0 2152 , rslLocations :: ![RawPackageLocationImmutable] 2153 -- ^ Where to grab all of the packages from. 2154 -- 2155 -- @since 0.1.0.0 2156 , rslDropPackages :: !(Set PackageName) 2157 -- ^ Packages present in the parent which should not be included 2158 -- here. 2159 -- 2160 -- @since 0.1.0.0 2161 , rslFlags :: !(Map PackageName (Map FlagName Bool)) 2162 -- ^ Flag values to override from the defaults 2163 -- 2164 -- @since 0.1.0.0 2165 , rslHidden :: !(Map PackageName Bool) 2166 -- ^ Packages which should be hidden when registering. This will 2167 -- affect, for example, the import parser in the script 2168 -- command. We use a 'Map' instead of just a 'Set' to allow 2169 -- overriding the hidden settings in a parent sl. 2170 -- 2171 -- @since 0.1.0.0 2172 , rslGhcOptions :: !(Map PackageName [Text]) 2173 -- ^ GHC options per package 2174 -- 2175 -- @since 0.1.0.0 2176 , rslPublishTime :: !(Maybe UTCTime) 2177 -- ^ See 'slPublishTime' 2178 -- 2179 -- @since 0.1.0.0 2180 } 2181 deriving (Show, Eq, Generic) 2182 2183instance NFData RawSnapshotLayer 2184 2185instance ToJSON RawSnapshotLayer where 2186 toJSON rsnap = object $ concat 2187 [ ["resolver" .= rslParent rsnap] 2188 , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap) 2189 , ["packages" .= rslLocations rsnap] 2190 , if Set.null (rslDropPackages rsnap) 2191 then [] 2192 else ["drop-packages" .= Set.map CabalString (rslDropPackages rsnap)] 2193 , if Map.null (rslFlags rsnap) 2194 then [] 2195 else ["flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))] 2196 , if Map.null (rslHidden rsnap) 2197 then [] 2198 else ["hidden" .= toCabalStringMap (rslHidden rsnap)] 2199 , if Map.null (rslGhcOptions rsnap) 2200 then [] 2201 else ["ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)] 2202 , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap) 2203 ] 2204 2205instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where 2206 parseJSON = withObjectWarnings "Snapshot" $ \o -> do 2207 _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format 2208 mcompiler <- o ..:? "compiler" 2209 mresolver <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"] 2210 unresolvedSnapshotParent <- 2211 case (mcompiler, mresolver) of 2212 (Nothing, Nothing) -> fail "Snapshot must have either resolver or compiler" 2213 (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing) 2214 (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do 2215 sl <- usl mdir 2216 case (sl, mcompiler) of 2217 (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2 2218 _ -> pure (sl, mcompiler) 2219 2220 unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= []) 2221 rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty) 2222 rslFlags <- (unCabalStringMap . fmap unCabalStringMap) <$> (o ..:? "flags" ..!= Map.empty) 2223 rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty) 2224 rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty) 2225 rslPublishTime <- o ..:? "publish-time" 2226 pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..}) 2227 <$> ((concat . map NE.toList) <$> sequenceA unresolvedLocs) 2228 <*> unresolvedSnapshotParent 2229 2230-- | A single layer of a snapshot, i.e. a specific YAML configuration file. 2231-- 2232-- @since 0.1.0.0 2233data SnapshotLayer = SnapshotLayer 2234 { slParent :: !SnapshotLocation 2235 -- ^ The sl to extend from. This is either a specific 2236 -- compiler, or a @SnapshotLocation@ which gives us more information 2237 -- (like packages). Ultimately, we'll end up with a 2238 -- @CompilerVersion@. 2239 -- 2240 -- @since 0.1.0.0 2241 , slCompiler :: !(Maybe WantedCompiler) 2242 -- ^ Override the compiler specified in 'slParent'. Must be 2243 -- 'Nothing' if using 'SLCompiler'. 2244 -- 2245 -- @since 0.1.0.0 2246 , slLocations :: ![PackageLocationImmutable] 2247 -- ^ Where to grab all of the packages from. 2248 -- 2249 -- @since 0.1.0.0 2250 , slDropPackages :: !(Set PackageName) 2251 -- ^ Packages present in the parent which should not be included 2252 -- here. 2253 -- 2254 -- @since 0.1.0.0 2255 , slFlags :: !(Map PackageName (Map FlagName Bool)) 2256 -- ^ Flag values to override from the defaults 2257 -- 2258 -- @since 0.1.0.0 2259 , slHidden :: !(Map PackageName Bool) 2260 -- ^ Packages which should be hidden when registering. This will 2261 -- affect, for example, the import parser in the script 2262 -- command. We use a 'Map' instead of just a 'Set' to allow 2263 -- overriding the hidden settings in a parent sl. 2264 -- 2265 -- @since 0.1.0.0 2266 , slGhcOptions :: !(Map PackageName [Text]) 2267 -- ^ GHC options per package 2268 -- 2269 -- @since 0.1.0.0 2270 , slPublishTime :: !(Maybe UTCTime) 2271 -- ^ Publication timestamp for this snapshot. This field is optional, and 2272 -- is for informational purposes only. 2273 -- 2274 -- @since 0.1.0.0 2275 } 2276 deriving (Show, Eq, Generic) 2277 2278instance ToJSON SnapshotLayer where 2279 toJSON snap = object $ concat 2280 [ ["resolver" .= slParent snap] 2281 , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap) 2282 , ["packages" .= slLocations snap] 2283 , if Set.null (slDropPackages snap) then [] else ["drop-packages" .= Set.map CabalString (slDropPackages snap)] 2284 , if Map.null (slFlags snap) then [] else ["flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))] 2285 , if Map.null (slHidden snap) then [] else ["hidden" .= toCabalStringMap (slHidden snap)] 2286 , if Map.null (slGhcOptions snap) then [] else ["ghc-options" .= toCabalStringMap (slGhcOptions snap)] 2287 , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap) 2288 ] 2289 2290-- | Convert snapshot layer into its "raw" equivalent. 2291-- 2292-- @since 0.1.0.0 2293toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer 2294toRawSnapshotLayer sl = RawSnapshotLayer 2295 { rslParent = toRawSL (slParent sl) 2296 , rslCompiler = slCompiler sl 2297 , rslLocations = map toRawPLI (slLocations sl) 2298 , rslDropPackages = slDropPackages sl 2299 , rslFlags = slFlags sl 2300 , rslHidden = slHidden sl 2301 , rslGhcOptions = slGhcOptions sl 2302 , rslPublishTime = slPublishTime sl 2303 } 2304 2305-- | An arbitrary hash for a snapshot, used for finding module names 2306-- in a snapshot. Mostly intended for Stack's usage. 2307-- 2308-- @since 0.1.0.0 2309newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256} 2310 deriving (Show) 2311 2312-- | Get the path to the global hints cache file 2313getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File) 2314getGlobalHintsFile = do 2315 root <- view $ pantryConfigL.to pcRootDir 2316 globalHintsRelFile <- parseRelFile "global-hints-cache.yaml" 2317 pure $ root </> globalHintsRelFile 2318 2319-- | Creates BlobKey for an input ByteString 2320-- 2321-- @since 0.1.0.0 2322bsToBlobKey :: ByteString -> BlobKey 2323bsToBlobKey bs = 2324 BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs))) 2325 2326-- | Warn if the package uses 'PCHpack'. 2327-- 2328-- @since 0.4.0.0 2329warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env () 2330warnMissingCabalFile loc = 2331 logWarn $ 2332 "DEPRECATED: The package at " <> display loc <> 2333 " does not include a cabal file.\n" <> 2334 "Instead, it includes an hpack package.yaml file for generating a cabal file.\n" <> 2335 "This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" <> 2336 "Support for this workflow will be removed in the future.\n" 2337