{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE MultiWayIf #-}
{-# LANGUAGE NamedFieldPuns #-}
module Pantry.Types
  ( PantryConfig (..)
  , PackageIndexConfig (..)
  , HackageSecurityConfig (..)
  , defaultHackageSecurityConfig
  , Storage (..)
  , HasPantryConfig (..)
  , BlobKey (..)
  , PackageName
  , Version
  , PackageIdentifier (..)
  , Revision (..)
  , ModuleName
  , CabalFileInfo (..)
  , PrintWarnings (..)
  , PackageNameP (..)
  , VersionP (..)
  , ModuleNameP (..)
  , PackageIdentifierRevision (..)
  , pirForHash
  , FileType (..)
  , BuildFile (..)
  , FileSize (..)
  , TreeEntry (..)
  , SafeFilePath
  , unSafeFilePath
  , mkSafeFilePath
  , safeFilePathToPath
  , hpackSafeFilePath
  , TreeKey (..)
  , Tree (..)
  , renderTree
  , parseTree
  , parseTreeM
  , SHA256
  , Unresolved
  , resolvePaths
  , Package (..)
  , PackageCabal (..)
  , PHpack (..)
  -- , PackageTarball (..)

  , RawPackageLocation (..)
  , PackageLocation (..)
  , toRawPL
  , RawPackageLocationImmutable (..)
  , PackageLocationImmutable (..)
  , toRawPLI
  , RawArchive (..)
  , Archive (..)
  , toRawArchive
  , Repo (..)
  , AggregateRepo (..)
  , SimpleRepo (..)
  , toAggregateRepos
  , rToSimpleRepo
  , arToSimpleRepo
  , RepoType (..)
  , parsePackageIdentifier
  , parsePackageName
  , parsePackageNameThrowing
  , parseFlagName
  , parseVersion
  , parseVersionThrowing
  , packageIdentifierString
  , packageNameString
  , flagNameString
  , versionString
  , moduleNameString
  , OptionalSubdirs (..)
  , ArchiveLocation (..)
  , RelFilePath (..)
  , CabalString (..)
  , toCabalStringMap
  , unCabalStringMap
  , parsePackageIdentifierRevision
  , Mismatch (..)
  , PantryException (..)
  , FuzzyResults (..)
  , ResolvedPath (..)
  , HpackExecutable (..)
  , WantedCompiler (..)
  --, resolveSnapshotLocation

  , snapshotLocation
  , defaultSnapshotLocation
  , SnapName (..)
  , parseSnapName
  , RawSnapshotLocation (..)
  , SnapshotLocation (..)
  , toRawSL
  , parseHackageText
  , parseRawSnapshotLocation
  , RawSnapshotLayer (..)
  , SnapshotLayer (..)
  , toRawSnapshotLayer
  , RawSnapshot (..)
  , Snapshot (..)
  , RawSnapshotPackage (..)
  , SnapshotPackage (..)
  , parseWantedCompiler
  , RawPackageMetadata (..)
  , PackageMetadata (..)
  , toRawPM
  , cabalFileName
  , SnapshotCacheHash (..)
  , getGlobalHintsFile
  , bsToBlobKey
  , warnMissingCabalFile
  , connRDBMS
  ) where

import 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, groupBy)
import RIO.Time (toGregorian, Day, UTCTime)
import qualified RIO.Map as Map
import qualified Data.Map.Strict as Map (mapKeysMonotonic)
import qualified RIO.Set as Set
import Data.Aeson.Types (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 (cabalSpecLatest)
#if MIN_VERSION_Cabal(3,4,0)
import Distribution.CabalSpecVersion (cabalSpecToVersionDigits)
#else
import Distribution.CabalSpecVersion (CabalSpecVersion (..))
#endif
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 qualified Data.List.NonEmpty as NE
import Casa.Client (CasaRepoPrefix)

#if MIN_VERSION_persistent(2, 13, 0)
import Database.Persist.SqlBackend.Internal (connRDBMS)
#endif

#if MIN_VERSION_aeson(2, 0, 0)
import qualified Data.Aeson.KeyMap as HM
import qualified Data.Aeson.Key

type AesonKey = Data.Aeson.Key.Key
#else
import qualified RIO.HashMap as HM

type AesonKey = Text
#endif

-- | Parsed tree with more information on the Haskell package it contains.

--

-- @since 0.1.0.0

data Package = Package
  { Package -> TreeKey
packageTreeKey :: !TreeKey
  -- ^ The 'TreeKey' containing this package.

  --

  -- This is a hash of the binary representation of 'packageTree'.

  --

  -- @since 0.1.0.0

  , Package -> Tree
packageTree :: !Tree
  -- ^ The 'Tree' containing this package.

  --

  -- @since 0.1.0.0

  , Package -> PackageCabal
packageCabalEntry :: !PackageCabal
  -- ^ Information on the cabal file inside this package.

  --

  -- @since 0.1.0.0

  , Package -> PackageIdentifier
packageIdent :: !PackageIdentifier
  -- ^ The package name and version in this package.

  --

  -- @since 0.1.0.0

  }
  deriving (Int -> Package -> ShowS
[Package] -> ShowS
Package -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Package] -> ShowS
$cshowList :: [Package] -> ShowS
show :: Package -> [Char]
$cshow :: Package -> [Char]
showsPrec :: Int -> Package -> ShowS
$cshowsPrec :: Int -> Package -> ShowS
Show, Package -> Package -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Package -> Package -> Bool
$c/= :: Package -> Package -> Bool
== :: Package -> Package -> Bool
$c== :: Package -> Package -> Bool
Eq, Eq Package
Package -> Package -> Bool
Package -> Package -> Ordering
Package -> Package -> Package
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Package -> Package -> Package
$cmin :: Package -> Package -> Package
max :: Package -> Package -> Package
$cmax :: Package -> Package -> Package
>= :: Package -> Package -> Bool
$c>= :: Package -> Package -> Bool
> :: Package -> Package -> Bool
$c> :: Package -> Package -> Bool
<= :: Package -> Package -> Bool
$c<= :: Package -> Package -> Bool
< :: Package -> Package -> Bool
$c< :: Package -> Package -> Bool
compare :: Package -> Package -> Ordering
$ccompare :: Package -> Package -> Ordering
Ord)

data PHpack = PHpack
    {
      PHpack -> TreeEntry
phOriginal :: !TreeEntry, -- ^ Original hpack file

      PHpack -> TreeEntry
phGenerated :: !TreeEntry, -- ^ Generated Cabal file

      PHpack -> Version
phVersion :: !Version -- ^ Version of Hpack used

    } deriving (Int -> PHpack -> ShowS
[PHpack] -> ShowS
PHpack -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PHpack] -> ShowS
$cshowList :: [PHpack] -> ShowS
show :: PHpack -> [Char]
$cshow :: PHpack -> [Char]
showsPrec :: Int -> PHpack -> ShowS
$cshowsPrec :: Int -> PHpack -> ShowS
Show, PHpack -> PHpack -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PHpack -> PHpack -> Bool
$c/= :: PHpack -> PHpack -> Bool
== :: PHpack -> PHpack -> Bool
$c== :: PHpack -> PHpack -> Bool
Eq, Eq PHpack
PHpack -> PHpack -> Bool
PHpack -> PHpack -> Ordering
PHpack -> PHpack -> PHpack
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PHpack -> PHpack -> PHpack
$cmin :: PHpack -> PHpack -> PHpack
max :: PHpack -> PHpack -> PHpack
$cmax :: PHpack -> PHpack -> PHpack
>= :: PHpack -> PHpack -> Bool
$c>= :: PHpack -> PHpack -> Bool
> :: PHpack -> PHpack -> Bool
$c> :: PHpack -> PHpack -> Bool
<= :: PHpack -> PHpack -> Bool
$c<= :: PHpack -> PHpack -> Bool
< :: PHpack -> PHpack -> Bool
$c< :: PHpack -> PHpack -> Bool
compare :: PHpack -> PHpack -> Ordering
$ccompare :: PHpack -> PHpack -> Ordering
Ord)

data PackageCabal = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file

                  | PCHpack !PHpack
                  deriving (Int -> PackageCabal -> ShowS
[PackageCabal] -> ShowS
PackageCabal -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageCabal] -> ShowS
$cshowList :: [PackageCabal] -> ShowS
show :: PackageCabal -> [Char]
$cshow :: PackageCabal -> [Char]
showsPrec :: Int -> PackageCabal -> ShowS
$cshowsPrec :: Int -> PackageCabal -> ShowS
Show, PackageCabal -> PackageCabal -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageCabal -> PackageCabal -> Bool
$c/= :: PackageCabal -> PackageCabal -> Bool
== :: PackageCabal -> PackageCabal -> Bool
$c== :: PackageCabal -> PackageCabal -> Bool
Eq, Eq PackageCabal
PackageCabal -> PackageCabal -> Bool
PackageCabal -> PackageCabal -> Ordering
PackageCabal -> PackageCabal -> PackageCabal
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageCabal -> PackageCabal -> PackageCabal
$cmin :: PackageCabal -> PackageCabal -> PackageCabal
max :: PackageCabal -> PackageCabal -> PackageCabal
$cmax :: PackageCabal -> PackageCabal -> PackageCabal
>= :: PackageCabal -> PackageCabal -> Bool
$c>= :: PackageCabal -> PackageCabal -> Bool
> :: PackageCabal -> PackageCabal -> Bool
$c> :: PackageCabal -> PackageCabal -> Bool
<= :: PackageCabal -> PackageCabal -> Bool
$c<= :: PackageCabal -> PackageCabal -> Bool
< :: PackageCabal -> PackageCabal -> Bool
$c< :: PackageCabal -> PackageCabal -> Bool
compare :: PackageCabal -> PackageCabal -> Ordering
$ccompare :: PackageCabal -> PackageCabal -> Ordering
Ord)

cabalFileName :: PackageName -> SafeFilePath
cabalFileName :: PackageName -> SafeFilePath
cabalFileName PackageName
name =
  case Text -> Maybe SafeFilePath
mkSafeFilePath forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Text
".cabal" of
    Maybe SafeFilePath
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"cabalFileName: failed for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PackageName
name
    Just SafeFilePath
sfp -> SafeFilePath
sfp

-- | The revision number of a package from Hackage, counting upwards

-- from 0 (the original cabal file).

--

-- See caveats on 'CFIRevision'.

--

-- @since 0.1.0.0

newtype Revision = Revision Word
    deriving (forall x. Rep Revision x -> Revision
forall x. Revision -> Rep Revision x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Revision x -> Revision
$cfrom :: forall x. Revision -> Rep Revision x
Generic, Int -> Revision -> ShowS
[Revision] -> ShowS
Revision -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Revision] -> ShowS
$cshowList :: [Revision] -> ShowS
show :: Revision -> [Char]
$cshow :: Revision -> [Char]
showsPrec :: Int -> Revision -> ShowS
$cshowsPrec :: Int -> Revision -> ShowS
Show, Revision -> Revision -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Revision -> Revision -> Bool
$c/= :: Revision -> Revision -> Bool
== :: Revision -> Revision -> Bool
$c== :: Revision -> Revision -> Bool
Eq, Revision -> ()
forall a. (a -> ()) -> NFData a
rnf :: Revision -> ()
$crnf :: Revision -> ()
NFData, Typeable Revision
Revision -> DataType
Revision -> Constr
(forall b. Data b => b -> b) -> Revision -> Revision
forall a.
Typeable a
-> (forall (c :: * -> *).
    (forall d b. Data d => c (d -> b) -> d -> c b)
    -> (forall g. g -> c g) -> a -> c a)
-> (forall (c :: * -> *).
    (forall b r. Data b => c (b -> r) -> c r)
    -> (forall r. r -> c r) -> Constr -> c a)
-> (a -> Constr)
-> (a -> DataType)
-> (forall (t :: * -> *) (c :: * -> *).
    Typeable t =>
    (forall d. Data d => c (t d)) -> Maybe (c a))
-> (forall (t :: * -> * -> *) (c :: * -> *).
    Typeable t =>
    (forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c a))
-> ((forall b. Data b => b -> b) -> a -> a)
-> (forall r r'.
    (r -> r' -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall r r'.
    (r' -> r -> r) -> r -> (forall d. Data d => d -> r') -> a -> r)
-> (forall u. (forall d. Data d => d -> u) -> a -> [u])
-> (forall u. Int -> (forall d. Data d => d -> u) -> a -> u)
-> (forall (m :: * -> *).
    Monad m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> (forall (m :: * -> *).
    MonadPlus m =>
    (forall d. Data d => d -> m d) -> a -> m a)
-> Data a
forall u. Int -> (forall d. Data d => d -> u) -> Revision -> u
forall u. (forall d. Data d => d -> u) -> Revision -> [u]
forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Revision
forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Revision -> c Revision
forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Revision)
forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Revision)
gmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
$cgmapMo :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
gmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
$cgmapMp :: forall (m :: * -> *).
MonadPlus m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
gmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
$cgmapM :: forall (m :: * -> *).
Monad m =>
(forall d. Data d => d -> m d) -> Revision -> m Revision
gmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Revision -> u
$cgmapQi :: forall u. Int -> (forall d. Data d => d -> u) -> Revision -> u
gmapQ :: forall u. (forall d. Data d => d -> u) -> Revision -> [u]
$cgmapQ :: forall u. (forall d. Data d => d -> u) -> Revision -> [u]
gmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
$cgmapQr :: forall r r'.
(r' -> r -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
gmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
$cgmapQl :: forall r r'.
(r -> r' -> r)
-> r -> (forall d. Data d => d -> r') -> Revision -> r
gmapT :: (forall b. Data b => b -> b) -> Revision -> Revision
$cgmapT :: (forall b. Data b => b -> b) -> Revision -> Revision
dataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Revision)
$cdataCast2 :: forall (t :: * -> * -> *) (c :: * -> *).
Typeable t =>
(forall d e. (Data d, Data e) => c (t d e)) -> Maybe (c Revision)
dataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Revision)
$cdataCast1 :: forall (t :: * -> *) (c :: * -> *).
Typeable t =>
(forall d. Data d => c (t d)) -> Maybe (c Revision)
dataTypeOf :: Revision -> DataType
$cdataTypeOf :: Revision -> DataType
toConstr :: Revision -> Constr
$ctoConstr :: Revision -> Constr
gunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Revision
$cgunfold :: forall (c :: * -> *).
(forall b r. Data b => c (b -> r) -> c r)
-> (forall r. r -> c r) -> Constr -> c Revision
gfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Revision -> c Revision
$cgfoldl :: forall (c :: * -> *).
(forall d b. Data d => c (d -> b) -> d -> c b)
-> (forall g. g -> c g) -> Revision -> c Revision
Data, Typeable, Eq Revision
Revision -> Revision -> Bool
Revision -> Revision -> Ordering
Revision -> Revision -> Revision
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Revision -> Revision -> Revision
$cmin :: Revision -> Revision -> Revision
max :: Revision -> Revision -> Revision
$cmax :: Revision -> Revision -> Revision
>= :: Revision -> Revision -> Bool
$c>= :: Revision -> Revision -> Bool
> :: Revision -> Revision -> Bool
$c> :: Revision -> Revision -> Bool
<= :: Revision -> Revision -> Bool
$c<= :: Revision -> Revision -> Bool
< :: Revision -> Revision -> Bool
$c< :: Revision -> Revision -> Bool
compare :: Revision -> Revision -> Ordering
$ccompare :: Revision -> Revision -> Ordering
Ord, Eq Revision
Int -> Revision -> Int
Revision -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: Revision -> Int
$chash :: Revision -> Int
hashWithSalt :: Int -> Revision -> Int
$chashWithSalt :: Int -> Revision -> Int
Hashable, Revision -> Text
Revision -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: Revision -> Text
$ctextDisplay :: Revision -> Text
display :: Revision -> Utf8Builder
$cdisplay :: Revision -> Utf8Builder
Display, PersistValue -> Either Text Revision
Revision -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text Revision
$cfromPersistValue :: PersistValue -> Either Text Revision
toPersistValue :: Revision -> PersistValue
$ctoPersistValue :: Revision -> PersistValue
PersistField, PersistField Revision
Proxy Revision -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy Revision -> SqlType
$csqlType :: Proxy Revision -> SqlType
PersistFieldSql)

-- | Represents a SQL database connection. This used to be a newtype

-- wrapper around a connection pool. However, when investigating

-- <https://github.com/commercialhaskell/stack/issues/4471>, it

-- appeared that holding a pool resulted in overly long write locks

-- being held on the database. As a result, we now abstract away

-- whether a pool is used, and the default implementation in

-- "Pantry.Storage" does not use a pool.

data Storage = Storage
  { Storage
-> forall env a.
   HasLogFunc env =>
   ReaderT SqlBackend (RIO env) a -> RIO env a
withStorage_ :: forall env a. HasLogFunc env => ReaderT SqlBackend (RIO env) a -> RIO env a
  , Storage -> forall env a. HasLogFunc env => RIO env a -> RIO env a
withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a
  }

-- | Configuration value used by the entire pantry package. Create one

-- using @withPantryConfig@. See also @PantryApp@ for a convenience

-- approach to using pantry.

--

-- @since 0.1.0.0

data PantryConfig = PantryConfig
  { PantryConfig -> PackageIndexConfig
pcPackageIndex :: !PackageIndexConfig
  , PantryConfig -> HpackExecutable
pcHpackExecutable :: !HpackExecutable
  , PantryConfig -> Path Abs Dir
pcRootDir :: !(Path Abs Dir)
  , PantryConfig -> Storage
pcStorage :: !Storage
  , PantryConfig -> MVar Bool
pcUpdateRef :: !(MVar Bool)
  -- ^ Want to try updating the index once during a single run for missing

  -- package identifiers. We also want to ensure we only update once at a

  -- time. Start at @True@.

  , PantryConfig
-> IORef
     (Map RawPackageLocationImmutable GenericPackageDescription)
pcParsedCabalFilesRawImmutable :: !(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
  -- ^ Cache of previously parsed cabal files, to save on slow parsing time.

  , PantryConfig
-> IORef
     (Map
        (Path Abs Dir)
        (PrintWarnings -> IO GenericPackageDescription, PackageName,
         Path Abs File))
pcParsedCabalFilesMutable ::
      !(IORef
        (Map
         (Path Abs Dir)
         (PrintWarnings -> IO GenericPackageDescription, PackageName, Path Abs File)
        )
       )
  -- ^ Cache for mutable packages. We want to allow for an optimization:

  -- deferring parsing of the 'GenericPackageDescription' until its actually

  -- needed. Therefore, we keep the filepath and the 'PackageName' derived from

  -- that filepath. When the @IO GenericPackageDescription@ is run, it will

  -- ensure that the @PackageName@ matches the value inside the cabal file, and

  -- print out any warnings that still need to be printed.

  , PantryConfig -> Int
pcConnectionCount :: !Int
  -- ^ concurrently open downloads

  , PantryConfig -> CasaRepoPrefix
pcCasaRepoPrefix :: !CasaRepoPrefix
  -- ^ The pull URL e.g. @https://casa.fpcomplete.com/v1/pull@

  , PantryConfig -> Int
pcCasaMaxPerRequest :: !Int
  -- ^ Maximum blobs sent per pull request.

  , PantryConfig -> SnapName -> RawSnapshotLocation
pcSnapshotLocation :: SnapName -> RawSnapshotLocation
  -- ^ The location of snapshot synonyms

  }

-- | Get the location of a snapshot synonym from the 'PantryConfig'.

--

-- @since 0.5.0.0

snapshotLocation :: HasPantryConfig env => SnapName -> RIO env RawSnapshotLocation
snapshotLocation :: forall env.
HasPantryConfig env =>
SnapName -> RIO env RawSnapshotLocation
snapshotLocation SnapName
name = do
  SnapName -> RawSnapshotLocation
loc <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> SnapName -> RawSnapshotLocation
pcSnapshotLocation
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SnapName -> RawSnapshotLocation
loc SnapName
name

-- | Should we print warnings when loading a cabal file?

--

-- @since 0.1.0.0

data PrintWarnings = YesPrintWarnings | NoPrintWarnings

-- | Wraps a value which potentially contains relative paths. Needs to

-- be provided with a base directory to resolve these paths.

--

-- Unwrap this using 'resolvePaths'.

--

-- @since 0.1.0.0

newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a)
  deriving forall a b. a -> Unresolved b -> Unresolved a
forall a b. (a -> b) -> Unresolved a -> Unresolved b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> Unresolved b -> Unresolved a
$c<$ :: forall a b. a -> Unresolved b -> Unresolved a
fmap :: forall a b. (a -> b) -> Unresolved a -> Unresolved b
$cfmap :: forall a b. (a -> b) -> Unresolved a -> Unresolved b
Functor
instance Applicative Unresolved where
  pure :: forall a. a -> Unresolved a
pure = forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure
  Unresolved Maybe (Path Abs Dir) -> IO (a -> b)
f <*> :: forall a b. Unresolved (a -> b) -> Unresolved a -> Unresolved b
<*> Unresolved Maybe (Path Abs Dir) -> IO a
x = forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> Maybe (Path Abs Dir) -> IO (a -> b)
f Maybe (Path Abs Dir)
mdir forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (Path Abs Dir) -> IO a
x Maybe (Path Abs Dir)
mdir

-- | Resolve all of the file paths in an 'Unresolved' relative to the

-- given directory.

--

-- @since 0.1.0.0

resolvePaths
  :: MonadIO m
  => Maybe (Path Abs Dir) -- ^ directory to use for relative paths

  -> Unresolved a
  -> m a
resolvePaths :: forall (m :: * -> *) a.
MonadIO m =>
Maybe (Path Abs Dir) -> Unresolved a -> m a
resolvePaths Maybe (Path Abs Dir)
mdir (Unresolved Maybe (Path Abs Dir) -> IO a
f) = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Maybe (Path Abs Dir) -> IO a
f Maybe (Path Abs Dir)
mdir)

-- | A combination of the relative path provided in a config file,

-- together with the resolved absolute path.

--

-- @since 0.1.0.0

data ResolvedPath t = ResolvedPath
  { forall t. ResolvedPath t -> RelFilePath
resolvedRelative :: !RelFilePath
  -- ^ Original value parsed from a config file.

  , forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute :: !(Path Abs t)
  -- ^ Absolute path resolved against base directory loaded from.

  }
  deriving (Int -> ResolvedPath t -> ShowS
forall t. Int -> ResolvedPath t -> ShowS
forall t. [ResolvedPath t] -> ShowS
forall t. ResolvedPath t -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ResolvedPath t] -> ShowS
$cshowList :: forall t. [ResolvedPath t] -> ShowS
show :: ResolvedPath t -> [Char]
$cshow :: forall t. ResolvedPath t -> [Char]
showsPrec :: Int -> ResolvedPath t -> ShowS
$cshowsPrec :: forall t. Int -> ResolvedPath t -> ShowS
Show, ResolvedPath t -> ResolvedPath t -> Bool
forall t. ResolvedPath t -> ResolvedPath t -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ResolvedPath t -> ResolvedPath t -> Bool
$c/= :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
== :: ResolvedPath t -> ResolvedPath t -> Bool
$c== :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
Eq, forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall t x. Rep (ResolvedPath t) x -> ResolvedPath t
forall t x. ResolvedPath t -> Rep (ResolvedPath t) x
$cto :: forall t x. Rep (ResolvedPath t) x -> ResolvedPath t
$cfrom :: forall t x. ResolvedPath t -> Rep (ResolvedPath t) x
Generic, ResolvedPath t -> ResolvedPath t -> Bool
ResolvedPath t -> ResolvedPath t -> Ordering
forall t. Eq (ResolvedPath t)
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall t. ResolvedPath t -> ResolvedPath t -> Bool
forall t. ResolvedPath t -> ResolvedPath t -> Ordering
forall t. ResolvedPath t -> ResolvedPath t -> ResolvedPath t
min :: ResolvedPath t -> ResolvedPath t -> ResolvedPath t
$cmin :: forall t. ResolvedPath t -> ResolvedPath t -> ResolvedPath t
max :: ResolvedPath t -> ResolvedPath t -> ResolvedPath t
$cmax :: forall t. ResolvedPath t -> ResolvedPath t -> ResolvedPath t
>= :: ResolvedPath t -> ResolvedPath t -> Bool
$c>= :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
> :: ResolvedPath t -> ResolvedPath t -> Bool
$c> :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
<= :: ResolvedPath t -> ResolvedPath t -> Bool
$c<= :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
< :: ResolvedPath t -> ResolvedPath t -> Bool
$c< :: forall t. ResolvedPath t -> ResolvedPath t -> Bool
compare :: ResolvedPath t -> ResolvedPath t -> Ordering
$ccompare :: forall t. ResolvedPath t -> ResolvedPath t -> Ordering
Ord)
instance NFData (ResolvedPath t)

-- | Location to load a package from. Can either be immutable (see

-- 'PackageLocationImmutable') or a local directory which is expected

-- to change over time. Raw version doesn't include exact package

-- version (e.g. could refer to the latest revision on Hackage)

--

-- @since 0.1.0.0

data RawPackageLocation
  = RPLImmutable !RawPackageLocationImmutable
  | RPLMutable !(ResolvedPath Dir)
  deriving (Int -> RawPackageLocation -> ShowS
[RawPackageLocation] -> ShowS
RawPackageLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawPackageLocation] -> ShowS
$cshowList :: [RawPackageLocation] -> ShowS
show :: RawPackageLocation -> [Char]
$cshow :: RawPackageLocation -> [Char]
showsPrec :: Int -> RawPackageLocation -> ShowS
$cshowsPrec :: Int -> RawPackageLocation -> ShowS
Show, RawPackageLocation -> RawPackageLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPackageLocation -> RawPackageLocation -> Bool
$c/= :: RawPackageLocation -> RawPackageLocation -> Bool
== :: RawPackageLocation -> RawPackageLocation -> Bool
$c== :: RawPackageLocation -> RawPackageLocation -> Bool
Eq, forall x. Rep RawPackageLocation x -> RawPackageLocation
forall x. RawPackageLocation -> Rep RawPackageLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawPackageLocation x -> RawPackageLocation
$cfrom :: forall x. RawPackageLocation -> Rep RawPackageLocation x
Generic)
instance NFData RawPackageLocation

-- | Location to load a package from. Can either be immutable (see

-- 'PackageLocationImmutable') or a local directory which is expected

-- to change over time.

--

-- @since 0.1.0.0

data PackageLocation
  = PLImmutable !PackageLocationImmutable
  | PLMutable !(ResolvedPath Dir)
  deriving (Int -> PackageLocation -> ShowS
[PackageLocation] -> ShowS
PackageLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageLocation] -> ShowS
$cshowList :: [PackageLocation] -> ShowS
show :: PackageLocation -> [Char]
$cshow :: PackageLocation -> [Char]
showsPrec :: Int -> PackageLocation -> ShowS
$cshowsPrec :: Int -> PackageLocation -> ShowS
Show, PackageLocation -> PackageLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageLocation -> PackageLocation -> Bool
$c/= :: PackageLocation -> PackageLocation -> Bool
== :: PackageLocation -> PackageLocation -> Bool
$c== :: PackageLocation -> PackageLocation -> Bool
Eq, forall x. Rep PackageLocation x -> PackageLocation
forall x. PackageLocation -> Rep PackageLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageLocation x -> PackageLocation
$cfrom :: forall x. PackageLocation -> Rep PackageLocation x
Generic)
instance NFData PackageLocation

instance Display PackageLocation where
  display :: PackageLocation -> Utf8Builder
display (PLImmutable PackageLocationImmutable
loc) = forall a. Display a => a -> Utf8Builder
display PackageLocationImmutable
loc
  display (PLMutable ResolvedPath Dir
fp) = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath Dir
fp

