{-# LANGUAGE NoImplicitPrelude          #-}
{-# LANGUAGE BangPatterns               #-}
{-# LANGUAGE CPP                        #-}
{-# LANGUAGE DeriveDataTypeable         #-}
{-# LANGUAGE DeriveFunctor              #-}
{-# LANGUAGE DeriveGeneric              #-}
{-# LANGUAGE FlexibleInstances          #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE LambdaCase                 #-}
{-# LANGUAGE MultiWayIf                 #-}
{-# LANGUAGE OverloadedStrings          #-}
{-# LANGUAGE RankNTypes                 #-}
{-# LANGUAGE RecordWildCards            #-}
{-# LANGUAGE ScopedTypeVariables        #-}
{-# LANGUAGE TupleSections              #-}

module Pantry.Types
  ( PantryConfig (..)
  , PackageIndexConfig (..)
  , HackageSecurityConfig (..)
  , defaultHackageSecurityConfig
  , Storage (..)
  , HasPantryConfig (..)
  , BlobKey (..)
  , PackageName
  , Version
  , PackageIdentifier (..)
  , Revision (..)
  , ModuleName
  , CabalFileInfo (..)
  , PrintWarnings (..)
  , PackageNameP (..)
  , VersionP (..)
  , ModuleNameP (..)
  , PackageIdentifierRevision (..)
  , pirForHash
  , FileType (..)
  , BuildFile (..)
  , FileSize (..)
  , TreeEntry (..)
  , SafeFilePath
  , unSafeFilePath
  , mkSafeFilePath
  , safeFilePathToPath
  , hpackSafeFilePath
  , TreeKey (..)
  , Tree (..)
  , renderTree
  , parseTree
  , parseTreeM
  , SHA256
  , Unresolved
  , resolvePaths
  , Package (..)
  , PackageCabal (..)
  , PHpack (..)
  -- , PackageTarball (..)
  , RawPackageLocation (..)
  , PackageLocation (..)
  , toRawPL
  , RawPackageLocationImmutable (..)
  , PackageLocationImmutable (..)
  , toRawPLI
  , RawArchive (..)
  , Archive (..)
  , toRawArchive
  , Repo (..)
  , AggregateRepo (..)
  , SimpleRepo (..)
  , toAggregateRepos
  , rToSimpleRepo
  , arToSimpleRepo
  , RepoType (..)
  , parsePackageIdentifier
  , parsePackageName
  , parsePackageNameThrowing
  , parseFlagName
  , parseVersion
  , parseVersionThrowing
  , packageIdentifierString
  , packageNameString
  , flagNameString
  , versionString
  , moduleNameString
  , OptionalSubdirs (..)
  , ArchiveLocation (..)
  , RelFilePath (..)
  , CabalString (..)
  , toCabalStringMap
  , unCabalStringMap
  , parsePackageIdentifierRevision
  , Mismatch (..)
  , PantryException (..)
  , FuzzyResults (..)
  , ResolvedPath (..)
  , HpackExecutable (..)
  , WantedCompiler (..)
  --, resolveSnapshotLocation
  , snapshotLocation
  , defaultSnapshotLocation
  , SnapName (..)
  , parseSnapName
  , RawSnapshotLocation (..)
  , SnapshotLocation (..)
  , toRawSL
  , parseHackageText
  , parseRawSnapshotLocation
  , RawSnapshotLayer (..)
  , SnapshotLayer (..)
  , toRawSnapshotLayer
  , RawSnapshot (..)
  , Snapshot (..)
  , RawSnapshotPackage (..)
  , SnapshotPackage (..)
  , parseWantedCompiler
  , RawPackageMetadata (..)
  , PackageMetadata (..)
  , toRawPM
  , cabalFileName
  , SnapshotCacheHash (..)
  , getGlobalHintsFile
  , bsToBlobKey
  , warnMissingCabalFile
  , connRDBMS
  ) where

import           Casa.Client ( CasaRepoPrefix )
import           Database.Persist.Class.PersistField ( PersistField (..) )
import           Database.Persist.PersistValue ( PersistValue (..) )
import           Database.Persist.Sql ( PersistFieldSql (..), SqlBackend )
#if MIN_VERSION_persistent(2, 13, 0)
import           Database.Persist.SqlBackend.Internal ( connRDBMS )
#endif
import           Database.Persist.Types ( SqlType (..) )
import           Data.Aeson.Encoding.Internal ( unsafeToEncoding )
import           Data.Aeson.Types
                   ( FromJSON (..), FromJSONKey (..), FromJSONKeyFunction (..)
                   , Object, Parser, ToJSON (..), ToJSONKey (..)
                   , ToJSONKeyFunction (..), Value (..), (.=), object
                   , toJSONKeyText, withObject, withText
                   )
import           Data.Aeson.WarningParser
                   ( WarningParser, WithJSONWarnings, (..:), (..:?), (..!=)
                   , (.:), (...:?), jsonSubWarnings, jsonSubWarningsT
                   , noJSONWarnings, tellJSONField, withObjectWarnings
                   )
import           Data.ByteString.Builder
                   ( byteString, toLazyByteString, wordDec )
import qualified Data.Conduit.Tar as Tar
import qualified Data.List.NonEmpty as NE
import qualified Data.Map.Strict as Map ( mapKeysMonotonic )
import           Data.Text.Read ( decimal )
import           Distribution.CabalSpecVersion ( cabalSpecLatest )
#if MIN_VERSION_Cabal(3,4,0)
import           Distribution.CabalSpecVersion ( cabalSpecToVersionDigits )
#else
import           Distribution.CabalSpecVersion ( CabalSpecVersion (..) )
#endif
import qualified Distribution.Compat.CharParsing as Parse
import           Distribution.ModuleName ( ModuleName )
import           Distribution.PackageDescription
                   ( FlagName, GenericPackageDescription, unFlagName )
import           Distribution.Parsec
                   ( PError (..), PWarning (..), ParsecParser
                   , explicitEitherParsec, parsec, showPos
                   )
import qualified Distribution.Pretty
import qualified Distribution.Text
import           Distribution.Types.PackageId ( PackageIdentifier (..) )
import           Distribution.Types.PackageName
                   ( PackageName, mkPackageName, unPackageName )
import           Distribution.Types.Version ( Version, mkVersion, nullVersion )
import           Distribution.Types.VersionRange ( VersionRange )
import qualified Hpack.Config as Hpack
import           Network.HTTP.Client ( parseRequest )
import           Network.HTTP.Types ( Status, statusCode )
import           Pantry.SHA256 ( SHA256 )
import qualified Pantry.SHA256 as SHA256
import           Path
                   ( Abs, Dir, File, Path, (</>), filename, parseRelFile
                   , toFilePath
                   )
import           Path.IO ( resolveDir, resolveFile )
import qualified RIO.Set as Set
import           RIO
import qualified RIO.ByteString as B
import qualified RIO.ByteString.Lazy as BL
import           RIO.List ( groupBy, intersperse )
import qualified RIO.Text as T
import           RIO.Time ( Day, UTCTime, toGregorian )
import qualified RIO.Map as Map
import           RIO.PrettyPrint
                   ( blankLine, bulletedList, fillSep, flow, hang, line
                   , mkNarrativeList, parens, string, style
                   )
import           RIO.PrettyPrint.Types ( Style (..) )
import           Text.PrettyPrint.Leijen.Extended ( Pretty (..), StyleDoc )

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

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

type AesonKey = Text
#endif

-- | Parsed tree with more information on the Haskell package it contains.
--
-- @since 0.1.0.0
data Package = Package
  { packageTreeKey :: !TreeKey
    -- ^ The 'TreeKey' containing this package.
    --
    -- This is a hash of the binary representation of 'packageTree'.
    --
    -- @since 0.1.0.0
  , packageTree :: !Tree
    -- ^ The 'Tree' containing this package.
    --
    -- @since 0.1.0.0
  , packageCabalEntry :: !PackageCabal
    -- ^ Information on the cabal file inside this package.
    --
    -- @since 0.1.0.0
  , packageIdent :: !PackageIdentifier
    -- ^ The package name and version in this package.
    --
    -- @since 0.1.0.0
  }
  deriving (Show, Eq, Ord)

data PHpack = PHpack
  { phOriginal :: !TreeEntry
    -- ^ Original hpack file
  , phGenerated :: !TreeEntry
    -- ^ Generated Cabal file
  , phVersion :: !Version
    -- ^ Version of Hpack used
  }
  deriving (Show, Eq, Ord)

data PackageCabal
  = PCCabalFile !TreeEntry -- ^ TreeEntry of Cabal file
  | PCHpack !PHpack
  deriving (Show, Eq, Ord)

cabalFileName :: PackageName -> SafeFilePath
cabalFileName name =
  case mkSafeFilePath $ T.pack (packageNameString name) <> ".cabal" of
    Nothing -> error $ "cabalFileName: failed for " ++ show name
    Just sfp -> sfp

-- | The revision number of a package from Hackage, counting upwards from 0 (the
-- original cabal file).
--
-- See caveats on 'CFIRevision'.
--
-- @since 0.1.0.0
newtype Revision = Revision Word
  deriving (Generic, Show, Eq, NFData, Data, Typeable, Ord, Hashable, Display, PersistField, PersistFieldSql)

-- | Represents a SQL database connection.

-- This used to be a newtype wrapper around a connection pool. However, when
-- investigating <https://github.com/commercialhaskell/stack/issues/4471>, it
-- appeared that holding a pool resulted in overly long write locks being held
-- on the database. As a result, we now abstract away whether a pool is used,
-- and the default implementation in "Pantry.Storage" does not use a pool.
data Storage = Storage
  { withStorage_ ::
         forall env a. HasLogFunc env
      => ReaderT SqlBackend (RIO env) a
      -> RIO env a
  , withWriteLock_ :: forall env a. HasLogFunc env => RIO env a -> RIO env a
  }

-- | Configuration value used by the entire pantry package. Create one using
-- 'withPantryConfig' or 'withPantryConfig''. See also 'PantryApp' for a
-- convenience approach to using pantry.
--
-- @since 0.1.0.0
data PantryConfig = PantryConfig
  { pcPackageIndex :: !PackageIndexConfig
  , pcHpackExecutable :: !HpackExecutable
  , pcRootDir :: !(Path Abs Dir)
  , pcStorage :: !Storage
  , pcUpdateRef :: !(MVar Bool)
    -- ^ Want to try updating the index once during a single run for missing
    -- package identifiers. We also want to ensure we only update once at a
    -- time. Start at @True@.
  , pcParsedCabalFilesRawImmutable ::
      !(IORef (Map RawPackageLocationImmutable GenericPackageDescription))
    -- ^ Cache of previously parsed cabal files, to save on slow parsing time.
  , pcParsedCabalFilesMutable ::
      !( IORef
           ( Map
             (Path Abs Dir)
             ( PrintWarnings -> IO GenericPackageDescription
             , PackageName
             , Path Abs File
             )
           )
       )
    -- ^ Cache for mutable packages. We want to allow for an optimization:
    -- deferring parsing of the 'GenericPackageDescription' until its actually
    -- needed. Therefore, we keep the filepath and the 'PackageName' derived
    -- from that filepath. When the @IO GenericPackageDescription@ is run, it
    -- will ensure that the @PackageName@ matches the value inside the cabal
    -- file, and print out any warnings that still need to be printed.
  , pcConnectionCount :: !Int
    -- ^ concurrently open downloads
  , pcCasaConfig :: !(Maybe (CasaRepoPrefix, Int))
    -- ^ Optionally, the Casa pull URL e.g. @https://casa.stackage.org@ and
    -- the maximum number of Casa keys to pull per request.
  , pcSnapshotLocation :: SnapName -> RawSnapshotLocation
    -- ^ The location of snapshot synonyms
  }

-- | Get the location of a snapshot synonym from the 'PantryConfig'.
--
-- @since 0.5.0.0
snapshotLocation ::
     HasPantryConfig env
  => SnapName
  -> RIO env RawSnapshotLocation
snapshotLocation name = do
  loc <- view $ pantryConfigL.to pcSnapshotLocation
  pure $ loc name

-- | Should we print warnings when loading a cabal file?
--
-- @since 0.1.0.0
data PrintWarnings = YesPrintWarnings | NoPrintWarnings

-- | Wraps a value which potentially contains relative paths. Needs to be
-- provided with a base directory to resolve these paths.
--
-- Unwrap this using 'resolvePaths'.
--
-- @since 0.1.0.0
newtype Unresolved a = Unresolved (Maybe (Path Abs Dir) -> IO a)
  deriving Functor

instance Applicative Unresolved where
  pure = Unresolved . const . pure
  Unresolved f <*> Unresolved x = Unresolved $ \mdir -> f mdir <*> x mdir

-- | Resolve all of the file paths in an 'Unresolved' relative to the given
-- directory.
--
-- @since 0.1.0.0
resolvePaths ::
     MonadIO m
  => Maybe (Path Abs Dir) -- ^ directory to use for relative paths
  -> Unresolved a
  -> m a
resolvePaths mdir (Unresolved f) = liftIO (f mdir)

-- | A combination of the relative path provided in a config file, together with
-- the resolved absolute path.
--
-- @since 0.1.0.0
data ResolvedPath t = ResolvedPath
  { resolvedRelative :: !RelFilePath
    -- ^ Original value parsed from a config file.
  , resolvedAbsolute :: !(Path Abs t)
    -- ^ Absolute path resolved against base directory loaded from.
  }
  deriving (Show, Eq, Generic, Ord)

instance NFData (ResolvedPath t)

-- | Location to load a package from. Can either be immutable (see
-- 'PackageLocationImmutable') or a local directory which is expected to change
-- over time. Raw version doesn't include exact package version (e.g. could
-- refer to the latest revision on Hackage)
--
-- @since 0.1.0.0
data RawPackageLocation
  = RPLImmutable !RawPackageLocationImmutable
  | RPLMutable !(ResolvedPath Dir)
  deriving (Show, Eq, Generic)

instance NFData RawPackageLocation

-- | Location to load a package from. Can either be immutable (see
-- 'PackageLocationImmutable') or a local directory which is expected to change
-- over time.
--
-- @since 0.1.0.0
data PackageLocation
  = PLImmutable !PackageLocationImmutable
  | PLMutable !(ResolvedPath Dir)
  deriving (Show, Eq, Generic)

instance NFData PackageLocation

instance Display PackageLocation where
  display (PLImmutable loc) = display loc
  display (PLMutable fp) = fromString $ toFilePath $ resolvedAbsolute fp

-- | Convert `PackageLocation` to its "raw" equivalent
--
-- @since 0.1.0.0
toRawPL :: PackageLocation -> RawPackageLocation
toRawPL (PLImmutable im) = RPLImmutable (toRawPLI im)
toRawPL (PLMutable m) = RPLMutable m

-- | Location for remote packages or archives assumed to be immutable.
-- as user specifies it i.e. not an exact location
--
-- @since 0.1.0.0
data RawPackageLocationImmutable
  = RPLIHackage !PackageIdentifierRevision !(Maybe TreeKey)
  | RPLIArchive !RawArchive !RawPackageMetadata
  | RPLIRepo    !Repo !RawPackageMetadata
  deriving (Show, Eq, Ord, Generic)

instance NFData RawPackageLocationImmutable

instance Display RawPackageLocationImmutable where
  display (RPLIHackage pir _tree) = display pir <> " (from Hackage)"
  display (RPLIArchive archive _pm) =
    "Archive from " <> display (raLocation archive) <>
    (if T.null $ raSubdir archive
       then mempty
       else " in subdir " <> display (raSubdir archive))
  display (RPLIRepo repo _pm) =
    "Repo from " <> display (repoUrl repo) <>
    ", commit " <> display (repoCommit repo) <>
    (if T.null $ repoSubdir repo
       then mempty
       else " in subdir " <> display (repoSubdir repo))

instance Pretty RawPackageLocationImmutable where
  pretty (RPLIHackage pir _tree) = fillSep
    [ fromString . T.unpack $ textDisplay pir
    , parens (flow "from Hackage")
    ]
  pretty (RPLIArchive archive _pm) = fillSep
    [ flow "Archive from"
    , pretty (raLocation archive)
    , if T.null $ raSubdir archive
        then mempty
        else fillSep
          [ flow "in subdir"
          , style Dir (fromString $ T.unpack (raSubdir archive))
          ]
    ]
  pretty (RPLIRepo repo _pm) = fillSep
    [ flow "Repo from"
    , style Url (fromString $ T.unpack (repoUrl repo)) <> ","
    , "commit"
    , fromString $ T.unpack (repoCommit repo)
    , if T.null $ repoSubdir repo
        then mempty
        else fillSep
          [ flow "in subdir"
          , style Dir (fromString $ T.unpack (repoSubdir repo))
          ]
    ]

-- | Location for remote packages or archives assumed to be immutable.
--
-- @since 0.1.0.0
data PackageLocationImmutable
  = PLIHackage !PackageIdentifier !BlobKey !TreeKey
  | PLIArchive !Archive !PackageMetadata
  | PLIRepo    !Repo !PackageMetadata
  deriving (Generic, Show, Eq, Ord, Typeable)

instance NFData PackageLocationImmutable

instance Display PackageLocationImmutable where
  display (PLIHackage ident _cabalHash _tree) =
    fromString (packageNameString $ pkgName ident) <> " (from Hackage)"
  display (PLIArchive archive _pm) =
    "Archive from " <> display (archiveLocation archive) <>
    (if T.null $ archiveSubdir archive
       then mempty
       else " in subdir " <> display (archiveSubdir archive))
  display (PLIRepo repo _pm) =
    "Repo from " <> display (repoUrl repo) <>
    ", commit " <> display (repoCommit repo) <>
    (if T.null $ repoSubdir repo
       then mempty
       else " in subdir " <> display (repoSubdir repo))

instance ToJSON PackageLocationImmutable where
  toJSON = toJSON . toRawPLI

-- | Package identifier and revision with a specified cabal file hash
--
-- @since 0.1.0.0
pirForHash :: PackageIdentifier -> BlobKey -> PackageIdentifierRevision
pirForHash (PackageIdentifier name ver) (BlobKey sha size') =
  let cfi = CFIHash sha (Just size')
  in PackageIdentifierRevision name ver cfi

-- | Convert `PackageLocationImmutable` to its "raw" equivalent
--
-- @since 0.1.0.0
toRawPLI :: PackageLocationImmutable -> RawPackageLocationImmutable
toRawPLI (PLIHackage ident cfKey treeKey) =
  RPLIHackage (pirForHash ident cfKey) (Just treeKey)
toRawPLI (PLIArchive archive pm) =
  RPLIArchive (toRawArchive archive) (toRawPM pm)
toRawPLI (PLIRepo repo pm) = RPLIRepo repo (toRawPM pm)

-- | A raw package archive, specified by a user, could have no
-- hash and file size information.
--
-- @since 0.1.0.0
data RawArchive = RawArchive
  { raLocation :: !ArchiveLocation
    -- ^ Location of the archive
    --
    -- @since 0.1.0.0
  , raHash :: !(Maybe SHA256)
    -- ^ Cryptographic hash of the archive file
    --
    -- @since 0.1.0.0
  , raSize :: !(Maybe FileSize)
    -- ^ Size of the archive file
    --
    -- @since 0.1.0.0
  , raSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.
    --
    -- @since 0.1.0.0
  }
  deriving (Generic, Show, Eq, Ord, Typeable)

instance NFData RawArchive

-- | A package archive, could be from a URL or a local file path. Local file
-- path archives are assumed to be unchanging over time, and so are allowed in
-- custom snapshots.
--
-- @since 0.1.0.0
data Archive = Archive
  { archiveLocation :: !ArchiveLocation
    -- ^ Location of the archive
    --
    -- @since 0.1.0.0
  , archiveHash :: !SHA256
    -- ^ Cryptographic hash of the archive file
    --
    -- @since 0.1.0.0
  , archiveSize :: !FileSize
    -- ^ Size of the archive file
    --
    -- @since 0.1.0.0
  , archiveSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.
    --
    -- @since 0.1.0.0
  }
  deriving (Generic, Show, Eq, Ord, Typeable)

instance NFData Archive

-- | Convert archive to its "raw" equivalent.
--
-- @since 0.1.0.0
toRawArchive :: Archive -> RawArchive
toRawArchive archive =
  RawArchive (archiveLocation archive) (Just $ archiveHash archive)
             (Just $ archiveSize archive) (archiveSubdir archive)

-- | The type of a source control repository.
--
-- @since 0.1.0.0
data RepoType = RepoGit | RepoHg
  deriving (Generic, Show, Eq, Ord, Typeable)

instance NFData RepoType

instance PersistField RepoType where
  toPersistValue RepoGit = toPersistValue (1 :: Int32)
  toPersistValue RepoHg = toPersistValue (2 :: Int32)
  fromPersistValue v = do
    i <- fromPersistValue v
    case i :: Int32 of
      1 -> pure RepoGit
      2 -> pure RepoHg
      _ -> Left $ fromString $ "Invalid RepoType: " ++ show i

instance PersistFieldSql RepoType where
  sqlType _ = SqlInt32

-- | Information on packages stored in a source control repository.
--
-- @since 0.1.0.0
data Repo = Repo
  { repoUrl :: !Text
    -- ^ Location of the repo
    --
    -- @since 0.1.0.0
  , repoCommit :: !Text
    -- ^ Commit to use from the repo. It's strongly recommended to use
    -- a hash instead of a tag or branch name.
    --
    -- @since 0.1.0.0
  , repoType :: !RepoType
    -- ^ The type of the repo
    --
    -- @since 0.1.0.0
  , repoSubdir :: !Text
    -- ^ Subdirectory within the archive to get the package from.
    --
    -- @since 0.1.0.0
  }
  deriving (Generic, Eq, Ord, Typeable)

instance NFData Repo

instance Show Repo where
  show = T.unpack . utf8BuilderToText . display

instance Display Repo where
  display (Repo url commit typ subdir) =
    (case typ of
       RepoGit -> "Git"
       RepoHg -> "Mercurial") <>
    " repo at " <>
    display url <>
    ", commit " <>
    display commit <>
    (if T.null subdir
      then mempty
      else " in subdirectory " <> display subdir)

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

data AggregateRepo = AggregateRepo
  { aRepo :: !SimpleRepo
  , aRepoSubdirs :: [(Text, RawPackageMetadata)]
  }
  deriving (Show, Generic, Eq, Ord, Typeable)

-- | Group input repositories by non-subdir values.
toAggregateRepos :: [(Repo, RawPackageMetadata)] -> [AggregateRepo]
toAggregateRepos = mapMaybe toAggregateRepo . groupBy matchRepoExclSubdir
 where
  toAggregateRepo :: [(Repo, RawPackageMetadata)] -> Maybe AggregateRepo
  toAggregateRepo [] = Nothing
  toAggregateRepo xs@((repo, _):_) =
    Just $ AggregateRepo (rToSimpleRepo repo) (fmap (first repoSubdir) xs)

  matchRepoExclSubdir x1 x2 =
    let (Repo url1 commit1 type1 _, _) = x1
        (Repo url2 commit2 type2 _, _) = x2
    in  (url1, commit1, type1) == (url2, commit2, type2)

arToSimpleRepo :: AggregateRepo -> SimpleRepo
arToSimpleRepo AggregateRepo {..} = aRepo

-- | Repository without subdirectory information.
--
-- @since 0.5.3
data SimpleRepo = SimpleRepo
  { sRepoUrl :: !Text
  , sRepoCommit :: !Text
  , sRepoType :: !RepoType
  }
  deriving (Show, Generic, Eq, Ord, Typeable)

instance Display SimpleRepo where
  display (SimpleRepo url commit typ) =
    (case typ of
       RepoGit -> "Git"
       RepoHg -> "Mercurial") <>
    " repo at " <>
    display url <>
    ", commit " <>
    display commit

-- An unexported newtype wrapper to hang a 'FromJSON' instance off of. Contains
-- a GitHub user and repo name separated by a forward slash, e.g. "foo/bar".
newtype GitHubRepo = GitHubRepo Text

instance FromJSON GitHubRepo where
  parseJSON = withText "GitHubRepo" $ \s -> do
    case T.split (== '/') s of
      [x, y] | not (T.null x || T.null y) -> pure (GitHubRepo s)
      _ -> fail "expecting \"user/repo\""

-- | Configuration to securely download package metadata and contents. For most
-- purposes, you'll want to use the default Hackage settings via
-- @defaultPackageIndexConfig@.
--
-- /NOTE/ It's highly recommended to only use the official Hackage
-- server or a mirror. See
-- <https://github.com/commercialhaskell/stack/issues/4137>.
--
-- @since 0.6.0
data PackageIndexConfig = PackageIndexConfig
  { picDownloadPrefix :: !Text
  , picHackageSecurityConfig :: !HackageSecurityConfig
  }
  deriving Show

-- | If the @hackage-security@ key is absent from the JSON object, assigns
-- default value 'defaultHackageSecurityConfig'.
--
-- @since 0.6.0
instance FromJSON (WithJSONWarnings PackageIndexConfig) where
  parseJSON = withObjectWarnings "PackageIndexConfig" $ \o -> do
    picDownloadPrefix <- o ..: "download-prefix"
    picHackageSecurityConfig <- jsonSubWarnings $
      o ..:? "hackage-security" ..!= noJSONWarnings defaultHackageSecurityConfig
    pure PackageIndexConfig {..}

-- | Default 'HackageSecurityConfig' value using the official Hackage server.
-- The value of the 'hscIgnoreExpiry' field is 'True'.
--
-- @since 0.7.0
defaultHackageSecurityConfig :: HackageSecurityConfig
defaultHackageSecurityConfig = HackageSecurityConfig
  { hscKeyIds =
      -- Key owners and public keys are provided as a convenience to readers.
      -- The canonical source for this mapping data is the hackage-root-keys
      -- repository and Hackage's root.json file.
      --
      -- Links:
      --  * https://github.com/haskell-infra/hackage-root-keys
      --  * https://hackage.haskell.org/root.json
      -- Please consult root.json on Hackage to map key IDs to public keys,
      -- and the hackage-root-keys repository to map public keys to their
      -- owners.
      [ -- Adam Gundry (uRPdSiL3/MNsk50z6NB55ABo0OrrNDXigtCul4vtzmw=)
        "fe331502606802feac15e514d9b9ea83fee8b6ffef71335479a2e68d84adc6b0"
      , -- Gershom Bazerman (bYoUXXQ9TtX10UriaMiQtTccuXPGnmldP68djzZ7cLo=)
        "1ea9ba32c526d1cc91ab5e5bd364ec5e9e8cb67179a471872f6e26f0ae773d42"
      , -- John Wiegley (zazm5w480r+zPO6Z0+8fjGuxZtb9pAuoVmQ+VkuCvgU=)
        "0a5c7ea47cd1b15f01f5f51a33adda7e655bc0f0b0615baa8e271f4c3351e21d"
      , -- Norman Ramsey (ZI8di3a9Un0s2RBrt5GwVRvfOXVuywADfXGPZfkiDb0=)
        "51f0161b906011b52c6613376b1ae937670da69322113a246a09f807c62f6921"
      , -- Mathieu Boespflug (ydN1nGGQ79K1Q0nN+ul+Ln8MxikTB95w0YdGd3v3kmg=)
        "be75553f3c7ba1dbe298da81f1d1b05c9d39dd8ed2616c9bddf1525ca8c03e48"
      , -- Joachim Breitner (5iUgwqZCWrCJktqMx0bBMIuoIyT4A1RYGozzchRN9rA=)
        "d26e46f3b631aae1433b89379a6c68bd417eb5d1c408f0643dcc07757fece522"
      ]
  , hscKeyThreshold = 3
  , hscIgnoreExpiry = True
  }

-- | Configuration for Hackage Security to securely download package metadata
-- and contents. For most purposes, you'll want to use the default Hackage
-- settings via @defaultHackageSecurityConfig@.
--
-- /NOTE/ It's highly recommended to only use the official Hackage
-- server or a mirror. See
-- <https://github.com/commercialhaskell/stack/issues/4137>.
--
-- @since 0.6.0
data HackageSecurityConfig = HackageSecurityConfig
  { hscKeyIds :: ![Text]
  , hscKeyThreshold :: !Int
  , hscIgnoreExpiry :: !Bool
  }
  deriving Show

-- | If the @ignore-expiry@ key is absent from the JSON object, assigns default
-- value 'True'.
--
-- @since 0.1.1.0
instance FromJSON (WithJSONWarnings HackageSecurityConfig) where
  parseJSON = withObjectWarnings "HackageSecurityConfig" $ \o -> do
    hscKeyIds <- o ..: "keyids"
    hscKeyThreshold <- o ..: "key-threshold"
    hscIgnoreExpiry <- o ..:? "ignore-expiry" ..!= True
    pure HackageSecurityConfig {..}

-- | An environment which contains a 'PantryConfig'.
--
-- @since 0.1.0.0
class HasPantryConfig env where
  -- | Lens to get or set the 'PantryConfig'
  --
  -- @since 0.1.0.0
  pantryConfigL :: Lens' env PantryConfig


-- | File size in bytes
--
-- @since 0.1.0.0
newtype FileSize = FileSize Word
  deriving ( Show, Eq, Ord, Typeable, Generic, Display, Hashable, NFData
           , PersistField, PersistFieldSql, ToJSON, FromJSON
           )

-- | A key for looking up a blob, which combines the SHA256 hash of the contents
-- and the file size.
--
-- The file size may seem redundant with the hash. However, it is necessary for
-- safely downloading blobs from an untrusted source. See
-- <https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys>.
--
-- @since 0.1.0.0
data BlobKey = BlobKey !SHA256 !FileSize
  deriving (Eq, Ord, Typeable, Generic)

instance NFData BlobKey

instance Show BlobKey where
  show = T.unpack . utf8BuilderToText . display

instance Display BlobKey where
  display (BlobKey sha size') = display sha <> "," <> display size'

blobKeyPairs :: BlobKey -> [(AesonKey, Value)]
blobKeyPairs (BlobKey sha size') =
  [ "sha256" .= sha
  , "size" .= size'
  ]

instance ToJSON BlobKey where
  toJSON = object . blobKeyPairs

instance FromJSON BlobKey where
  parseJSON = withObject "BlobKey" $ \o -> BlobKey
    <$> o .: "sha256"
    <*> o .: "size"

newtype PackageNameP = PackageNameP { unPackageNameP :: PackageName }
  deriving (Eq, Ord, Show, Read, NFData)

instance Display PackageNameP where
  display = fromString . packageNameString . unPackageNameP

instance PersistField PackageNameP where
  toPersistValue (PackageNameP pn) = PersistText $ T.pack $ packageNameString pn
  fromPersistValue v = do
    str <- fromPersistValue v
    case parsePackageName str of
      Nothing -> Left $ "Invalid package name: " <> T.pack str
      Just pn -> Right $ PackageNameP pn

instance PersistFieldSql PackageNameP where
  sqlType _ = SqlString

instance ToJSON PackageNameP where
  toJSON (PackageNameP pn) = String $ T.pack $ packageNameString pn

instance FromJSON PackageNameP where
  parseJSON =
    withText "PackageNameP" $ pure . PackageNameP . mkPackageName . T.unpack

instance ToJSONKey PackageNameP where
  toJSONKey =
    ToJSONKeyText
      (fromString . packageNameString . unPackageNameP)
      (unsafeToEncoding . getUtf8Builder . display)

instance FromJSONKey PackageNameP where
  fromJSONKey = FromJSONKeyText $ PackageNameP . mkPackageName . T.unpack

newtype VersionP = VersionP { unVersionP :: Version }
  deriving (Eq, Ord, Show, Read, NFData)

instance PersistField VersionP where
  toPersistValue (VersionP v) = PersistText $ T.pack $ versionString v
  fromPersistValue v = do
    str <- fromPersistValue v
    case parseVersion str of
      Nothing -> Left $ "Invalid version number: " <> T.pack str
      Just ver -> Right $ VersionP ver

instance PersistFieldSql VersionP where
  sqlType _ = SqlString

instance Display VersionP where
  display (VersionP v) = fromString $ versionString v

instance ToJSON VersionP where
  toJSON (VersionP v) = String $ T.pack $ versionString v

instance FromJSON VersionP where
  parseJSON =
    withText "VersionP" $
    either (fail . displayException) (pure . VersionP) . parseVersionThrowing . T.unpack

newtype ModuleNameP = ModuleNameP
  { unModuleNameP :: ModuleName
  }
  deriving (Eq, Ord, Show, NFData)

instance Display ModuleNameP where
  display = fromString . moduleNameString . unModuleNameP

instance PersistField ModuleNameP where
  toPersistValue (ModuleNameP mn) = PersistText $ T.pack $ moduleNameString mn
  fromPersistValue v = do
    str <- fromPersistValue v
    case parseModuleName str of
      Nothing -> Left $ "Invalid module name: " <> T.pack str
      Just pn -> Right $ ModuleNameP pn

instance PersistFieldSql ModuleNameP where
  sqlType _ = SqlString

-- | How to choose a cabal file for a package from Hackage. This is to work with
-- Hackage cabal file revisions, which makes @PackageIdentifier@ insufficient
-- for specifying a package from Hackage.
--
-- @since 0.1.0.0
data CabalFileInfo
  = CFILatest
    -- ^ Take the latest revision of the cabal file available. This
    -- isn't reproducible at all, but the running assumption (not
    -- necessarily true) is that cabal file revisions do not change
    -- semantics of the build.
    --
    -- @since 0.1.0.0
  | CFIHash !SHA256 !(Maybe FileSize)
    -- ^ Identify by contents of the cabal file itself. Only reason for
    -- @Maybe@ on @FileSize@ is for compatibility with input that
    -- doesn't include the file size.
    --
    -- @since 0.1.0.0
  | CFIRevision !Revision
    -- ^ Identify by revision number, with 0 being the original and
    -- counting upward. This relies on Hackage providing consistent
    -- versioning. @CFIHash@ should be preferred wherever possible for
    -- reproducibility.
    --
    -- @since 0.1.0.0
  deriving (Generic, Show, Eq, Ord, Typeable)

instance NFData CabalFileInfo

instance Hashable CabalFileInfo

instance Display CabalFileInfo where
  display CFILatest = mempty
  display (CFIHash hash' msize) =
    "@sha256:" <> display hash' <> maybe mempty (\i -> "," <> display i) msize
  display (CFIRevision rev) = "@rev:" <> display rev

-- | A full specification for a package from Hackage, including the package
-- name, version, and how to load up the correct cabal file revision.
--
-- @since 0.1.0.0
data PackageIdentifierRevision
  = PackageIdentifierRevision !PackageName !Version !CabalFileInfo
  deriving (Generic, Eq, Ord, Typeable)

instance NFData PackageIdentifierRevision

instance Show PackageIdentifierRevision where
  show = T.unpack . utf8BuilderToText . display

instance Display PackageIdentifierRevision where
  display (PackageIdentifierRevision name version cfi) =
       fromString (packageNameString name)
    <> "-"
    <> fromString (versionString version)
    <> display cfi

instance ToJSON PackageIdentifierRevision where
  toJSON = toJSON . utf8BuilderToText . display

instance FromJSON PackageIdentifierRevision where
  parseJSON = withText "PackageIdentifierRevision" $ \t ->
    case parsePackageIdentifierRevision t of
      Left e -> fail $ show e
      Right pir -> pure pir

-- | Parse a hackage text.
--
-- @since 0.1.0.0
parseHackageText :: Text -> Either PantryException (PackageIdentifier, BlobKey)
parseHackageText t =
  either (\x -> error (show x) $ const $ Left $ PackageIdentifierRevisionParseFail t) Right $
  explicitEitherParsec (hackageTextParsec <* Parse.eof) $
  T.unpack t

hackageTextParsec :: ParsecParser (PackageIdentifier, BlobKey)
hackageTextParsec = do
  ident <- packageIdentifierParsec
  _ <- Parse.string "@sha256:"

  shaT <- Parse.munch (/= ',')
  sha <- either (const mzero) pure $ SHA256.fromHexText $ fromString shaT

  _ <- Parse.char ','
  size' <- Parse.integral -- FIXME probably need to handle overflow, since unfortunately Cabal doesn't
  pure (ident, BlobKey sha (FileSize size'))

splitColon :: Text -> Maybe (Text, Text)
splitColon t' =
  let (x, y) = T.break (== ':') t'
  in  (x, ) <$> T.stripPrefix ":" y

-- | Parse a 'PackageIdentifierRevision'
--
-- @since 0.1.0.0
parsePackageIdentifierRevision ::
     Text
  -> Either PantryException PackageIdentifierRevision
parsePackageIdentifierRevision t =
  maybe (Left $ PackageIdentifierRevisionParseFail t) Right $ do
    let (identT, cfiT) = T.break (== '@') t
    PackageIdentifier name version <- parsePackageIdentifier $ T.unpack identT
    cfi <-
      case splitColon cfiT of
        Just ("@sha256", shaSizeT) -> do
          let (shaT, sizeT) = T.break (== ',') shaSizeT
          sha <- either (const Nothing) Just $ SHA256.fromHexText shaT
          msize <-
            case T.stripPrefix "," sizeT of
              Nothing -> Just Nothing
              Just sizeT' ->
                case decimal sizeT' of
                  Right (size', "") -> Just $ Just $ FileSize size'
                  _ -> Nothing
          pure $ CFIHash sha msize
        Just ("@rev", revT) ->
          case decimal revT of
            Right (rev, "") -> pure $ CFIRevision $ Revision rev
            _ -> Nothing
        Nothing -> pure CFILatest
        _ -> Nothing
    pure $ PackageIdentifierRevision name version cfi

data Mismatch a = Mismatch
  { mismatchExpected :: !a
  , mismatchActual :: !a
  }

-- | Things that can go wrong in pantry. Note two things:
--
-- * Many other exception types may be thrown from underlying libraries. Pantry
--   does not attempt to wrap these underlying exceptions.
--
-- * We may add more constructors to this data type in minor version bumps of
--   pantry. This technically breaks the PVP. You should not be writing pattern
--   matches against this type that expect total matching.
--
-- @since 0.1.0.0
data PantryException
  = PackageIdentifierRevisionParseFail !Text
  | InvalidCabalFile
      !(Either RawPackageLocationImmutable (Path Abs File))
      !(Maybe Version)
      ![PError]
      ![PWarning]
  | TreeWithoutCabalFile !RawPackageLocationImmutable
  | TreeWithMultipleCabalFiles !RawPackageLocationImmutable ![SafeFilePath]
  | MismatchedCabalName !(Path Abs File) !PackageName
  | NoLocalPackageDirFound !(Path Abs Dir)
  | NoCabalFileFound !(Path Abs Dir)
  | MultipleCabalFilesFound !(Path Abs Dir) ![Path Abs File]
  | InvalidWantedCompiler !Text
  | InvalidSnapshotLocation !(Path Abs Dir) !Text
  | InvalidOverrideCompiler !WantedCompiler !WantedCompiler
  | InvalidFilePathSnapshot !Text
  | InvalidSnapshot !RawSnapshotLocation !SomeException
  | MismatchedPackageMetadata
      !RawPackageLocationImmutable
      !RawPackageMetadata
      !(Maybe TreeKey)
      !PackageIdentifier
  | Non200ResponseStatus !Status
  | InvalidBlobKey !(Mismatch BlobKey)
  | Couldn'tParseSnapshot !RawSnapshotLocation !String
  | WrongCabalFileName !RawPackageLocationImmutable !SafeFilePath !PackageName
  | DownloadInvalidSHA256 !Text !(Mismatch SHA256)
  | DownloadInvalidSize !Text !(Mismatch FileSize)
  | DownloadTooLarge !Text !(Mismatch FileSize)
  -- ^ Different from 'DownloadInvalidSize' since 'mismatchActual' is
  -- a lower bound on the size from the server.
  | LocalNoArchiveFileFound !(Path Abs File)
  | LocalInvalidSHA256 !(Path Abs File) !(Mismatch SHA256)
  | LocalInvalidSize !(Path Abs File) !(Mismatch FileSize)
  | UnknownArchiveType !ArchiveLocation
  | InvalidTarFileType !ArchiveLocation !FilePath !Tar.FileType
  | UnsupportedTarball !ArchiveLocation !Text
  | NoHackageCryptographicHash !PackageIdentifier
  | FailedToCloneRepo !SimpleRepo
  | TreeReferencesMissingBlob !RawPackageLocationImmutable !SafeFilePath !BlobKey
  | CompletePackageMetadataMismatch !RawPackageLocationImmutable !PackageMetadata
  | CRC32Mismatch !ArchiveLocation !FilePath !(Mismatch Word32)
  | UnknownHackagePackage !PackageIdentifierRevision !FuzzyResults
  | CannotCompleteRepoNonSHA1 !Repo
  | MutablePackageLocationFromUrl !Text
  | MismatchedCabalFileForHackage !PackageIdentifierRevision !(Mismatch PackageIdentifier)
  | PackageNameParseFail !Text
  | PackageVersionParseFail !Text
  | InvalidCabalFilePath !(Path Abs File)
  | DuplicatePackageNames !Utf8Builder ![(PackageName, [RawPackageLocationImmutable])]
  | MigrationFailure !Text !(Path Abs File) !SomeException
  | NoCasaConfig
  | InvalidTreeFromCasa !BlobKey !ByteString
  | ParseSnapNameException !Text
  | HpackLibraryException !(Path Abs File) !String
  | HpackExeException !FilePath !(Path Abs Dir) !SomeException
  deriving Typeable

instance Exception PantryException where

instance Show PantryException where
  show = T.unpack . utf8BuilderToText . display

-- To support the Haskell Foundation's
-- [Haskell Error Index](https://errors.haskell.org/) initiative, all Pantry
-- error messages generated by Pantry itself begin with an unique code in the
-- form `[S-nnn]`, where `nnn` is a three-digit number in the range 100 to 999.
-- The numbers are selected at random, not in sequence.
--
-- Prettier versions of these error messages are also provided. See the instance
-- of Pretty.
instance Display PantryException where
  display NoCasaConfig =
    "Error: [S-889]\n"
    <> "The Pantry configuration has no Casa configuration."
  display (InvalidTreeFromCasa blobKey _bs) =
    "Error: [S-258]\n"
    <> "Invalid tree from casa: "
    <> display blobKey
  display (PackageIdentifierRevisionParseFail text) =
    "Error: [S-360]\n"
    <> "Invalid package identifier (with optional revision): "
    <> display text
  display (InvalidCabalFile loc mversion errs warnings) =
    "Error: [S-242]\n"
    <> "Unable to parse cabal file from package "
    <> either display (fromString . toFilePath) loc
    <> "\n\n"
    <> foldMap
         ( \(PError pos msg) ->
                 "- "
              <> fromString (showPos pos)
              <> ": "
              <> fromString msg
              <> "\n"
         )
         errs
    <> foldMap
         ( \(PWarning _ pos msg) ->
                 "- "
              <> fromString (showPos pos)
              <> ": "
              <> fromString msg
              <> "\n"
         )
         warnings
    <> ( case mversion of
           Just version
             | version > cabalSpecLatestVersion ->
                    "\n\nThe cabal file uses the cabal specification version "
                 <> fromString (versionString version)
                 <> ", but we only support up to version "
                 <> fromString (versionString cabalSpecLatestVersion)
                 <> ".\nRecommended action: upgrade your build tool (e.g., `stack upgrade`)."
           _ -> mempty
       )
  display (TreeWithoutCabalFile pl) =
    "Error: [S-654]\n"
    <> "No cabal file found for "
    <> display pl
  display (TreeWithMultipleCabalFiles pl sfps) =
    "Error: [S-500]\n"
    <> "Multiple cabal files found for "
    <> display pl
    <> ": "
    <> fold (intersperse ", " (map display sfps))
  display (MismatchedCabalName fp name) =
    "Error: [S-910]\n"
    <> "The Cabal file:\n"
    <> fromString (toFilePath fp)
    <> "\nis not named after the package that it defines.\n"
    <> "Please rename the file to: "
    <> fromString (packageNameString name)
    <> ".cabal\n"
    <> "Hackage rejects packages where the first part of the Cabal file name "
    <> "is not the package name."
  display (NoLocalPackageDirFound dir) =
    "Error: [S-395]\n"
    <> "Stack looks for packages in the directories configured in the\n"
    <> "'packages' and 'extra-deps' fields defined in its project-level\n"
    <> "configuration file (usually stack.yaml)\n"
    <> "The current entry points to "
    <> fromString (toFilePath dir)
    <> ",\nbut no such directory could be found. If, alternatively, a package\n"
    <> "in the package index was intended, its name and version must be\n"
    <> "specified as an extra-dep."
  display (NoCabalFileFound dir) =
    "Error: [S-636]\n"
    <> "Stack looks for packages in the directories configured in the\n"
    <> "'packages' and 'extra-deps' fields defined in its project-level\n"
    <> "configuration file (usually stack.yaml)\n"
    <> "The current entry points to "
    <> fromString (toFilePath dir)
    <> ",\nbut no .cabal or package.yaml file could be found there."
  display (MultipleCabalFilesFound dir files) =
    "Error: [S-368]\n"
    <> "Multiple .cabal files found in directory "
    <> fromString (toFilePath dir)
    <> ":\n"
    <> fold
         ( intersperse
             "\n"
             (map (\x -> "- " <> fromString (toFilePath (filename x))) files)
         )
  display (InvalidWantedCompiler t) =
    "Error: [S-204]\n"
    <> "Invalid wanted compiler: "
    <> display t
  display (InvalidSnapshotLocation dir t) =
    "Error: [S-935]\n"
    <> "Invalid snapshot location "
    <> displayShow t
    <> " relative to directory "
    <> displayShow (toFilePath dir)
  display (InvalidOverrideCompiler x y) =
    "Error: [S-287]\n"
    <> "Specified compiler for a snapshot ("
    <> display x
    <> "), but also specified an override compiler ("
    <> display y
    <> ")"
  display (InvalidFilePathSnapshot t) =
    "Error: [S-617]\n"
    <> "Specified snapshot as file path with "
    <> displayShow t
    <> ", but not reading from a local file"
  display (InvalidSnapshot loc err) =
    "Error: [S-775]\n"
    <> "Exception while reading snapshot from "
    <> display loc
    <> ":\n"
    <> displayShow err
  display (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
    "Error: [S-427]\n"
    <> "Mismatched package metadata for "
    <> display loc
    <> "\nFound: "
    <> fromString (packageIdentifierString foundIdent)
    <> ( case mtreeKey of
           Nothing -> mempty
           Just treeKey -> " with tree " <> display treeKey
       )
    <> "\nExpected: "
    <> display pm
  display (Non200ResponseStatus status) =
    "Error: [S-571]\n"
    <> "Unexpected non-200 HTTP status code: "
    <> displayShow (statusCode status)
  display (InvalidBlobKey Mismatch{..}) =
    "Error: [S-236]\n"
    <> "Invalid blob key found, expected: "
    <> display mismatchExpected
    <> ", actual: "
    <> display mismatchActual
  display (Couldn'tParseSnapshot sl err) =
    "Error: [S-645]\n"
    <> "Couldn't parse snapshot from "
    <> display sl
    <> ": "
    <> fromString err
  display (WrongCabalFileName pl sfp name) =
    "Error: [S-575]\n"
    <> "Wrong cabal file name for package "
    <> display pl
    <> "\nThe cabal file is named "
    <> display sfp
    <> ", but package name is "
    <> fromString (packageNameString name)
    <> "\nFor more information, see:\n  - https://github.com/commercialhaskell/stack/issues/317\n  -https://github.com/commercialhaskell/stack/issues/895"
  display (DownloadInvalidSHA256 url Mismatch {..}) =
    "Error: [S-394]\n"
    <> "Mismatched SHA256 hash from "
    <> display url
    <> "\nExpected: "
    <> display mismatchExpected
    <> "\nActual:   "
    <> display mismatchActual
  display (DownloadInvalidSize url Mismatch {..}) =
    "Error: [S-401]\n"
    <> "Mismatched download size from "
    <> display url
    <> "\nExpected: "
    <> display mismatchExpected
    <> "\nActual:   "
    <> display mismatchActual
  display (DownloadTooLarge url Mismatch {..}) =
    "Error: [S-113]\n"
    <> "Download from "
    <> display url
    <> " was too large.\n"
    <> "Expected: "
    <> display mismatchExpected
    <> ", stopped after receiving: "
    <> display mismatchActual
  display (LocalNoArchiveFileFound path) =
    "Error: [S-628]\n"
    <> "Stack looks for packages in the archive files configured in the\n"
    <> "'extra-deps' field defined in its project-level configuration file\n"
    <> "(usually stack.yaml)\n"
    <> "An entry points to "
    <> fromString (toFilePath path)
    <> ",\nbut no such archive file could be found."
  display (LocalInvalidSHA256 path Mismatch {..}) =
    "Error: [S-834]\n"
    <> "Mismatched SHA256 hash from "
    <> fromString (toFilePath path)
    <> "\nExpected: "
    <> display mismatchExpected
    <> "\nActual:   "
    <> display mismatchActual
  display (LocalInvalidSize path Mismatch {..}) =
    "Error: [S-713]\n"
    <> "Mismatched file size from "
    <> fromString (toFilePath path)
    <> "\nExpected: "
    <> display mismatchExpected
    <> "\nActual:   "
    <> display mismatchActual
  display (UnknownArchiveType loc) =
    "Error: [S-372]\n"
    <> "Unable to determine archive type of: "
    <> display loc
  display (InvalidTarFileType loc fp x) =
    "Error: [S-950]\n"
    <> "Unsupported tar file type in archive "
    <> display loc
    <> " at file "
    <> fromString fp
    <> ": "
    <> displayShow x
  display (UnsupportedTarball loc err) =
    "Error: [S-760]\n"
    <> "Unsupported tarball from "
    <> display loc
    <> ": "
    <> display err
  display (NoHackageCryptographicHash ident) =
    "Error: [S-922]\n"
    <> "No cryptographic hash found for Hackage package "
    <> fromString (packageIdentifierString ident)
  display (FailedToCloneRepo repo) =
    "Error: [S-109]\n"
    <> "Failed to clone repo "
    <> display repo
  display (TreeReferencesMissingBlob loc sfp key) =
    "Error: [S-237]\n"
    <> "The package "
    <> display loc
    <> " needs blob "
    <> display key
    <> " for file path "
    <> display sfp
    <> ", but the blob is not available"
  display (CompletePackageMetadataMismatch loc pm) =
    "Error: [S-984]\n"
    <> "When completing package metadata for "
    <> display loc
    <> ", some values changed in the new package metadata: "
    <> display pm
  display (CRC32Mismatch loc fp Mismatch {..}) =
    "Error: [S-607]\n"
    <> "CRC32 mismatch in ZIP file from "
    <> display loc
    <> " on internal file "
    <> fromString fp
    <> "\nExpected: "
    <> display mismatchExpected
    <> "\nActual:   "
    <> display mismatchActual
  display (UnknownHackagePackage pir fuzzy) =
    "Error: [S-476]\n"
    <> "Could not find "
    <> display pir
    <> " on Hackage"
    <> displayFuzzy fuzzy
  display (CannotCompleteRepoNonSHA1 repo) =
    "Error: [S-112]\n"
    <> "Cannot complete repo information for a non SHA1 commit due to non-reproducibility: "
    <> display repo
  display (MutablePackageLocationFromUrl t) =
    "Error: [S-321]\n"
    <> "Cannot refer to a mutable package location from a URL: "
    <> display t
  display (MismatchedCabalFileForHackage pir Mismatch{..}) =
    "Error: [S-377]\n"
    <> "When processing cabal file for Hackage package "
    <> display pir
    <> ":\nMismatched package identifier."
    <> "\nExpected: "
    <> fromString (packageIdentifierString mismatchExpected)
    <> "\nActual:   "
    <> fromString (packageIdentifierString mismatchActual)
  display (PackageNameParseFail t) =
    "Error: [S-580]\n"
    <> "Invalid package name: "
    <> display t
  display (PackageVersionParseFail t) =
    "Error: [S-479]\n"
    <> "Invalid version: "
    <> display t
  display (InvalidCabalFilePath fp) =
    "Error: [S-824]\n"
    <> "File path contains a name which is not a valid package name: "
    <> fromString (toFilePath fp)
  display (DuplicatePackageNames source pairs') =
    "Error: [S-674]\n"
    <> "Duplicate package names ("
    <> source
    <> "):\n"
    <> foldMap
         ( \(name, locs) ->
                fromString (packageNameString name)
             <> ":\n"
             <> foldMap (\loc -> "- " <> display loc <> "\n") locs
         )
         pairs'
  display (MigrationFailure desc fp err) =
    "Error: [S-536]\n"
    <> "Encountered error while migrating database "
    <> display desc
    <> "\nlocated at "
    <> fromString (toFilePath fp)
    <> ":"
    <> "\n    "
    <> displayShow err
  display (ParseSnapNameException t) =
    "Error: [S-994]\n"
     <> "Invalid snapshot name: "
     <> display t
  display (HpackLibraryException file err) =
    "Error: [S-305]\n"
    <> "Failed to generate a Cabal file using the Hpack library on file:\n"
    <> fromString (toFilePath file)
    <> "\n\n"
    <> "The error encountered was:\n\n"
    <> fromString err
  display (HpackExeException fp dir err) =
    "Error: [S-720]\n"
    <> "Failed to generate a Cabal file using the Hpack executable:\n"
    <> fromString fp
    <> "in directory: "
    <> fromString (toFilePath dir)
    <> "\n\n"
    <> "The error encountered was:\n\n"
    <> fromString (show err)

-- See also the instance of Display. Although prettier, these messages are
-- intended to be substantively the same as the corresponding 'black and white'
-- versions.
instance Pretty PantryException where
  pretty NoCasaConfig =
    "[S-889]"
    <> line
    <> flow "The Pantry configuration has no Casa configuration."
  pretty (InvalidTreeFromCasa blobKey _bs) =
    "[S-258]"
    <> line
    <> fillSep
         [ flow "Invalid tree from casa:"
         , fromString . T.unpack $ textDisplay blobKey
         ]
  pretty (PackageIdentifierRevisionParseFail text) =
    "[S-360]"
    <> line
    <> fillSep
         [ flow "Invalid package identifier (with optional revision):"
         , fromString $ T.unpack text
         ]
  pretty (InvalidCabalFile loc mversion errs warnings) =
    "[S-242]"
    <> line
    <> fillSep
         [ flow "Unable to parse Cabal file from package"
         , either pretty pretty loc <> ":"
         ]
    <> line
    <> bulletedList
         ( map (\(PError pos msg) -> fillSep
             [ fromString (showPos pos) <> ":"
             , fromString msg
             ])
             errs
         )
    <> line
    <> bulletedList
         ( map (\(PWarning _ pos msg) -> fillSep
             [ fromString (showPos pos) <> ":"
             , fromString msg
             ])
             warnings
         )
    <> ( case mversion of
           Just version | version > cabalSpecLatestVersion ->
                line
             <> fillSep
                  [ flow "The Cabal file uses the Cabal specification version"
                  , style Current (fromString $ versionString version) <> ","
                  , flow "but we only support up to version"
                  , fromString (versionString cabalSpecLatestVersion) <> "."
                  , flow "Recommended action: upgrade your build tool"
                  , parens (fillSep
                      [ "e.g."
                      , style Shell (flow "stack upgrade")
                      ]) <> "."
                  ]
           _ -> mempty
       )
  pretty (TreeWithoutCabalFile loc) =
    "[S-654]"
    <> line
    <> fillSep
         [ flow "No Cabal file found for"
         , pretty loc <> "."
         ]
  pretty (TreeWithMultipleCabalFiles loc sfps) =
    "[S-500]"
    <> line
    <> fillSep
         ( flow "Multiple Cabal files found for"
         : (pretty loc <> ":")
         : mkNarrativeList (Just File) False
             (map (fromString . T.unpack . textDisplay) sfps :: [StyleDoc])
         )
  pretty (MismatchedCabalName fp name) =
    "[S-910]"
    <> line
    <> fillSep
         [ flow "The Cabal file"
         , pretty fp
         , flow "is not named after the package that it defines. Please rename"
         , flow "the file to"
         , style File (fromString $ packageNameString name <> ".cabal") <> "."
         , flow "Hackage rejects packages where the first part of the Cabal"
         , flow "file name is not the package name."
         ]
  pretty (NoLocalPackageDirFound dir) =
    "[S-395]"
    <> line
    <> fillSep
         [ flow "Stack looks for packages in the directories configured in the"
         , style Shell "packages"
         , "and"
         , style Shell "extra-deps"
         , flow "fields defined in its project-level configuration file"
         , parens (fillSep ["usually", style File "stack.yaml"]) <> "."
         , flow "The current entry points to"
         , pretty dir
         , flow "but no such directory could be found. If, alternatively, a"
         , flow "package in the package index was intended, its name and"
         , flow "version must be specified as an extra-dep."
         ]
  pretty (NoCabalFileFound dir) =
    "[S-636]"
    <> line
    <> fillSep
         [ flow "Stack looks for packages in the directories configured in the"
         , style Shell "packages"
         , "and"
         , style Shell "extra-deps"
         , flow "fields defined in its project-level configuration file"
         , parens (fillSep ["usually", style File "stack.yaml"]) <> "."
         , flow "The current entry points to"
         , pretty dir
         , flow "but no Cabal file or"
         , style File "package.yaml"
         , flow "could be found there."
         ]
  pretty (MultipleCabalFilesFound dir files) =
    "[S-368]"
    <> line
    <> fillSep
         ( flow "Multiple Cabal files found in directory"
         : (pretty dir <> ":")
         : mkNarrativeList (Just File) False
             (map (pretty . filename) files)
         )
  pretty (InvalidWantedCompiler t) =
    "[S-204]"
    <> line
    <> fillSep
         [ flow "Invalid wanted compiler:"
         , style Current (fromString $ T.unpack t) <> "."
         ]
  pretty (InvalidSnapshotLocation dir t) =
    "[S-935]"
    <> line
    <> fillSep
         [ flow "Invalid snapshot location"
         , style Current (fromString $ T.unpack t)
         , flow "relative to directory"
         , pretty dir <> "."
         ]
  pretty (InvalidOverrideCompiler x y) =
    "[S-287]"
    <> line
    <> fillSep
         [ flow "Specified compiler for a snapshot"
         , parens (style Shell (fromString . T.unpack $ textDisplay x))
         , flow "but also specified an override compiler"
         , parens (style Shell (fromString . T.unpack $ textDisplay y)) <> "."
         ]
  pretty (InvalidFilePathSnapshot t) =
    "[S-617]"
    <> line
    <> fillSep
         [ flow "Specified snapshot as file path with"
         , style File (fromString $ T.unpack t) <> ","
         , flow "but not reading from a local file."
         ]
  pretty (InvalidSnapshot loc err) =
    "[S-775]"
    <> line
    <> fillSep
         [ flow "Exception while reading snapshot from"
         , pretty loc <> ":"
         ]
    <> blankLine
    <> string (displayException err)
  pretty (MismatchedPackageMetadata loc pm mtreeKey foundIdent) =
    "[S-427]"
    <> line
    <> fillSep
         [ flow "Mismatched package metadata for"
         , pretty loc <> "."
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , let t = textDisplay pm
           in  if T.null t
                 then "nothing."
                 else fromString $ T.unpack t <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Found:   "
         , fromString $ packageIdentifierString foundIdent <> case mtreeKey of
             Nothing -> "."
             _ -> mempty
         , case mtreeKey of
             Nothing -> mempty
             Just treeKey -> fillSep
               [ "with tree"
               , fromString . T.unpack $ textDisplay treeKey <> "."
               ]
         ])
  pretty (Non200ResponseStatus status) =
    "[S-571]"
    <> line
    <> fillSep
         [ flow "Unexpected non-200 HTTP status code:"
         , (fromString . show $ statusCode status) <> "."
         ]
  pretty (InvalidBlobKey Mismatch{..}) =
    "[S-236]"
    <> line
    <> fillSep
         [ flow "Invalid blob key found, expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> ","
         , "actual:"
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ]
  pretty (Couldn'tParseSnapshot sl err) =
    "[S-645]"
    <> line
    <> fillSep
         [ flow "Couldn't parse snapshot from"
         , pretty sl <> ":"
         ]
    <> blankLine
    <> string err
  pretty (WrongCabalFileName loc sfp name) =
    "[S-575]"
    <> line
    <> fillSep
         [ flow "Wrong Cabal file name for package"
         , pretty loc <> "."
         , flow "The Cabal file is named"
         , style File (fromString . T.unpack $ textDisplay sfp) <> ","
         , flow "but package name is"
         , fromString (packageNameString name) <> "."
         , flow "For more information, see"
         , style Url "https://github.com/commercialhaskell/stack/issues/317"
         , "and"
         , style Url "https://github.com/commercialhaskell/stack/issues/895" <> "."
         ]
  pretty (DownloadInvalidSHA256 url Mismatch {..}) =
    "[S-394]"
    <> line
    <> fillSep
         [ flow "Mismatched SHA256 hash from"
         , style Url (fromString $ T.unpack url) <> "."
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Actual:  "
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ])
  pretty (DownloadInvalidSize url Mismatch {..}) =
    "[S-401]"
    <> line
    <> fillSep
         [ flow "Mismatched download size from"
         , style Url (fromString $ T.unpack url) <> "."
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Actual:  "
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ])
  pretty (DownloadTooLarge url Mismatch {..}) =
    "[S-113]"
    <> line
    <> fillSep
         [ flow "Download from"
         , style Url (fromString $ T.unpack url)
         , flow "was too large. Expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> ","
         , flow "stopped after receiving:"
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ]
  pretty (LocalNoArchiveFileFound path) =
    "[S-628]"
    <> line
    <> fillSep
         [ flow "Stack looks for packages in the archive files configured in"
         , "the"
         , style Shell "extra-deps"
         , flow "field defined in its project-level configuration file"
         , parens (fillSep ["usually", style File "stack.yaml"]) <> "."
         , flow "An entry points to"
         , pretty path
         , flow "but no such archive file could be found."
         ]
  pretty (LocalInvalidSHA256 path Mismatch {..}) =
    "[S-834]"
    <> line
    <> fillSep
         [ flow "Mismatched SHA256 hash from"
         , pretty path <> "."
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Actual:  "
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ])
  pretty (LocalInvalidSize path Mismatch {..}) =
    "[S-713]"
    <> line
    <> fillSep
         [ flow "Mismatched file size from"
         , pretty path <> "."
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Actual:  "
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ])
  pretty (UnknownArchiveType loc) =
    "[S-372]"
    <> line
    <> fillSep
         [ flow "Unable to determine archive type of:"
         , pretty loc <> "."
         ]
  pretty (InvalidTarFileType loc fp x) =
    "[S-950]"
    <> line
    <> fillSep
         [ flow "Unsupported tar file type in archive"
         , pretty loc
         , flow "at file"
         , style File (fromString fp) <> ":"
         , fromString $ show x <> "."
         ]
  pretty (UnsupportedTarball loc err) =
    "[S-760]"
    <> line
    <> fillSep
         [ flow "Unsupported tarball from"
         , pretty loc <> ":"
         ]
    <> blankLine
    <> string (T.unpack err)
  pretty (NoHackageCryptographicHash ident) =
    "[S-922]"
    <> line
    <> fillSep
         [ flow "No cryptographic hash found for Hackage package"
         , fromString (packageIdentifierString ident) <> "."
         ]
  pretty (FailedToCloneRepo repo) =
    "[S-109]"
    <> line
    <> fillSep
         [ flow "Failed to clone repository"
         , fromString . T.unpack $ textDisplay repo
         ]
  pretty (TreeReferencesMissingBlob loc sfp key) =
    "[S-237]"
    <> line
    <> fillSep
         [ flow "The package"
         , pretty loc
         , flow "needs blob"
         , fromString . T.unpack $ textDisplay key
         , flow "for file path"
         , style File (fromString . T.unpack $ textDisplay sfp) <> ","
         , flow "but the blob is not available."
         ]
  pretty (CompletePackageMetadataMismatch loc pm) =
    "[S-984]"
    <> line
    <> fillSep
         [ flow "When completing package metadata for"
         , pretty loc <> ","
         , flow "some values changed in the new package metadata:"
         , fromString . T.unpack $ textDisplay pm <> "."
         ]
  pretty (CRC32Mismatch loc fp Mismatch {..}) =
    "[S-607]"
    <> line
    <> fillSep
         [ flow "CRC32 mismatch in Zip file from"
         , pretty loc
         , flow "on internal file"
         , style File (fromString fp)
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , fromString . T.unpack $ textDisplay mismatchExpected <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Actual:  "
         , fromString . T.unpack $ textDisplay mismatchActual <> "."
         ])
  pretty (UnknownHackagePackage pir fuzzy) =
    "[S-476]"
    <> line
    <> fillSep
         [ flow "Could not find"
         , style Error (fromString . T.unpack $ textDisplay pir)
         , flow "on Hackage."
         ]
    <> prettyFuzzy fuzzy
  pretty (CannotCompleteRepoNonSHA1 repo) =
    "[S-112]"
    <> line
    <> fillSep
         [ flow "Cannot complete repo information for a non SHA1 commit due to"
         , "non-reproducibility:"
         , fromString . T.unpack $ textDisplay repo <> "."
         ]
  pretty (MutablePackageLocationFromUrl t) =
    "[S-321]"
    <> line
    <> fillSep
         [ flow "Cannot refer to a mutable package location from a URL:"
         , style Url (fromString $ T.unpack t) <> "."
         ]
  pretty (MismatchedCabalFileForHackage pir Mismatch{..}) =
    "[S-377]"
    <> line
    <> fillSep
         [ flow "When processing Cabal file for Hackage package"
         , fromString . T.unpack $ textDisplay pir <> ","
         , flow "mismatched package identifier."
         ]
    <> blankLine
    <> hang 10 (fillSep
         [ "Expected:"
         , fromString (packageIdentifierString mismatchExpected) <> "."
         ])
    <> line
    <> hang 10 (fillSep
         [ "Actual:  "
         , fromString (packageIdentifierString mismatchActual) <> "."
         ])
  pretty (PackageNameParseFail t) =
    "[S-580]"
    <> line
    <> fillSep
         [ flow "Invalid package name:"
         , fromString $ T.unpack t <> "."
         ]
  pretty (PackageVersionParseFail t) =
    "[S-479]"
    <> line
    <> fillSep
         [ flow "Invalid version:"
         , fromString $ T.unpack t <> "."
         ]
  pretty (InvalidCabalFilePath fp) =
    "[S-824]"
    <> line
    <> fillSep
         [ flow "File path contains a name which is not a valid package name:"
         , pretty fp <> "."
         ]
  pretty (DuplicatePackageNames source pairs') =
    "[S-674]"
    <> line
    <> fillSep
         [ flow "Duplicate package names"
         , parens (fromString . T.unpack $ textDisplay source) <> ":"
         ]
    <> line
    <> foldMap
         ( \(name, locs) ->
                fromString (packageNameString name) <> ":"
             <> line
             <> bulletedList (map pretty locs)
             <> line
         )
         pairs'
  pretty (MigrationFailure desc fp err) =
    "[S-536]"
    <> line
    <> fillSep
         [ flow "Encountered error while migrating database"
         , fromString $ T.unpack desc
         , flow "located at"
         , pretty fp <> ":"
         ]
    <> blankLine
    <> string (displayException err)
  pretty (ParseSnapNameException t) =
    "[S-994]"
    <> line
    <> fillSep
         [ flow "Invalid snapshot name:"
         , fromString $ T.unpack t <> "."
         ]
  pretty (HpackLibraryException file err) =
    "[S-305]"
    <> line
    <> fillSep
         [ flow "Failed to generate a Cabal file using the Hpack library on"
         , "file:"
         , pretty file <> "."
         , flow "The error encountered was:"
         ]
    <> blankLine
    <> string err
  pretty (HpackExeException fp dir err) =
    "[S-720]"
    <> line
    <> fillSep
         [ flow "Failed to generate a Cabal file using the Hpack executable:"
         , style File (fromString fp)
         , flow "in directory:"
         , pretty dir <> "."
         , flow "The error encountered was:"
         ]
    <> blankLine
    <> string (displayException err)

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

displayFuzzy :: FuzzyResults -> Utf8Builder
displayFuzzy (FRNameNotFound names) =
  case NE.nonEmpty names of
    Nothing -> ""
    Just names' ->
      "\nPerhaps you meant " <>
      orSeparated (NE.map (fromString . packageNameString) names') <>
      "?"
displayFuzzy (FRVersionNotFound pirs) =
  "\nPossible candidates: " <>
  commaSeparated (NE.map display pirs) <>
  "."
displayFuzzy (FRRevisionNotFound pirs) =
  "\nThe specified revision was not found.\nPossible candidates: " <>
  commaSeparated (NE.map display pirs) <>
  "."

prettyFuzzy :: FuzzyResults -> StyleDoc
prettyFuzzy (FRNameNotFound names) =
  case NE.nonEmpty names of
    Nothing -> mempty
    Just names' ->
         line
      <> fillSep
           ( flow "Perhaps you meant one of"
           : mkNarrativeList Nothing False
               (NE.toList $ NE.map (fromString . packageNameString) names' :: [StyleDoc])
           )
prettyFuzzy (FRVersionNotFound pirs) =
     line
  <> fillSep
       ( flow "Possible candidates:"
       : mkNarrativeList Nothing False
           (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc])
       )
prettyFuzzy (FRRevisionNotFound pirs) =
     line
  <> fillSep
       ( flow "The specified revision was not found. Possible candidates:"
       : mkNarrativeList Nothing False
           (NE.toList $ NE.map (fromString . T.unpack . textDisplay) pirs :: [StyleDoc])
       )

orSeparated :: NonEmpty Utf8Builder -> Utf8Builder
orSeparated xs
  | NE.length xs == 1 = NE.head xs
  | NE.length xs == 2 = NE.head xs <> " or " <> NE.last xs
  | otherwise = fold (intersperse ", " (NE.init xs)) <> ", or " <> NE.last xs

commaSeparated :: NonEmpty Utf8Builder -> Utf8Builder
commaSeparated = fold . NE.intersperse ", "

cabalSpecLatestVersion :: Version
cabalSpecLatestVersion = mkVersion $ cabalSpecToVersionDigits cabalSpecLatest

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

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

data FileType = FTNormal | FTExecutable
  deriving (Show, Eq, Enum, Bounded, Ord)

instance PersistField FileType where
  toPersistValue FTNormal = PersistInt64 1
  toPersistValue FTExecutable = PersistInt64 2

  fromPersistValue v = do
    i <- fromPersistValue v
    case i :: Int64 of
      1 -> Right FTNormal
      2 -> Right FTExecutable
      _ -> Left $ "Invalid FileType: " <> tshow i

instance PersistFieldSql FileType where
  sqlType _ = SqlInt32

data TreeEntry = TreeEntry
  { teBlob :: !BlobKey
  , teType :: !FileType
  }
  deriving (Show, Eq, Ord)

newtype SafeFilePath = SafeFilePath Text
  deriving (Show, Eq, Ord, Display)

instance PersistField SafeFilePath where
  toPersistValue = toPersistValue . unSafeFilePath
  fromPersistValue v = do
    t <- fromPersistValue v
    maybe (Left $ "Invalid SafeFilePath: " <> t) Right $ mkSafeFilePath t

instance PersistFieldSql SafeFilePath where
  sqlType _ = SqlString

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

safeFilePathToPath :: (MonadThrow m) => Path Abs Dir -> SafeFilePath -> m (Path Abs File)
safeFilePathToPath dir (SafeFilePath path) = do
  fpath <- parseRelFile (T.unpack path)
  pure $ dir </> fpath

mkSafeFilePath :: Text -> Maybe SafeFilePath
mkSafeFilePath t = do
  guard $ not $ "\\" `T.isInfixOf` t
  guard $ not $ "//" `T.isInfixOf` t
  guard $ not $ "\n" `T.isInfixOf` t
  guard $ not $ "\0" `T.isInfixOf` t

  (c, _) <- T.uncons t
  guard $ c /= '/'

  guard $ (not . any (T.all (== '.'))) $ T.split (== '/') t

  Just $ SafeFilePath t

-- | SafeFilePath for `package.yaml` file.
hpackSafeFilePath :: SafeFilePath
hpackSafeFilePath =
    let fpath = mkSafeFilePath (T.pack Hpack.packageConfig)
    in case fpath of
         Nothing -> error $
           "hpackSafeFilePath: Not able to encode " <> Hpack.packageConfig
         Just sfp -> sfp

-- | The hash of the binary representation of a 'Tree'.
--
-- @since 0.1.0.0
newtype TreeKey = TreeKey BlobKey
  deriving (Show, Eq, Ord, Generic, Typeable, ToJSON, FromJSON, NFData, Display)

-- | Represents the contents of a tree, which is a mapping from
-- relative file paths to 'TreeEntry's.
--
-- @since 0.1.0.0
newtype Tree
  = TreeMap (Map SafeFilePath TreeEntry)
  -- In the future, consider allowing more lax parsing
  -- See: https://www.fpcomplete.com/blog/2018/07/pantry-part-2-trees-keys
  -- TreeTarball !PackageTarball
  deriving (Show, Eq, Ord)

renderTree :: Tree -> ByteString
renderTree = BL.toStrict . toLazyByteString . go
 where
  go :: Tree -> Builder
  go (TreeMap m) = "map:" <> Map.foldMapWithKey goEntry m

  goEntry sfp (TreeEntry (BlobKey sha (FileSize size')) ft) =
    netstring (unSafeFilePath sfp) <>
    byteString (SHA256.toRaw sha) <>
    netword size' <>
    (case ft of
      FTNormal -> "N"
      FTExecutable -> "X")

netstring :: Text -> Builder
netstring t =
  let bs = encodeUtf8 t
  in  netword (fromIntegral (B.length bs)) <> byteString bs

netword :: Word -> Builder
netword w = wordDec w <> ":"

parseTreeM :: MonadThrow m => (BlobKey, ByteString) -> m (TreeKey, Tree)
parseTreeM (blobKey, blob) =
  case parseTree blob of
    Nothing -> throwM (InvalidTreeFromCasa blobKey blob)
    Just tree -> pure (TreeKey blobKey, tree)

parseTree :: ByteString -> Maybe Tree
parseTree bs1 = do
  tree <- parseTree' bs1
  let bs2 = renderTree tree
  guard $ bs1 == bs2
  Just tree

parseTree' :: ByteString -> Maybe Tree
parseTree' bs0 = do
  entriesBS <- B.stripPrefix "map:" bs0
  TreeMap <$> loop Map.empty entriesBS
 where
  loop !m bs1
    | B.null bs1 = pure m
    | otherwise = do
        (sfpBS, bs2) <- takeNetstring bs1
        sfp <-
          case decodeUtf8' sfpBS of
            Left _ -> Nothing
            Right sfpT -> mkSafeFilePath sfpT
        (sha, bs3) <- takeSha bs2
        (size', bs4) <- takeNetword bs3
        (typeW, bs5) <- B.uncons bs4
        ft <-
          case typeW of
            78 -> Just FTNormal -- 'N'
            88 -> Just FTExecutable -- 'X'
            _ -> Nothing
        let entry = TreeEntry (BlobKey sha (FileSize (fromIntegral size'))) ft
        loop (Map.insert sfp entry m) bs5

  takeNetstring bs1 = do
    (size', bs2) <- takeNetword bs1
    guard $ B.length bs2 >= size'
    Just $ B.splitAt size' bs2

  takeSha bs = do
    let (x, y) = B.splitAt 32 bs
    x' <- either (const Nothing) Just (SHA256.fromRaw x)
    Just (x', y)

  takeNetword =
    go 0
   where
    go !accum bs = do
      (next, rest) <- B.uncons bs
      if
        | next == 58 -> pure (accum, rest) -- ':'
        | next >= 48 && next <= 57 ->
            go
              (accum * 10 + fromIntegral (next - 48))
              rest
        | otherwise -> Nothing

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

-- | This is almost a copy of Cabal's parser for package identifiers,
-- the main difference is in the fact that Stack requires version to be
-- present while Cabal uses "null version" as a default value
--
-- @since 0.1.0.0
parsePackageIdentifier :: String -> Maybe PackageIdentifier
parsePackageIdentifier = either (const Nothing) Just . explicitEitherParsec (packageIdentifierParsec <* Parse.eof)

packageIdentifierParsec :: ParsecParser PackageIdentifier
packageIdentifierParsec = do
  ident@(PackageIdentifier _ v) <- parsec

  -- version is a required component of a package identifier for Stack
  guard (v /= nullVersion)

  pure ident

-- | Parse a package name from a 'String'.
--
-- @since 0.1.0.0
parsePackageName :: String -> Maybe PackageName
parsePackageName = Distribution.Text.simpleParse

-- | Parse a package name from a 'String' throwing on failure
--
-- @since 0.1.0.0
parsePackageNameThrowing :: MonadThrow m => String -> m PackageName
parsePackageNameThrowing str =
  case parsePackageName str of
    Nothing -> throwM $ PackageNameParseFail $ T.pack str
    Just pn -> pure pn

-- | Parse a version from a 'String'.
--
-- @since 0.1.0.0
parseVersion :: String -> Maybe Version
parseVersion = Distribution.Text.simpleParse

-- | Parse a package version from a 'String' throwing on failure
--
-- @since 0.1.0.0
parseVersionThrowing :: MonadThrow m => String -> m Version
parseVersionThrowing str =
  case parseVersion str of
    Nothing -> throwM $ PackageVersionParseFail $ T.pack str
    Just v -> pure v

-- | Parse a version range from a 'String'.
--
-- @since 0.1.0.0
parseVersionRange :: String -> Maybe VersionRange
parseVersionRange = Distribution.Text.simpleParse

-- | Parse a module name from a 'String'.
--
-- @since 0.1.0.0
parseModuleName :: String -> Maybe ModuleName
parseModuleName = Distribution.Text.simpleParse

-- | Parse a flag name from a 'String'.
--
-- @since 0.1.0.0
parseFlagName :: String -> Maybe FlagName
parseFlagName = Distribution.Text.simpleParse

-- | Render a package name as a 'String'.
--
-- @since 0.1.0.0
packageNameString :: PackageName -> String
packageNameString = unPackageName

-- | Render a package identifier as a 'String'.
--
-- @since 0.1.0.0
packageIdentifierString :: PackageIdentifier -> String
packageIdentifierString = Distribution.Text.display

-- | Render a version as a 'String'.
--
-- @since 0.1.0.0
versionString :: Version -> String
versionString = Distribution.Text.display

-- | Render a flag name as a 'String'.
--
-- @since 0.1.0.0
flagNameString :: FlagName -> String
flagNameString = unFlagName

-- | Render a module name as a 'String'.
--
-- @since 0.1.0.0
moduleNameString :: ModuleName -> String
moduleNameString = Distribution.Text.display

data OptionalSubdirs
  = OSSubdirs !(NonEmpty Text)
  | OSPackageMetadata !Text !RawPackageMetadata
  -- ^ subdirectory and package metadata
  deriving (Show, Eq, Generic)

instance NFData OptionalSubdirs

-- | Metadata provided by a config file for archives and repos. This information
-- can be used for optimized lookups of information like package identifiers, or
-- for validating that the user configuration has the expected information.
--
-- @since 0.1.0.0
data RawPackageMetadata = RawPackageMetadata
  { rpmName :: !(Maybe PackageName)
    -- ^ Package name in the cabal file
    --
    -- @since 0.1.0.0
  , rpmVersion :: !(Maybe Version)
    -- ^ Package version in the cabal file
    --
    -- @since 0.1.0.0
  , rpmTreeKey :: !(Maybe TreeKey)
    -- ^ Tree key of the loaded up package
    --
    -- @since 0.1.0.0
  }
  deriving (Show, Eq, Ord, Generic, Typeable)

instance NFData RawPackageMetadata

instance Display RawPackageMetadata where
  display rpm = fold $ intersperse ", " $ catMaybes
    [ (\name -> "name == " <> fromString (packageNameString name)) <$> rpmName rpm
    , (\version -> "version == " <> fromString (versionString version)) <$> rpmVersion rpm
    , (\tree -> "tree == " <> display tree) <$> rpmTreeKey rpm
    ]

-- | Exact metadata specifying concrete package
--
-- @since 0.1.0.0
data PackageMetadata = PackageMetadata
  { pmIdent :: !PackageIdentifier
    -- ^ Package identifier in the cabal file
    --
    -- @since 0.1.0.0
  , pmTreeKey :: !TreeKey
    -- ^ Tree key of the loaded up package
    --
    -- @since 0.1.0.0
  }
  deriving (Show, Eq, Ord, Generic, Typeable)

-- i PackageMetadata
instance NFData PackageMetadata

instance Display PackageMetadata where
  display pm = fold $ intersperse ", "
    [ "ident == " <> fromString (packageIdentifierString $ pmIdent pm)
    , "tree == " <> display (pmTreeKey pm)
    ]

parsePackageMetadata :: Object -> WarningParser PackageMetadata
parsePackageMetadata o = do
  _oldCabalFile :: Maybe BlobKey <- o ..:? "cabal-file"
  pantryTree :: BlobKey <- o ..: "pantry-tree"
  CabalString pkgName <- o ..: "name"
  CabalString pkgVersion <- o ..: "version"
  let pmTreeKey = TreeKey pantryTree
      pmIdent = PackageIdentifier {..}
  pure PackageMetadata {..}


-- | Convert package metadata to its "raw" equivalent.
--
-- @since 0.1.0.0
toRawPM :: PackageMetadata -> RawPackageMetadata
toRawPM pm = RawPackageMetadata (Just name) (Just version) (Just $ pmTreeKey pm)
 where
  PackageIdentifier name version = pmIdent pm

-- | File path relative to the configuration file it was parsed from
--
-- @since 0.1.0.0
newtype RelFilePath = RelFilePath Text
  deriving (Show, ToJSON, FromJSON, Eq, Ord, Generic, Typeable, NFData, Display)

-- | Location that an archive is stored at
--
-- @since 0.1.0.0
data ArchiveLocation
  = ALUrl !Text
    -- ^ Archive stored at an HTTP(S) URL
    --
    -- @since 0.1.0.0
  | ALFilePath !(ResolvedPath File)
    -- ^ Archive stored at a local file path
    --
    -- @since 0.1.0.0
  deriving (Show, Eq, Ord, Generic, Typeable)

instance NFData ArchiveLocation

instance Display ArchiveLocation where
  display (ALUrl url) = display url
  display (ALFilePath resolved) =
    fromString $ toFilePath $ resolvedAbsolute resolved

instance Pretty ArchiveLocation where
  pretty (ALUrl url) = style Url (fromString $ T.unpack url)
  pretty (ALFilePath resolved) = pretty $ resolvedAbsolute resolved

parseArchiveLocationObject ::
     Object
  -> WarningParser (Unresolved ArchiveLocation)
parseArchiveLocationObject o =
      ((o ..: "url") >>= either (fail . T.unpack) pure . validateUrl)
  <|> ((o ..: "filepath") >>= either (fail . T.unpack) pure . validateFilePath)
  <|> ((o ..: "archive") >>= either (fail . T.unpack) pure . parseArchiveLocationText)
  <|> ((o ..: "location") >>= either (fail . T.unpack) pure . parseArchiveLocationText)

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

validateUrl :: Text -> Either Text (Unresolved ArchiveLocation)
validateUrl t =
  case parseRequest $ T.unpack t of
    Left _ -> Left $ "Could not parse URL: " <> t
    Right _ -> pure $ pure $ ALUrl t

validateFilePath :: Text -> Either Text (Unresolved ArchiveLocation)
validateFilePath t =
  if any (`T.isSuffixOf` t) (T.words ".zip .tar .tar.gz")
    then pure $ Unresolved $ \case
      Nothing -> throwIO $ InvalidFilePathSnapshot t
      Just dir -> do
        abs' <- resolveFile dir $ T.unpack t
        pure $ ALFilePath $ ResolvedPath (RelFilePath t) abs'
    else Left $ "Does not have an archive file extension: " <> t

instance ToJSON RawPackageLocation where
  toJSON (RPLImmutable rpli) = toJSON rpli
  toJSON (RPLMutable resolved) = toJSON (resolvedRelative resolved)

instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocation))) where
  parseJSON v =
    (fmap . fmap . fmap . fmap) RPLImmutable (parseJSON v) <|>
    (noJSONWarnings . mkMutable <$> parseJSON v)
   where
    mkMutable :: Text -> Unresolved (NonEmpty RawPackageLocation)
    mkMutable t = Unresolved $ \mdir -> do
      case mdir of
        Nothing -> throwIO $ MutablePackageLocationFromUrl t
        Just dir -> do
          abs' <- resolveDir dir $ T.unpack t
          pure $ pure $ RPLMutable $ ResolvedPath (RelFilePath t) abs'

instance ToJSON RawPackageLocationImmutable where
  toJSON (RPLIHackage pir mtree) = object $
    ("hackage" .= pir) : maybe [] (\tree -> ["pantry-tree" .= tree]) mtree
  toJSON (RPLIArchive (RawArchive loc msha msize subdir) rpm) = object $ concat
    [ case loc of
        ALUrl url -> ["url" .= url]
        ALFilePath resolved -> ["filepath" .= resolvedRelative resolved]
    , maybe [] (\sha -> ["sha256" .= sha]) msha
    , maybe [] (\size' -> ["size" .= size']) msize
    , [ "subdir" .= subdir | not (T.null subdir) ]
    , rpmToPairs rpm
    ]
  toJSON (RPLIRepo (Repo url commit typ subdir) rpm) = object $ concat
    [ [ urlKey .= url
      , "commit" .= commit
      ]
    , ["subdir" .= subdir | not (T.null subdir) ]
    , rpmToPairs rpm
    ]
   where
    urlKey =
      case typ of
        RepoGit -> "git"
        RepoHg  -> "hg"

rpmToPairs :: RawPackageMetadata -> [(AesonKey, Value)]
rpmToPairs (RawPackageMetadata mname mversion mtree) = concat
  [ maybe [] (\name -> ["name" .= CabalString name]) mname
  , maybe [] (\version -> ["version" .= CabalString version]) mversion
  , maybe [] (\tree -> ["pantry-tree" .= tree]) mtree
  ]

instance FromJSON (WithJSONWarnings (Unresolved PackageLocationImmutable)) where
  parseJSON v =
        repoObject v
    <|> archiveObject v
    <|> hackageObject v
    <|> github v
    <|> fail ("Could not parse a UnresolvedPackageLocationImmutable from: " ++ show v)
   where
    repoObject ::
         Value
      -> Parser (WithJSONWarnings (Unresolved PackageLocationImmutable))
    repoObject =
      withObjectWarnings "UnresolvedPackageLocationImmutable.PLIRepo" $ \o -> do
        pm <- parsePackageMetadata o
        repoSubdir <- o ..:? "subdir" ..!= ""
        repoCommit <- o ..: "commit"
        (repoType, repoUrl) <-
            (o ..: "git" >>= \url -> pure (RepoGit, url)) <|>
            (o ..: "hg" >>= \url -> pure (RepoHg, url))
        pure $ pure $ PLIRepo Repo {..} pm

    archiveObject =
      withObjectWarnings "UnresolvedPackageLocationImmutable.PLIArchive" $ \o -> do
        pm <- parsePackageMetadata o
        Unresolved mkArchiveLocation <- parseArchiveLocationObject o
        archiveHash <- o ..: "sha256"
        archiveSize <- o ..: "size"
        archiveSubdir <- o ..:? "subdir" ..!= ""
        pure $ Unresolved $ \mdir -> do
          archiveLocation <- mkArchiveLocation mdir
          pure $ PLIArchive Archive {..} pm

    hackageObject =
      withObjectWarnings "UnresolvedPackagelocationimmutable.PLIHackage (Object)" $ \o -> do
        treeKey <- o ..: "pantry-tree"
        htxt <- o ..: "hackage"
        case parseHackageText htxt of
          Left e -> fail $ show e
          Right (pkgIdentifier, blobKey) ->
            pure $ pure $ PLIHackage pkgIdentifier blobKey (TreeKey treeKey)

    github =
      withObjectWarnings "UnresolvedPackagelocationimmutable.PLIArchive:github" (\o -> do
        pm <- parsePackageMetadata o
        GitHubRepo ghRepo <- o ..: "github"
        commit <- o ..: "commit"
        let archiveLocation = ALUrl $ T.concat
              [ "https://github.com/"
              , ghRepo
              , "/archive/"
              , commit
              , ".tar.gz"
              ]
        archiveHash <- o ..: "sha256"
        archiveSize <- o ..: "size"
        archiveSubdir <- o ..:? "subdir" ..!= ""
        pure $ pure $ PLIArchive Archive {..} pm)

instance FromJSON (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable))) where
  parseJSON v =
        http v
    <|> hackageText v
    <|> hackageObject v
    <|> repo v
    <|> archiveObject v
    <|> github v
    <|> fail ("Could not parse a UnresolvedRawPackageLocationImmutable from: " ++ show v)
   where
    http :: Value -> Parser (WithJSONWarnings (Unresolved (NonEmpty RawPackageLocationImmutable)))
    http = withText "UnresolvedPackageLocationImmutable.RPLIArchive (Text)" $ \t ->
      case parseArchiveLocationText t of
        Left _ -> fail $ "Invalid archive location: " ++ T.unpack t
        Right (Unresolved mkArchiveLocation) ->
          pure $ noJSONWarnings $ Unresolved $ \mdir -> do
            raLocation <- mkArchiveLocation mdir
            let raHash = Nothing
                raSize = Nothing
                raSubdir = T.empty
            pure $ pure $ RPLIArchive RawArchive {..} rpmEmpty

    hackageText = withText "UnresolvedPackageLocationImmutable.UPLIHackage (Text)" $ \t ->
      case parsePackageIdentifierRevision t of
        Left e -> fail $ show e
        Right pir -> pure $ noJSONWarnings $ pure $ pure $ RPLIHackage pir Nothing

    hackageObject = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIHackage" $ \o -> pure . pure <$> (RPLIHackage
      <$> o ..: "hackage"
      <*> o ..:? "pantry-tree")

    optionalSubdirs :: Object -> WarningParser OptionalSubdirs
    optionalSubdirs o =
      -- if subdirs exists, it needs to be valid
      case HM.lookup "subdirs" o of
        Just v' -> do
          tellJSONField "subdirs"
          subdirs <- lift $ parseJSON v'
          case NE.nonEmpty subdirs of
            Nothing -> fail "Invalid empty subdirs"
            Just x -> pure $ OSSubdirs x
        Nothing -> OSPackageMetadata
          <$> o ..:? "subdir" ..!= T.empty
          <*> (   rawPackageMetadataHelper
              <$> (fmap unCabalString <$> (o ..:? "name"))
              <*> (fmap unCabalString <$> (o ..:? "version"))
              <*> o ..:? "pantry-tree"
              <*> o ..:? "cabal-file"
              )

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

    repo = withObjectWarnings "UnresolvedPackageLocationImmutable.UPLIRepo" $ \o -> do
      (repoType, repoUrl) <-
        ((RepoGit, ) <$> o ..: "git") <|>
        ((RepoHg, ) <$> o ..: "hg")
      repoCommit <- o ..: "commit"
      os <- optionalSubdirs o
      pure $ pure $ NE.map (\(repoSubdir, pm) -> RPLIRepo Repo {..} pm) (osToRpms os)

    archiveObject = withObjectWarnings "UnresolvedPackageLocationImmutable.RPLIArchive" $ \o -> do
      Unresolved mkArchiveLocation <- parseArchiveLocationObject o
      raHash <- o ..:? "sha256"
      raSize <- o ..:? "size"
      os <- optionalSubdirs o
      pure $ Unresolved $ \mdir -> do
        raLocation <- mkArchiveLocation mdir
        pure $ NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os)

    github = withObjectWarnings "PLArchive:github" $ \o -> do
      GitHubRepo ghRepo <- o ..: "github"
      commit <- o ..: "commit"
      let raLocation = ALUrl $ T.concat
            [ "https://github.com/"
            , ghRepo
            , "/archive/"
            , commit
            , ".tar.gz"
            ]
      raHash <- o ..:? "sha256"
      raSize <- o ..:? "size"
      os <- optionalSubdirs o
      pure $ pure $
        NE.map (\(raSubdir, pm) -> RPLIArchive RawArchive {..} pm) (osToRpms os)

-- | Returns pairs of subdirectory and 'PackageMetadata'.
osToRpms :: OptionalSubdirs -> NonEmpty (Text, RawPackageMetadata)
osToRpms (OSSubdirs subdirs) = NE.map (, rpmEmpty) subdirs
osToRpms (OSPackageMetadata subdir rpm) = pure (subdir, rpm)

rpmEmpty :: RawPackageMetadata
rpmEmpty = RawPackageMetadata Nothing Nothing Nothing

-- | Newtype wrapper for easier JSON integration with Cabal types.
--
-- @since 0.1.0.0
newtype CabalString a = CabalString { unCabalString :: a }
  deriving (Show, Eq, Ord, Typeable)

-- I'd like to use coerce here, but can't due to roles. unsafeCoerce
-- could work, but let's avoid unsafe code.

-- | Wrap the keys in a 'Map' with a 'CabalString' to get a 'ToJSON'
-- instance.
--
-- @since 0.1.0.0
toCabalStringMap :: Map a v -> Map (CabalString a) v
toCabalStringMap = Map.mapKeysMonotonic CabalString

-- | Unwrap the 'CabalString' from the keys in a 'Map' to use a
-- 'FromJSON' instance.
--
-- @since 0.1.0.0
unCabalStringMap :: Map (CabalString a) v -> Map a v
unCabalStringMap = Map.mapKeysMonotonic unCabalString

instance Distribution.Pretty.Pretty a => ToJSON (CabalString a) where
  toJSON = toJSON . Distribution.Text.display . unCabalString

instance Distribution.Pretty.Pretty a => ToJSONKey (CabalString a) where
  toJSONKey = toJSONKeyText $ T.pack . Distribution.Text.display . unCabalString

instance forall a. IsCabalString a => FromJSON (CabalString a) where
  parseJSON = withText name $ \t ->
    case cabalStringParser $ T.unpack t of
      Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t
      Just x -> pure $ CabalString x
   where
    name = cabalStringName (Nothing :: Maybe a)

instance forall a. IsCabalString a => FromJSONKey (CabalString a) where
  fromJSONKey =
    FromJSONKeyTextParser $ \t ->
    case cabalStringParser $ T.unpack t of
      Nothing -> fail $ "Invalid " ++ name ++ ": " ++ T.unpack t
      Just x -> pure $ CabalString x
   where
    name = cabalStringName (Nothing :: Maybe a)

class IsCabalString a where
  cabalStringName :: proxy a -> String
  cabalStringParser :: String -> Maybe a

instance IsCabalString PackageName where
  cabalStringName _ = "package name"
  cabalStringParser = parsePackageName

instance IsCabalString Version where
  cabalStringName _ = "version"
  cabalStringParser = parseVersion

instance IsCabalString VersionRange where
  cabalStringName _ = "version range"
  cabalStringParser = parseVersionRange

instance IsCabalString PackageIdentifier where
  cabalStringName _ = "package identifier"
  cabalStringParser = parsePackageIdentifier

instance IsCabalString FlagName where
  cabalStringName _ = "flag name"
  cabalStringParser = parseFlagName

-- | What to use for running hpack
--
-- @since 0.1.0.0
data HpackExecutable
  = HpackBundled
    -- ^ Compiled in library
  | HpackCommand !FilePath
    -- ^ Executable at the provided path
  deriving (Show, Read, Eq, Ord)


-- | Which compiler a snapshot wants to use. The build tool may elect to do some
-- fuzzy matching of versions (e.g., allowing different patch versions).
--
-- @since 0.1.0.0
data WantedCompiler
  = WCGhc !Version
  | WCGhcGit !Text !Text
  | WCGhcjs
      !Version
      !Version
    -- ^ GHCJS version followed by GHC version
  deriving (Show, Eq, Ord, Generic)

instance NFData WantedCompiler

instance Display WantedCompiler where
  display (WCGhc vghc) = "ghc-" <> fromString (versionString vghc)
  display (WCGhcjs vghcjs vghc) =
       "ghcjs-"
    <> fromString (versionString vghcjs)
    <> "_ghc-" <> fromString (versionString vghc)
  display (WCGhcGit commit flavour) =
    "ghc-git-" <> display commit <> "-" <> display flavour

instance ToJSON WantedCompiler where
  toJSON = toJSON . utf8BuilderToText . display

instance FromJSON WantedCompiler where
  parseJSON =
    withText "WantedCompiler" $ either (fail . show) pure . parseWantedCompiler

instance FromJSONKey WantedCompiler where
  fromJSONKey =
    FromJSONKeyTextParser $ \t ->
    case parseWantedCompiler t of
      Left e -> fail $ "Invalid WantedCompiler " ++ show t ++ ": " ++ show e
      Right x -> pure x

-- | Parse a 'Text' into a 'WantedCompiler' value.
--
-- @since 0.1.0.0
parseWantedCompiler :: Text -> Either PantryException WantedCompiler
parseWantedCompiler t0 = maybe (Left $ InvalidWantedCompiler t0) Right $
  case T.stripPrefix "ghcjs-" t0 of
    Just t1 -> parseGhcjs t1
    Nothing -> case T.stripPrefix "ghc-git-" t0 of
       Just t1 -> parseGhcGit t1
       Nothing -> T.stripPrefix "ghc-" t0 >>= parseGhc
 where
  parseGhcjs t1 = do
    let (ghcjsVT, t2) = T.break (== '_') t1
    ghcjsV <- parseVersion $ T.unpack ghcjsVT
    ghcVT <- T.stripPrefix "_ghc-" t2
    ghcV <- parseVersion $ T.unpack ghcVT
    pure $ WCGhcjs ghcjsV ghcV
  parseGhcGit t1 = do
    let (commit, flavour) = T.break (== '-') t1
    pure $ WCGhcGit commit (T.drop 1 flavour)
  parseGhc = fmap WCGhc . parseVersion . T.unpack

instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLocation)) where
  parseJSON v = text v <|> obj v
   where
    text :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
    text =
      withText "UnresolvedSnapshotLocation (Text)" $
        pure . noJSONWarnings . parseRawSnapshotLocation

    obj :: Value -> Parser (WithJSONWarnings (Unresolved RawSnapshotLocation))
    obj = withObjectWarnings "UnresolvedSnapshotLocation (Object)" $ \o ->
      (pure . RSLCompiler <$> o ..: "compiler") <|>
      ((\x y -> pure $ RSLUrl x y) <$> o ..: "url" <*> blobKey o) <|>
      (parseRawSnapshotLocationPath <$> o ..: "filepath")

    blobKey o = do
      msha <- o ..:? "sha256"
      msize <- o ..:? "size"
      case (msha, msize) of
        (Nothing, Nothing) -> pure Nothing
        (Just sha, Just size') -> pure $ Just $ BlobKey sha size'
        (Just _sha, Nothing) -> fail "You must also specify the file size"
        (Nothing, Just _) -> fail "You must also specify the file's SHA256"

instance Display SnapshotLocation where
  display (SLCompiler compiler) = display compiler
  display (SLUrl url blob) = display url <> " (" <> display blob <> ")"
  display (SLFilePath resolved) = display (resolvedRelative resolved)

-- | Parse a 'Text' into an 'Unresolved' 'RawSnapshotLocation'.
--
-- @since 0.1.0.0
parseRawSnapshotLocation :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocation t0 = fromMaybe (parseRawSnapshotLocationPath t0) $
  either (const Nothing) (Just . pure . RSLCompiler) (parseWantedCompiler t0) <|>
  (pure . RSLSynonym <$> parseSnapName t0) <|>
  parseGitHub <|>
  parseUrl
 where
  parseGitHub = do
    t1 <- T.stripPrefix "github:" t0
    let (user, t2) = T.break (== '/') t1
    t3 <- T.stripPrefix "/" t2
    let (repo, t4) = T.break (== ':') t3
    path <- T.stripPrefix ":" t4
    Just $ pure $ githubSnapshotLocation user repo path

  parseUrl = parseRequest (T.unpack t0) $> pure (RSLUrl t0 Nothing)

parseRawSnapshotLocationPath :: Text -> Unresolved RawSnapshotLocation
parseRawSnapshotLocationPath t =
  Unresolved $ \case
    Nothing -> throwIO $ InvalidFilePathSnapshot t
    Just dir -> do
      abs' <- resolveFile dir (T.unpack t) `catchAny` \_ -> throwIO (InvalidSnapshotLocation dir t)
      pure $ RSLFilePath $ ResolvedPath (RelFilePath t) abs'

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

defUser :: Text
defUser = "commercialhaskell"

defRepo :: Text
defRepo = "stackage-snapshots"

-- | Default location of snapshot synonyms, i.e. commercialhaskell's GitHub
-- repository.
--
-- @since 0.5.0.0
defaultSnapshotLocation ::
     SnapName
  -> RawSnapshotLocation
defaultSnapshotLocation (LTS x y) =
  githubSnapshotLocation defUser defRepo $
  utf8BuilderToText $
  "lts/" <> display x <> "/" <> display y <> ".yaml"
defaultSnapshotLocation (Nightly date) =
     githubSnapshotLocation defUser defRepo
  $  utf8BuilderToText
  $  "nightly/"
  <> display year
  <> "/"
  <> display month
  <> "/"
  <> display day
  <> ".yaml"
 where
  (year, month, day) = toGregorian date

-- | A snapshot synonym. It is expanded according to the field
-- 'snapshotLocation' of a 'PantryConfig'.
--
-- @ since 0.5.0.0
data SnapName
    = LTS
        !Int -- ^ Major version
        !Int -- ^ Minor version
      -- ^ LTS Haskell snapshot, displayed as @"lts-maj.min"@.
      --
      -- @since 0.5.0.0
    | Nightly !Day
      -- ^ Stackage Nightly snapshot, displayed as @"nighly-YYYY-MM-DD"@.
      --
      -- @since 0.5.0.0
    deriving (Eq, Ord, Generic)

instance NFData SnapName

instance Display SnapName where
  display (LTS x y) = "lts-" <> display x <> "." <> display y
  display (Nightly date) = "nightly-" <> displayShow date

instance Show SnapName where
  show = T.unpack . utf8BuilderToText . display

instance ToJSON SnapName where
  toJSON syn = String $ utf8BuilderToText $ display syn

-- | Parse the short representation of a 'SnapName'.
--
-- @since 0.5.0.0
parseSnapName :: MonadThrow m => Text -> m SnapName
parseSnapName t0 =
  case lts <|> nightly of
    Nothing -> throwM $ ParseSnapNameException t0
    Just sn -> pure sn
 where
  lts = do
    t1 <- T.stripPrefix "lts-" t0
    Right (x, t2) <- Just $ decimal t1
    t3 <- T.stripPrefix "." t2
    Right (y, "") <- Just $ decimal t3
    pure $ LTS x y
  nightly = do
    t1 <- T.stripPrefix "nightly-" t0
    Nightly <$> readMaybe (T.unpack t1)

-- | Where to load a snapshot from in raw form (RSUrl could have a missing
-- BlobKey)
--
-- @since 0.1.0.0
data RawSnapshotLocation
  = RSLCompiler !WantedCompiler
    -- ^ Don't use an actual snapshot, just a version of the compiler with its
    -- shipped packages.
    --
    -- @since 0.1.0.0
  | RSLUrl !Text !(Maybe BlobKey)
    -- ^ Download the snapshot from the given URL. The optional 'BlobKey' is
    -- used for reproducibility.
    --
    -- @since 0.1.0.0
  | RSLFilePath !(ResolvedPath File)
    -- ^ Snapshot at a local file path.
    --
    -- @since 0.1.0.0
  | RSLSynonym !SnapName
    -- ^ Snapshot synonym (LTS/Nightly).
    --
    -- @since 0.5.0.0
  deriving (Show, Eq, Ord, Generic)

instance NFData RawSnapshotLocation

instance Display RawSnapshotLocation where
  display (RSLCompiler compiler) = display compiler
  display (RSLUrl url Nothing) = display url
  display (RSLUrl url (Just blob)) = display url <> " (" <> display blob <> ")"
  display (RSLFilePath resolved) = display (resolvedRelative resolved)
  display (RSLSynonym syn) = display syn

instance Pretty RawSnapshotLocation where
  pretty (RSLCompiler compiler) = fromString . T.unpack $ textDisplay compiler
  pretty (RSLUrl url Nothing) = style Url (fromString $ T.unpack url)
  pretty (RSLUrl url (Just blob)) = fillSep
    [ style Url (fromString $ T.unpack  url)
    , parens (fromString . T.unpack $ textDisplay blob)
    ]
  pretty (RSLFilePath resolved) =
    style File (fromString . T.unpack $ textDisplay (resolvedRelative resolved))
  pretty (RSLSynonym syn) =
    style Shell (fromString . T.unpack $ textDisplay syn)

instance ToJSON RawSnapshotLocation where
  toJSON (RSLCompiler compiler) = object ["compiler" .= compiler]
  toJSON (RSLUrl url mblob) = object
    $ "url" .= url
    : maybe [] blobKeyPairs mblob
  toJSON (RSLFilePath resolved) =
    object ["filepath" .= resolvedRelative resolved]
  toJSON (RSLSynonym syn) = toJSON syn

-- | Where to load a snapshot from.
--
-- @since 0.1.0.0
data SnapshotLocation
  = SLCompiler !WantedCompiler
    -- ^ Don't use an actual snapshot, just a version of the compiler
    -- with its shipped packages.
    --
    -- @since 0.1.0.0
  | SLUrl !Text !BlobKey
    -- ^ Download the snapshot from the given URL. The optional
    -- 'BlobKey' is used for reproducibility.
    --
    -- @since 0.1.0.0
  | SLFilePath !(ResolvedPath File)
    -- ^ Snapshot at a local file path.
    --
    -- @since 0.1.0.0
  deriving (Show, Eq, Ord, Generic)

instance NFData SnapshotLocation

instance ToJSON SnapshotLocation where
  toJSON sl = toJSON (toRawSL sl)

instance FromJSON (WithJSONWarnings (Unresolved SnapshotLocation)) where
  parseJSON v = file v <|> url v <|> compiler v
   where
    file = withObjectWarnings "SLFilepath" $ \o -> do
      ufp <- o ..: "filepath"
      pure $ Unresolved $ \case
        Nothing -> throwIO $ InvalidFilePathSnapshot ufp
        Just dir -> do
          absolute <- resolveFile dir (T.unpack ufp)
          let fp = ResolvedPath (RelFilePath ufp) absolute
          pure $ SLFilePath fp
    url = withObjectWarnings "SLUrl" $ \o -> do
      url' <- o ..: "url"
      sha <- o ..: "sha256"
      size <- o ..: "size"
      pure $ Unresolved $ \_ -> pure $ SLUrl url' (BlobKey sha size)
    compiler = withObjectWarnings "SLCompiler" $ \o -> do
      c <- o ..: "compiler"
      pure $ Unresolved $ \_ -> pure $ SLCompiler c

-- | Convert snapshot location to its "raw" equivalent.
--
-- @since 0.1.0.0
toRawSL :: SnapshotLocation -> RawSnapshotLocation
toRawSL (SLCompiler c) = RSLCompiler c
toRawSL (SLUrl url blob) = RSLUrl url (Just blob)
toRawSL (SLFilePath fp) = RSLFilePath fp

-- | A flattened representation of all the layers in a snapshot.
--
-- @since 0.1.0.0
data RawSnapshot = RawSnapshot
  { rsCompiler :: !WantedCompiler
    -- ^ The compiler wanted for this snapshot.
  , rsPackages :: !(Map PackageName RawSnapshotPackage)
    -- ^ Packages available in this snapshot for installation. This will be
    -- applied on top of any globally available packages.
  , rsDrop :: !(Set PackageName)
    -- ^ Global packages that should be dropped/ignored.
  }

-- | A flattened representation of all the layers in a snapshot.
--
-- @since 0.1.0.0
data Snapshot = Snapshot
  { snapshotCompiler :: !WantedCompiler
    -- ^ The compiler wanted for this snapshot.
  , snapshotPackages :: !(Map PackageName SnapshotPackage)
    -- ^ Packages available in this snapshot for installation. This will be
    -- applied on top of any globally available packages.
  , snapshotDrop :: !(Set PackageName)
    -- ^ Global packages that should be dropped/ignored.
  }

-- | Settings for a package found in a snapshot.
--
-- @since 0.1.0.0
data RawSnapshotPackage = RawSnapshotPackage
  { rspLocation :: !RawPackageLocationImmutable
    -- ^ Where to get the package from
  , rspFlags :: !(Map FlagName Bool)
    -- ^ Same as 'slFlags'
  , rspHidden :: !Bool
    -- ^ Same as 'slHidden'
  , rspGhcOptions :: ![Text]
    -- ^ Same as 'slGhcOptions'
  }

-- | Settings for a package found in a snapshot.
--
-- @since 0.1.0.0
data SnapshotPackage = SnapshotPackage
  { spLocation :: !PackageLocationImmutable
    -- ^ Where to get the package from
  , spFlags :: !(Map FlagName Bool)
    -- ^ Same as 'slFlags'
  , spHidden :: !Bool
    -- ^ Same as 'slHidden'
  , spGhcOptions :: ![Text]
    -- ^ Same as 'slGhcOptions'
  }
  deriving Show

-- | A single layer of a snapshot, i.e. a specific YAML configuration file.
--
-- @since 0.1.0.0
data RawSnapshotLayer = RawSnapshotLayer
  { rslParent :: !RawSnapshotLocation
    -- ^ The sl to extend from. This is either a specific compiler, or a
    -- @SnapshotLocation@ which gives us more information (like packages).
    -- Ultimately, we'll end up with a @CompilerVersion@.
    --
    -- @since 0.1.0.0
  , rslCompiler :: !(Maybe WantedCompiler)
    -- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if
    -- using 'SLCompiler'.
    --
    -- @since 0.1.0.0
  , rslLocations :: ![RawPackageLocationImmutable]
    -- ^ Where to grab all of the packages from.
    --
    -- @since 0.1.0.0
  , rslDropPackages :: !(Set PackageName)
    -- ^ Packages present in the parent which should not be included here.
    --
    -- @since 0.1.0.0
  , rslFlags :: !(Map PackageName (Map FlagName Bool))
    -- ^ Flag values to override from the defaults
    --
    -- @since 0.1.0.0
  , rslHidden :: !(Map PackageName Bool)
    -- ^ Packages which should be hidden when registering. This will affect, for
    -- example, the import parser in the script command. We use a 'Map' instead
    -- of just a 'Set' to allow overriding the hidden settings in a parent sl.
    --
    -- @since 0.1.0.0
  , rslGhcOptions :: !(Map PackageName [Text])
    -- ^ GHC options per package
    --
    -- @since 0.1.0.0
  , rslPublishTime :: !(Maybe UTCTime)
    -- ^ See 'slPublishTime'
    --
    -- @since 0.1.0.0
  }
  deriving (Show, Eq, Generic)

instance NFData RawSnapshotLayer

instance ToJSON RawSnapshotLayer where
  toJSON rsnap = object $ concat
    [ ["resolver" .= rslParent rsnap]
    , maybe [] (\compiler -> ["compiler" .= compiler]) (rslCompiler rsnap)
    , ["packages" .= rslLocations rsnap]
    , [ "drop-packages" .= Set.map CabalString (rslDropPackages rsnap)
      | not (Set.null (rslDropPackages rsnap))
      ]
    , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (rslFlags rsnap))
      | not(Map.null (rslFlags rsnap))
      ]
    , [ "hidden" .= toCabalStringMap (rslHidden rsnap)
      | not (Map.null (rslHidden rsnap))
      ]
    , [ "ghc-options" .= toCabalStringMap (rslGhcOptions rsnap)
      | not (Map.null (rslGhcOptions rsnap))
      ]
    , maybe [] (\time -> ["publish-time" .= time]) (rslPublishTime rsnap)
    ]

instance FromJSON (WithJSONWarnings (Unresolved RawSnapshotLayer)) where
  parseJSON = withObjectWarnings "Snapshot" $ \o -> do
    _ :: Maybe Text <- o ..:? "name" -- avoid warnings for old snapshot format
    mCompiler <- o ..:? "compiler"
    mSnapshot <- jsonSubWarningsT $ o ...:? ["snapshot", "resolver"]
    unresolvedSnapshotParent <-
      case (mCompiler, mSnapshot) of
        (Nothing, Nothing) -> fail "Snapshot must have either a compiler or a snapshot"
        (Just compiler, Nothing) -> pure $ pure (RSLCompiler compiler, Nothing)
        (_, Just (Unresolved usl)) -> pure $ Unresolved $ \mdir -> do
          sl <- usl mdir
          case (sl, mCompiler) of
            (RSLCompiler c1, Just c2) -> throwIO $ InvalidOverrideCompiler c1 c2
            _ -> pure (sl, mCompiler)

    unresolvedLocs <- jsonSubWarningsT (o ..:? "packages" ..!= [])
    rslDropPackages <- Set.map unCabalString <$> (o ..:? "drop-packages" ..!= Set.empty)
    rslFlags <- unCabalStringMap . fmap unCabalStringMap <$> (o ..:? "flags" ..!= Map.empty)
    rslHidden <- unCabalStringMap <$> (o ..:? "hidden" ..!= Map.empty)
    rslGhcOptions <- unCabalStringMap <$> (o ..:? "ghc-options" ..!= Map.empty)
    rslPublishTime <- o ..:? "publish-time"
    pure $ (\rslLocations (rslParent, rslCompiler) -> RawSnapshotLayer {..})
      <$> (concatMap NE.toList <$> sequenceA unresolvedLocs)
      <*> unresolvedSnapshotParent

-- | A single layer of a snapshot, i.e. a specific YAML configuration file.
--
-- @since 0.1.0.0
data SnapshotLayer = SnapshotLayer
  { slParent :: !SnapshotLocation
    -- ^ The sl to extend from. This is either a specific compiler, or a
    -- @SnapshotLocation@ which gives us more information (like packages).
    -- Ultimately, we'll end up with a @CompilerVersion@.
    --
    -- @since 0.1.0.0
  , slCompiler :: !(Maybe WantedCompiler)
    -- ^ Override the compiler specified in 'slParent'. Must be 'Nothing' if
    -- using 'SLCompiler'.
    --
    -- @since 0.1.0.0
  , slLocations :: ![PackageLocationImmutable]
    -- ^ Where to grab all of the packages from.
    --
    -- @since 0.1.0.0
  , slDropPackages :: !(Set PackageName)
    -- ^ Packages present in the parent which should not be included here.
    --
    -- @since 0.1.0.0
  , slFlags :: !(Map PackageName (Map FlagName Bool))
    -- ^ Flag values to override from the defaults
    --
    -- @since 0.1.0.0
  , slHidden :: !(Map PackageName Bool)
    -- ^ Packages which should be hidden when registering. This will affect, for
    -- example, the import parser in the script command. We use a 'Map' instead
    -- of just a 'Set' to allow overriding the hidden settings in a parent sl.
    --
    -- @since 0.1.0.0
  , slGhcOptions :: !(Map PackageName [Text])
    -- ^ GHC options per package
    --
    -- @since 0.1.0.0
  , slPublishTime :: !(Maybe UTCTime)
    -- ^ Publication timestamp for this snapshot. This field is optional, and is
    -- for informational purposes only.
    --
    -- @since 0.1.0.0
  }
  deriving (Show, Eq, Generic)

instance ToJSON SnapshotLayer where
  toJSON snap = object $ concat
    [ ["resolver" .= slParent snap]
    , maybe [] (\compiler -> ["compiler" .= compiler]) (slCompiler snap)
    , ["packages" .= slLocations snap]
    , [ "drop-packages" .= Set.map CabalString (slDropPackages snap)
      | not (Set.null (slDropPackages snap))
      ]
    , [ "flags" .= fmap toCabalStringMap (toCabalStringMap (slFlags snap))
      | not (Map.null (slFlags snap))
      ]
    , [ "hidden" .= toCabalStringMap (slHidden snap)
      | not (Map.null (slHidden snap))
      ]
    , [ "ghc-options" .= toCabalStringMap (slGhcOptions snap)
      | not (Map.null (slGhcOptions snap))
      ]
    , maybe [] (\time -> ["publish-time" .= time]) (slPublishTime snap)
    ]

-- | Convert snapshot layer into its "raw" equivalent.
--
-- @since 0.1.0.0
toRawSnapshotLayer :: SnapshotLayer -> RawSnapshotLayer
toRawSnapshotLayer sl = RawSnapshotLayer
  { rslParent = toRawSL (slParent sl)
  , rslCompiler = slCompiler sl
  , rslLocations = map toRawPLI (slLocations sl)
  , rslDropPackages = slDropPackages sl
  , rslFlags = slFlags sl
  , rslHidden = slHidden sl
  , rslGhcOptions = slGhcOptions sl
  , rslPublishTime = slPublishTime sl
  }

-- | An arbitrary hash for a snapshot, used for finding module names in a
-- snapshot. Mostly intended for Stack's usage.
--
-- @since 0.1.0.0
newtype SnapshotCacheHash = SnapshotCacheHash { unSnapshotCacheHash :: SHA256}
  deriving (Show)

-- | Get the path to the global hints cache file
getGlobalHintsFile :: HasPantryConfig env => RIO env (Path Abs File)
getGlobalHintsFile = do
  root <- view $ pantryConfigL.to pcRootDir
  globalHintsRelFile <- parseRelFile "global-hints-cache.yaml"
  pure $ root </> globalHintsRelFile

-- | Creates BlobKey for an input ByteString
--
-- @since 0.1.0.0
bsToBlobKey :: ByteString -> BlobKey
bsToBlobKey bs =
  BlobKey (SHA256.hashBytes bs) (FileSize (fromIntegral (B.length bs)))

-- | Warn if the package uses 'PCHpack'.
--
-- @since 0.4.0.0
warnMissingCabalFile :: HasLogFunc env => RawPackageLocationImmutable -> RIO env ()
warnMissingCabalFile loc =
  logWarn $
       "DEPRECATED: The package at "
    <> display loc
    <> " does not include a cabal file.\n"
    <> "Instead, it includes an hpack package.yaml file for generating a cabal file.\n"
    <> "This usage is deprecated; please see "
    <> "https://github.com/commercialhaskell/stack/issues/5210.\n"
    <> "Support for this workflow will be removed in the future.\n"