-- | Convert `PackageLocation` to its "raw" equivalent

--

-- @since 0.1.0.0

toRawPL :: PackageLocation -> RawPackageLocation
toRawPL :: PackageLocation -> RawPackageLocation
toRawPL (PLImmutable PackageLocationImmutable
im) = RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable (PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI PackageLocationImmutable
im)
toRawPL (PLMutable ResolvedPath Dir
m) = ResolvedPath Dir -> RawPackageLocation
RPLMutable ResolvedPath Dir
m

-- | Location for remote packages or archives assumed to be immutable.

-- as user specifies it i.e. not an exact location

--

-- @since 0.1.0.0

data RawPackageLocationImmutable
  = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey)
  | RPLIArchive !RawArchive !RawPackageMetadata
  | RPLIRepo    !Repo !RawPackageMetadata
  deriving (Int -> RawPackageLocationImmutable -> ShowS
[RawPackageLocationImmutable] -> ShowS
RawPackageLocationImmutable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawPackageLocationImmutable] -> ShowS
$cshowList :: [RawPackageLocationImmutable] -> ShowS
show :: RawPackageLocationImmutable -> [Char]
$cshow :: RawPackageLocationImmutable -> [Char]
showsPrec :: Int -> RawPackageLocationImmutable -> ShowS
$cshowsPrec :: Int -> RawPackageLocationImmutable -> ShowS
Show, RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c/= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
== :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c== :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
Eq, Eq RawPackageLocationImmutable
RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
RawPackageLocationImmutable
-> RawPackageLocationImmutable -> Ordering
RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
$cmin :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
max :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
$cmax :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> RawPackageLocationImmutable
>= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c>= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
> :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c> :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
<= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c<= :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
< :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
$c< :: RawPackageLocationImmutable -> RawPackageLocationImmutable -> Bool
compare :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> Ordering
$ccompare :: RawPackageLocationImmutable
-> RawPackageLocationImmutable -> Ordering
Ord, forall x.
Rep RawPackageLocationImmutable x -> RawPackageLocationImmutable
forall x.
RawPackageLocationImmutable -> Rep RawPackageLocationImmutable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep RawPackageLocationImmutable x -> RawPackageLocationImmutable
$cfrom :: forall x.
RawPackageLocationImmutable -> Rep RawPackageLocationImmutable x
Generic)

instance NFData RawPackageLocationImmutable

instance Display RawPackageLocationImmutable where
  display :: RawPackageLocationImmutable -> Utf8Builder
display (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
_tree) = forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (from Hackage)"
  display (RPLIArchive RawArchive
archive RawPackageMetadata
_pm) =
    Utf8Builder
"Archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (RawArchive -> ArchiveLocation
raLocation RawArchive
archive) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ RawArchive -> Text
raSubdir RawArchive
archive
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (RawArchive -> Text
raSubdir RawArchive
archive))
  display (RPLIRepo Repo
repo RawPackageMetadata
_pm) =
    Utf8Builder
"Repo from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoUrl Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoCommit Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Repo -> Text
repoSubdir Repo
repo
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoSubdir Repo
repo))

-- | Location for remote packages or archives assumed to be immutable.

--

-- @since 0.1.0.0

data PackageLocationImmutable
  = PLIHackage !PackageIdentifier !BlobKey !TreeKey
  | PLIArchive !Archive !PackageMetadata
  | PLIRepo    !Repo !PackageMetadata
  deriving (forall x.
Rep PackageLocationImmutable x -> PackageLocationImmutable
forall x.
PackageLocationImmutable -> Rep PackageLocationImmutable x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep PackageLocationImmutable x -> PackageLocationImmutable
$cfrom :: forall x.
PackageLocationImmutable -> Rep PackageLocationImmutable x
Generic, Int -> PackageLocationImmutable -> ShowS
[PackageLocationImmutable] -> ShowS
PackageLocationImmutable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageLocationImmutable] -> ShowS
$cshowList :: [PackageLocationImmutable] -> ShowS
show :: PackageLocationImmutable -> [Char]
$cshow :: PackageLocationImmutable -> [Char]
showsPrec :: Int -> PackageLocationImmutable -> ShowS
$cshowsPrec :: Int -> PackageLocationImmutable -> ShowS
Show, PackageLocationImmutable -> PackageLocationImmutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c/= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
== :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c== :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
Eq, Eq PackageLocationImmutable
PackageLocationImmutable -> PackageLocationImmutable -> Bool
PackageLocationImmutable -> PackageLocationImmutable -> Ordering
PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
$cmin :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
max :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
$cmax :: PackageLocationImmutable
-> PackageLocationImmutable -> PackageLocationImmutable
>= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c>= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
> :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c> :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
<= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c<= :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
< :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
$c< :: PackageLocationImmutable -> PackageLocationImmutable -> Bool
compare :: PackageLocationImmutable -> PackageLocationImmutable -> Ordering
$ccompare :: PackageLocationImmutable -> PackageLocationImmutable -> Ordering
Ord, Typeable)
instance NFData PackageLocationImmutable

instance Display PackageLocationImmutable where
  display :: PackageLocationImmutable -> Utf8Builder
display (PLIHackage PackageIdentifier
ident BlobKey
_cabalHash TreeKey
_tree) =
    forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> PackageName
pkgName PackageIdentifier
ident) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (from Hackage)"
  display (PLIArchive Archive
archive PackageMetadata
_pm) =
    Utf8Builder
"Archive from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Archive -> ArchiveLocation
archiveLocation Archive
archive) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Archive -> Text
archiveSubdir Archive
archive
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Archive -> Text
archiveSubdir Archive
archive))
  display (PLIRepo Repo
repo PackageMetadata
_pm) =
    Utf8Builder
"Repo from " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoUrl Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoCommit Repo
repo) forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null forall a b. (a -> b) -> a -> b
$ Repo -> Text
repoSubdir Repo
repo
       then forall a. Monoid a => a
mempty
       else Utf8Builder
" in subdir " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (Repo -> Text
repoSubdir Repo
repo))

instance ToJSON PackageLocationImmutable where
  toJSON :: PackageLocationImmutable -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI

-- | Package identifier and revision with a specified cabal file hash

--

-- @since 0.1.0.0

pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash (PackageIdentifier PackageName
name Version
ver) (BlobKey SHA256
sha FileSize
size') =
  let cfi :: CabalFileInfo
cfi = SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha (forall a. a -> Maybe a
Just FileSize
size')
  in PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
ver CabalFileInfo
cfi

-- | Convert `PackageLocationImmutable` to its "raw" equivalent

--

-- @since 0.1.0.0

toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (PLIHackage PackageIdentifier
ident BlobKey
cfKey TreeKey
treeKey) = PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage (PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash PackageIdentifier
ident BlobKey
cfKey) (forall a. a -> Maybe a
Just TreeKey
treeKey)
toRawPLI (PLIArchive Archive
archive PackageMetadata
pm) = RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive (Archive -> RawArchive
toRawArchive Archive
archive) (PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm)
toRawPLI (PLIRepo Repo
repo PackageMetadata
pm) = Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo Repo
repo (PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm)

-- | A raw package archive, specified by a user, could have no

-- hash and file size information.

--

-- @since 0.1.0.0

data RawArchive = RawArchive
  { RawArchive -> ArchiveLocation
raLocation :: !ArchiveLocation
  -- ^ Location of the archive

  --

  -- @since 0.1.0.0

  , RawArchive -> Maybe SHA256
raHash :: !(Maybe SHA256)
  -- ^ Cryptographic hash of the archive file

  --

  -- @since 0.1.0.0

  , RawArchive -> Maybe FileSize
raSize :: !(Maybe FileSize)
  -- ^ Size of the archive file

  --

  -- @since 0.1.0.0

  , RawArchive -> Text
raSubdir :: !Text
  -- ^ Subdirectory within the archive to get the package from.

  --

  -- @since 0.1.0.0

  }
    deriving (forall x. Rep RawArchive x -> RawArchive
forall x. RawArchive -> Rep RawArchive x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawArchive x -> RawArchive
$cfrom :: forall x. RawArchive -> Rep RawArchive x
Generic, Int -> RawArchive -> ShowS
[RawArchive] -> ShowS
RawArchive -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawArchive] -> ShowS
$cshowList :: [RawArchive] -> ShowS
show :: RawArchive -> [Char]
$cshow :: RawArchive -> [Char]
showsPrec :: Int -> RawArchive -> ShowS
$cshowsPrec :: Int -> RawArchive -> ShowS
Show, RawArchive -> RawArchive -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawArchive -> RawArchive -> Bool
$c/= :: RawArchive -> RawArchive -> Bool
== :: RawArchive -> RawArchive -> Bool
$c== :: RawArchive -> RawArchive -> Bool
Eq, Eq RawArchive
RawArchive -> RawArchive -> Bool
RawArchive -> RawArchive -> Ordering
RawArchive -> RawArchive -> RawArchive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawArchive -> RawArchive -> RawArchive
$cmin :: RawArchive -> RawArchive -> RawArchive
max :: RawArchive -> RawArchive -> RawArchive
$cmax :: RawArchive -> RawArchive -> RawArchive
>= :: RawArchive -> RawArchive -> Bool
$c>= :: RawArchive -> RawArchive -> Bool
> :: RawArchive -> RawArchive -> Bool
$c> :: RawArchive -> RawArchive -> Bool
<= :: RawArchive -> RawArchive -> Bool
$c<= :: RawArchive -> RawArchive -> Bool
< :: RawArchive -> RawArchive -> Bool
$c< :: RawArchive -> RawArchive -> Bool
compare :: RawArchive -> RawArchive -> Ordering
$ccompare :: RawArchive -> RawArchive -> Ordering
Ord, Typeable)

instance NFData RawArchive

-- | A package archive, could be from a URL or a local file

-- path. Local file path archives are assumed to be unchanging

-- over time, and so are allowed in custom snapshots.

--

-- @since 0.1.0.0

data Archive = Archive
  { Archive -> ArchiveLocation
archiveLocation :: !ArchiveLocation
  -- ^ Location of the archive

  --

  -- @since 0.1.0.0

  , Archive -> SHA256
archiveHash :: !SHA256
  -- ^ Cryptographic hash of the archive file

  --

  -- @since 0.1.0.0

  , Archive -> FileSize
archiveSize :: !FileSize
  -- ^ Size of the archive file

  --

  -- @since 0.1.0.0

  , Archive -> Text
archiveSubdir :: !Text
  -- ^ Subdirectory within the archive to get the package from.

  --

  -- @since 0.1.0.0

  }
    deriving (forall x. Rep Archive x -> Archive
forall x. Archive -> Rep Archive x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Archive x -> Archive
$cfrom :: forall x. Archive -> Rep Archive x
Generic, Int -> Archive -> ShowS
[Archive] -> ShowS
Archive -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Archive] -> ShowS
$cshowList :: [Archive] -> ShowS
show :: Archive -> [Char]
$cshow :: Archive -> [Char]
showsPrec :: Int -> Archive -> ShowS
$cshowsPrec :: Int -> Archive -> ShowS
Show, Archive -> Archive -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Archive -> Archive -> Bool
$c/= :: Archive -> Archive -> Bool
== :: Archive -> Archive -> Bool
$c== :: Archive -> Archive -> Bool
Eq, Eq Archive
Archive -> Archive -> Bool
Archive -> Archive -> Ordering
Archive -> Archive -> Archive
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Archive -> Archive -> Archive
$cmin :: Archive -> Archive -> Archive
max :: Archive -> Archive -> Archive
$cmax :: Archive -> Archive -> Archive
>= :: Archive -> Archive -> Bool
$c>= :: Archive -> Archive -> Bool
> :: Archive -> Archive -> Bool
$c> :: Archive -> Archive -> Bool
<= :: Archive -> Archive -> Bool
$c<= :: Archive -> Archive -> Bool
< :: Archive -> Archive -> Bool
$c< :: Archive -> Archive -> Bool
compare :: Archive -> Archive -> Ordering
$ccompare :: Archive -> Archive -> Ordering
Ord, Typeable)
instance NFData Archive

-- | Convert archive to its "raw" equivalent.

--

-- @since 0.1.0.0

toRawArchive :: Archive -> RawArchive
toRawArchive :: Archive -> RawArchive
toRawArchive Archive
archive =
  ArchiveLocation
-> Maybe SHA256 -> Maybe FileSize -> Text -> RawArchive
RawArchive (Archive -> ArchiveLocation
archiveLocation Archive
archive) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Archive -> SHA256
archiveHash Archive
archive)
             (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Archive -> FileSize
archiveSize Archive
archive) (Archive -> Text
archiveSubdir Archive
archive)

-- | The type of a source control repository.

--

-- @since 0.1.0.0

data RepoType = RepoGit | RepoHg
    deriving (forall x. Rep RepoType x -> RepoType
forall x. RepoType -> Rep RepoType x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RepoType x -> RepoType
$cfrom :: forall x. RepoType -> Rep RepoType x
Generic, Int -> RepoType -> ShowS
[RepoType] -> ShowS
RepoType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RepoType] -> ShowS
$cshowList :: [RepoType] -> ShowS
show :: RepoType -> [Char]
$cshow :: RepoType -> [Char]
showsPrec :: Int -> RepoType -> ShowS
$cshowsPrec :: Int -> RepoType -> ShowS
Show, RepoType -> RepoType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RepoType -> RepoType -> Bool
$c/= :: RepoType -> RepoType -> Bool
== :: RepoType -> RepoType -> Bool
$c== :: RepoType -> RepoType -> Bool
Eq, Eq RepoType
RepoType -> RepoType -> Bool
RepoType -> RepoType -> Ordering
RepoType -> RepoType -> RepoType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RepoType -> RepoType -> RepoType
$cmin :: RepoType -> RepoType -> RepoType
max :: RepoType -> RepoType -> RepoType
$cmax :: RepoType -> RepoType -> RepoType
>= :: RepoType -> RepoType -> Bool
$c>= :: RepoType -> RepoType -> Bool
> :: RepoType -> RepoType -> Bool
$c> :: RepoType -> RepoType -> Bool
<= :: RepoType -> RepoType -> Bool
$c<= :: RepoType -> RepoType -> Bool
< :: RepoType -> RepoType -> Bool
$c< :: RepoType -> RepoType -> Bool
compare :: RepoType -> RepoType -> Ordering
$ccompare :: RepoType -> RepoType -> Ordering
Ord, Typeable)
instance NFData RepoType
instance PersistField RepoType where
  toPersistValue :: RepoType -> PersistValue
toPersistValue RepoType
RepoGit = forall a. PersistField a => a -> PersistValue
toPersistValue (Int32
1 :: Int32)
  toPersistValue RepoType
RepoHg = forall a. PersistField a => a -> PersistValue
toPersistValue (Int32
2 :: Int32)
  fromPersistValue :: PersistValue -> Either Text RepoType
fromPersistValue PersistValue
v = do
    Int32
i <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case Int32
i :: Int32 of
      Int32
1 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoType
RepoGit
      Int32
2 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure RepoType
RepoHg
      Int32
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid RepoType: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Int32
i
instance PersistFieldSql RepoType where
  sqlType :: Proxy RepoType -> SqlType
sqlType Proxy RepoType
_ = SqlType
SqlInt32

-- | Information on packages stored in a source control repository.

--

-- @since 0.1.0.0

data Repo = Repo
  { Repo -> Text
repoUrl :: !Text
    -- ^ Location of the repo

    --

    -- @since 0.1.0.0

  , Repo -> Text
repoCommit :: !Text
    -- ^ Commit to use from the repo. It's strongly recommended to use

    -- a hash instead of a tag or branch name.

    --

    -- @since 0.1.0.0

  , Repo -> RepoType
repoType :: !RepoType
    -- ^ The type of the repo

    --

    -- @since 0.1.0.0

  , Repo -> Text
repoSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.

    --

    -- @since 0.1.0.0

  }
    deriving (forall x. Rep Repo x -> Repo
forall x. Repo -> Rep Repo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Repo x -> Repo
$cfrom :: forall x. Repo -> Rep Repo x
Generic, Repo -> Repo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Repo -> Repo -> Bool
$c/= :: Repo -> Repo -> Bool
== :: Repo -> Repo -> Bool
$c== :: Repo -> Repo -> Bool
Eq, Eq Repo
Repo -> Repo -> Bool
Repo -> Repo -> Ordering
Repo -> Repo -> Repo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Repo -> Repo -> Repo
$cmin :: Repo -> Repo -> Repo
max :: Repo -> Repo -> Repo
$cmax :: Repo -> Repo -> Repo
>= :: Repo -> Repo -> Bool
$c>= :: Repo -> Repo -> Bool
> :: Repo -> Repo -> Bool
$c> :: Repo -> Repo -> Bool
<= :: Repo -> Repo -> Bool
$c<= :: Repo -> Repo -> Bool
< :: Repo -> Repo -> Bool
$c< :: Repo -> Repo -> Bool
compare :: Repo -> Repo -> Ordering
$ccompare :: Repo -> Repo -> Ordering
Ord, Typeable)
instance NFData Repo
instance Show Repo where
  show :: Repo -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
instance Display Repo where
  display :: Repo -> Utf8Builder
display (Repo Text
url Text
commit RepoType
typ Text
subdir) =
    (case RepoType
typ of
       RepoType
RepoGit -> Utf8Builder
"Git"
       RepoType
RepoHg -> Utf8Builder
"Mercurial") forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
" repo at " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
commit forall a. Semigroup a => a -> a -> a
<>
    (if Text -> Bool
T.null Text
subdir
      then forall a. Monoid a => a
mempty
      else Utf8Builder
" in subdirectory " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
subdir)

rToSimpleRepo :: Repo -> SimpleRepo
rToSimpleRepo :: Repo -> SimpleRepo
rToSimpleRepo Repo {Text
RepoType
repoSubdir :: Text
repoType :: RepoType
repoCommit :: Text
repoUrl :: Text
repoType :: Repo -> RepoType
repoSubdir :: Repo -> Text
repoCommit :: Repo -> Text
repoUrl :: Repo -> Text
..} = SimpleRepo { sRepoUrl :: Text
sRepoUrl = Text
repoUrl, sRepoCommit :: Text
sRepoCommit = Text
repoCommit, sRepoType :: RepoType
sRepoType = RepoType
repoType }

data AggregateRepo = AggregateRepo
  { AggregateRepo -> SimpleRepo
aRepo :: !SimpleRepo
  , AggregateRepo -> [(Text, RawPackageMetadata)]
aRepoSubdirs :: [(Text, RawPackageMetadata)]
  }
    deriving (Int -> AggregateRepo -> ShowS
[AggregateRepo] -> ShowS
AggregateRepo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [AggregateRepo] -> ShowS
$cshowList :: [AggregateRepo] -> ShowS
show :: AggregateRepo -> [Char]
$cshow :: AggregateRepo -> [Char]
showsPrec :: Int -> AggregateRepo -> ShowS
$cshowsPrec :: Int -> AggregateRepo -> ShowS
Show, forall x. Rep AggregateRepo x -> AggregateRepo
forall x. AggregateRepo -> Rep AggregateRepo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AggregateRepo x -> AggregateRepo
$cfrom :: forall x. AggregateRepo -> Rep AggregateRepo x
Generic, AggregateRepo -> AggregateRepo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AggregateRepo -> AggregateRepo -> Bool
$c/= :: AggregateRepo -> AggregateRepo -> Bool
== :: AggregateRepo -> AggregateRepo -> Bool
$c== :: AggregateRepo -> AggregateRepo -> Bool
Eq, Eq AggregateRepo
AggregateRepo -> AggregateRepo -> Bool
AggregateRepo -> AggregateRepo -> Ordering
AggregateRepo -> AggregateRepo -> AggregateRepo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: AggregateRepo -> AggregateRepo -> AggregateRepo
$cmin :: AggregateRepo -> AggregateRepo -> AggregateRepo
max :: AggregateRepo -> AggregateRepo -> AggregateRepo
$cmax :: AggregateRepo -> AggregateRepo -> AggregateRepo
>= :: AggregateRepo -> AggregateRepo -> Bool
$c>= :: AggregateRepo -> AggregateRepo -> Bool
> :: AggregateRepo -> AggregateRepo -> Bool
$c> :: AggregateRepo -> AggregateRepo -> Bool
<= :: AggregateRepo -> AggregateRepo -> Bool
$c<= :: AggregateRepo -> AggregateRepo -> Bool
< :: AggregateRepo -> AggregateRepo -> Bool
$c< :: AggregateRepo -> AggregateRepo -> Bool
compare :: AggregateRepo -> AggregateRepo -> Ordering
$ccompare :: AggregateRepo -> AggregateRepo -> Ordering
Ord, Typeable)

-- | Group input repositories by non-subdir values.

toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
toAggregateRepo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. (a -> a -> Bool) -> [a] -> [[a]]
groupBy forall {b} {b}. (Repo, b) -> (Repo, b) -> Bool
matchRepoExclSubdir
 where
  toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
  toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
toAggregateRepo [] = forall a. Maybe a
Nothing
  toAggregateRepo xs :: [(Repo, RawPackageMetadata)]
xs@((Repo
repo, RawPackageMetadata
_):[(Repo, RawPackageMetadata)]
_) =
    forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SimpleRepo -> [(Text, RawPackageMetadata)] -> AggregateRepo
AggregateRepo (Repo -> SimpleRepo
rToSimpleRepo Repo
repo) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first Repo -> Text
repoSubdir) [(Repo, RawPackageMetadata)]
xs)

  matchRepoExclSubdir :: (Repo, b) -> (Repo, b) -> Bool
matchRepoExclSubdir (Repo, b)
x1 (Repo, b)
x2 =
    let (Repo Text
url1 Text
commit1 RepoType
type1 Text
_, b
_) = (Repo, b)
x1
        (Repo Text
url2 Text
commit2 RepoType
type2 Text
_, b
_) = (Repo, b)
x2
    in  (Text
url1, Text
commit1, RepoType
type1) forall a. Eq a => a -> a -> Bool
== (Text
url2, Text
commit2, RepoType
type2)

arToSimpleRepo :: AggregateRepo -> SimpleRepo
arToSimpleRepo :: AggregateRepo -> SimpleRepo
arToSimpleRepo AggregateRepo {[(Text, RawPackageMetadata)]
SimpleRepo
aRepoSubdirs :: [(Text, RawPackageMetadata)]
aRepo :: SimpleRepo
aRepoSubdirs :: AggregateRepo -> [(Text, RawPackageMetadata)]
aRepo :: AggregateRepo -> SimpleRepo
..} = SimpleRepo
aRepo

-- | Repository without subdirectory information.

--

-- @since 0.5.3

data SimpleRepo = SimpleRepo
  { SimpleRepo -> Text
sRepoUrl :: !Text
  , SimpleRepo -> Text
sRepoCommit :: !Text
  , SimpleRepo -> RepoType
sRepoType :: !RepoType
  }
    deriving (Int -> SimpleRepo -> ShowS
[SimpleRepo] -> ShowS
SimpleRepo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SimpleRepo] -> ShowS
$cshowList :: [SimpleRepo] -> ShowS
show :: SimpleRepo -> [Char]
$cshow :: SimpleRepo -> [Char]
showsPrec :: Int -> SimpleRepo -> ShowS
$cshowsPrec :: Int -> SimpleRepo -> ShowS
Show, forall x. Rep SimpleRepo x -> SimpleRepo
forall x. SimpleRepo -> Rep SimpleRepo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SimpleRepo x -> SimpleRepo
$cfrom :: forall x. SimpleRepo -> Rep SimpleRepo x
Generic, SimpleRepo -> SimpleRepo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SimpleRepo -> SimpleRepo -> Bool
$c/= :: SimpleRepo -> SimpleRepo -> Bool
== :: SimpleRepo -> SimpleRepo -> Bool
$c== :: SimpleRepo -> SimpleRepo -> Bool
Eq, Eq SimpleRepo
SimpleRepo -> SimpleRepo -> Bool
SimpleRepo -> SimpleRepo -> Ordering
SimpleRepo -> SimpleRepo -> SimpleRepo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SimpleRepo -> SimpleRepo -> SimpleRepo
$cmin :: SimpleRepo -> SimpleRepo -> SimpleRepo
max :: SimpleRepo -> SimpleRepo -> SimpleRepo
$cmax :: SimpleRepo -> SimpleRepo -> SimpleRepo
>= :: SimpleRepo -> SimpleRepo -> Bool
$c>= :: SimpleRepo -> SimpleRepo -> Bool
> :: SimpleRepo -> SimpleRepo -> Bool
$c> :: SimpleRepo -> SimpleRepo -> Bool
<= :: SimpleRepo -> SimpleRepo -> Bool
$c<= :: SimpleRepo -> SimpleRepo -> Bool
< :: SimpleRepo -> SimpleRepo -> Bool
$c< :: SimpleRepo -> SimpleRepo -> Bool
compare :: SimpleRepo -> SimpleRepo -> Ordering
$ccompare :: SimpleRepo -> SimpleRepo -> Ordering
Ord, Typeable)

instance Display SimpleRepo where
  display :: SimpleRepo -> Utf8Builder
display (SimpleRepo Text
url Text
commit RepoType
typ) =
    (case RepoType
typ of
       RepoType
RepoGit -> Utf8Builder
"Git"
       RepoType
RepoHg -> Utf8Builder
"Mercurial") forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
" repo at " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<>
    Utf8Builder
", commit " forall a. Semigroup a => a -> a -> a
<>
    forall a. Display a => a -> Utf8Builder
display Text
commit

-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains

-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar".

newtype GitHubRepo = GitHubRepo Text

instance FromJSON GitHubRepo where
    parseJSON :: Value -> Parser GitHubRepo
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"GitHubRepo" forall a b. (a -> b) -> a -> b
$ \Text
s -> do
        case (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
s of
            [Text
x, Text
y] | Bool -> Bool
not (Text -> Bool
T.null Text
x Bool -> Bool -> Bool
|| Text -> Bool
T.null Text
y) -> forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> GitHubRepo
GitHubRepo Text
s)
            [Text]
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"expecting \"user/repo\""

-- | Configuration to securely download package metadata and contents. For most

-- purposes, you'll want to use the default Hackage settings via

-- @defaultPackageIndexConfig@.

--

-- /NOTE/ It's highly recommended to only use the official Hackage

-- server or a mirror. See

-- <https://github.com/commercialhaskell/stack/issues/4137>.

--

-- @since 0.6.0

data PackageIndexConfig = PackageIndexConfig
  { PackageIndexConfig -> Text
picDownloadPrefix :: !Text
  , PackageIndexConfig -> HackageSecurityConfig
picHackageSecurityConfig :: !HackageSecurityConfig
  }
  deriving Int -> PackageIndexConfig -> ShowS
[PackageIndexConfig] -> ShowS
PackageIndexConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageIndexConfig] -> ShowS
$cshowList :: [PackageIndexConfig] -> ShowS
show :: PackageIndexConfig -> [Char]
$cshow :: PackageIndexConfig -> [Char]
showsPrec :: Int -> PackageIndexConfig -> ShowS
$cshowsPrec :: Int -> PackageIndexConfig -> ShowS
Show

-- | If the @hackage-security@ key is absent from the JSON object, assigns

-- default value 'defaultHackageSecurityConfig'.

--

-- @since 0.6.0

instance FromJSON (WithJSONWarnings PackageIndexConfig) where
  parseJSON :: Value -> Parser (WithJSONWarnings PackageIndexConfig)
parseJSON = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"PackageIndexConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Text
picDownloadPrefix <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"download-prefix"
    HackageSecurityConfig
picHackageSecurityConfig <- forall a. WarningParser (WithJSONWarnings a) -> WarningParser a
jsonSubWarnings forall a b. (a -> b) -> a -> b
$
      Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"hackage-security" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall a. a -> WithJSONWarnings a
noJSONWarnings HackageSecurityConfig
defaultHackageSecurityConfig
    forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIndexConfig {Text
HackageSecurityConfig
picHackageSecurityConfig :: HackageSecurityConfig
picDownloadPrefix :: Text
picHackageSecurityConfig :: HackageSecurityConfig
picDownloadPrefix :: Text
..}

-- | Default 'HackageSecurityConfig' value using the official Hackage server.

-- The value of the 'hscIgnoreExpiry' field is 'True'.

--

-- @since 0.7.0

defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig = HackageSecurityConfig
  { hscKeyIds :: [Text]
hscKeyIds =
      [ Text
"0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
      , Text
"1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
      , Text
"2c6c3627bd6c982990239487f1abd02e08a02e6cf16edb105a8012d444d870c3"
      , Text
"51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
      , Text
"fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
      ]
  , hscKeyThreshold :: Int
hscKeyThreshold = Int
3
  , hscIgnoreExpiry :: Bool
hscIgnoreExpiry = Bool
True
  }

-- | Configuration for Hackage Security to securely download package metadata

-- and contents. For most purposes, you'll want to use the default Hackage

-- settings via @defaultHackageSecurityConfig@.

--

-- /NOTE/ It's highly recommended to only use the official Hackage

-- server or a mirror. See

-- <https://github.com/commercialhaskell/stack/issues/4137>.

--

-- @since 0.6.0

data HackageSecurityConfig = HackageSecurityConfig
  { HackageSecurityConfig -> [Text]
hscKeyIds :: ![Text]
  , HackageSecurityConfig -> Int
hscKeyThreshold :: !Int
  , HackageSecurityConfig -> Bool
hscIgnoreExpiry :: !Bool
  }
  deriving Int -> HackageSecurityConfig -> ShowS
[HackageSecurityConfig] -> ShowS
HackageSecurityConfig -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HackageSecurityConfig] -> ShowS
$cshowList :: [HackageSecurityConfig] -> ShowS
show :: HackageSecurityConfig -> [Char]
$cshow :: HackageSecurityConfig -> [Char]
showsPrec :: Int -> HackageSecurityConfig -> ShowS
$cshowsPrec :: Int -> HackageSecurityConfig -> ShowS
Show

-- | If the @ignore-expiry@ key is absent from the JSON object, assigns default

-- value 'True'.

--

-- @since 0.1.1.0

instance FromJSON (WithJSONWarnings HackageSecurityConfig) where
  parseJSON :: Value -> Parser (WithJSONWarnings HackageSecurityConfig)
parseJSON = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"HackageSecurityConfig" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    [Text]
hscKeyIds <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"keyids"
    Int
hscKeyThreshold <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"key-threshold"
    Bool
hscIgnoreExpiry <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"ignore-expiry" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Bool
True
    forall (f :: * -> *) a. Applicative f => a -> f a
pure HackageSecurityConfig {Bool
Int
[Text]
hscIgnoreExpiry :: Bool
hscKeyThreshold :: Int
hscKeyIds :: [Text]
hscIgnoreExpiry :: Bool
hscKeyThreshold :: Int
hscKeyIds :: [Text]
..}

-- | An environment which contains a 'PantryConfig'.

--

-- @since 0.1.0.0

class HasPantryConfig env where
  -- | Lens to get or set the 'PantryConfig'

  --

  -- @since 0.1.0.0

  pantryConfigL :: Lens' env PantryConfig


-- | File size in bytes

--

-- @since 0.1.0.0

newtype FileSize = FileSize Word
  deriving (Int -> FileSize -> ShowS
[FileSize] -> ShowS
FileSize -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FileSize] -> ShowS
$cshowList :: [FileSize] -> ShowS
show :: FileSize -> [Char]
$cshow :: FileSize -> [Char]
showsPrec :: Int -> FileSize -> ShowS
$cshowsPrec :: Int -> FileSize -> ShowS
Show, FileSize -> FileSize -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileSize -> FileSize -> Bool
$c/= :: FileSize -> FileSize -> Bool
== :: FileSize -> FileSize -> Bool
$c== :: FileSize -> FileSize -> Bool
Eq, Eq FileSize
FileSize -> FileSize -> Bool
FileSize -> FileSize -> Ordering
FileSize -> FileSize -> FileSize
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileSize -> FileSize -> FileSize
$cmin :: FileSize -> FileSize -> FileSize
max :: FileSize -> FileSize -> FileSize
$cmax :: FileSize -> FileSize -> FileSize
>= :: FileSize -> FileSize -> Bool
$c>= :: FileSize -> FileSize -> Bool
> :: FileSize -> FileSize -> Bool
$c> :: FileSize -> FileSize -> Bool
<= :: FileSize -> FileSize -> Bool
$c<= :: FileSize -> FileSize -> Bool
< :: FileSize -> FileSize -> Bool
$c< :: FileSize -> FileSize -> Bool
compare :: FileSize -> FileSize -> Ordering
$ccompare :: FileSize -> FileSize -> Ordering
Ord, Typeable, forall x. Rep FileSize x -> FileSize
forall x. FileSize -> Rep FileSize x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep FileSize x -> FileSize
$cfrom :: forall x. FileSize -> Rep FileSize x
Generic, FileSize -> Text
FileSize -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: FileSize -> Text
$ctextDisplay :: FileSize -> Text
display :: FileSize -> Utf8Builder
$cdisplay :: FileSize -> Utf8Builder
Display, Eq FileSize
Int -> FileSize -> Int
FileSize -> Int
forall a. Eq a -> (Int -> a -> Int) -> (a -> Int) -> Hashable a
hash :: FileSize -> Int
$chash :: FileSize -> Int
hashWithSalt :: Int -> FileSize -> Int
$chashWithSalt :: Int -> FileSize -> Int
Hashable, FileSize -> ()
forall a. (a -> ()) -> NFData a
rnf :: FileSize -> ()
$crnf :: FileSize -> ()
NFData, PersistValue -> Either Text FileSize
FileSize -> PersistValue
forall a.
(a -> PersistValue)
-> (PersistValue -> Either Text a) -> PersistField a
fromPersistValue :: PersistValue -> Either Text FileSize
$cfromPersistValue :: PersistValue -> Either Text FileSize
toPersistValue :: FileSize -> PersistValue
$ctoPersistValue :: FileSize -> PersistValue
PersistField, PersistField FileSize
Proxy FileSize -> SqlType
forall a.
PersistField a -> (Proxy a -> SqlType) -> PersistFieldSql a
sqlType :: Proxy FileSize -> SqlType
$csqlType :: Proxy FileSize -> SqlType
PersistFieldSql, [FileSize] -> Encoding
[FileSize] -> Value
FileSize -> Encoding
FileSize -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [FileSize] -> Encoding
$ctoEncodingList :: [FileSize] -> Encoding
toJSONList :: [FileSize] -> Value
$ctoJSONList :: [FileSize] -> Value
toEncoding :: FileSize -> Encoding
$ctoEncoding :: FileSize -> Encoding
toJSON :: FileSize -> Value
$ctoJSON :: FileSize -> Value
ToJSON, Value -> Parser [FileSize]
Value -> Parser FileSize
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [FileSize]
$cparseJSONList :: Value -> Parser [FileSize]
parseJSON :: Value -> Parser FileSize
$cparseJSON :: Value -> Parser FileSize
FromJSON)

-- | A key for looking up a blob, which combines the SHA256 hash of

-- the contents and the file size.

--

-- The file size may seem redundant with the hash. However, it is

-- necessary for safely downloading blobs from an untrusted

-- source. See

-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>.

--

-- @since 0.1.0.0

data BlobKey = BlobKey !SHA256 !FileSize
  deriving (BlobKey -> BlobKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BlobKey -> BlobKey -> Bool
$c/= :: BlobKey -> BlobKey -> Bool
== :: BlobKey -> BlobKey -> Bool
$c== :: BlobKey -> BlobKey -> Bool
Eq, Eq BlobKey
BlobKey -> BlobKey -> Bool
BlobKey -> BlobKey -> Ordering
BlobKey -> BlobKey -> BlobKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: BlobKey -> BlobKey -> BlobKey
$cmin :: BlobKey -> BlobKey -> BlobKey
max :: BlobKey -> BlobKey -> BlobKey
$cmax :: BlobKey -> BlobKey -> BlobKey
>= :: BlobKey -> BlobKey -> Bool
$c>= :: BlobKey -> BlobKey -> Bool
> :: BlobKey -> BlobKey -> Bool
$c> :: BlobKey -> BlobKey -> Bool
<= :: BlobKey -> BlobKey -> Bool
$c<= :: BlobKey -> BlobKey -> Bool
< :: BlobKey -> BlobKey -> Bool
$c< :: BlobKey -> BlobKey -> Bool
compare :: BlobKey -> BlobKey -> Ordering
$ccompare :: BlobKey -> BlobKey -> Ordering
Ord, Typeable, forall x. Rep BlobKey x -> BlobKey
forall x. BlobKey -> Rep BlobKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep BlobKey x -> BlobKey
$cfrom :: forall x. BlobKey -> Rep BlobKey x
Generic)
instance NFData BlobKey

instance Show BlobKey where
  show :: BlobKey -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
instance Display BlobKey where
  display :: BlobKey -> Utf8Builder
display (BlobKey SHA256
sha FileSize
size') = forall a. Display a => a -> Utf8Builder
display SHA256
sha forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"," forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
size'

blobKeyPairs :: BlobKey -> [(AesonKey, Value)]
blobKeyPairs :: BlobKey -> [(AesonKey, Value)]
blobKeyPairs (BlobKey SHA256
sha FileSize
size') =
    [ AesonKey
"sha256" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SHA256
sha
    , AesonKey
"size" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= FileSize
size'
    ]

instance ToJSON BlobKey where
  toJSON :: BlobKey -> Value
toJSON = [(AesonKey, Value)] -> Value
object forall b c a. (b -> c) -> (a -> b) -> a -> c
. BlobKey -> [(AesonKey, Value)]
blobKeyPairs
instance FromJSON BlobKey where
  parseJSON :: Value -> Parser BlobKey
parseJSON = forall a. [Char] -> (Object -> Parser a) -> Value -> Parser a
withObject [Char]
"BlobKey" forall a b. (a -> b) -> a -> b
$ \Object
o -> SHA256 -> FileSize -> BlobKey
BlobKey
    forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"sha256"
    forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> Parser a
.: Text
"size"

newtype PackageNameP = PackageNameP { PackageNameP -> PackageName
unPackageNameP :: PackageName }
  deriving (PackageNameP -> PackageNameP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageNameP -> PackageNameP -> Bool
$c/= :: PackageNameP -> PackageNameP -> Bool
== :: PackageNameP -> PackageNameP -> Bool
$c== :: PackageNameP -> PackageNameP -> Bool
Eq, Eq PackageNameP
PackageNameP -> PackageNameP -> Bool
PackageNameP -> PackageNameP -> Ordering
PackageNameP -> PackageNameP -> PackageNameP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageNameP -> PackageNameP -> PackageNameP
$cmin :: PackageNameP -> PackageNameP -> PackageNameP
max :: PackageNameP -> PackageNameP -> PackageNameP
$cmax :: PackageNameP -> PackageNameP -> PackageNameP
>= :: PackageNameP -> PackageNameP -> Bool
$c>= :: PackageNameP -> PackageNameP -> Bool
> :: PackageNameP -> PackageNameP -> Bool
$c> :: PackageNameP -> PackageNameP -> Bool
<= :: PackageNameP -> PackageNameP -> Bool
$c<= :: PackageNameP -> PackageNameP -> Bool
< :: PackageNameP -> PackageNameP -> Bool
$c< :: PackageNameP -> PackageNameP -> Bool
compare :: PackageNameP -> PackageNameP -> Ordering
$ccompare :: PackageNameP -> PackageNameP -> Ordering
Ord, Int -> PackageNameP -> ShowS
[PackageNameP] -> ShowS
PackageNameP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageNameP] -> ShowS
$cshowList :: [PackageNameP] -> ShowS
show :: PackageNameP -> [Char]
$cshow :: PackageNameP -> [Char]
showsPrec :: Int -> PackageNameP -> ShowS
$cshowsPrec :: Int -> PackageNameP -> ShowS
Show, ReadPrec [PackageNameP]
ReadPrec PackageNameP
Int -> ReadS PackageNameP
ReadS [PackageNameP]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [PackageNameP]
$creadListPrec :: ReadPrec [PackageNameP]
readPrec :: ReadPrec PackageNameP
$creadPrec :: ReadPrec PackageNameP
readList :: ReadS [PackageNameP]
$creadList :: ReadS [PackageNameP]
readsPrec :: Int -> ReadS PackageNameP
$creadsPrec :: Int -> ReadS PackageNameP
Read, PackageNameP -> ()
forall a. (a -> ()) -> NFData a
rnf :: PackageNameP -> ()
$crnf :: PackageNameP -> ()
NFData)
instance Display PackageNameP where
  display :: PackageNameP -> Utf8Builder
display = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageNameP -> PackageName
unPackageNameP
instance PersistField PackageNameP where
  toPersistValue :: PackageNameP -> PersistValue
toPersistValue (PackageNameP PackageName
pn) = Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pn
  fromPersistValue :: PersistValue -> Either Text PackageNameP
fromPersistValue PersistValue
v = do
    [Char]
str <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case [Char] -> Maybe PackageName
parsePackageName [Char]
str of
      Maybe PackageName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid package name: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
str
      Just PackageName
pn -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ PackageName -> PackageNameP
PackageNameP PackageName
pn
instance PersistFieldSql PackageNameP where
  sqlType :: Proxy PackageNameP -> SqlType
sqlType Proxy PackageNameP
_ = SqlType
SqlString
instance ToJSON PackageNameP where
  toJSON :: PackageNameP -> Value
toJSON (PackageNameP PackageName
pn) = Text -> Value
String forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ PackageName -> [Char]
packageNameString PackageName
pn
instance FromJSON PackageNameP where
  parseJSON :: Value -> Parser PackageNameP
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"PackageNameP" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> PackageNameP
PackageNameP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PackageName
mkPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack
instance ToJSONKey PackageNameP where
  toJSONKey :: ToJSONKeyFunction PackageNameP
toJSONKey =
    forall a.
(a -> AesonKey) -> (a -> Encoding' AesonKey) -> ToJSONKeyFunction a
ToJSONKeyText
      (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageNameP -> PackageName
unPackageNameP)
      (forall a. Builder -> Encoding' a
unsafeToEncoding forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Builder
getUtf8Builder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display)
instance FromJSONKey PackageNameP where
  fromJSONKey :: FromJSONKeyFunction PackageNameP
fromJSONKey = forall a. (Text -> a) -> FromJSONKeyFunction a
FromJSONKeyText forall a b. (a -> b) -> a -> b
$ PackageName -> PackageNameP
PackageNameP forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> PackageName
mkPackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

newtype VersionP = VersionP { VersionP -> Version
unVersionP :: Version }
  deriving (VersionP -> VersionP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: VersionP -> VersionP -> Bool
$c/= :: VersionP -> VersionP -> Bool
== :: VersionP -> VersionP -> Bool
$c== :: VersionP -> VersionP -> Bool
Eq, Eq VersionP
VersionP -> VersionP -> Bool
VersionP -> VersionP -> Ordering
VersionP -> VersionP -> VersionP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: VersionP -> VersionP -> VersionP
$cmin :: VersionP -> VersionP -> VersionP
max :: VersionP -> VersionP -> VersionP
$cmax :: VersionP -> VersionP -> VersionP
>= :: VersionP -> VersionP -> Bool
$c>= :: VersionP -> VersionP -> Bool
> :: VersionP -> VersionP -> Bool
$c> :: VersionP -> VersionP -> Bool
<= :: VersionP -> VersionP -> Bool
$c<= :: VersionP -> VersionP -> Bool
< :: VersionP -> VersionP -> Bool
$c< :: VersionP -> VersionP -> Bool
compare :: VersionP -> VersionP -> Ordering
$ccompare :: VersionP -> VersionP -> Ordering
Ord, Int -> VersionP -> ShowS
[VersionP] -> ShowS
VersionP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [VersionP] -> ShowS
$cshowList :: [VersionP] -> ShowS
show :: VersionP -> [Char]
$cshow :: VersionP -> [Char]
showsPrec :: Int -> VersionP -> ShowS
$cshowsPrec :: Int -> VersionP -> ShowS
Show, ReadPrec [VersionP]
ReadPrec VersionP
Int -> ReadS VersionP
ReadS [VersionP]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [VersionP]
$creadListPrec :: ReadPrec [VersionP]
readPrec :: ReadPrec VersionP
$creadPrec :: ReadPrec VersionP
readList :: ReadS [VersionP]
$creadList :: ReadS [VersionP]
readsPrec :: Int -> ReadS VersionP
$creadsPrec :: Int -> ReadS VersionP
Read, VersionP -> ()
forall a. (a -> ()) -> NFData a
rnf :: VersionP -> ()
$crnf :: VersionP -> ()
NFData)
instance PersistField VersionP where
  toPersistValue :: VersionP -> PersistValue
toPersistValue (VersionP Version
v) = Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
v
  fromPersistValue :: PersistValue -> Either Text VersionP
fromPersistValue PersistValue
v = do
    [Char]
str <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case [Char] -> Maybe Version
parseVersion [Char]
str of
      Maybe Version
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid version number: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
str
      Just Version
ver -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Version -> VersionP
VersionP Version
ver
instance PersistFieldSql VersionP where
  sqlType :: Proxy VersionP -> SqlType
sqlType Proxy VersionP
_ = SqlType
SqlString
instance Display VersionP where
  display :: VersionP -> Utf8Builder
display (VersionP Version
v) = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
v
instance ToJSON VersionP where
  toJSON :: VersionP -> Value
toJSON (VersionP Version
v) = Text -> Value
String forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ Version -> [Char]
versionString Version
v
instance FromJSON VersionP where
  parseJSON :: Value -> Parser VersionP
parseJSON =
    forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"VersionP" forall a b. (a -> b) -> a -> b
$
    forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Exception e => e -> [Char]
displayException) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Version -> VersionP
VersionP) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

newtype ModuleNameP = ModuleNameP
  { ModuleNameP -> ModuleName
unModuleNameP :: ModuleName
  } deriving (ModuleNameP -> ModuleNameP -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ModuleNameP -> ModuleNameP -> Bool
$c/= :: ModuleNameP -> ModuleNameP -> Bool
== :: ModuleNameP -> ModuleNameP -> Bool
$c== :: ModuleNameP -> ModuleNameP -> Bool
Eq, Eq ModuleNameP
ModuleNameP -> ModuleNameP -> Bool
ModuleNameP -> ModuleNameP -> Ordering
ModuleNameP -> ModuleNameP -> ModuleNameP
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ModuleNameP -> ModuleNameP -> ModuleNameP
$cmin :: ModuleNameP -> ModuleNameP -> ModuleNameP
max :: ModuleNameP -> ModuleNameP -> ModuleNameP
$cmax :: ModuleNameP -> ModuleNameP -> ModuleNameP
>= :: ModuleNameP -> ModuleNameP -> Bool
$c>= :: ModuleNameP -> ModuleNameP -> Bool
> :: ModuleNameP -> ModuleNameP -> Bool
$c> :: ModuleNameP -> ModuleNameP -> Bool
<= :: ModuleNameP -> ModuleNameP -> Bool
$c<= :: ModuleNameP -> ModuleNameP -> Bool
< :: ModuleNameP -> ModuleNameP -> Bool
$c< :: ModuleNameP -> ModuleNameP -> Bool
compare :: ModuleNameP -> ModuleNameP -> Ordering
$ccompare :: ModuleNameP -> ModuleNameP -> Ordering
Ord, Int -> ModuleNameP -> ShowS
[ModuleNameP] -> ShowS
ModuleNameP -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ModuleNameP] -> ShowS
$cshowList :: [ModuleNameP] -> ShowS
show :: ModuleNameP -> [Char]
$cshow :: ModuleNameP -> [Char]
showsPrec :: Int -> ModuleNameP -> ShowS
$cshowsPrec :: Int -> ModuleNameP -> ShowS
Show, ModuleNameP -> ()
forall a. (a -> ()) -> NFData a
rnf :: ModuleNameP -> ()
$crnf :: ModuleNameP -> ()
NFData)
instance Display ModuleNameP where
  display :: ModuleNameP -> Utf8Builder
display = forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Char]
moduleNameString forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleNameP -> ModuleName
unModuleNameP
instance PersistField ModuleNameP where
  toPersistValue :: ModuleNameP -> PersistValue
toPersistValue (ModuleNameP ModuleName
mn) = Text -> PersistValue
PersistText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall a b. (a -> b) -> a -> b
$ ModuleName -> [Char]
moduleNameString ModuleName
mn
  fromPersistValue :: PersistValue -> Either Text ModuleNameP
fromPersistValue PersistValue
v = do
    [Char]
str <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case [Char] -> Maybe ModuleName
parseModuleName [Char]
str of
      Maybe ModuleName
Nothing -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid module name: " forall a. Semigroup a => a -> a -> a
<> [Char] -> Text
T.pack [Char]
str
      Just ModuleName
pn -> forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ ModuleName -> ModuleNameP
ModuleNameP ModuleName
pn
instance PersistFieldSql ModuleNameP where
  sqlType :: Proxy ModuleNameP -> SqlType
sqlType Proxy ModuleNameP
_ = SqlType
SqlString

-- | How to choose a cabal file for a package from Hackage. This is to

-- work with Hackage cabal file revisions, which makes

-- @PackageIdentifier@ insufficient for specifying a package from

-- Hackage.

--

-- @since 0.1.0.0

data CabalFileInfo
  = CFILatest
  -- ^ Take the latest revision of the cabal file available. This

  -- isn't reproducible at all, but the running assumption (not

  -- necessarily true) is that cabal file revisions do not change

  -- semantics of the build.

  --

  -- @since 0.1.0.0

  | CFIHash !SHA256 !(Maybe FileSize)
  -- ^ Identify by contents of the cabal file itself. Only reason for

  -- @Maybe@ on @FileSize@ is for compatibility with input that

  -- doesn't include the file size.

  --

  -- @since 0.1.0.0

  | CFIRevision !Revision
  -- ^ Identify by revision number, with 0 being the original and

  -- counting upward. This relies on Hackage providing consistent

  -- versioning. @CFIHash@ should be preferred wherever possible for

  -- reproducibility.

  --

  -- @since 0.1.0.0

    deriving (forall x. Rep CabalFileInfo x -> CabalFileInfo
forall x. CabalFileInfo -> Rep CabalFileInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CabalFileInfo x -> CabalFileInfo
$cfrom :: forall x. CabalFileInfo -> Rep CabalFileInfo x
Generic, Int -> CabalFileInfo -> ShowS
[CabalFileInfo] -> ShowS
CabalFileInfo -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CabalFileInfo] -> ShowS
$cshowList :: [CabalFileInfo] -> ShowS
show :: CabalFileInfo -> [Char]
$cshow :: CabalFileInfo -> [Char]
showsPrec :: Int -> CabalFileInfo -> ShowS
$cshowsPrec :: Int -> CabalFileInfo -> ShowS
Show, CabalFileInfo -> CabalFileInfo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CabalFileInfo -> CabalFileInfo -> Bool
$c/= :: CabalFileInfo -> CabalFileInfo -> Bool
== :: CabalFileInfo -> CabalFileInfo -> Bool
$c== :: CabalFileInfo -> CabalFileInfo -> Bool
Eq, Eq CabalFileInfo
CabalFileInfo -> CabalFileInfo -> Bool
CabalFileInfo -> CabalFileInfo -> Ordering
CabalFileInfo -> CabalFileInfo -> CabalFileInfo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
$cmin :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
max :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
$cmax :: CabalFileInfo -> CabalFileInfo -> CabalFileInfo
>= :: CabalFileInfo -> CabalFileInfo -> Bool
$c>= :: CabalFileInfo -> CabalFileInfo -> Bool
> :: CabalFileInfo -> CabalFileInfo -> Bool
$c> :: CabalFileInfo -> CabalFileInfo -> Bool
<= :: CabalFileInfo -> CabalFileInfo -> Bool
$c<= :: CabalFileInfo -> CabalFileInfo -> Bool
< :: CabalFileInfo -> CabalFileInfo -> Bool
$c< :: CabalFileInfo -> CabalFileInfo -> Bool
compare :: CabalFileInfo -> CabalFileInfo -> Ordering
$ccompare :: CabalFileInfo -> CabalFileInfo -> Ordering
Ord, Typeable)
instance NFData CabalFileInfo
instance Hashable CabalFileInfo

instance Display CabalFileInfo where
  display :: CabalFileInfo -> Utf8Builder
display CabalFileInfo
CFILatest = forall a. Monoid a => a
mempty
  display (CFIHash SHA256
hash' Maybe FileSize
msize) =
    Utf8Builder
"@sha256:" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
hash' forall a. Semigroup a => a -> a -> a
<> forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Monoid a => a
mempty (\FileSize
i -> Utf8Builder
"," forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
i) Maybe FileSize
msize
  display (CFIRevision Revision
rev) = Utf8Builder
"@rev:" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Revision
rev

-- | A full specification for a package from Hackage, including the

-- package name, version, and how to load up the correct cabal file

-- revision.

--

-- @since 0.1.0.0

data PackageIdentifierRevision = PackageIdentifierRevision !PackageName !Version !CabalFileInfo
  deriving (forall x.
Rep PackageIdentifierRevision x -> PackageIdentifierRevision
forall x.
PackageIdentifierRevision -> Rep PackageIdentifierRevision x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x.
Rep PackageIdentifierRevision x -> PackageIdentifierRevision
$cfrom :: forall x.
PackageIdentifierRevision -> Rep PackageIdentifierRevision x
Generic, PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c/= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
== :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c== :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
Eq, Eq PackageIdentifierRevision
PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
PackageIdentifierRevision -> PackageIdentifierRevision -> Ordering
PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
$cmin :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
max :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
$cmax :: PackageIdentifierRevision
-> PackageIdentifierRevision -> PackageIdentifierRevision
>= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c>= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
> :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c> :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
<= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c<= :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
< :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
$c< :: PackageIdentifierRevision -> PackageIdentifierRevision -> Bool
compare :: PackageIdentifierRevision -> PackageIdentifierRevision -> Ordering
$ccompare :: PackageIdentifierRevision -> PackageIdentifierRevision -> Ordering
Ord, Typeable)
instance NFData PackageIdentifierRevision

instance Show PackageIdentifierRevision where
  show :: PackageIdentifierRevision -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance Display PackageIdentifierRevision where
  display :: PackageIdentifierRevision -> Utf8Builder
display (PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi) =
    forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
version) forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display CabalFileInfo
cfi

instance ToJSON PackageIdentifierRevision where
  toJSON :: PackageIdentifierRevision -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
instance FromJSON PackageIdentifierRevision where
  parseJSON :: Value -> Parser PackageIdentifierRevision
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"PackageIdentifierRevision" forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t of
      Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PantryException
e
      Right PackageIdentifierRevision
pir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifierRevision
pir

-- | Parse a hackage text.

--

-- @since 0.1.0.0

parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText Text
t =
  forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\[Char]
x -> forall a. HasCallStack => [Char] -> a
error (forall a. Show a => a -> [Char]
show [Char]
x) forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageIdentifierRevisionParseFail Text
t) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
  forall a. ParsecParser a -> [Char] -> Either [Char] a
explicitEitherParsec (ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Parsing m => m ()
Parse.eof) forall a b. (a -> b) -> a -> b
$
  Text -> [Char]
T.unpack Text
t

hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec = do
  PackageIdentifier
ident <- ParsecParser PackageIdentifier
packageIdentifierParsec
  [Char]
_ <- forall (m :: * -> *). CharParsing m => [Char] -> m [Char]
Parse.string [Char]
"@sha256:"

  [Char]
shaT <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m [Char]
Parse.munch (forall a. Eq a => a -> a -> Bool
/= Char
',')
  SHA256
sha <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall (m :: * -> *) a. MonadPlus m => m a
mzero) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Either SHA256Exception SHA256
SHA256.fromHexText forall a b. (a -> b) -> a -> b
$ forall a. IsString a => [Char] -> a
fromString [Char]
shaT

  Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
Parse.char Char
','
  Word
size' <- forall (m :: * -> *) a. (CharParsing m, Integral a) => m a
Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't

  forall (f :: * -> *) a. Applicative f => a -> f a
pure (PackageIdentifier
ident, SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha (Word -> FileSize
FileSize Word
size'))

splitColon :: Text -> Maybe (Text, Text)
splitColon :: Text -> Maybe (Text, Text)
splitColon Text
t' =
    let (Text
x, Text
y) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
t'
     in (Text
x, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
y

-- | Parse a 'PackageIdentifierRevision'

--

-- @since 0.1.0.0

parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision :: Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageIdentifierRevisionParseFail Text
t) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ do
  let (Text
identT, Text
cfiT) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'@') Text
t
  PackageIdentifier PackageName
name Version
version <- [Char] -> Maybe PackageIdentifier
parsePackageIdentifier forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
identT
  CabalFileInfo
cfi <-
    case Text -> Maybe (Text, Text)
splitColon Text
cfiT of
      Just (Text
"@sha256", Text
shaSizeT) -> do
        let (Text
shaT, Text
sizeT) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
',') Text
shaSizeT
        SHA256
sha <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> Either SHA256Exception SHA256
SHA256.fromHexText Text
shaT
        Maybe FileSize
msize <-
          case Text -> Text -> Maybe Text
T.stripPrefix Text
"," Text
sizeT of
            Maybe Text
Nothing -> forall a. a -> Maybe a
Just forall a. Maybe a
Nothing
            Just Text
sizeT' ->
              case forall a. Integral a => Reader a
decimal Text
sizeT' of
                Right (Word
size', Text
"") -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Word -> FileSize
FileSize Word
size'
                Either [Char] (Word, Text)
_ -> forall a. Maybe a
Nothing
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ SHA256 -> Maybe FileSize -> CabalFileInfo
CFIHash SHA256
sha Maybe FileSize
msize
      Just (Text
"@rev", Text
revT) ->
        case forall a. Integral a => Reader a
decimal Text
revT of
          Right (Word
rev, Text
"") -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Revision -> CabalFileInfo
CFIRevision forall a b. (a -> b) -> a -> b
$ Word -> Revision
Revision Word
rev
          Either [Char] (Word, Text)
_ -> forall a. Maybe a
Nothing
      Maybe (Text, Text)
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure CabalFileInfo
CFILatest
      Maybe (Text, Text)
_ -> forall a. Maybe a
Nothing
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageName
-> Version -> CabalFileInfo -> PackageIdentifierRevision
PackageIdentifierRevision PackageName
name Version
version CabalFileInfo
cfi

data Mismatch a = Mismatch
  { forall a. Mismatch a -> a
mismatchExpected :: !a
  , forall a. Mismatch a -> a
mismatchActual :: !a
  }

-- | Things that can go wrong in pantry. Note two things:

--

-- * Many other exception types may be thrown from underlying

--   libraries. Pantry does not attempt to wrap these underlying

--   exceptions.

--

-- * We may add more constructors to this data type in minor version

--   bumps of pantry. This technically breaks the PVP. You should not

--   be writing pattern matches against this type that expect total

--   matching.

--

-- @since 0.1.0.0

data PantryException
  = PackageIdentifierRevisionParseFail !Text
  | InvalidCabalFile
      !(Either RawPackageLocationImmutable (Path Abs File))
      !(Maybe Version)
      ![PError]
      ![PWarning]
  | TreeWithoutCabalFile !RawPackageLocationImmutable
  | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath]
  | MismatchedCabalName !(Path Abs File) !PackageName
  | NoCabalFileFound !(Path Abs Dir)
  | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File]
  | InvalidWantedCompiler !Text
  | InvalidSnapshotLocation !(Path Abs Dir) !Text
  | InvalidOverrideCompiler !WantedCompiler !WantedCompiler
  | InvalidFilePathSnapshot !Text
  | InvalidSnapshot !RawSnapshotLocation !SomeException
  | MismatchedPackageMetadata
      !RawPackageLocationImmutable
      !RawPackageMetadata
      !(Maybe TreeKey)
      !PackageIdentifier
  | Non200ResponseStatus !Status
  | InvalidBlobKey !(Mismatch BlobKey)
  | Couldn'tParseSnapshot !RawSnapshotLocation !String
  | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName
  | DownloadInvalidSHA256 !Text !(Mismatch SHA256)
  | DownloadInvalidSize !Text !(Mismatch FileSize)
  | DownloadTooLarge !Text !(Mismatch FileSize)
  -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is

  -- a lower bound on the size from the server.

  | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256)
  | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize)
  | UnknownArchiveType !ArchiveLocation
  | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType
  | UnsupportedTarball !ArchiveLocation !Text
  | NoHackageCryptographicHash !PackageIdentifier
  | FailedToCloneRepo !SimpleRepo
  | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey
  | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata
  | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32)
  | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults
  | CannotCompleteRepoNonSHA1 !Repo
  | MutablePackageLocationFromUrl !Text
  | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier)
  | PackageNameParseFail !Text
  | PackageVersionParseFail !Text
  | InvalidCabalFilePath !(Path Abs File)
  | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])]
  | MigrationFailure !Text !(Path Abs File) !SomeException
  | InvalidTreeFromCasa !BlobKey !ByteString
  | ParseSnapNameException !Text

  deriving Typeable
instance Exception PantryException where
instance Show PantryException where
  show :: PantryException -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

-- To support the Haskell Foundation's

-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry

-- error messages generated by Pantry itself begin with an unique code in the

-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999.

-- The numbers are selected at random, not in sequence.

instance Display PantryException where
  display :: PantryException -> Utf8Builder
display (InvalidTreeFromCasa BlobKey
blobKey ByteString
_bs) =
    Utf8Builder
"Error: [S-258]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid tree from casa: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blobKey
  display (PackageIdentifierRevisionParseFail Text
text) =
    Utf8Builder
"Error: [S-360]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid package identifier (with optional revision): "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
text
  display (InvalidCabalFile Either RawPackageLocationImmutable (Path Abs File)
loc Maybe Version
mversion [PError]
errs [PWarning]
warnings) =
    Utf8Builder
"Error: [S-242]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unable to parse cabal file from package "
    forall a. Semigroup a => a -> a -> a
<> forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. Display a => a -> Utf8Builder
display (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b t. Path b t -> [Char]
toFilePath) Either RawPackageLocationImmutable (Path Abs File)
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n\n"
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PError Position
pos [Char]
msg) ->
                 Utf8Builder
"- "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Position -> [Char]
showPos Position
pos)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
msg
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
         )
         [PError]
errs
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PWarning PWarnType
_ Position
pos [Char]
msg) ->
                 Utf8Builder
"- "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Position -> [Char]
showPos Position
pos)
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
              forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
msg
              forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n"
         )
         [PWarning]
warnings
    forall a. Semigroup a => a -> a -> a
<> ( case Maybe Version
mversion of
           Just Version
version
             | Version
version forall a. Ord a => a -> a -> Bool
> Version
cabalSpecLatestVersion ->
                    Utf8Builder
"\n\nThe cabal file uses the cabal specification version "
                 forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
version)
                 forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but we only support up to version "
                 forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
cabalSpecLatestVersion)
                 forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)."
           Maybe Version
_ -> forall a. Monoid a => a
mempty
       )
  display (TreeWithoutCabalFile RawPackageLocationImmutable
pl) =
    Utf8Builder
"Error: [S-654]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"No cabal file found for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
  display (TreeWithMultipleCabalFiles RawPackageLocationImmutable
pl [SafeFilePath]
sfps) =
    Utf8Builder
"Error: [S-500]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Multiple cabal files found for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Display a => a -> Utf8Builder
display [SafeFilePath]
sfps))
  display (MismatchedCabalName Path Abs File
fp PackageName
name) =
    Utf8Builder
"Error: [S-910]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"cabal file path "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" does not match the package name it defines.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Please rename the file to: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".cabal\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"For more information, see: https://github.com/commercialhaskell/stack/issues/317"
  display (NoCabalFileFound Path Abs Dir
dir) =
    Utf8Builder
"Error: [S-636]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Stack looks for packages in the directories configured in\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"the 'packages' and 'extra-deps' fields defined in your stack.yaml\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The current entry points to "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
",\nbut no .cabal or package.yaml file could be found there."
  display (MultipleCabalFilesFound Path Abs Dir
dir [Path Abs File]
files) =
    Utf8Builder
"Error: [S-368]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Multiple .cabal files found in directory "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\n"
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold
         ( forall a. a -> [a] -> [a]
intersperse
             Utf8Builder
"\n"
             (forall a b. (a -> b) -> [a] -> [b]
map (\Path Abs File
x -> Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath (forall b. Path b File -> Path Rel File
filename Path Abs File
x))) [Path Abs File]
files)
         )
  display (InvalidWantedCompiler Text
t) =
    Utf8Builder
"Error: [S-204]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid wanted compiler: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (InvalidSnapshotLocation Path Abs Dir
dir Text
t) =
    Utf8Builder
"Error: [S-935]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid snapshot location "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
t
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" relative to directory "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (forall b t. Path b t -> [Char]
toFilePath Path Abs Dir
dir)
  display (InvalidOverrideCompiler WantedCompiler
x WantedCompiler
y) =
    Utf8Builder
"Error: [S-287]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Specified compiler for a resolver ("
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display WantedCompiler
x
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"), but also specified an override compiler ("
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display WantedCompiler
y
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
  display (InvalidFilePathSnapshot Text
t) =
    Utf8Builder
"Error: [S-617]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Specified snapshot as file path with "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Text
t
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but not reading from a local file"
  display (InvalidSnapshot RawSnapshotLocation
loc SomeException
e) =
    Utf8Builder
"Error: [S-775]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Exception while reading snapshot from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\n"
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
e
  display (MismatchedPackageMetadata RawPackageLocationImmutable
loc RawPackageMetadata
pm Maybe TreeKey
mtreeKey PackageIdentifier
foundIdent) =
    Utf8Builder
"Error: [S-427]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched package metadata for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nFound: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
foundIdent)
    forall a. Semigroup a => a -> a -> a
<> ( case Maybe TreeKey
mtreeKey of
           Maybe TreeKey
Nothing -> forall a. Monoid a => a
mempty
           Just TreeKey
treeKey -> Utf8Builder
" with tree " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display TreeKey
treeKey
       )
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageMetadata
pm
  display (Non200ResponseStatus Status
status) =
    Utf8Builder
"Error: [S-571]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unexpected non-200 HTTP status code: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow (Status -> Int
statusCode Status
status)
  display (InvalidBlobKey Mismatch{BlobKey
mismatchActual :: BlobKey
mismatchExpected :: BlobKey
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-236]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid blob key found, expected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", actual: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
mismatchActual
  display (Couldn'tParseSnapshot RawSnapshotLocation
sl [Char]
e) =
    Utf8Builder
"Error: [S-645]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Couldn't parse snapshot from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawSnapshotLocation
sl
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
e
  display (WrongCabalFileName RawPackageLocationImmutable
pl SafeFilePath
sfp PackageName
name) =
    Utf8Builder
"Error: [S-575]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Wrong cabal file name for package "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
pl
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nThe cabal file is named "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SafeFilePath
sfp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but package name is "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nFor more information, see:\n  - https://github.com/commercialhaskell/stack/issues/317\n  -https://github.com/commercialhaskell/stack/issues/895"
  display (DownloadInvalidSHA256 Text
url Mismatch {SHA256
mismatchActual :: SHA256
mismatchExpected :: SHA256
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-394]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched SHA256 hash from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchActual
  display (DownloadInvalidSize Text
url Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-401]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched download size from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchActual
  display (DownloadTooLarge Text
url Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-113]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Download from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
url
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" was too large.\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Expected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", stopped after receiving: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchActual
  display (LocalInvalidSHA256 Path Abs File
path Mismatch {SHA256
mismatchActual :: SHA256
mismatchExpected :: SHA256
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-834]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched SHA256 hash from "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
path)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SHA256
mismatchActual
  display (LocalInvalidSize Path Abs File
path Mismatch {FileSize
mismatchActual :: FileSize
mismatchExpected :: FileSize
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-713]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Mismatched file size from "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
path)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display FileSize
mismatchActual
  display (UnknownArchiveType ArchiveLocation
loc) =
    Utf8Builder
"Error: [S-372]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unable to determine archive type of: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
  display (InvalidTarFileType ArchiveLocation
loc [Char]
fp FileType
x) =
    Utf8Builder
"Error: [S-950]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unsupported tar file type in archive "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" at file "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
fp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow FileType
x
  display (UnsupportedTarball ArchiveLocation
loc Text
e) =
    Utf8Builder
"Error: [S-760]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Unsupported tarball from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
": "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
e
  display (NoHackageCryptographicHash PackageIdentifier
ident) =
    Utf8Builder
"Error: [S-922]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"No cryptographic hash found for Hackage package "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
ident)
  display (FailedToCloneRepo SimpleRepo
repo) =
    Utf8Builder
"Error: [S-109]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Failed to clone repo "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SimpleRepo
repo
  display (TreeReferencesMissingBlob RawPackageLocationImmutable
loc SafeFilePath
sfp BlobKey
key) =
    Utf8Builder
"Error: [S-237]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"The package "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" needs blob "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
key
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" for file path "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display SafeFilePath
sfp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", but the blob is not available"
  display (CompletePackageMetadataMismatch RawPackageLocationImmutable
loc PackageMetadata
pm) =
    Utf8Builder
"Error: [S-984]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"When completing package metadata for "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", some values changed in the new package metadata: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageMetadata
pm
  display (CRC32Mismatch ArchiveLocation
loc [Char]
fp Mismatch {Word32
mismatchActual :: Word32
mismatchExpected :: Word32
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-607]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"CRC32 mismatch in ZIP file from "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display ArchiveLocation
loc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" on internal file "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString [Char]
fp
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Word32
mismatchExpected
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Word32
mismatchActual
  display (UnknownHackagePackage PackageIdentifierRevision
pir FuzzyResults
fuzzy) =
    Utf8Builder
"Error: [S-476]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Could not find "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" on Hackage"
    forall a. Semigroup a => a -> a -> a
<> FuzzyResults -> Utf8Builder
displayFuzzy FuzzyResults
fuzzy
  display (CannotCompleteRepoNonSHA1 Repo
repo) =
    Utf8Builder
"Error: [S-112]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Cannot complete repo information for a non SHA1 commit due to non-reproducibility: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Repo
repo
  display (MutablePackageLocationFromUrl Text
t) =
    Utf8Builder
"Error: [S-321]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Cannot refer to a mutable package location from a URL: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (MismatchedCabalFileForHackage PackageIdentifierRevision
pir Mismatch{PackageIdentifier
mismatchActual :: PackageIdentifier
mismatchExpected :: PackageIdentifier
mismatchActual :: forall a. Mismatch a -> a
mismatchExpected :: forall a. Mismatch a -> a
..}) =
    Utf8Builder
"Error: [S-377]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"When processing cabal file for Hackage package "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display PackageIdentifierRevision
pir
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\nMismatched package identifier."
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nExpected: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
mismatchExpected)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nActual:   "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString PackageIdentifier
mismatchActual)
  display (PackageNameParseFail Text
t) =
    Utf8Builder
"Error: [S-580]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid package name: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (PackageVersionParseFail Text
t) =
    Utf8Builder
"Error: [S-479]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid version: "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t
  display (InvalidCabalFilePath Path Abs File
fp) =
    Utf8Builder
"Error: [S-824]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"File path contains a name which is not a valid package name: "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
  display (DuplicatePackageNames Utf8Builder
source [(PackageName, [RawPackageLocationImmutable])]
pairs') =
    Utf8Builder
"Error: [S-674]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Duplicate package names ("
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
source
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"):\n"
    forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap
         ( \(PackageName
name, [RawPackageLocationImmutable]
locs) ->
                forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)
             forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":\n"
             forall a. Semigroup a => a -> a -> a
<> forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (\RawPackageLocationImmutable
loc -> Utf8Builder
"- " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n") [RawPackageLocationImmutable]
locs
         )
         [(PackageName, [RawPackageLocationImmutable])]
pairs'
  display (MigrationFailure Text
desc Path Abs File
fp SomeException
ex) =
    Utf8Builder
"Error: [S-536]\n"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Encountered error while migrating database "
    forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
desc
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\nlocated at "
    forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (forall b t. Path b t -> [Char]
toFilePath Path Abs File
fp)
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
":"
    forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"\n    "
    forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow SomeException
ex
  display (ParseSnapNameException Text
t) =
    Utf8Builder
"Error: [S-994]\n"
     forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"Invalid snapshot name: "
     forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
t

data FuzzyResults
  = FRNameNotFound ![PackageName]
  | FRVersionNotFound !(NonEmpty PackageIdentifierRevision)
  | FRRevisionNotFound !(NonEmpty PackageIdentifierRevision)

displayFuzzy :: FuzzyResults -> Utf8Builder
displayFuzzy :: FuzzyResults -> Utf8Builder
displayFuzzy (FRNameNotFound [PackageName]
names) =
  case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [PackageName]
names of
    Maybe (NonEmpty PackageName)
Nothing -> Utf8Builder
""
    Just NonEmpty PackageName
names' ->
      Utf8Builder
"\nPerhaps you meant " forall a. Semigroup a => a -> a -> a
<>
      NonEmpty Utf8Builder -> Utf8Builder
orSeparated (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (forall a. IsString a => [Char] -> a
fromString forall b c a. (b -> c) -> (a -> b) -> a -> c
. PackageName -> [Char]
packageNameString) NonEmpty PackageName
names') forall a. Semigroup a => a -> a -> a
<>
      Utf8Builder
"?"
displayFuzzy (FRVersionNotFound NonEmpty PackageIdentifierRevision
pirs) =
  Utf8Builder
"\nPossible candidates: " forall a. Semigroup a => a -> a -> a
<>
  NonEmpty Utf8Builder -> Utf8Builder
commaSeparated (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a. Display a => a -> Utf8Builder
display NonEmpty PackageIdentifierRevision
pirs) forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"."
displayFuzzy (FRRevisionNotFound NonEmpty PackageIdentifierRevision
pirs) =
  Utf8Builder
"\nThe specified revision was not found.\nPossible candidates: " forall a. Semigroup a => a -> a -> a
<>
  NonEmpty Utf8Builder -> Utf8Builder
commaSeparated (forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map forall a. Display a => a -> Utf8Builder
display NonEmpty PackageIdentifierRevision
pirs) forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"."

orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
orSeparated NonEmpty Utf8Builder
xs
  | forall a. NonEmpty a -> Int
NE.length NonEmpty Utf8Builder
xs forall a. Eq a => a -> a -> Bool
== Int
1 = forall a. NonEmpty a -> a
NE.head NonEmpty Utf8Builder
xs
  | forall a. NonEmpty a -> Int
NE.length NonEmpty Utf8Builder
xs forall a. Eq a => a -> a -> Bool
== Int
2 = forall a. NonEmpty a -> a
NE.head NonEmpty Utf8Builder
xs forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" or " forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> a
NE.last NonEmpty Utf8Builder
xs
  | Bool
otherwise = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold (forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " (forall a. NonEmpty a -> [a]
NE.init NonEmpty Utf8Builder
xs)) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
", or " forall a. Semigroup a => a -> a -> a
<> forall a. NonEmpty a -> a
NE.last NonEmpty Utf8Builder
xs

commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder
commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder
commaSeparated = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> NonEmpty a -> NonEmpty a
NE.intersperse Utf8Builder
", "

cabalSpecLatestVersion :: Version
cabalSpecLatestVersion :: Version
cabalSpecLatestVersion = [Int] -> Version
mkVersion forall a b. (a -> b) -> a -> b
$ CabalSpecVersion -> [Int]
cabalSpecToVersionDigits CabalSpecVersion
cabalSpecLatest

#if !MIN_VERSION_Cabal(3,4,0)
cabalSpecToVersionDigits :: CabalSpecVersion -> [Int]
cabalSpecToVersionDigits CabalSpecV3_0   = [3,0]
cabalSpecToVersionDigits CabalSpecV2_4   = [2,4]
cabalSpecToVersionDigits CabalSpecV2_2   = [2,2]
cabalSpecToVersionDigits CabalSpecV2_0   = [2,0]
cabalSpecToVersionDigits CabalSpecV1_24  = [1,24]
cabalSpecToVersionDigits CabalSpecV1_22  = [1,22]
cabalSpecToVersionDigits CabalSpecV1_20  = [1,20]
cabalSpecToVersionDigits CabalSpecV1_18  = [1,18]
cabalSpecToVersionDigits CabalSpecV1_12  = [1,12]
cabalSpecToVersionDigits CabalSpecV1_10  = [1,10]
cabalSpecToVersionDigits CabalSpecV1_8   = [1,8]
cabalSpecToVersionDigits CabalSpecV1_6   = [1,6]
cabalSpecToVersionDigits CabalSpecV1_4   = [1,4]
cabalSpecToVersionDigits CabalSpecV1_2   = [1,2]
cabalSpecToVersionDigits CabalSpecV1_0   = [1,0]
#endif

data BuildFile = BFCabal !SafeFilePath !TreeEntry
               | BFHpack !TreeEntry -- We don't need SafeFilePath for Hpack since it has to be package.yaml file

  deriving (Int -> BuildFile -> ShowS
[BuildFile] -> ShowS
BuildFile -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [BuildFile] -> ShowS
$cshowList :: [BuildFile] -> ShowS
show :: BuildFile -> [Char]
$cshow :: BuildFile -> [Char]
showsPrec :: Int -> BuildFile -> ShowS
$cshowsPrec :: Int -> BuildFile -> ShowS
Show, BuildFile -> BuildFile -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: BuildFile -> BuildFile -> Bool
$c/= :: BuildFile -> BuildFile -> Bool
== :: BuildFile -> BuildFile -> Bool
$c== :: BuildFile -> BuildFile -> Bool
Eq)

data FileType = FTNormal | FTExecutable
  deriving (Int -> FileType -> ShowS
[FileType] -> ShowS
FileType -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FileType] -> ShowS
$cshowList :: [FileType] -> ShowS
show :: FileType -> [Char]
$cshow :: FileType -> [Char]
showsPrec :: Int -> FileType -> ShowS
$cshowsPrec :: Int -> FileType -> ShowS
Show, FileType -> FileType -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FileType -> FileType -> Bool
$c/= :: FileType -> FileType -> Bool
== :: FileType -> FileType -> Bool
$c== :: FileType -> FileType -> Bool
Eq, Int -> FileType
FileType -> Int
FileType -> [FileType]
FileType -> FileType
FileType -> FileType -> [FileType]
FileType -> FileType -> FileType -> [FileType]
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: FileType -> FileType -> FileType -> [FileType]
$cenumFromThenTo :: FileType -> FileType -> FileType -> [FileType]
enumFromTo :: FileType -> FileType -> [FileType]
$cenumFromTo :: FileType -> FileType -> [FileType]
enumFromThen :: FileType -> FileType -> [FileType]
$cenumFromThen :: FileType -> FileType -> [FileType]
enumFrom :: FileType -> [FileType]
$cenumFrom :: FileType -> [FileType]
fromEnum :: FileType -> Int
$cfromEnum :: FileType -> Int
toEnum :: Int -> FileType
$ctoEnum :: Int -> FileType
pred :: FileType -> FileType
$cpred :: FileType -> FileType
succ :: FileType -> FileType
$csucc :: FileType -> FileType
Enum, FileType
forall a. a -> a -> Bounded a
maxBound :: FileType
$cmaxBound :: FileType
minBound :: FileType
$cminBound :: FileType
Bounded, Eq FileType
FileType -> FileType -> Bool
FileType -> FileType -> Ordering
FileType -> FileType -> FileType
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: FileType -> FileType -> FileType
$cmin :: FileType -> FileType -> FileType
max :: FileType -> FileType -> FileType
$cmax :: FileType -> FileType -> FileType
>= :: FileType -> FileType -> Bool
$c>= :: FileType -> FileType -> Bool
> :: FileType -> FileType -> Bool
$c> :: FileType -> FileType -> Bool
<= :: FileType -> FileType -> Bool
$c<= :: FileType -> FileType -> Bool
< :: FileType -> FileType -> Bool
$c< :: FileType -> FileType -> Bool
compare :: FileType -> FileType -> Ordering
$ccompare :: FileType -> FileType -> Ordering
Ord)
instance PersistField FileType where
  toPersistValue :: FileType -> PersistValue
toPersistValue FileType
FTNormal = Int64 -> PersistValue
PersistInt64 Int64
1
  toPersistValue FileType
FTExecutable = Int64 -> PersistValue
PersistInt64 Int64
2

  fromPersistValue :: PersistValue -> Either Text FileType
fromPersistValue PersistValue
v = do
    Int64
i <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    case Int64
i :: Int64 of
      Int64
1 -> forall a b. b -> Either a b
Right FileType
FTNormal
      Int64
2 -> forall a b. b -> Either a b
Right FileType
FTExecutable
      Int64
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid FileType: " forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Text
tshow Int64
i
instance PersistFieldSql FileType where
  sqlType :: Proxy FileType -> SqlType
sqlType Proxy FileType
_ = SqlType
SqlInt32

data TreeEntry = TreeEntry
  { TreeEntry -> BlobKey
teBlob :: !BlobKey
  , TreeEntry -> FileType
teType :: !FileType
  }
  deriving (Int -> TreeEntry -> ShowS
[TreeEntry] -> ShowS
TreeEntry -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TreeEntry] -> ShowS
$cshowList :: [TreeEntry] -> ShowS
show :: TreeEntry -> [Char]
$cshow :: TreeEntry -> [Char]
showsPrec :: Int -> TreeEntry -> ShowS
$cshowsPrec :: Int -> TreeEntry -> ShowS
Show, TreeEntry -> TreeEntry -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeEntry -> TreeEntry -> Bool
$c/= :: TreeEntry -> TreeEntry -> Bool
== :: TreeEntry -> TreeEntry -> Bool
$c== :: TreeEntry -> TreeEntry -> Bool
Eq, Eq TreeEntry
TreeEntry -> TreeEntry -> Bool
TreeEntry -> TreeEntry -> Ordering
TreeEntry -> TreeEntry -> TreeEntry
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TreeEntry -> TreeEntry -> TreeEntry
$cmin :: TreeEntry -> TreeEntry -> TreeEntry
max :: TreeEntry -> TreeEntry -> TreeEntry
$cmax :: TreeEntry -> TreeEntry -> TreeEntry
>= :: TreeEntry -> TreeEntry -> Bool
$c>= :: TreeEntry -> TreeEntry -> Bool
> :: TreeEntry -> TreeEntry -> Bool
$c> :: TreeEntry -> TreeEntry -> Bool
<= :: TreeEntry -> TreeEntry -> Bool
$c<= :: TreeEntry -> TreeEntry -> Bool
< :: TreeEntry -> TreeEntry -> Bool
$c< :: TreeEntry -> TreeEntry -> Bool
compare :: TreeEntry -> TreeEntry -> Ordering
$ccompare :: TreeEntry -> TreeEntry -> Ordering
Ord)

newtype SafeFilePath = SafeFilePath Text
  deriving (Int -> SafeFilePath -> ShowS
[SafeFilePath] -> ShowS
SafeFilePath -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SafeFilePath] -> ShowS
$cshowList :: [SafeFilePath] -> ShowS
show :: SafeFilePath -> [Char]
$cshow :: SafeFilePath -> [Char]
showsPrec :: Int -> SafeFilePath -> ShowS
$cshowsPrec :: Int -> SafeFilePath -> ShowS
Show, SafeFilePath -> SafeFilePath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SafeFilePath -> SafeFilePath -> Bool
$c/= :: SafeFilePath -> SafeFilePath -> Bool
== :: SafeFilePath -> SafeFilePath -> Bool
$c== :: SafeFilePath -> SafeFilePath -> Bool
Eq, Eq SafeFilePath
SafeFilePath -> SafeFilePath -> Bool
SafeFilePath -> SafeFilePath -> Ordering
SafeFilePath -> SafeFilePath -> SafeFilePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SafeFilePath -> SafeFilePath -> SafeFilePath
$cmin :: SafeFilePath -> SafeFilePath -> SafeFilePath
max :: SafeFilePath -> SafeFilePath -> SafeFilePath
$cmax :: SafeFilePath -> SafeFilePath -> SafeFilePath
>= :: SafeFilePath -> SafeFilePath -> Bool
$c>= :: SafeFilePath -> SafeFilePath -> Bool
> :: SafeFilePath -> SafeFilePath -> Bool
$c> :: SafeFilePath -> SafeFilePath -> Bool
<= :: SafeFilePath -> SafeFilePath -> Bool
$c<= :: SafeFilePath -> SafeFilePath -> Bool
< :: SafeFilePath -> SafeFilePath -> Bool
$c< :: SafeFilePath -> SafeFilePath -> Bool
compare :: SafeFilePath -> SafeFilePath -> Ordering
$ccompare :: SafeFilePath -> SafeFilePath -> Ordering
Ord, SafeFilePath -> Text
SafeFilePath -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: SafeFilePath -> Text
$ctextDisplay :: SafeFilePath -> Text
display :: SafeFilePath -> Utf8Builder
$cdisplay :: SafeFilePath -> Utf8Builder
Display)

instance PersistField SafeFilePath where
  toPersistValue :: SafeFilePath -> PersistValue
toPersistValue = forall a. PersistField a => a -> PersistValue
toPersistValue forall b c a. (b -> c) -> (a -> b) -> a -> c
. SafeFilePath -> Text
unSafeFilePath
  fromPersistValue :: PersistValue -> Either Text SafeFilePath
fromPersistValue PersistValue
v = do
    Text
t <- forall a. PersistField a => PersistValue -> Either Text a
fromPersistValue PersistValue
v
    forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Invalid SafeFilePath: " forall a. Semigroup a => a -> a -> a
<> Text
t) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$ Text -> Maybe SafeFilePath
mkSafeFilePath Text
t
instance PersistFieldSql SafeFilePath where
  sqlType :: Proxy SafeFilePath -> SqlType
sqlType Proxy SafeFilePath
_ = SqlType
SqlString

unSafeFilePath :: SafeFilePath -> Text
unSafeFilePath :: SafeFilePath -> Text
unSafeFilePath (SafeFilePath Text
t) = Text
t

safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File)
safeFilePathToPath :: forall (m :: * -> *).
MonadThrow m =>
Path Abs Dir -> SafeFilePath -> m (Path Abs File)
safeFilePathToPath Path Abs Dir
dir (SafeFilePath Text
path) = do
  Path Rel File
fpath <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile (Text -> [Char]
T.unpack Text
path)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Path Abs Dir
dir forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
fpath

mkSafeFilePath :: Text -> Maybe SafeFilePath
mkSafeFilePath :: Text -> Maybe SafeFilePath
mkSafeFilePath Text
t = do
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"\\" Text -> Text -> Bool
`T.isInfixOf` Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"//" Text -> Text -> Bool
`T.isInfixOf` Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"\n" Text -> Text -> Bool
`T.isInfixOf` Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Text
"\0" Text -> Text -> Bool
`T.isInfixOf` Text
t

  (Char
c, Text
_) <- Text -> Maybe (Char, Text)
T.uncons Text
t
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Char
c forall a. Eq a => a -> a -> Bool
/= Char
'/'

  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Char -> Bool) -> Text -> Bool
T.all (forall a. Eq a => a -> a -> Bool
== Char
'.')) forall a b. (a -> b) -> a -> b
$ (Char -> Bool) -> Text -> [Text]
T.split (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
t

  forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Text -> SafeFilePath
SafeFilePath Text
t

-- | SafeFilePath for `package.yaml` file.

hpackSafeFilePath :: SafeFilePath
hpackSafeFilePath :: SafeFilePath
hpackSafeFilePath =
    let fpath :: Maybe SafeFilePath
fpath = Text -> Maybe SafeFilePath
mkSafeFilePath ([Char] -> Text
T.pack [Char]
Hpack.packageConfig)
    in case Maybe SafeFilePath
fpath of
         Maybe SafeFilePath
Nothing -> forall a. HasCallStack => [Char] -> a
error forall a b. (a -> b) -> a -> b
$ [Char]
"hpackSafeFilePath: Not able to encode " forall a. Semigroup a => a -> a -> a
<> ([Char]
Hpack.packageConfig)
         Just SafeFilePath
sfp -> SafeFilePath
sfp

-- | The hash of the binary representation of a 'Tree'.

--

-- @since 0.1.0.0

newtype TreeKey = TreeKey BlobKey
  deriving (Int -> TreeKey -> ShowS
[TreeKey] -> ShowS
TreeKey -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TreeKey] -> ShowS
$cshowList :: [TreeKey] -> ShowS
show :: TreeKey -> [Char]
$cshow :: TreeKey -> [Char]
showsPrec :: Int -> TreeKey -> ShowS
$cshowsPrec :: Int -> TreeKey -> ShowS
Show, TreeKey -> TreeKey -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: TreeKey -> TreeKey -> Bool
$c/= :: TreeKey -> TreeKey -> Bool
== :: TreeKey -> TreeKey -> Bool
$c== :: TreeKey -> TreeKey -> Bool
Eq, Eq TreeKey
TreeKey -> TreeKey -> Bool
TreeKey -> TreeKey -> Ordering
TreeKey -> TreeKey -> TreeKey
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: TreeKey -> TreeKey -> TreeKey
$cmin :: TreeKey -> TreeKey -> TreeKey
max :: TreeKey -> TreeKey -> TreeKey
$cmax :: TreeKey -> TreeKey -> TreeKey
>= :: TreeKey -> TreeKey -> Bool
$c>= :: TreeKey -> TreeKey -> Bool
> :: TreeKey -> TreeKey -> Bool
$c> :: TreeKey -> TreeKey -> Bool
<= :: TreeKey -> TreeKey -> Bool
$c<= :: TreeKey -> TreeKey -> Bool
< :: TreeKey -> TreeKey -> Bool
$c< :: TreeKey -> TreeKey -> Bool
compare :: TreeKey -> TreeKey -> Ordering
$ccompare :: TreeKey -> TreeKey -> Ordering
Ord, forall x. Rep TreeKey x -> TreeKey
forall x. TreeKey -> Rep TreeKey x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep TreeKey x -> TreeKey
$cfrom :: forall x. TreeKey -> Rep TreeKey x
Generic, Typeable, [TreeKey] -> Encoding
[TreeKey] -> Value
TreeKey -> Encoding
TreeKey -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [TreeKey] -> Encoding
$ctoEncodingList :: [TreeKey] -> Encoding
toJSONList :: [TreeKey] -> Value
$ctoJSONList :: [TreeKey] -> Value
toEncoding :: TreeKey -> Encoding
$ctoEncoding :: TreeKey -> Encoding
toJSON :: TreeKey -> Value
$ctoJSON :: TreeKey -> Value
ToJSON, Value -> Parser [TreeKey]
Value -> Parser TreeKey
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [TreeKey]
$cparseJSONList :: Value -> Parser [TreeKey]
parseJSON :: Value -> Parser TreeKey
$cparseJSON :: Value -> Parser TreeKey
FromJSON, TreeKey -> ()
forall a. (a -> ()) -> NFData a
rnf :: TreeKey -> ()
$crnf :: TreeKey -> ()
NFData, TreeKey -> Text
TreeKey -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: TreeKey -> Text
$ctextDisplay :: TreeKey -> Text
display :: TreeKey -> Utf8Builder
$cdisplay :: TreeKey -> Utf8Builder
Display)

-- | Represents the contents of a tree, which is a mapping from

-- relative file paths to 'TreeEntry's.

--

-- @since 0.1.0.0

newtype Tree
  = TreeMap (Map SafeFilePath TreeEntry)
  -- In the future, consider allowing more lax parsing

  -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys

  -- TreeTarball !PackageTarball

  deriving (Int -> Tree -> ShowS
[Tree] -> ShowS
Tree -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [Tree] -> ShowS
$cshowList :: [Tree] -> ShowS
show :: Tree -> [Char]
$cshow :: Tree -> [Char]
showsPrec :: Int -> Tree -> ShowS
$cshowsPrec :: Int -> Tree -> ShowS
Show, Tree -> Tree -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Tree -> Tree -> Bool
$c/= :: Tree -> Tree -> Bool
== :: Tree -> Tree -> Bool
$c== :: Tree -> Tree -> Bool
Eq, Eq Tree
Tree -> Tree -> Bool
Tree -> Tree -> Ordering
Tree -> Tree -> Tree
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Tree -> Tree -> Tree
$cmin :: Tree -> Tree -> Tree
max :: Tree -> Tree -> Tree
$cmax :: Tree -> Tree -> Tree
>= :: Tree -> Tree -> Bool
$c>= :: Tree -> Tree -> Bool
> :: Tree -> Tree -> Bool
$c> :: Tree -> Tree -> Bool
<= :: Tree -> Tree -> Bool
$c<= :: Tree -> Tree -> Bool
< :: Tree -> Tree -> Bool
$c< :: Tree -> Tree -> Bool
compare :: Tree -> Tree -> Ordering
$ccompare :: Tree -> Tree -> Ordering
Ord)

renderTree :: Tree -> ByteString
renderTree :: Tree -> ByteString
renderTree = ByteString -> ByteString
BL.toStrict forall b c a. (b -> c) -> (a -> b) -> a -> c
. Builder -> ByteString
toLazyByteString forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tree -> Builder
go
  where
    go :: Tree -> Builder
    go :: Tree -> Builder
go (TreeMap Map SafeFilePath TreeEntry
m) = Builder
"map:" forall a. Semigroup a => a -> a -> a
<> forall m k a. Monoid m => (k -> a -> m) -> Map k a -> m
Map.foldMapWithKey SafeFilePath -> TreeEntry -> Builder
goEntry Map SafeFilePath TreeEntry
m

    goEntry :: SafeFilePath -> TreeEntry -> Builder
goEntry SafeFilePath
sfp (TreeEntry (BlobKey SHA256
sha (FileSize Word
size')) FileType
ft) =
      Text -> Builder
netstring (SafeFilePath -> Text
unSafeFilePath SafeFilePath
sfp) forall a. Semigroup a => a -> a -> a
<>
      ByteString -> Builder
byteString (SHA256 -> ByteString
SHA256.toRaw SHA256
sha) forall a. Semigroup a => a -> a -> a
<>
      Word -> Builder
netword Word
size' forall a. Semigroup a => a -> a -> a
<>
      (case FileType
ft of
         FileType
FTNormal -> Builder
"N"
         FileType
FTExecutable -> Builder
"X")

netstring :: Text -> Builder
netstring :: Text -> Builder
netstring Text
t =
  let bs :: ByteString
bs = Text -> ByteString
encodeUtf8 Text
t
   in Word -> Builder
netword (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)) forall a. Semigroup a => a -> a -> a
<> ByteString -> Builder
byteString ByteString
bs

netword :: Word -> Builder
netword :: Word -> Builder
netword Word
w = Word -> Builder
wordDec Word
w forall a. Semigroup a => a -> a -> a
<> Builder
":"

parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM :: forall (m :: * -> *).
MonadThrow m =>
(BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM (BlobKey
blobKey, ByteString
blob) =
  case ByteString -> Maybe Tree
parseTree ByteString
blob of
    Maybe Tree
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (BlobKey -> ByteString -> PantryException
InvalidTreeFromCasa BlobKey
blobKey ByteString
blob)
    Just Tree
tree -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (BlobKey -> TreeKey
TreeKey BlobKey
blobKey, Tree
tree)

parseTree :: ByteString -> Maybe Tree
parseTree :: ByteString -> Maybe Tree
parseTree ByteString
bs1 = do
  Tree
tree <- ByteString -> Maybe Tree
parseTree' ByteString
bs1
  let bs2 :: ByteString
bs2 = Tree -> ByteString
renderTree Tree
tree
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ByteString
bs1 forall a. Eq a => a -> a -> Bool
== ByteString
bs2
  forall a. a -> Maybe a
Just Tree
tree

parseTree' :: ByteString -> Maybe Tree
parseTree' :: ByteString -> Maybe Tree
parseTree' ByteString
bs0 = do
  ByteString
entriesBS <- ByteString -> ByteString -> Maybe ByteString
B.stripPrefix ByteString
"map:" ByteString
bs0
  Map SafeFilePath TreeEntry -> Tree
TreeMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map SafeFilePath TreeEntry
-> ByteString -> Maybe (Map SafeFilePath TreeEntry)
loop forall k a. Map k a
Map.empty ByteString
entriesBS
  where
    loop :: Map SafeFilePath TreeEntry
-> ByteString -> Maybe (Map SafeFilePath TreeEntry)
loop !Map SafeFilePath TreeEntry
m ByteString
bs1
      | ByteString -> Bool
B.null ByteString
bs1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Map SafeFilePath TreeEntry
m
      | Bool
otherwise = do
          (ByteString
sfpBS, ByteString
bs2) <- ByteString -> Maybe (ByteString, ByteString)
takeNetstring ByteString
bs1
          SafeFilePath
sfp <-
            case ByteString -> Either UnicodeException Text
decodeUtf8' ByteString
sfpBS of
              Left UnicodeException
_ -> forall a. Maybe a
Nothing
              Right Text
sfpT -> Text -> Maybe SafeFilePath
mkSafeFilePath Text
sfpT
          (SHA256
sha, ByteString
bs3) <- ByteString -> Maybe (SHA256, ByteString)
takeSha ByteString
bs2
          (Int
size', ByteString
bs4) <- ByteString -> Maybe (Int, ByteString)
takeNetword ByteString
bs3
          (Word8
typeW, ByteString
bs5) <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs4
          FileType
ft <-
            case Word8
typeW of
              Word8
78 -> forall a. a -> Maybe a
Just FileType
FTNormal -- 'N'

              Word8
88 -> forall a. a -> Maybe a
Just FileType
FTExecutable -- 'X'

              Word8
_ -> forall a. Maybe a
Nothing
          let entry :: TreeEntry
entry = BlobKey -> FileType -> TreeEntry
TreeEntry (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha (Word -> FileSize
FileSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
size'))) FileType
ft
          Map SafeFilePath TreeEntry
-> ByteString -> Maybe (Map SafeFilePath TreeEntry)
loop (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert SafeFilePath
sfp TreeEntry
entry Map SafeFilePath TreeEntry
m) ByteString
bs5

    takeNetstring :: ByteString -> Maybe (ByteString, ByteString)
takeNetstring ByteString
bs1 = do
      (Int
size', ByteString
bs2) <- ByteString -> Maybe (Int, ByteString)
takeNetword ByteString
bs1
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ ByteString -> Int
B.length ByteString
bs2 forall a. Ord a => a -> a -> Bool
>= Int
size'
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
size' ByteString
bs2

    takeSha :: ByteString -> Maybe (SHA256, ByteString)
takeSha ByteString
bs = do
      let (ByteString
x, ByteString
y) = Int -> ByteString -> (ByteString, ByteString)
B.splitAt Int
32 ByteString
bs
      SHA256
x' <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just (ByteString -> Either SHA256Exception SHA256
SHA256.fromRaw ByteString
x)
      forall a. a -> Maybe a
Just (SHA256
x', ByteString
y)

    takeNetword :: ByteString -> Maybe (Int, ByteString)
takeNetword =
      forall {t}. Num t => t -> ByteString -> Maybe (t, ByteString)
go Int
0
      where
        go :: t -> ByteString -> Maybe (t, ByteString)
go !t
accum ByteString
bs = do
          (Word8
next, ByteString
rest) <- ByteString -> Maybe (Word8, ByteString)
B.uncons ByteString
bs
          if
            | Word8
next forall a. Eq a => a -> a -> Bool
== Word8
58 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (t
accum, ByteString
rest) -- ':'

            | Word8
next forall a. Ord a => a -> a -> Bool
>= Word8
48 Bool -> Bool -> Bool
&& Word8
next forall a. Ord a => a -> a -> Bool
<= Word8
57 ->
                t -> ByteString -> Maybe (t, ByteString)
go
                  (t
accum forall a. Num a => a -> a -> a
* t
10 forall a. Num a => a -> a -> a
+ forall a b. (Integral a, Num b) => a -> b
fromIntegral (Word8
next forall a. Num a => a -> a -> a
- Word8
48))
                  ByteString
rest
            | Bool
otherwise -> forall a. Maybe a
Nothing

    {-
data PackageTarball = PackageTarball
  { ptBlob :: !BlobKey
  -- ^ Contains the tarball itself
  , ptCabal :: !BlobKey
  -- ^ Contains the cabal file contents
  , ptSubdir :: !FilePath
  -- ^ Subdir containing the files we want for this package.
  --
  -- There must be precisely one file with a @.cabal@ file extension
  -- located there. Thanks to Hackage revisions, its contents will be
  -- overwritten by the value of @ptCabal@.
  }
  deriving Show
    -}

-- | This is almost a copy of Cabal's parser for package identifiers,

-- the main difference is in the fact that Stack requires version to be

-- present while Cabal uses "null version" as a default value

--

-- @since 0.1.0.0

parsePackageIdentifier :: String -> Maybe PackageIdentifier
parsePackageIdentifier :: [Char] -> Maybe PackageIdentifier
parsePackageIdentifier = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ParsecParser a -> [Char] -> Either [Char] a
explicitEitherParsec (ParsecParser PackageIdentifier
packageIdentifierParsec forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* forall (m :: * -> *). Parsing m => m ()
Parse.eof)

packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec = do
  ident :: PackageIdentifier
ident@(PackageIdentifier PackageName
_ Version
v) <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec

  -- version is a required component of a package identifier for Stack

  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Version
v forall a. Eq a => a -> a -> Bool
/= Version
nullVersion)

  forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageIdentifier
ident

-- | Parse a package name from a 'String'.

--

-- @since 0.1.0.0

parsePackageName :: String -> Maybe PackageName
parsePackageName :: [Char] -> Maybe PackageName
parsePackageName = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a package name from a 'String' throwing on failure

--

-- @since 0.1.0.0

parsePackageNameThrowing :: MonadThrow m => String -> m PackageName
parsePackageNameThrowing :: forall (m :: * -> *). MonadThrow m => [Char] -> m PackageName
parsePackageNameThrowing [Char]
str =
  case [Char] -> Maybe PackageName
parsePackageName [Char]
str of
    Maybe PackageName
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageNameParseFail forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
str
    Just PackageName
pn -> forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageName
pn

-- | Parse a version from a 'String'.

--

-- @since 0.1.0.0

parseVersion :: String -> Maybe Version
parseVersion :: [Char] -> Maybe Version
parseVersion = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a package version from a 'String' throwing on failure

--

-- @since 0.1.0.0

parseVersionThrowing :: MonadThrow m => String -> m Version
parseVersionThrowing :: forall (m :: * -> *). MonadThrow m => [Char] -> m Version
parseVersionThrowing [Char]
str =
  case [Char] -> Maybe Version
parseVersion [Char]
str of
    Maybe Version
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> PantryException
PackageVersionParseFail forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack [Char]
str
    Just Version
v -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Version
v

-- | Parse a version range from a 'String'.

--

-- @since 0.1.0.0

parseVersionRange :: String -> Maybe VersionRange
parseVersionRange :: [Char] -> Maybe VersionRange
parseVersionRange = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a module name from a 'String'.

--

-- @since 0.1.0.0

parseModuleName :: String -> Maybe ModuleName
parseModuleName :: [Char] -> Maybe ModuleName
parseModuleName = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Parse a flag name from a 'String'.

--

-- @since 0.1.0.0

parseFlagName :: String -> Maybe FlagName
parseFlagName :: [Char] -> Maybe FlagName
parseFlagName = forall a. Parsec a => [Char] -> Maybe a
Distribution.Text.simpleParse

-- | Render a package name as a 'String'.

--

-- @since 0.1.0.0

packageNameString :: PackageName -> String
packageNameString :: PackageName -> [Char]
packageNameString = PackageName -> [Char]
unPackageName

-- | Render a package identifier as a 'String'.

--

-- @since 0.1.0.0

packageIdentifierString :: PackageIdentifier -> String
packageIdentifierString :: PackageIdentifier -> [Char]
packageIdentifierString = forall a. Pretty a => a -> [Char]
Distribution.Text.display

-- | Render a version as a 'String'.

--

-- @since 0.1.0.0

versionString :: Version -> String
versionString :: Version -> [Char]
versionString = forall a. Pretty a => a -> [Char]
Distribution.Text.display

-- | Render a flag name as a 'String'.

--

-- @since 0.1.0.0

flagNameString :: FlagName -> String
flagNameString :: FlagName -> [Char]
flagNameString = FlagName -> [Char]
unFlagName

-- | Render a module name as a 'String'.

--

-- @since 0.1.0.0

moduleNameString :: ModuleName -> String
moduleNameString :: ModuleName -> [Char]
moduleNameString = forall a. Pretty a => a -> [Char]
Distribution.Text.display

data OptionalSubdirs
  = OSSubdirs !(NonEmpty Text)
  | OSPackageMetadata !Text !RawPackageMetadata
  -- ^ subdirectory and package metadata

  deriving (Int -> OptionalSubdirs -> ShowS
[OptionalSubdirs] -> ShowS
OptionalSubdirs -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [OptionalSubdirs] -> ShowS
$cshowList :: [OptionalSubdirs] -> ShowS
show :: OptionalSubdirs -> [Char]
$cshow :: OptionalSubdirs -> [Char]
showsPrec :: Int -> OptionalSubdirs -> ShowS
$cshowsPrec :: Int -> OptionalSubdirs -> ShowS
Show, OptionalSubdirs -> OptionalSubdirs -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: OptionalSubdirs -> OptionalSubdirs -> Bool
$c/= :: OptionalSubdirs -> OptionalSubdirs -> Bool
== :: OptionalSubdirs -> OptionalSubdirs -> Bool
$c== :: OptionalSubdirs -> OptionalSubdirs -> Bool
Eq, forall x. Rep OptionalSubdirs x -> OptionalSubdirs
forall x. OptionalSubdirs -> Rep OptionalSubdirs x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep OptionalSubdirs x -> OptionalSubdirs
$cfrom :: forall x. OptionalSubdirs -> Rep OptionalSubdirs x
Generic)
instance NFData OptionalSubdirs

-- | Metadata provided by a config file for archives and repos. This

-- information can be used for optimized lookups of information like

-- package identifiers, or for validating that the user configuration

-- has the expected information.

--

-- @since 0.1.0.0

data RawPackageMetadata = RawPackageMetadata
  { RawPackageMetadata -> Maybe PackageName
rpmName :: !(Maybe PackageName)
    -- ^ Package name in the cabal file

    --

    -- @since 0.1.0.0

  , RawPackageMetadata -> Maybe Version
rpmVersion :: !(Maybe Version)
    -- ^ Package version in the cabal file

    --

    -- @since 0.1.0.0

  , RawPackageMetadata -> Maybe TreeKey
rpmTreeKey :: !(Maybe TreeKey)
    -- ^ Tree key of the loaded up package

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> RawPackageMetadata -> ShowS
[RawPackageMetadata] -> ShowS
RawPackageMetadata -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawPackageMetadata] -> ShowS
$cshowList :: [RawPackageMetadata] -> ShowS
show :: RawPackageMetadata -> [Char]
$cshow :: RawPackageMetadata -> [Char]
showsPrec :: Int -> RawPackageMetadata -> ShowS
$cshowsPrec :: Int -> RawPackageMetadata -> ShowS
Show, RawPackageMetadata -> RawPackageMetadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c/= :: RawPackageMetadata -> RawPackageMetadata -> Bool
== :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c== :: RawPackageMetadata -> RawPackageMetadata -> Bool
Eq, Eq RawPackageMetadata
RawPackageMetadata -> RawPackageMetadata -> Bool
RawPackageMetadata -> RawPackageMetadata -> Ordering
RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
$cmin :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
max :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
$cmax :: RawPackageMetadata -> RawPackageMetadata -> RawPackageMetadata
>= :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c>= :: RawPackageMetadata -> RawPackageMetadata -> Bool
> :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c> :: RawPackageMetadata -> RawPackageMetadata -> Bool
<= :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c<= :: RawPackageMetadata -> RawPackageMetadata -> Bool
< :: RawPackageMetadata -> RawPackageMetadata -> Bool
$c< :: RawPackageMetadata -> RawPackageMetadata -> Bool
compare :: RawPackageMetadata -> RawPackageMetadata -> Ordering
$ccompare :: RawPackageMetadata -> RawPackageMetadata -> Ordering
Ord, forall x. Rep RawPackageMetadata x -> RawPackageMetadata
forall x. RawPackageMetadata -> Rep RawPackageMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawPackageMetadata x -> RawPackageMetadata
$cfrom :: forall x. RawPackageMetadata -> Rep RawPackageMetadata x
Generic, Typeable)
instance NFData RawPackageMetadata

instance Display RawPackageMetadata where
  display :: RawPackageMetadata -> Utf8Builder
display RawPackageMetadata
rpm = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes
    [ (\PackageName
name -> Utf8Builder
"name == " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageName -> [Char]
packageNameString PackageName
name)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageMetadata -> Maybe PackageName
rpmName RawPackageMetadata
rpm
    , (\Version
version -> Utf8Builder
"version == " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
version)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageMetadata -> Maybe Version
rpmVersion RawPackageMetadata
rpm
    , (\TreeKey
tree -> Utf8Builder
"tree == " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display TreeKey
tree) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RawPackageMetadata -> Maybe TreeKey
rpmTreeKey RawPackageMetadata
rpm
    ]

-- | Exact metadata specifying concrete package

--

-- @since 0.1.0.0

data PackageMetadata = PackageMetadata
  { PackageMetadata -> PackageIdentifier
pmIdent :: !PackageIdentifier
    -- ^ Package identifier in the cabal file

    --

    -- @since 0.1.0.0

  , PackageMetadata -> TreeKey
pmTreeKey :: !TreeKey
    -- ^ Tree key of the loaded up package

    --

    -- @since 0.1.0.0

  }
  deriving (Int -> PackageMetadata -> ShowS
[PackageMetadata] -> ShowS
PackageMetadata -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PackageMetadata] -> ShowS
$cshowList :: [PackageMetadata] -> ShowS
show :: PackageMetadata -> [Char]
$cshow :: PackageMetadata -> [Char]
showsPrec :: Int -> PackageMetadata -> ShowS
$cshowsPrec :: Int -> PackageMetadata -> ShowS
Show, PackageMetadata -> PackageMetadata -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PackageMetadata -> PackageMetadata -> Bool
$c/= :: PackageMetadata -> PackageMetadata -> Bool
== :: PackageMetadata -> PackageMetadata -> Bool
$c== :: PackageMetadata -> PackageMetadata -> Bool
Eq, Eq PackageMetadata
PackageMetadata -> PackageMetadata -> Bool
PackageMetadata -> PackageMetadata -> Ordering
PackageMetadata -> PackageMetadata -> PackageMetadata
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PackageMetadata -> PackageMetadata -> PackageMetadata
$cmin :: PackageMetadata -> PackageMetadata -> PackageMetadata
max :: PackageMetadata -> PackageMetadata -> PackageMetadata
$cmax :: PackageMetadata -> PackageMetadata -> PackageMetadata
>= :: PackageMetadata -> PackageMetadata -> Bool
$c>= :: PackageMetadata -> PackageMetadata -> Bool
> :: PackageMetadata -> PackageMetadata -> Bool
$c> :: PackageMetadata -> PackageMetadata -> Bool
<= :: PackageMetadata -> PackageMetadata -> Bool
$c<= :: PackageMetadata -> PackageMetadata -> Bool
< :: PackageMetadata -> PackageMetadata -> Bool
$c< :: PackageMetadata -> PackageMetadata -> Bool
compare :: PackageMetadata -> PackageMetadata -> Ordering
$ccompare :: PackageMetadata -> PackageMetadata -> Ordering
Ord, forall x. Rep PackageMetadata x -> PackageMetadata
forall x. PackageMetadata -> Rep PackageMetadata x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PackageMetadata x -> PackageMetadata
$cfrom :: forall x. PackageMetadata -> Rep PackageMetadata x
Generic, Typeable)
-- i PackageMetadata

instance NFData PackageMetadata

instance Display PackageMetadata where
  display :: PackageMetadata -> Utf8Builder
display PackageMetadata
pm = forall (t :: * -> *) m. (Foldable t, Monoid m) => t m -> m
fold forall a b. (a -> b) -> a -> b
$ forall a. a -> [a] -> [a]
intersperse Utf8Builder
", " forall a b. (a -> b) -> a -> b
$
    [ Utf8Builder
"ident == " forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (PackageIdentifier -> [Char]
packageIdentifierString forall a b. (a -> b) -> a -> b
$ PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm)
    , Utf8Builder
"tree == " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display (PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm)
    ]

parsePackageMetadata :: Object -> WarningParser PackageMetadata
parsePackageMetadata :: Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o = do
  Maybe BlobKey
_oldCabalFile :: Maybe BlobKey <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"cabal-file"
  BlobKey
pantryTree :: BlobKey <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"pantry-tree"
  CabalString PackageName
pkgName <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"name"
  CabalString Version
pkgVersion <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"version"
  let pmTreeKey :: TreeKey
pmTreeKey = BlobKey -> TreeKey
TreeKey BlobKey
pantryTree
      pmIdent :: PackageIdentifier
pmIdent = PackageIdentifier {PackageName
Version
pkgVersion :: Version
pkgVersion :: Version
pkgName :: PackageName
pkgName :: PackageName
..}
  forall (f :: * -> *) a. Applicative f => a -> f a
pure PackageMetadata {PackageIdentifier
TreeKey
pmIdent :: PackageIdentifier
pmTreeKey :: TreeKey
pmTreeKey :: TreeKey
pmIdent :: PackageIdentifier
..}


-- | Convert package metadata to its "raw" equivalent.

--

-- @since 0.1.0.0

toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM PackageMetadata
pm = Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata (forall a. a -> Maybe a
Just PackageName
name) (forall a. a -> Maybe a
Just Version
version) (forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ PackageMetadata -> TreeKey
pmTreeKey PackageMetadata
pm)
  where
    PackageIdentifier PackageName
name Version
version = PackageMetadata -> PackageIdentifier
pmIdent PackageMetadata
pm

-- | File path relative to the configuration file it was parsed from

--

-- @since 0.1.0.0

newtype RelFilePath = RelFilePath Text
  deriving (Int -> RelFilePath -> ShowS
[RelFilePath] -> ShowS
RelFilePath -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RelFilePath] -> ShowS
$cshowList :: [RelFilePath] -> ShowS
show :: RelFilePath -> [Char]
$cshow :: RelFilePath -> [Char]
showsPrec :: Int -> RelFilePath -> ShowS
$cshowsPrec :: Int -> RelFilePath -> ShowS
Show, [RelFilePath] -> Encoding
[RelFilePath] -> Value
RelFilePath -> Encoding
RelFilePath -> Value
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [RelFilePath] -> Encoding
$ctoEncodingList :: [RelFilePath] -> Encoding
toJSONList :: [RelFilePath] -> Value
$ctoJSONList :: [RelFilePath] -> Value
toEncoding :: RelFilePath -> Encoding
$ctoEncoding :: RelFilePath -> Encoding
toJSON :: RelFilePath -> Value
$ctoJSON :: RelFilePath -> Value
ToJSON, Value -> Parser [RelFilePath]
Value -> Parser RelFilePath
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [RelFilePath]
$cparseJSONList :: Value -> Parser [RelFilePath]
parseJSON :: Value -> Parser RelFilePath
$cparseJSON :: Value -> Parser RelFilePath
FromJSON, RelFilePath -> RelFilePath -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RelFilePath -> RelFilePath -> Bool
$c/= :: RelFilePath -> RelFilePath -> Bool
== :: RelFilePath -> RelFilePath -> Bool
$c== :: RelFilePath -> RelFilePath -> Bool
Eq, Eq RelFilePath
RelFilePath -> RelFilePath -> Bool
RelFilePath -> RelFilePath -> Ordering
RelFilePath -> RelFilePath -> RelFilePath
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RelFilePath -> RelFilePath -> RelFilePath
$cmin :: RelFilePath -> RelFilePath -> RelFilePath
max :: RelFilePath -> RelFilePath -> RelFilePath
$cmax :: RelFilePath -> RelFilePath -> RelFilePath
>= :: RelFilePath -> RelFilePath -> Bool
$c>= :: RelFilePath -> RelFilePath -> Bool
> :: RelFilePath -> RelFilePath -> Bool
$c> :: RelFilePath -> RelFilePath -> Bool
<= :: RelFilePath -> RelFilePath -> Bool
$c<= :: RelFilePath -> RelFilePath -> Bool
< :: RelFilePath -> RelFilePath -> Bool
$c< :: RelFilePath -> RelFilePath -> Bool
compare :: RelFilePath -> RelFilePath -> Ordering
$ccompare :: RelFilePath -> RelFilePath -> Ordering
Ord, forall x. Rep RelFilePath x -> RelFilePath
forall x. RelFilePath -> Rep RelFilePath x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RelFilePath x -> RelFilePath
$cfrom :: forall x. RelFilePath -> Rep RelFilePath x
Generic, Typeable, RelFilePath -> ()
forall a. (a -> ()) -> NFData a
rnf :: RelFilePath -> ()
$crnf :: RelFilePath -> ()
NFData, RelFilePath -> Text
RelFilePath -> Utf8Builder
forall a. (a -> Utf8Builder) -> (a -> Text) -> Display a
textDisplay :: RelFilePath -> Text
$ctextDisplay :: RelFilePath -> Text
display :: RelFilePath -> Utf8Builder
$cdisplay :: RelFilePath -> Utf8Builder
Display)

-- | Location that an archive is stored at

--

-- @since 0.1.0.0

data ArchiveLocation
  = ALUrl !Text
    -- ^ Archive stored at an HTTP(S) URL

    --

    -- @since 0.1.0.0

  | ALFilePath !(ResolvedPath File)
    -- ^ Archive stored at a local file path

    --

    -- @since 0.1.0.0

  deriving (Int -> ArchiveLocation -> ShowS
[ArchiveLocation] -> ShowS
ArchiveLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [ArchiveLocation] -> ShowS
$cshowList :: [ArchiveLocation] -> ShowS
show :: ArchiveLocation -> [Char]
$cshow :: ArchiveLocation -> [Char]
showsPrec :: Int -> ArchiveLocation -> ShowS
$cshowsPrec :: Int -> ArchiveLocation -> ShowS
Show, ArchiveLocation -> ArchiveLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ArchiveLocation -> ArchiveLocation -> Bool
$c/= :: ArchiveLocation -> ArchiveLocation -> Bool
== :: ArchiveLocation -> ArchiveLocation -> Bool
$c== :: ArchiveLocation -> ArchiveLocation -> Bool
Eq, Eq ArchiveLocation
ArchiveLocation -> ArchiveLocation -> Bool
ArchiveLocation -> ArchiveLocation -> Ordering
ArchiveLocation -> ArchiveLocation -> ArchiveLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
$cmin :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
max :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
$cmax :: ArchiveLocation -> ArchiveLocation -> ArchiveLocation
>= :: ArchiveLocation -> ArchiveLocation -> Bool
$c>= :: ArchiveLocation -> ArchiveLocation -> Bool
> :: ArchiveLocation -> ArchiveLocation -> Bool
$c> :: ArchiveLocation -> ArchiveLocation -> Bool
<= :: ArchiveLocation -> ArchiveLocation -> Bool
$c<= :: ArchiveLocation -> ArchiveLocation -> Bool
< :: ArchiveLocation -> ArchiveLocation -> Bool
$c< :: ArchiveLocation -> ArchiveLocation -> Bool
compare :: ArchiveLocation -> ArchiveLocation -> Ordering
$ccompare :: ArchiveLocation -> ArchiveLocation -> Ordering
Ord, forall x. Rep ArchiveLocation x -> ArchiveLocation
forall x. ArchiveLocation -> Rep ArchiveLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep ArchiveLocation x -> ArchiveLocation
$cfrom :: forall x. ArchiveLocation -> Rep ArchiveLocation x
Generic, Typeable)
instance NFData ArchiveLocation

instance Display ArchiveLocation where
  display :: ArchiveLocation -> Utf8Builder
display (ALUrl Text
url) = forall a. Display a => a -> Utf8Builder
display Text
url
  display (ALFilePath ResolvedPath File
resolved) = forall a. IsString a => [Char] -> a
fromString forall a b. (a -> b) -> a -> b
$ forall b t. Path b t -> [Char]
toFilePath forall a b. (a -> b) -> a -> b
$ forall t. ResolvedPath t -> Path Abs t
resolvedAbsolute ResolvedPath File
resolved

parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject :: Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject Object
o =
    ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"url") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
validateUrl) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"filepath") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"archive") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    ((Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"location") forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText)

parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText :: Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText Text
t =
  case Text -> Either Text (Unresolved ArchiveLocation)
validateUrl Text
t of
    Left Text
e1 ->
      case Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath Text
t of
        Left Text
e2 -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.unlines
          [ Text
"Invalid archive location, neither a URL nor a file path"
          , Text
"  URL error: " forall a. Semigroup a => a -> a -> a
<> Text
e1
          , Text
"  File path error: " forall a. Semigroup a => a -> a -> a
<> Text
e2
          ]
        Right Unresolved ArchiveLocation
x -> forall a b. b -> Either a b
Right Unresolved ArchiveLocation
x
    Right Unresolved ArchiveLocation
x -> forall a b. b -> Either a b
Right Unresolved ArchiveLocation
x

validateUrl :: Text -> Either Text (Unresolved ArchiveLocation)
validateUrl :: Text -> Either Text (Unresolved ArchiveLocation)
validateUrl Text
t =
  case forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
    Left SomeException
_ -> forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Could not parse URL: " forall a. Semigroup a => a -> a -> a
<> Text
t
    Right Request
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> ArchiveLocation
ALUrl Text
t

validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath Text
t =
  if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Text
ext -> Text
ext Text -> Text -> Bool
`T.isSuffixOf` Text
t) (Text -> [Text]
T.words Text
".zip .tar .tar.gz")
    then forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir ->
           case Maybe (Path Abs Dir)
mdir of
             Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidFilePathSnapshot Text
t
             Just Path Abs Dir
dir -> do
               Path Abs File
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
dir forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
               forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> ArchiveLocation
ALFilePath forall a b. (a -> b) -> a -> b
$ forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
t) Path Abs File
abs'
    else forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text
"Does not have an archive file extension: " forall a. Semigroup a => a -> a -> a
<> Text
t

instance ToJSON RawPackageLocation where
  toJSON :: RawPackageLocation -> Value
toJSON (RPLImmutable RawPackageLocationImmutable
rpli) = forall a. ToJSON a => a -> Value
toJSON RawPackageLocationImmutable
rpli
  toJSON (RPLMutable ResolvedPath Dir
resolved) = forall a. ToJSON a => a -> Value
toJSON (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath Dir
resolved)
instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where
  parseJSON :: Value
-> Parser
     (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation)))
parseJSON Value
v =
    ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmapforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) RawPackageLocationImmutable -> RawPackageLocation
RPLImmutable (forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
    ((forall a. a -> WithJSONWarnings a
noJSONWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Unresolved (NonEmpty RawPackageLocation)
mkMutable) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. FromJSON a => Value -> Parser a
parseJSON Value
v)
    where
      mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation)
      mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation)
mkMutable Text
t = forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
        case Maybe (Path Abs Dir)
mdir of
          Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
MutablePackageLocationFromUrl Text
t
          Just Path Abs Dir
dir -> do
            Path Abs Dir
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs Dir)
resolveDir Path Abs Dir
dir forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath Dir -> RawPackageLocation
RPLMutable forall a b. (a -> b) -> a -> b
$ forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
t) Path Abs Dir
abs'

instance ToJSON RawPackageLocationImmutable where
  toJSON :: RawPackageLocationImmutable -> Value
toJSON (RPLIHackage PackageIdentifierRevision
pir Maybe TreeKey
mtree) = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [AesonKey
"hackage" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= PackageIdentifierRevision
pir]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\TreeKey
tree -> [AesonKey
"pantry-tree" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= TreeKey
tree]) Maybe TreeKey
mtree
    ]
  toJSON (RPLIArchive (RawArchive ArchiveLocation
loc Maybe SHA256
msha Maybe FileSize
msize Text
subdir) RawPackageMetadata
rpm) = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ case ArchiveLocation
loc of
        ALUrl Text
url -> [AesonKey
"url" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
url]
        ALFilePath ResolvedPath File
resolved -> [AesonKey
"filepath" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\SHA256
sha -> [AesonKey
"sha256" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SHA256
sha]) Maybe SHA256
msha
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\FileSize
size' -> [AesonKey
"size" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= FileSize
size']) Maybe FileSize
msize
    , if Text -> Bool
T.null Text
subdir then [] else [AesonKey
"subdir" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
subdir]
    , RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs RawPackageMetadata
rpm
    ]
  toJSON (RPLIRepo (Repo Text
url Text
commit RepoType
typ Text
subdir) RawPackageMetadata
rpm) = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [ AesonKey
urlKey forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
url
      , AesonKey
"commit" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
commit
      ]
    , if Text -> Bool
T.null Text
subdir then [] else [AesonKey
"subdir" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
subdir]
    , RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs RawPackageMetadata
rpm
    ]
    where
      urlKey :: AesonKey
urlKey =
        case RepoType
typ of
          RepoType
RepoGit -> AesonKey
"git"
          RepoType
RepoHg  -> AesonKey
"hg"

rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs (RawPackageMetadata Maybe PackageName
mname Maybe Version
mversion Maybe TreeKey
mtree) = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
  [ forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\PackageName
name -> [AesonKey
"name" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a. a -> CabalString a
CabalString PackageName
name]) Maybe PackageName
mname
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\Version
version -> [AesonKey
"version" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a. a -> CabalString a
CabalString Version
version]) Maybe Version
mversion
  , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\TreeKey
tree -> [AesonKey
"pantry-tree" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= TreeKey
tree]) Maybe TreeKey
mtree
  ]

instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where
    parseJSON :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
parseJSON Value
v = Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
repoObject Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
archiveObject Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
hackageObject Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall {f :: * -> *}.
Applicative f =>
Value -> Parser (WithJSONWarnings (f PackageLocationImmutable))
github Value
v
                  forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Could not parse a UnresolvedPackageLocationImmutable from: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
v)
        where
          repoObject :: Value -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
          repoObject :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
repoObject = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.PLIRepo" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
            PackageMetadata
pm <- Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o
            Text
repoSubdir <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
""
            Text
repoCommit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
            (RepoType
repoType, Text
repoUrl) <-
                (Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"git" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
url -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoType
RepoGit, Text
url)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
                (Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hg" forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Text
url -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RepoType
RepoHg, Text
url))
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Repo -> PackageMetadata -> PackageLocationImmutable
PLIRepo Repo {Text
RepoType
repoUrl :: Text
repoType :: RepoType
repoCommit :: Text
repoSubdir :: Text
repoType :: RepoType
repoSubdir :: Text
repoCommit :: Text
repoUrl :: Text
..} PackageMetadata
pm

          archiveObject :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
archiveObject =
            forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.PLIArchive" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
              PackageMetadata
pm <- Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o
              Unresolved Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation <- Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject Object
o
              SHA256
archiveHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"sha256"
              FileSize
archiveSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"size"
              Text
archiveSubdir <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
""
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
                ArchiveLocation
archiveLocation <- Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation Maybe (Path Abs Dir)
mdir
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive Archive {Text
SHA256
ArchiveLocation
FileSize
archiveLocation :: ArchiveLocation
archiveSubdir :: Text
archiveSize :: FileSize
archiveHash :: SHA256
archiveSize :: FileSize
archiveHash :: SHA256
archiveSubdir :: Text
archiveLocation :: ArchiveLocation
..} PackageMetadata
pm

          hackageObject :: Value
-> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
hackageObject =
             forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackagelocationimmutable.PLIHackage (Object)" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
                      BlobKey
treeKey <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"pantry-tree"
                      Text
htxt <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hackage"
                      case Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText Text
htxt of
                        Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PantryException
e
                        Right (PackageIdentifier
pkgIdentifier, BlobKey
blobKey) ->
                          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageIdentifier -> BlobKey -> TreeKey -> PackageLocationImmutable
PLIHackage PackageIdentifier
pkgIdentifier BlobKey
blobKey (BlobKey -> TreeKey
TreeKey BlobKey
treeKey)

          github :: Value -> Parser (WithJSONWarnings (f PackageLocationImmutable))
github Value
value =
            forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackagelocationimmutable.PLIArchive:github" (\Object
o -> do
              PackageMetadata
pm <- Object -> WarningParser PackageMetadata
parsePackageMetadata Object
o
              GitHubRepo Text
ghRepo <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"github"
              Text
commit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
              let archiveLocation :: ArchiveLocation
archiveLocation = Text -> ArchiveLocation
ALUrl forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
                    [ Text
"https://github.com/"
                    , Text
ghRepo
                    , Text
"/archive/"
                    , Text
commit
                    , Text
".tar.gz"
                    ]
              SHA256
archiveHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"sha256"
              FileSize
archiveSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"size"
              Text
archiveSubdir <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
""
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Archive -> PackageMetadata -> PackageLocationImmutable
PLIArchive Archive {Text
SHA256
ArchiveLocation
FileSize
archiveSubdir :: Text
archiveSize :: FileSize
archiveHash :: SHA256
archiveLocation :: ArchiveLocation
archiveSize :: FileSize
archiveHash :: SHA256
archiveSubdir :: Text
archiveLocation :: ArchiveLocation
..} PackageMetadata
pm) Value
value

instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where
  parseJSON :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
parseJSON Value
v
      = Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
http Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageText Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
repo Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
archiveObject Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
github Value
v
    forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail ([Char]
"Could not parse a UnresolvedRawPackageLocationImmutable from: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Value
v)
    where
      http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable)))
      http :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
http = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"UnresolvedPackageLocationImmutable.RPLIArchive (Text)" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text -> Either Text (Unresolved ArchiveLocation)
parseArchiveLocationText Text
t of
          Left Text
_ -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid archive location: " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
          Right (Unresolved Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation) ->
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> WithJSONWarnings a
noJSONWarnings forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
              ArchiveLocation
raLocation <- Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation Maybe (Path Abs Dir)
mdir
              let raHash :: Maybe a
raHash = forall a. Maybe a
Nothing
                  raSize :: Maybe a
raSize = forall a. Maybe a
Nothing
                  raSubdir :: Text
raSubdir = Text
T.empty
              forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive {Text
ArchiveLocation
forall a. Maybe a
raSubdir :: Text
raSize :: forall a. Maybe a
raHash :: forall a. Maybe a
raLocation :: ArchiveLocation
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSubdir :: Text
raLocation :: ArchiveLocation
..} RawPackageMetadata
rpmEmpty

      hackageText :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageText = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"UnresolvedPackageLocationImmutable.UPLIHackage (Text)" forall a b. (a -> b) -> a -> b
$ \Text
t ->
        case Text -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision Text
t of
          Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show PantryException
e
          Right PackageIdentifierRevision
pir -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> WithJSONWarnings a
noJSONWarnings forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage PackageIdentifierRevision
pir forall a. Maybe a
Nothing

      hackageObject :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
hackageObject = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.UPLIHackage" forall a b. (a -> b) -> a -> b
$ \Object
o -> (forall (f :: * -> *) a. Applicative f => a -> f a
pureforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall (f :: * -> *) a. Applicative f => a -> f a
pure) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PackageIdentifierRevision
-> Maybe TreeKey -> RawPackageLocationImmutable
RPLIHackage
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hackage"
        forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"pantry-tree")

      optionalSubdirs :: Object -> WarningParser OptionalSubdirs
      optionalSubdirs :: Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o =
        -- if subdirs exists, it needs to be valid

        case forall v. AesonKey -> KeyMap v -> Maybe v
HM.lookup AesonKey
"subdirs" Object
o of
          Just Value
v' -> do
            Text -> WarningParser ()
tellJSONField Text
"subdirs"
            [Text]
subdirs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. FromJSON a => Value -> Parser a
parseJSON Value
v'
            case forall a. [a] -> Maybe (NonEmpty a)
NE.nonEmpty [Text]
subdirs of
              Maybe (NonEmpty Text)
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Invalid empty subdirs"
              Just NonEmpty Text
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ NonEmpty Text -> OptionalSubdirs
OSSubdirs NonEmpty Text
x
          Maybe Value
Nothing -> Text -> RawPackageMetadata -> OptionalSubdirs
OSPackageMetadata
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"subdir" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= Text
T.empty
            forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Maybe PackageName
-> Maybe Version
-> Maybe TreeKey
-> Maybe BlobKey
-> RawPackageMetadata
rawPackageMetadataHelper
                  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. CabalString a -> a
unCabalString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"name"))
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. CabalString a -> a
unCabalString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"version"))
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"pantry-tree"
                  forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"cabal-file")

      rawPackageMetadataHelper
        :: Maybe PackageName
        -> Maybe Version
        -> Maybe TreeKey
        -> Maybe BlobKey
        -> RawPackageMetadata
      rawPackageMetadataHelper :: Maybe PackageName
-> Maybe Version
-> Maybe TreeKey
-> Maybe BlobKey
-> RawPackageMetadata
rawPackageMetadataHelper Maybe PackageName
name Maybe Version
version Maybe TreeKey
pantryTree Maybe BlobKey
_ignoredCabalFile =
        Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata Maybe PackageName
name Maybe Version
version Maybe TreeKey
pantryTree

      repo :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
repo = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.UPLIRepo" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        (RepoType
repoType, Text
repoUrl) <-
          ((RepoType
RepoGit, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"git") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
          ((RepoType
RepoHg, ) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"hg")
        Text
repoCommit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
        OptionalSubdirs
os <- Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(Text
repoSubdir, RawPackageMetadata
pm) -> Repo -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIRepo Repo {Text
RepoType
repoSubdir :: Text
repoCommit :: Text
repoUrl :: Text
repoType :: RepoType
repoType :: RepoType
repoSubdir :: Text
repoCommit :: Text
repoUrl :: Text
..} RawPackageMetadata
pm) (OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms OptionalSubdirs
os)

      archiveObject :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
archiveObject = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedPackageLocationImmutable.RPLIArchive" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        Unresolved Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation <- Object -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject Object
o
        Maybe SHA256
raHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"sha256"
        Maybe FileSize
raSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"size"
        OptionalSubdirs
os <- Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
          ArchiveLocation
raLocation <- Maybe (Path Abs Dir) -> IO ArchiveLocation
mkArchiveLocation Maybe (Path Abs Dir)
mdir
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(Text
raSubdir, RawPackageMetadata
pm) -> RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive {Maybe SHA256
Maybe FileSize
Text
ArchiveLocation
raSubdir :: Text
raLocation :: ArchiveLocation
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSubdir :: Text
raLocation :: ArchiveLocation
..} RawPackageMetadata
pm) (OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms OptionalSubdirs
os)

      github :: Value
-> Parser
     (WithJSONWarnings
        (Unresolved (NonEmpty RawPackageLocationImmutable)))
github = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"PLArchive:github" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
        GitHubRepo Text
ghRepo <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"github"
        Text
commit <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"commit"
        let raLocation :: ArchiveLocation
raLocation = Text -> ArchiveLocation
ALUrl forall a b. (a -> b) -> a -> b
$ [Text] -> Text
T.concat
              [ Text
"https://github.com/"
              , Text
ghRepo
              , Text
"/archive/"
              , Text
commit
              , Text
".tar.gz"
              ]
        Maybe SHA256
raHash <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"sha256"
        Maybe FileSize
raSize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"size"
        OptionalSubdirs
os <- Object -> WarningParser OptionalSubdirs
optionalSubdirs Object
o
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (\(Text
raSubdir, RawPackageMetadata
pm) -> RawArchive -> RawPackageMetadata -> RawPackageLocationImmutable
RPLIArchive RawArchive {Maybe SHA256
Maybe FileSize
Text
ArchiveLocation
raSubdir :: Text
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raLocation :: ArchiveLocation
raSize :: Maybe FileSize
raHash :: Maybe SHA256
raSubdir :: Text
raLocation :: ArchiveLocation
..} RawPackageMetadata
pm) (OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms OptionalSubdirs
os)

-- | Returns pairs of subdirectory and 'PackageMetadata'.

osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms (OSSubdirs NonEmpty Text
subdirs) = forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
NE.map (, RawPackageMetadata
rpmEmpty) NonEmpty Text
subdirs
osToRpms (OSPackageMetadata Text
subdir RawPackageMetadata
rpm) = forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text
subdir, RawPackageMetadata
rpm)

rpmEmpty :: RawPackageMetadata
rpmEmpty :: RawPackageMetadata
rpmEmpty = Maybe PackageName
-> Maybe Version -> Maybe TreeKey -> RawPackageMetadata
RawPackageMetadata forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing

-- | Newtype wrapper for easier JSON integration with Cabal types.

--

-- @since 0.1.0.0

newtype CabalString a = CabalString { forall a. CabalString a -> a
unCabalString :: a }
  deriving (Int -> CabalString a -> ShowS
forall a. Show a => Int -> CabalString a -> ShowS
forall a. Show a => [CabalString a] -> ShowS
forall a. Show a => CabalString a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [CabalString a] -> ShowS
$cshowList :: forall a. Show a => [CabalString a] -> ShowS
show :: CabalString a -> [Char]
$cshow :: forall a. Show a => CabalString a -> [Char]
showsPrec :: Int -> CabalString a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> CabalString a -> ShowS
Show, CabalString a -> CabalString a -> Bool
forall a. Eq a => CabalString a -> CabalString a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CabalString a -> CabalString a -> Bool
$c/= :: forall a. Eq a => CabalString a -> CabalString a -> Bool
== :: CabalString a -> CabalString a -> Bool
$c== :: forall a. Eq a => CabalString a -> CabalString a -> Bool
Eq, CabalString a -> CabalString a -> Bool
CabalString a -> CabalString a -> Ordering
CabalString a -> CabalString a -> CabalString a
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall {a}. Ord a => Eq (CabalString a)
forall a. Ord a => CabalString a -> CabalString a -> Bool
forall a. Ord a => CabalString a -> CabalString a -> Ordering
forall a. Ord a => CabalString a -> CabalString a -> CabalString a
min :: CabalString a -> CabalString a -> CabalString a
$cmin :: forall a. Ord a => CabalString a -> CabalString a -> CabalString a
max :: CabalString a -> CabalString a -> CabalString a
$cmax :: forall a. Ord a => CabalString a -> CabalString a -> CabalString a
>= :: CabalString a -> CabalString a -> Bool
$c>= :: forall a. Ord a => CabalString a -> CabalString a -> Bool
> :: CabalString a -> CabalString a -> Bool
$c> :: forall a. Ord a => CabalString a -> CabalString a -> Bool
<= :: CabalString a -> CabalString a -> Bool
$c<= :: forall a. Ord a => CabalString a -> CabalString a -> Bool
< :: CabalString a -> CabalString a -> Bool
$c< :: forall a. Ord a => CabalString a -> CabalString a -> Bool
compare :: CabalString a -> CabalString a -> Ordering
$ccompare :: forall a. Ord a => CabalString a -> CabalString a -> Ordering
Ord, Typeable)

-- I'd like to use coerce here, but can't due to roles. unsafeCoerce

-- could work, but let's avoid unsafe code.


-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON'

-- instance.

--

-- @since 0.1.0.0

toCabalStringMap :: Map a v -> Map (CabalString a) v
toCabalStringMap :: forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap = forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic forall a. a -> CabalString a
CabalString

-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a

-- 'FromJSON' instance.

--

-- @since 0.1.0.0

unCabalStringMap :: Map (CabalString a) v -> Map a v
unCabalStringMap :: forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap = forall k1 k2 a. (k1 -> k2) -> Map k1 a -> Map k2 a
Map.mapKeysMonotonic forall a. CabalString a -> a
unCabalString

instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where
  toJSON :: CabalString a -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
Distribution.Text.display forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CabalString a -> a
unCabalString
instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where
  toJSONKey :: ToJSONKeyFunction (CabalString a)
toJSONKey = forall a. (a -> Text) -> ToJSONKeyFunction a
toJSONKeyText forall a b. (a -> b) -> a -> b
$ [Char] -> Text
T.pack forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
Distribution.Text.display forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. CabalString a -> a
unCabalString

instance forall a. IsCabalString a => FromJSON (CabalString a) where
  parseJSON :: Value -> Parser (CabalString a)
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
name forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case forall a. IsCabalString a => [Char] -> Maybe a
cabalStringParser forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
      Maybe a
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
      Just a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> CabalString a
CabalString a
x
    where
      name :: [Char]
name = forall a (proxy :: * -> *). IsCabalString a => proxy a -> [Char]
cabalStringName (forall a. Maybe a
Nothing :: Maybe a)
instance forall a. IsCabalString a => FromJSONKey (CabalString a) where
  fromJSONKey :: FromJSONKeyFunction (CabalString a)
fromJSONKey =
    forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case forall a. IsCabalString a => [Char] -> Maybe a
cabalStringParser forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
t of
      Maybe a
Nothing -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid " forall a. [a] -> [a] -> [a]
++ [Char]
name forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ Text -> [Char]
T.unpack Text
t
      Just a
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> CabalString a
CabalString a
x
    where
      name :: [Char]
name = forall a (proxy :: * -> *). IsCabalString a => proxy a -> [Char]
cabalStringName (forall a. Maybe a
Nothing :: Maybe a)

class IsCabalString a where
  cabalStringName :: proxy a -> String
  cabalStringParser :: String -> Maybe a
instance IsCabalString PackageName where
  cabalStringName :: forall (proxy :: * -> *). proxy PackageName -> [Char]
cabalStringName proxy PackageName
_ = [Char]
"package name"
  cabalStringParser :: [Char] -> Maybe PackageName
cabalStringParser = [Char] -> Maybe PackageName
parsePackageName
instance IsCabalString Version where
  cabalStringName :: forall (proxy :: * -> *). proxy Version -> [Char]
cabalStringName proxy Version
_ = [Char]
"version"
  cabalStringParser :: [Char] -> Maybe Version
cabalStringParser = [Char] -> Maybe Version
parseVersion
instance IsCabalString VersionRange where
  cabalStringName :: forall (proxy :: * -> *). proxy VersionRange -> [Char]
cabalStringName proxy VersionRange
_ = [Char]
"version range"
  cabalStringParser :: [Char] -> Maybe VersionRange
cabalStringParser = [Char] -> Maybe VersionRange
parseVersionRange
instance IsCabalString PackageIdentifier where
  cabalStringName :: forall (proxy :: * -> *). proxy PackageIdentifier -> [Char]
cabalStringName proxy PackageIdentifier
_ = [Char]
"package identifier"
  cabalStringParser :: [Char] -> Maybe PackageIdentifier
cabalStringParser = [Char] -> Maybe PackageIdentifier
parsePackageIdentifier
instance IsCabalString FlagName where
  cabalStringName :: forall (proxy :: * -> *). proxy FlagName -> [Char]
cabalStringName proxy FlagName
_ = [Char]
"flag name"
  cabalStringParser :: [Char] -> Maybe FlagName
cabalStringParser = [Char] -> Maybe FlagName
parseFlagName

-- | What to use for running hpack

--

-- @since 0.1.0.0

data HpackExecutable
    = HpackBundled
    -- ^ Compiled in library

    | HpackCommand !FilePath
    -- ^ Executable at the provided path

    deriving (Int -> HpackExecutable -> ShowS
[HpackExecutable] -> ShowS
HpackExecutable -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [HpackExecutable] -> ShowS
$cshowList :: [HpackExecutable] -> ShowS
show :: HpackExecutable -> [Char]
$cshow :: HpackExecutable -> [Char]
showsPrec :: Int -> HpackExecutable -> ShowS
$cshowsPrec :: Int -> HpackExecutable -> ShowS
Show, ReadPrec [HpackExecutable]
ReadPrec HpackExecutable
Int -> ReadS HpackExecutable
ReadS [HpackExecutable]
forall a.
(Int -> ReadS a)
-> ReadS [a] -> ReadPrec a -> ReadPrec [a] -> Read a
readListPrec :: ReadPrec [HpackExecutable]
$creadListPrec :: ReadPrec [HpackExecutable]
readPrec :: ReadPrec HpackExecutable
$creadPrec :: ReadPrec HpackExecutable
readList :: ReadS [HpackExecutable]
$creadList :: ReadS [HpackExecutable]
readsPrec :: Int -> ReadS HpackExecutable
$creadsPrec :: Int -> ReadS HpackExecutable
Read, HpackExecutable -> HpackExecutable -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: HpackExecutable -> HpackExecutable -> Bool
$c/= :: HpackExecutable -> HpackExecutable -> Bool
== :: HpackExecutable -> HpackExecutable -> Bool
$c== :: HpackExecutable -> HpackExecutable -> Bool
Eq, Eq HpackExecutable
HpackExecutable -> HpackExecutable -> Bool
HpackExecutable -> HpackExecutable -> Ordering
HpackExecutable -> HpackExecutable -> HpackExecutable
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: HpackExecutable -> HpackExecutable -> HpackExecutable
$cmin :: HpackExecutable -> HpackExecutable -> HpackExecutable
max :: HpackExecutable -> HpackExecutable -> HpackExecutable
$cmax :: HpackExecutable -> HpackExecutable -> HpackExecutable
>= :: HpackExecutable -> HpackExecutable -> Bool
$c>= :: HpackExecutable -> HpackExecutable -> Bool
> :: HpackExecutable -> HpackExecutable -> Bool
$c> :: HpackExecutable -> HpackExecutable -> Bool
<= :: HpackExecutable -> HpackExecutable -> Bool
$c<= :: HpackExecutable -> HpackExecutable -> Bool
< :: HpackExecutable -> HpackExecutable -> Bool
$c< :: HpackExecutable -> HpackExecutable -> Bool
compare :: HpackExecutable -> HpackExecutable -> Ordering
$ccompare :: HpackExecutable -> HpackExecutable -> Ordering
Ord)


-- | Which compiler a snapshot wants to use. The build tool may elect

-- to do some fuzzy matching of versions (e.g., allowing different

-- patch versions).

--

-- @since 0.1.0.0

data WantedCompiler
  = WCGhc !Version
  | WCGhcGit !Text !Text
  | WCGhcjs
      !Version
      !Version
    -- ^ GHCJS version followed by GHC version

 deriving (Int -> WantedCompiler -> ShowS
[WantedCompiler] -> ShowS
WantedCompiler -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [WantedCompiler] -> ShowS
$cshowList :: [WantedCompiler] -> ShowS
show :: WantedCompiler -> [Char]
$cshow :: WantedCompiler -> [Char]
showsPrec :: Int -> WantedCompiler -> ShowS
$cshowsPrec :: Int -> WantedCompiler -> ShowS
Show, WantedCompiler -> WantedCompiler -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: WantedCompiler -> WantedCompiler -> Bool
$c/= :: WantedCompiler -> WantedCompiler -> Bool
== :: WantedCompiler -> WantedCompiler -> Bool
$c== :: WantedCompiler -> WantedCompiler -> Bool
Eq, Eq WantedCompiler
WantedCompiler -> WantedCompiler -> Bool
WantedCompiler -> WantedCompiler -> Ordering
WantedCompiler -> WantedCompiler -> WantedCompiler
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: WantedCompiler -> WantedCompiler -> WantedCompiler
$cmin :: WantedCompiler -> WantedCompiler -> WantedCompiler
max :: WantedCompiler -> WantedCompiler -> WantedCompiler
$cmax :: WantedCompiler -> WantedCompiler -> WantedCompiler
>= :: WantedCompiler -> WantedCompiler -> Bool
$c>= :: WantedCompiler -> WantedCompiler -> Bool
> :: WantedCompiler -> WantedCompiler -> Bool
$c> :: WantedCompiler -> WantedCompiler -> Bool
<= :: WantedCompiler -> WantedCompiler -> Bool
$c<= :: WantedCompiler -> WantedCompiler -> Bool
< :: WantedCompiler -> WantedCompiler -> Bool
$c< :: WantedCompiler -> WantedCompiler -> Bool
compare :: WantedCompiler -> WantedCompiler -> Ordering
$ccompare :: WantedCompiler -> WantedCompiler -> Ordering
Ord, forall x. Rep WantedCompiler x -> WantedCompiler
forall x. WantedCompiler -> Rep WantedCompiler x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep WantedCompiler x -> WantedCompiler
$cfrom :: forall x. WantedCompiler -> Rep WantedCompiler x
Generic)

instance NFData WantedCompiler
instance Display WantedCompiler where
  display :: WantedCompiler -> Utf8Builder
display (WCGhc Version
vghc) = Utf8Builder
"ghc-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
vghc)
  display (WCGhcjs Version
vghcjs Version
vghc) =
    Utf8Builder
"ghcjs-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
vghcjs) forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"_ghc-" forall a. Semigroup a => a -> a -> a
<> forall a. IsString a => [Char] -> a
fromString (Version -> [Char]
versionString Version
vghc)
  display (WCGhcGit Text
commit Text
flavour) =
    Utf8Builder
"ghc-git-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
commit forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Text
flavour
instance ToJSON WantedCompiler where
  toJSON :: WantedCompiler -> Value
toJSON = forall a. ToJSON a => a -> Value
toJSON forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display
instance FromJSON WantedCompiler where
  parseJSON :: Value -> Parser WantedCompiler
parseJSON = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"WantedCompiler" forall a b. (a -> b) -> a -> b
$ forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Either PantryException WantedCompiler
parseWantedCompiler
instance FromJSONKey WantedCompiler where
  fromJSONKey :: FromJSONKeyFunction WantedCompiler
fromJSONKey =
    forall a. (Text -> Parser a) -> FromJSONKeyFunction a
FromJSONKeyTextParser forall a b. (a -> b) -> a -> b
$ \Text
t ->
    case Text -> Either PantryException WantedCompiler
parseWantedCompiler Text
t of
      Left PantryException
e -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail forall a b. (a -> b) -> a -> b
$ [Char]
"Invalid WantedCompiler " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Text
t forall a. [a] -> [a] -> [a]
++ [Char]
": " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show PantryException
e
      Right WantedCompiler
x -> forall (f :: * -> *) a. Applicative f => a -> f a
pure WantedCompiler
x

-- | Parse a 'Text' into a 'WantedCompiler' value.

--

-- @since 0.1.0.0

parseWantedCompiler :: Text -> Either PantryException WantedCompiler
parseWantedCompiler :: Text -> Either PantryException WantedCompiler
parseWantedCompiler Text
t0 = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall a b. a -> Either a b
Left forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidWantedCompiler Text
t0) forall a b. b -> Either a b
Right forall a b. (a -> b) -> a -> b
$
  case Text -> Text -> Maybe Text
T.stripPrefix Text
"ghcjs-" Text
t0 of
    Just Text
t1 -> Text -> Maybe WantedCompiler
parseGhcjs Text
t1
    Maybe Text
Nothing -> case Text -> Text -> Maybe Text
T.stripPrefix Text
"ghc-git-" Text
t0 of
       Just Text
t1 -> forall {f :: * -> *}. Applicative f => Text -> f WantedCompiler
parseGhcGit Text
t1
       Maybe Text
Nothing -> Text -> Text -> Maybe Text
T.stripPrefix Text
"ghc-" Text
t0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Text -> Maybe WantedCompiler
parseGhc
  where
    parseGhcjs :: Text -> Maybe WantedCompiler
parseGhcjs Text
t1 = do
      let (Text
ghcjsVT, Text
t2) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'_') Text
t1
      Version
ghcjsV <- [Char] -> Maybe Version
parseVersion forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
ghcjsVT
      Text
ghcVT <- Text -> Text -> Maybe Text
T.stripPrefix Text
"_ghc-" Text
t2
      Version
ghcV <- [Char] -> Maybe Version
parseVersion forall a b. (a -> b) -> a -> b
$ Text -> [Char]
T.unpack Text
ghcVT
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Version -> Version -> WantedCompiler
WCGhcjs Version
ghcjsV Version
ghcV
    parseGhcGit :: Text -> f WantedCompiler
parseGhcGit Text
t1 = do
      let (Text
commit, Text
flavour) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'-') Text
t1
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> WantedCompiler
WCGhcGit Text
commit (Int -> Text -> Text
T.drop Int
1 Text
flavour)
    parseGhc :: Text -> Maybe WantedCompiler
parseGhc = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Version -> WantedCompiler
WCGhc forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Maybe Version
parseVersion forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack

instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where
  parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
parseJSON Value
v = Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
text Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
obj Value
v
    where
      text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
      text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
text = forall a. [Char] -> (Text -> Parser a) -> Value -> Parser a
withText [Char]
"UnresolvedSnapshotLocation (Text)" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> WithJSONWarnings a
noJSONWarnings forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation

      obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
      obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
obj = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"UnresolvedSnapshotLocation (Object)" forall a b. (a -> b) -> a -> b
$ \Object
o ->
        ((forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. WantedCompiler -> RawSnapshotLocation
RSLCompiler) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"compiler") forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        ((\Text
x Maybe BlobKey
y -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
x Maybe BlobKey
y) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"url" forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object -> WarningParser (Maybe BlobKey)
blobKey Object
o) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
        (Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"filepath")

      blobKey :: Object -> WarningParser (Maybe BlobKey)
blobKey Object
o = do
        Maybe SHA256
msha <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"sha256"
        Maybe FileSize
msize <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"size"
        case (Maybe SHA256
msha, Maybe FileSize
msize) of
          (Maybe SHA256
Nothing, Maybe FileSize
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing
          (Just SHA256
sha, Just FileSize
size') -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size'
          (Just SHA256
_sha, Maybe FileSize
Nothing) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"You must also specify the file size"
          (Maybe SHA256
Nothing, Just FileSize
_) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"You must also specify the file's SHA256"

instance Display SnapshotLocation where
  display :: SnapshotLocation -> Utf8Builder
display (SLCompiler WantedCompiler
compiler) = forall a. Display a => a -> Utf8Builder
display WantedCompiler
compiler
  display (SLUrl Text
url BlobKey
blob) = forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blob forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
  display (SLFilePath ResolvedPath File
resolved) = forall a. Display a => a -> Utf8Builder
display (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved)

-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'.

--

-- @since 0.1.0.0

parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation Text
t0 = forall a. a -> Maybe a -> a
fromMaybe (Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath Text
t0) forall a b. (a -> b) -> a -> b
$
  (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (forall a b. a -> b -> a
const forall a. Maybe a
Nothing) (forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. WantedCompiler -> RawSnapshotLocation
RSLCompiler) (Text -> Either PantryException WantedCompiler
parseWantedCompiler Text
t0)) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SnapName -> RawSnapshotLocation
RSLSynonym forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t0) forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Maybe (Unresolved RawSnapshotLocation)
parseGitHub forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|>
  Maybe (Unresolved RawSnapshotLocation)
parseUrl
  where
    parseGitHub :: Maybe (Unresolved RawSnapshotLocation)
parseGitHub = do
      Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"github:" Text
t0
      let (Text
user, Text
t2) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
'/') Text
t1
      Text
t3 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"/" Text
t2
      let (Text
repo, Text
t4) = (Char -> Bool) -> Text -> (Text, Text)
T.break (forall a. Eq a => a -> a -> Bool
== Char
':') Text
t3
      Text
path <- Text -> Text -> Maybe Text
T.stripPrefix Text
":" Text
t4
      forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
user Text
repo Text
path

    parseUrl :: Maybe (Unresolved RawSnapshotLocation)
parseUrl = forall (m :: * -> *). MonadThrow m => [Char] -> m Request
parseRequest (Text -> [Char]
T.unpack Text
t0) forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
t0 forall a. Maybe a
Nothing)

parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath Text
t =
  forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir ->
  case Maybe (Path Abs Dir)
mdir of
    Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidFilePathSnapshot Text
t
    Just Path Abs Dir
dir -> do
      Path Abs File
abs' <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
dir (Text -> [Char]
T.unpack Text
t) forall (m :: * -> *) a.
MonadUnliftIO m =>
m a -> (SomeException -> m a) -> m a
`catchAny` \SomeException
_ -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO (Path Abs Dir -> Text -> PantryException
InvalidSnapshotLocation Path Abs Dir
dir Text
t)
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> RawSnapshotLocation
RSLFilePath forall a b. (a -> b) -> a -> b
$ forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
t) Path Abs File
abs'

githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation :: Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
user Text
repo Text
path =
  let url :: Text
url = [Text] -> Text
T.concat
        [ Text
"https://raw.githubusercontent.com/"
        , Text
user
        , Text
"/"
        , Text
repo
        , Text
"/master/"
        , Text
path
        ]
   in Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
url forall a. Maybe a
Nothing

defUser :: Text
defUser :: Text
defUser = Text
"commercialhaskell"

defRepo :: Text
defRepo :: Text
defRepo = Text
"stackage-snapshots"

-- | Default location of snapshot synonyms

-- , i.e. commercialhaskell's GitHub repository.

--

-- @since 0.5.0.0

defaultSnapshotLocation
  :: SnapName
  -> RawSnapshotLocation
defaultSnapshotLocation :: SnapName -> RawSnapshotLocation
defaultSnapshotLocation (LTS Int
x Int
y) =
  Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
defUser Text
defRepo forall a b. (a -> b) -> a -> b
$
  Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$
  Utf8Builder
"lts/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
defaultSnapshotLocation (Nightly Day
date) =
  Text -> Text -> Text -> RawSnapshotLocation
githubSnapshotLocation Text
defUser Text
defRepo forall a b. (a -> b) -> a -> b
$
  Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$
  Utf8Builder
"nightly/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Year
year forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
month forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"/" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
day forall a. Semigroup a => a -> a -> a
<> Utf8Builder
".yaml"
  where
    (Year
year, Int
month, Int
day) = Day -> (Year, Int, Int)
toGregorian Day
date

-- | A snapshot synonym.

-- It is expanded according to the field 'snapshotLocation'

-- of a 'PantryConfig'.

--

-- @ since 0.5.0.0

data SnapName
    -- | LTS Haskell snapshot,

    -- displayed as @"lts-maj.min"@.

    --

    -- @since 0.5.0.0

    = LTS
        !Int -- ^ Major version

        !Int -- ^ Minor version

    -- | Stackage Nightly snapshot,

    -- displayed as @"nighly-YYYY-MM-DD"@.

    --

    -- @since 0.5.0.0

    | Nightly !Day
    deriving (SnapName -> SnapName -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapName -> SnapName -> Bool
$c/= :: SnapName -> SnapName -> Bool
== :: SnapName -> SnapName -> Bool
$c== :: SnapName -> SnapName -> Bool
Eq, Eq SnapName
SnapName -> SnapName -> Bool
SnapName -> SnapName -> Ordering
SnapName -> SnapName -> SnapName
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapName -> SnapName -> SnapName
$cmin :: SnapName -> SnapName -> SnapName
max :: SnapName -> SnapName -> SnapName
$cmax :: SnapName -> SnapName -> SnapName
>= :: SnapName -> SnapName -> Bool
$c>= :: SnapName -> SnapName -> Bool
> :: SnapName -> SnapName -> Bool
$c> :: SnapName -> SnapName -> Bool
<= :: SnapName -> SnapName -> Bool
$c<= :: SnapName -> SnapName -> Bool
< :: SnapName -> SnapName -> Bool
$c< :: SnapName -> SnapName -> Bool
compare :: SnapName -> SnapName -> Ordering
$ccompare :: SnapName -> SnapName -> Ordering
Ord, forall x. Rep SnapName x -> SnapName
forall x. SnapName -> Rep SnapName x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SnapName x -> SnapName
$cfrom :: forall x. SnapName -> Rep SnapName x
Generic)

instance NFData SnapName

instance Display SnapName where
  display :: SnapName -> Utf8Builder
display (LTS Int
x Int
y) = Utf8Builder
"lts-" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
x forall a. Semigroup a => a -> a -> a
<> Utf8Builder
"." forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display Int
y
  display (Nightly Day
date) = Utf8Builder
"nightly-" forall a. Semigroup a => a -> a -> a
<> forall a. Show a => a -> Utf8Builder
displayShow Day
date

instance Show SnapName where
  show :: SnapName -> [Char]
show = Text -> [Char]
T.unpack forall b c a. (b -> c) -> (a -> b) -> a -> c
. Utf8Builder -> Text
utf8BuilderToText forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Display a => a -> Utf8Builder
display

instance ToJSON SnapName where
  toJSON :: SnapName -> Value
toJSON SnapName
syn = Text -> Value
String forall a b. (a -> b) -> a -> b
$ Utf8Builder -> Text
utf8BuilderToText forall a b. (a -> b) -> a -> b
$ forall a. Display a => a -> Utf8Builder
display SnapName
syn

-- | Parse the short representation of a 'SnapName'.

--

-- @since 0.5.0.0

parseSnapName :: MonadThrow m => Text -> m SnapName
parseSnapName :: forall (m :: * -> *). MonadThrow m => Text -> m SnapName
parseSnapName Text
t0 =
    case Maybe SnapName
lts forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe SnapName
nightly of
        Maybe SnapName
Nothing -> forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM forall a b. (a -> b) -> a -> b
$ Text -> PantryException
ParseSnapNameException Text
t0
        Just SnapName
sn -> forall (m :: * -> *) a. Monad m => a -> m a
return SnapName
sn
  where
    lts :: Maybe SnapName
lts = do
        Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"lts-" Text
t0
        Right (Int
x, Text
t2) <- forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Integral a => Reader a
decimal Text
t1
        Text
t3 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"." Text
t2
        Right (Int
y, Text
"") <- forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. Integral a => Reader a
decimal Text
t3
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Int -> Int -> SnapName
LTS Int
x Int
y
    nightly :: Maybe SnapName
nightly = do
        Text
t1 <- Text -> Text -> Maybe Text
T.stripPrefix Text
"nightly-" Text
t0
        Day -> SnapName
Nightly forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Read a => [Char] -> Maybe a
readMaybe (Text -> [Char]
T.unpack Text
t1)

-- | Where to load a snapshot from in raw form

-- (RSUrl could have a missing BlobKey)

--

-- @since 0.1.0.0

data RawSnapshotLocation
  = RSLCompiler !WantedCompiler
    -- ^ Don't use an actual snapshot, just a version of the compiler

    -- with its shipped packages.

    --

    -- @since 0.1.0.0

  | RSLUrl !Text !(Maybe BlobKey)
    -- ^ Download the snapshot from the given URL. The optional

    -- 'BlobKey' is used for reproducibility.

    --

    -- @since 0.1.0.0

  | RSLFilePath !(ResolvedPath File)
    -- ^ Snapshot at a local file path.

    --

    -- @since 0.1.0.0

  | RSLSynonym !SnapName
    -- ^ Snapshot synonym (LTS/Nightly).

    --

    -- @since 0.5.0.0

  deriving (Int -> RawSnapshotLocation -> ShowS
[RawSnapshotLocation] -> ShowS
RawSnapshotLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawSnapshotLocation] -> ShowS
$cshowList :: [RawSnapshotLocation] -> ShowS
show :: RawSnapshotLocation -> [Char]
$cshow :: RawSnapshotLocation -> [Char]
showsPrec :: Int -> RawSnapshotLocation -> ShowS
$cshowsPrec :: Int -> RawSnapshotLocation -> ShowS
Show, RawSnapshotLocation -> RawSnapshotLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c/= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
== :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c== :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
Eq, Eq RawSnapshotLocation
RawSnapshotLocation -> RawSnapshotLocation -> Bool
RawSnapshotLocation -> RawSnapshotLocation -> Ordering
RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
$cmin :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
max :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
$cmax :: RawSnapshotLocation -> RawSnapshotLocation -> RawSnapshotLocation
>= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c>= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
> :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c> :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
<= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c<= :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
< :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
$c< :: RawSnapshotLocation -> RawSnapshotLocation -> Bool
compare :: RawSnapshotLocation -> RawSnapshotLocation -> Ordering
$ccompare :: RawSnapshotLocation -> RawSnapshotLocation -> Ordering
Ord, forall x. Rep RawSnapshotLocation x -> RawSnapshotLocation
forall x. RawSnapshotLocation -> Rep RawSnapshotLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawSnapshotLocation x -> RawSnapshotLocation
$cfrom :: forall x. RawSnapshotLocation -> Rep RawSnapshotLocation x
Generic)

instance NFData RawSnapshotLocation

instance Display RawSnapshotLocation where
  display :: RawSnapshotLocation -> Utf8Builder
display (RSLCompiler WantedCompiler
compiler) = forall a. Display a => a -> Utf8Builder
display WantedCompiler
compiler
  display (RSLUrl Text
url Maybe BlobKey
Nothing) = forall a. Display a => a -> Utf8Builder
display Text
url
  display (RSLUrl Text
url (Just BlobKey
blob)) = forall a. Display a => a -> Utf8Builder
display Text
url forall a. Semigroup a => a -> a -> a
<> Utf8Builder
" (" forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display BlobKey
blob forall a. Semigroup a => a -> a -> a
<> Utf8Builder
")"
  display (RSLFilePath ResolvedPath File
resolved) = forall a. Display a => a -> Utf8Builder
display (forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved)
  display (RSLSynonym SnapName
syn) = forall a. Display a => a -> Utf8Builder
display SnapName
syn


instance ToJSON RawSnapshotLocation where
  toJSON :: RawSnapshotLocation -> Value
toJSON (RSLCompiler WantedCompiler
compiler) = [(AesonKey, Value)] -> Value
object [AesonKey
"compiler" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= WantedCompiler
compiler]
  toJSON (RSLUrl Text
url Maybe BlobKey
mblob) = [(AesonKey, Value)] -> Value
object
    forall a b. (a -> b) -> a -> b
$ AesonKey
"url" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= Text
url
    forall a. a -> [a] -> [a]
: forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] BlobKey -> [(AesonKey, Value)]
blobKeyPairs Maybe BlobKey
mblob
  toJSON (RSLFilePath ResolvedPath File
resolved) = [(AesonKey, Value)] -> Value
object [AesonKey
"filepath" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall t. ResolvedPath t -> RelFilePath
resolvedRelative ResolvedPath File
resolved]
  toJSON (RSLSynonym SnapName
syn) = forall a. ToJSON a => a -> Value
toJSON SnapName
syn

-- | Where to load a snapshot from.

--

-- @since 0.1.0.0

data SnapshotLocation
  = SLCompiler !WantedCompiler
    -- ^ Don't use an actual snapshot, just a version of the compiler

    -- with its shipped packages.

    --

    -- @since 0.1.0.0

  | SLUrl !Text !BlobKey
    -- ^ Download the snapshot from the given URL. The optional

    -- 'BlobKey' is used for reproducibility.

    --

    -- @since 0.1.0.0

  | SLFilePath !(ResolvedPath File)
    -- ^ Snapshot at a local file path.

    --

    -- @since 0.1.0.0

  deriving (Int -> SnapshotLocation -> ShowS
[SnapshotLocation] -> ShowS
SnapshotLocation -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotLocation] -> ShowS
$cshowList :: [SnapshotLocation] -> ShowS
show :: SnapshotLocation -> [Char]
$cshow :: SnapshotLocation -> [Char]
showsPrec :: Int -> SnapshotLocation -> ShowS
$cshowsPrec :: Int -> SnapshotLocation -> ShowS
Show, SnapshotLocation -> SnapshotLocation -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotLocation -> SnapshotLocation -> Bool
$c/= :: SnapshotLocation -> SnapshotLocation -> Bool
== :: SnapshotLocation -> SnapshotLocation -> Bool
$c== :: SnapshotLocation -> SnapshotLocation -> Bool
Eq, Eq SnapshotLocation
SnapshotLocation -> SnapshotLocation -> Bool
SnapshotLocation -> SnapshotLocation -> Ordering
SnapshotLocation -> SnapshotLocation -> SnapshotLocation
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
$cmin :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
max :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
$cmax :: SnapshotLocation -> SnapshotLocation -> SnapshotLocation
>= :: SnapshotLocation -> SnapshotLocation -> Bool
$c>= :: SnapshotLocation -> SnapshotLocation -> Bool
> :: SnapshotLocation -> SnapshotLocation -> Bool
$c> :: SnapshotLocation -> SnapshotLocation -> Bool
<= :: SnapshotLocation -> SnapshotLocation -> Bool
$c<= :: SnapshotLocation -> SnapshotLocation -> Bool
< :: SnapshotLocation -> SnapshotLocation -> Bool
$c< :: SnapshotLocation -> SnapshotLocation -> Bool
compare :: SnapshotLocation -> SnapshotLocation -> Ordering
$ccompare :: SnapshotLocation -> SnapshotLocation -> Ordering
Ord, forall x. Rep SnapshotLocation x -> SnapshotLocation
forall x. SnapshotLocation -> Rep SnapshotLocation x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SnapshotLocation x -> SnapshotLocation
$cfrom :: forall x. SnapshotLocation -> Rep SnapshotLocation x
Generic)
instance NFData SnapshotLocation

instance ToJSON SnapshotLocation where
  toJSON :: SnapshotLocation -> Value
toJSON SnapshotLocation
sl = forall a. ToJSON a => a -> Value
toJSON (SnapshotLocation -> RawSnapshotLocation
toRawSL SnapshotLocation
sl)

instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where
    parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
parseJSON Value
v = Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
file Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
url Value
v forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
compiler Value
v
      where
        file :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
file = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"SLFilepath" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
           Text
ufp <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"filepath"
           forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir ->
             case Maybe (Path Abs Dir)
mdir of
               Maybe (Path Abs Dir)
Nothing -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ Text -> PantryException
InvalidFilePathSnapshot Text
ufp
               Just Path Abs Dir
dir -> do
                 Path Abs File
absolute <- forall (m :: * -> *).
MonadIO m =>
Path Abs Dir -> [Char] -> m (Path Abs File)
resolveFile Path Abs Dir
dir (Text -> [Char]
T.unpack Text
ufp)
                 let fp :: ResolvedPath File
fp = forall t. RelFilePath -> Path Abs t -> ResolvedPath t
ResolvedPath (Text -> RelFilePath
RelFilePath Text
ufp) Path Abs File
absolute
                 forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ ResolvedPath File -> SnapshotLocation
SLFilePath ResolvedPath File
fp
        url :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
url = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"SLUrl" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
          Text
url' <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"url"
          SHA256
sha <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"sha256"
          FileSize
size <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"size"
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text -> BlobKey -> SnapshotLocation
SLUrl Text
url' (SHA256 -> FileSize -> BlobKey
BlobKey SHA256
sha FileSize
size)
        compiler :: Value -> Parser (WithJSONWarnings (Unresolved SnapshotLocation))
compiler = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"SLCompiler" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
          WantedCompiler
c <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser a
..: Text
"compiler"
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ WantedCompiler -> SnapshotLocation
SLCompiler WantedCompiler
c

-- | Convert snapshot location to its "raw" equivalent.

--

-- @since 0.1.0.0

toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL (SLCompiler WantedCompiler
c) = WantedCompiler -> RawSnapshotLocation
RSLCompiler WantedCompiler
c
toRawSL (SLUrl Text
url BlobKey
blob) = Text -> Maybe BlobKey -> RawSnapshotLocation
RSLUrl Text
url (forall a. a -> Maybe a
Just BlobKey
blob)
toRawSL (SLFilePath ResolvedPath File
fp) = ResolvedPath File -> RawSnapshotLocation
RSLFilePath ResolvedPath File
fp

-- | A flattened representation of all the layers in a snapshot.

--

-- @since 0.1.0.0

data RawSnapshot = RawSnapshot
  { RawSnapshot -> WantedCompiler
rsCompiler :: !WantedCompiler
  -- ^ The compiler wanted for this snapshot.

  , RawSnapshot -> Map PackageName RawSnapshotPackage
rsPackages :: !(Map PackageName RawSnapshotPackage)
  -- ^ Packages available in this snapshot for installation. This will be

  -- applied on top of any globally available packages.

  , RawSnapshot -> Set PackageName
rsDrop :: !(Set PackageName)
  -- ^ Global packages that should be dropped/ignored.

  }

-- | A flattened representation of all the layers in a snapshot.

--

-- @since 0.1.0.0

data Snapshot = Snapshot
  { Snapshot -> WantedCompiler
snapshotCompiler :: !WantedCompiler
  -- ^ The compiler wanted for this snapshot.

  , Snapshot -> Map PackageName SnapshotPackage
snapshotPackages :: !(Map PackageName SnapshotPackage)
  -- ^ Packages available in this snapshot for installation. This will be

  -- applied on top of any globally available packages.

  , Snapshot -> Set PackageName
snapshotDrop :: !(Set PackageName)
  -- ^ Global packages that should be dropped/ignored.

  }

-- | Settings for a package found in a snapshot.

--

-- @since 0.1.0.0

data RawSnapshotPackage = RawSnapshotPackage
  { RawSnapshotPackage -> RawPackageLocationImmutable
rspLocation :: !RawPackageLocationImmutable
  -- ^ Where to get the package from

  , RawSnapshotPackage -> Map FlagName Bool
rspFlags :: !(Map FlagName Bool)
  -- ^ Same as 'slFlags'

  , RawSnapshotPackage -> Bool
rspHidden :: !Bool
  -- ^ Same as 'slHidden'

  , RawSnapshotPackage -> [Text]
rspGhcOptions :: ![Text]
  -- ^ Same as 'slGhcOptions'

  }

-- | Settings for a package found in a snapshot.

--

-- @since 0.1.0.0

data SnapshotPackage = SnapshotPackage
  { SnapshotPackage -> PackageLocationImmutable
spLocation :: !PackageLocationImmutable
  -- ^ Where to get the package from

  , SnapshotPackage -> Map FlagName Bool
spFlags :: !(Map FlagName Bool)
  -- ^ Same as 'slFlags'

  , SnapshotPackage -> Bool
spHidden :: !Bool
  -- ^ Same as 'slHidden'

  , SnapshotPackage -> [Text]
spGhcOptions :: ![Text]
  -- ^ Same as 'slGhcOptions'

  }
  deriving Int -> SnapshotPackage -> ShowS
[SnapshotPackage] -> ShowS
SnapshotPackage -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotPackage] -> ShowS
$cshowList :: [SnapshotPackage] -> ShowS
show :: SnapshotPackage -> [Char]
$cshow :: SnapshotPackage -> [Char]
showsPrec :: Int -> SnapshotPackage -> ShowS
$cshowsPrec :: Int -> SnapshotPackage -> ShowS
Show

-- | A single layer of a snapshot, i.e. a specific YAML configuration file.

--

-- @since 0.1.0.0

data RawSnapshotLayer = RawSnapshotLayer
  { RawSnapshotLayer -> RawSnapshotLocation
rslParent :: !RawSnapshotLocation
  -- ^ The sl to extend from. This is either a specific

  -- compiler, or a @SnapshotLocation@ which gives us more information

  -- (like packages). Ultimately, we'll end up with a

  -- @CompilerVersion@.

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler :: !(Maybe WantedCompiler)
  -- ^ Override the compiler specified in 'slParent'. Must be

  -- 'Nothing' if using 'SLCompiler'.

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations :: ![RawPackageLocationImmutable]
  -- ^ Where to grab all of the packages from.

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> Set PackageName
rslDropPackages :: !(Set PackageName)
  -- ^ Packages present in the parent which should not be included

  -- here.

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags :: !(Map PackageName (Map FlagName Bool))
  -- ^ Flag values to override from the defaults

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> Map PackageName Bool
rslHidden :: !(Map PackageName Bool)
  -- ^ Packages which should be hidden when registering. This will

  -- affect, for example, the import parser in the script

  -- command. We use a 'Map' instead of just a 'Set' to allow

  -- overriding the hidden settings in a parent sl.

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions :: !(Map PackageName [Text])
  -- ^ GHC options per package

  --

  -- @since 0.1.0.0

  , RawSnapshotLayer -> Maybe UTCTime
rslPublishTime :: !(Maybe UTCTime)
  -- ^ See 'slPublishTime'

  --

  -- @since 0.1.0.0

  }
  deriving (Int -> RawSnapshotLayer -> ShowS
[RawSnapshotLayer] -> ShowS
RawSnapshotLayer -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [RawSnapshotLayer] -> ShowS
$cshowList :: [RawSnapshotLayer] -> ShowS
show :: RawSnapshotLayer -> [Char]
$cshow :: RawSnapshotLayer -> [Char]
showsPrec :: Int -> RawSnapshotLayer -> ShowS
$cshowsPrec :: Int -> RawSnapshotLayer -> ShowS
Show, RawSnapshotLayer -> RawSnapshotLayer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
$c/= :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
== :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
$c== :: RawSnapshotLayer -> RawSnapshotLayer -> Bool
Eq, forall x. Rep RawSnapshotLayer x -> RawSnapshotLayer
forall x. RawSnapshotLayer -> Rep RawSnapshotLayer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep RawSnapshotLayer x -> RawSnapshotLayer
$cfrom :: forall x. RawSnapshotLayer -> Rep RawSnapshotLayer x
Generic)

instance NFData RawSnapshotLayer

instance ToJSON RawSnapshotLayer where
  toJSON :: RawSnapshotLayer -> Value
toJSON RawSnapshotLayer
rsnap = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [AesonKey
"resolver" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= RawSnapshotLayer -> RawSnapshotLocation
rslParent RawSnapshotLayer
rsnap]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\WantedCompiler
compiler -> [AesonKey
"compiler" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= WantedCompiler
compiler]) (RawSnapshotLayer -> Maybe WantedCompiler
rslCompiler RawSnapshotLayer
rsnap)
    , [AesonKey
"packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= RawSnapshotLayer -> [RawPackageLocationImmutable]
rslLocations RawSnapshotLayer
rsnap]
    , if forall a. Set a -> Bool
Set.null (RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsnap)
        then []
        else [AesonKey
"drop-packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. a -> CabalString a
CabalString (RawSnapshotLayer -> Set PackageName
rslDropPackages RawSnapshotLayer
rsnap)]
    , if forall k a. Map k a -> Bool
Map.null (RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsnap)
        then []
        else [AesonKey
"flags" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (RawSnapshotLayer -> Map PackageName (Map FlagName Bool)
rslFlags RawSnapshotLayer
rsnap))]
    , if forall k a. Map k a -> Bool
Map.null (RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsnap)
        then []
        else [AesonKey
"hidden" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (RawSnapshotLayer -> Map PackageName Bool
rslHidden RawSnapshotLayer
rsnap)]
    , if forall k a. Map k a -> Bool
Map.null (RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsnap)
        then []
        else [AesonKey
"ghc-options" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (RawSnapshotLayer -> Map PackageName [Text]
rslGhcOptions RawSnapshotLayer
rsnap)]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\UTCTime
time -> [AesonKey
"publish-time" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= UTCTime
time]) (RawSnapshotLayer -> Maybe UTCTime
rslPublishTime RawSnapshotLayer
rsnap)
    ]

instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where
  parseJSON :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLayer))
parseJSON = forall a.
[Char]
-> (Object -> WarningParser a)
-> Value
-> Parser (WithJSONWarnings a)
withObjectWarnings [Char]
"Snapshot" forall a b. (a -> b) -> a -> b
$ \Object
o -> do
    Maybe Text
_ :: Maybe Text <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"name" -- avoid warnings for old snapshot format

    Maybe WantedCompiler
mcompiler <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"compiler"
    Maybe (Unresolved RawSnapshotLocation)
mresolver <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT forall a b. (a -> b) -> a -> b
$ Object
o forall a. FromJSON a => Object -> [Text] -> WarningParser (Maybe a)
...:? [Text
"snapshot", Text
"resolver"]
    Unresolved (RawSnapshotLocation, Maybe WantedCompiler)
unresolvedSnapshotParent <-
      case (Maybe WantedCompiler
mcompiler, Maybe (Unresolved RawSnapshotLocation)
mresolver) of
        (Maybe WantedCompiler
Nothing, Maybe (Unresolved RawSnapshotLocation)
Nothing) -> forall (m :: * -> *) a. MonadFail m => [Char] -> m a
fail [Char]
"Snapshot must have either resolver or compiler"
        (Just WantedCompiler
compiler, Maybe (Unresolved RawSnapshotLocation)
Nothing) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure (WantedCompiler -> RawSnapshotLocation
RSLCompiler WantedCompiler
compiler, forall a. Maybe a
Nothing)
        (Maybe WantedCompiler
_, Just (Unresolved Maybe (Path Abs Dir) -> IO RawSnapshotLocation
usl)) -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. (Maybe (Path Abs Dir) -> IO a) -> Unresolved a
Unresolved forall a b. (a -> b) -> a -> b
$ \Maybe (Path Abs Dir)
mdir -> do
          RawSnapshotLocation
sl <- Maybe (Path Abs Dir) -> IO RawSnapshotLocation
usl Maybe (Path Abs Dir)
mdir
          case (RawSnapshotLocation
sl, Maybe WantedCompiler
mcompiler) of
            (RSLCompiler WantedCompiler
c1, Just WantedCompiler
c2) -> forall (m :: * -> *) e a. (MonadIO m, Exception e) => e -> m a
throwIO forall a b. (a -> b) -> a -> b
$ WantedCompiler -> WantedCompiler -> PantryException
InvalidOverrideCompiler WantedCompiler
c1 WantedCompiler
c2
            (RawSnapshotLocation, Maybe WantedCompiler)
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (RawSnapshotLocation
sl, Maybe WantedCompiler
mcompiler)

    [Unresolved (NonEmpty RawPackageLocationImmutable)]
unresolvedLocs <- forall (t :: * -> *) a.
Traversable t =>
WarningParser (t (WithJSONWarnings a)) -> WarningParser (t a)
jsonSubWarningsT (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"packages" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= [])
    Set PackageName
rslDropPackages <- forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. CabalString a -> a
unCabalString forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"drop-packages" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall a. Set a
Set.empty)
    Map PackageName (Map FlagName Bool)
rslFlags <- (forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"flags" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall k a. Map k a
Map.empty)
    Map PackageName Bool
rslHidden <- forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"hidden" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall k a. Map k a
Map.empty)
    Map PackageName [Text]
rslGhcOptions <- forall a v. Map (CabalString a) v -> Map a v
unCabalStringMap forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"ghc-options" forall a. WarningParser (Maybe a) -> a -> WarningParser a
..!= forall k a. Map k a
Map.empty)
    Maybe UTCTime
rslPublishTime <- Object
o forall a. FromJSON a => Object -> Text -> WarningParser (Maybe a)
..:? Text
"publish-time"
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ (\[RawPackageLocationImmutable]
rslLocations (RawSnapshotLocation
rslParent, Maybe WantedCompiler
rslCompiler) -> RawSnapshotLayer {[RawPackageLocationImmutable]
Maybe UTCTime
Maybe WantedCompiler
Set PackageName
Map PackageName Bool
Map PackageName [Text]
Map PackageName (Map FlagName Bool)
RawSnapshotLocation
rslCompiler :: Maybe WantedCompiler
rslParent :: RawSnapshotLocation
rslLocations :: [RawPackageLocationImmutable]
rslPublishTime :: Maybe UTCTime
rslGhcOptions :: Map PackageName [Text]
rslHidden :: Map PackageName Bool
rslFlags :: Map PackageName (Map FlagName Bool)
rslDropPackages :: Set PackageName
rslPublishTime :: Maybe UTCTime
rslGhcOptions :: Map PackageName [Text]
rslHidden :: Map PackageName Bool
rslFlags :: Map PackageName (Map FlagName Bool)
rslDropPackages :: Set PackageName
rslLocations :: [RawPackageLocationImmutable]
rslCompiler :: Maybe WantedCompiler
rslParent :: RawSnapshotLocation
..})
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map forall a. NonEmpty a -> [a]
NE.toList) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
sequenceA [Unresolved (NonEmpty RawPackageLocationImmutable)]
unresolvedLocs)
      forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Unresolved (RawSnapshotLocation, Maybe WantedCompiler)
unresolvedSnapshotParent

-- | A single layer of a snapshot, i.e. a specific YAML configuration file.

--

-- @since 0.1.0.0

data SnapshotLayer = SnapshotLayer
  { SnapshotLayer -> SnapshotLocation
slParent :: !SnapshotLocation
  -- ^ The sl to extend from. This is either a specific

  -- compiler, or a @SnapshotLocation@ which gives us more information

  -- (like packages). Ultimately, we'll end up with a

  -- @CompilerVersion@.

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> Maybe WantedCompiler
slCompiler :: !(Maybe WantedCompiler)
  -- ^ Override the compiler specified in 'slParent'. Must be

  -- 'Nothing' if using 'SLCompiler'.

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> [PackageLocationImmutable]
slLocations :: ![PackageLocationImmutable]
  -- ^ Where to grab all of the packages from.

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> Set PackageName
slDropPackages :: !(Set PackageName)
  -- ^ Packages present in the parent which should not be included

  -- here.

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags :: !(Map PackageName (Map FlagName Bool))
  -- ^ Flag values to override from the defaults

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> Map PackageName Bool
slHidden :: !(Map PackageName Bool)
  -- ^ Packages which should be hidden when registering. This will

  -- affect, for example, the import parser in the script

  -- command. We use a 'Map' instead of just a 'Set' to allow

  -- overriding the hidden settings in a parent sl.

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> Map PackageName [Text]
slGhcOptions :: !(Map PackageName [Text])
  -- ^ GHC options per package

  --

  -- @since 0.1.0.0

  , SnapshotLayer -> Maybe UTCTime
slPublishTime :: !(Maybe UTCTime)
  -- ^ Publication timestamp for this snapshot. This field is optional, and

  -- is for informational purposes only.

  --

  -- @since 0.1.0.0

  }
  deriving (Int -> SnapshotLayer -> ShowS
[SnapshotLayer] -> ShowS
SnapshotLayer -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotLayer] -> ShowS
$cshowList :: [SnapshotLayer] -> ShowS
show :: SnapshotLayer -> [Char]
$cshow :: SnapshotLayer -> [Char]
showsPrec :: Int -> SnapshotLayer -> ShowS
$cshowsPrec :: Int -> SnapshotLayer -> ShowS
Show, SnapshotLayer -> SnapshotLayer -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SnapshotLayer -> SnapshotLayer -> Bool
$c/= :: SnapshotLayer -> SnapshotLayer -> Bool
== :: SnapshotLayer -> SnapshotLayer -> Bool
$c== :: SnapshotLayer -> SnapshotLayer -> Bool
Eq, forall x. Rep SnapshotLayer x -> SnapshotLayer
forall x. SnapshotLayer -> Rep SnapshotLayer x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep SnapshotLayer x -> SnapshotLayer
$cfrom :: forall x. SnapshotLayer -> Rep SnapshotLayer x
Generic)

instance ToJSON SnapshotLayer where
  toJSON :: SnapshotLayer -> Value
toJSON SnapshotLayer
snap = [(AesonKey, Value)] -> Value
object forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
    [ [AesonKey
"resolver" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SnapshotLayer -> SnapshotLocation
slParent SnapshotLayer
snap]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\WantedCompiler
compiler -> [AesonKey
"compiler" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= WantedCompiler
compiler]) (SnapshotLayer -> Maybe WantedCompiler
slCompiler SnapshotLayer
snap)
    , [AesonKey
"packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= SnapshotLayer -> [PackageLocationImmutable]
slLocations SnapshotLayer
snap]
    , if forall a. Set a -> Bool
Set.null (SnapshotLayer -> Set PackageName
slDropPackages SnapshotLayer
snap) then [] else [AesonKey
"drop-packages" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map forall a. a -> CabalString a
CabalString (SnapshotLayer -> Set PackageName
slDropPackages SnapshotLayer
snap)]
    , if forall k a. Map k a -> Bool
Map.null (SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags SnapshotLayer
snap) then [] else [AesonKey
"flags" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags SnapshotLayer
snap))]
    , if forall k a. Map k a -> Bool
Map.null (SnapshotLayer -> Map PackageName Bool
slHidden SnapshotLayer
snap) then [] else [AesonKey
"hidden" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (SnapshotLayer -> Map PackageName Bool
slHidden SnapshotLayer
snap)]
    , if forall k a. Map k a -> Bool
Map.null (SnapshotLayer -> Map PackageName [Text]
slGhcOptions SnapshotLayer
snap) then [] else [AesonKey
"ghc-options" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= forall a v. Map a v -> Map (CabalString a) v
toCabalStringMap (SnapshotLayer -> Map PackageName [Text]
slGhcOptions SnapshotLayer
snap)]
    , forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] (\UTCTime
time -> [AesonKey
"publish-time" forall kv v. (KeyValue kv, ToJSON v) => AesonKey -> v -> kv
.= UTCTime
time]) (SnapshotLayer -> Maybe UTCTime
slPublishTime SnapshotLayer
snap)
    ]

-- | Convert snapshot layer into its "raw" equivalent.

--

-- @since 0.1.0.0

toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer
toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer
toRawSnapshotLayer SnapshotLayer
sl = RawSnapshotLayer
  { rslParent :: RawSnapshotLocation
rslParent = SnapshotLocation -> RawSnapshotLocation
toRawSL (SnapshotLayer -> SnapshotLocation
slParent SnapshotLayer
sl)
  , rslCompiler :: Maybe WantedCompiler
rslCompiler = SnapshotLayer -> Maybe WantedCompiler
slCompiler SnapshotLayer
sl
  , rslLocations :: [RawPackageLocationImmutable]
rslLocations = forall a b. (a -> b) -> [a] -> [b]
map PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (SnapshotLayer -> [PackageLocationImmutable]
slLocations SnapshotLayer
sl)
  , rslDropPackages :: Set PackageName
rslDropPackages = SnapshotLayer -> Set PackageName
slDropPackages SnapshotLayer
sl
  , rslFlags :: Map PackageName (Map FlagName Bool)
rslFlags = SnapshotLayer -> Map PackageName (Map FlagName Bool)
slFlags SnapshotLayer
sl
  , rslHidden :: Map PackageName Bool
rslHidden = SnapshotLayer -> Map PackageName Bool
slHidden SnapshotLayer
sl
  , rslGhcOptions :: Map PackageName [Text]
rslGhcOptions = SnapshotLayer -> Map PackageName [Text]
slGhcOptions SnapshotLayer
sl
  , rslPublishTime :: Maybe UTCTime
rslPublishTime = SnapshotLayer -> Maybe UTCTime
slPublishTime SnapshotLayer
sl
  }

-- | An arbitrary hash for a snapshot, used for finding module names

-- in a snapshot. Mostly intended for Stack's usage.

--

-- @since 0.1.0.0

newtype SnapshotCacheHash = SnapshotCacheHash { SnapshotCacheHash -> SHA256
unSnapshotCacheHash :: SHA256}
  deriving (Int -> SnapshotCacheHash -> ShowS
[SnapshotCacheHash] -> ShowS
SnapshotCacheHash -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [SnapshotCacheHash] -> ShowS
$cshowList :: [SnapshotCacheHash] -> ShowS
show :: SnapshotCacheHash -> [Char]
$cshow :: SnapshotCacheHash -> [Char]
showsPrec :: Int -> SnapshotCacheHash -> ShowS
$cshowsPrec :: Int -> SnapshotCacheHash -> ShowS
Show)

-- | Get the path to the global hints cache file

getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile :: forall env. HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile = do
  Path Abs Dir
root <- forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view forall a b. (a -> b) -> a -> b
$ forall env. HasPantryConfig env => Lens' env PantryConfig
pantryConfigLforall b c a. (b -> c) -> (a -> b) -> a -> c
.forall s a. (s -> a) -> SimpleGetter s a
to PantryConfig -> Path Abs Dir
pcRootDir
  Path Rel File
globalHintsRelFile <- forall (m :: * -> *). MonadThrow m => [Char] -> m (Path Rel File)
parseRelFile [Char]
"global-hints-cache.yaml"
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Path Abs Dir
root forall b t. Path b Dir -> Path Rel t -> Path b t
</> Path Rel File
globalHintsRelFile

-- | Creates BlobKey for an input ByteString

--

-- @since 0.1.0.0

bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey ByteString
bs =
    SHA256 -> FileSize -> BlobKey
BlobKey (ByteString -> SHA256
SHA256.hashBytes ByteString
bs) (Word -> FileSize
FileSize (forall a b. (Integral a, Num b) => a -> b
fromIntegral (ByteString -> Int
B.length ByteString
bs)))

-- | Warn if the package uses 'PCHpack'.

--

-- @since 0.4.0.0

warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile :: forall env.
HasLogFunc env =>
RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile RawPackageLocationImmutable
loc =
  forall (m :: * -> *) env.
(MonadIO m, MonadReader env m, HasLogFunc env, HasCallStack) =>
Utf8Builder -> m ()
logWarn forall a b. (a -> b) -> a -> b
$
  Utf8Builder
"DEPRECATED: The package at " forall a. Semigroup a => a -> a -> a
<> forall a. Display a => a -> Utf8Builder
display RawPackageLocationImmutable
loc forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
" does not include a cabal file.\n" forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"Instead, it includes an hpack package.yaml file for generating a cabal file.\n" forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"This usage is deprecated; please see https://github.com/commercialhaskell/stack/issues/5210.\n" forall a. Semigroup a => a -> a -> a
<>
  Utf8Builder
"Support for this workflow will be removed in the future.\n"