{-# LANGUAGE DeriveGeneric #-}
module Distribution.Client.Types.Repo (
    -- * Remote repository
    RemoteRepo (..),
    emptyRemoteRepo,
    -- * Local repository (no-index)
    LocalRepo (..),
    emptyLocalRepo,
    localRepoCacheKey,
    -- * Repository
    Repo (..),
    repoName,
    isRepoRemote,
    maybeRepoRemote,
) where

import Distribution.Client.Compat.Prelude
import Prelude ()

import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString)

import Distribution.Simple.Utils (toUTF8BS)

import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)

import qualified Data.ByteString.Lazy.Char8      as LBS
import qualified Distribution.Compat.CharParsing as P
import qualified Text.PrettyPrint                as Disp

import Distribution.Client.Types.RepoName

-------------------------------------------------------------------------------
-- Remote repository
-------------------------------------------------------------------------------

data RemoteRepo =
    RemoteRepo {
      RemoteRepo -> RepoName
remoteRepoName     :: RepoName,
      RemoteRepo -> URI
remoteRepoURI      :: URI,

      -- | Enable secure access?
      --
      -- 'Nothing' here represents "whatever the default is"; this is important
      -- to allow for a smooth transition from opt-in to opt-out security
      -- (once we switch to opt-out, all access to the central Hackage
      -- repository should be secure by default)
      RemoteRepo -> Maybe Bool
remoteRepoSecure :: Maybe Bool,

      -- | Root key IDs (for bootstrapping)
      RemoteRepo -> [String]
remoteRepoRootKeys :: [String],

      -- | Threshold for verification during bootstrapping
      RemoteRepo -> Int
remoteRepoKeyThreshold :: Int,

      -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a
      -- special case we may know a repo supports both and want to try HTTPS
      -- if we can, but still allow falling back to HTTP.
      --
      -- This field is not currently stored in the config file, but is filled
      -- in automagically for known repos.
      RemoteRepo -> Bool
remoteRepoShouldTryHttps :: Bool
    }

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

instance Binary RemoteRepo
instance Structured RemoteRepo

instance Pretty RemoteRepo where
    pretty :: RemoteRepo -> Doc
pretty RemoteRepo
r =
        RepoName -> Doc
forall a. Pretty a => a -> Doc
pretty (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
r) Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
<<>>
        String -> Doc
Disp.text (ShowS -> URI -> ShowS
uriToString ShowS
forall a. a -> a
id (RemoteRepo -> URI
remoteRepoURI RemoteRepo
r) [])

-- | Note: serialised format represents 'RemoteRepo' only partially.
instance Parsec RemoteRepo where
    parsec :: m RemoteRepo
parsec = do
        RepoName
name <- m RepoName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
        String
uriStr <- (Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
P.munch1 (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c Char -> String -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (String
"+-=._/*()@'$:;&!?~" :: String))
        URI
uri <- m URI -> (URI -> m URI) -> Maybe URI -> m URI
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> m URI
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> m URI) -> String -> m URI
forall a b. (a -> b) -> a -> b
$ String
"Cannot parse URI:" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
uriStr) URI -> m URI
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe URI
parseAbsoluteURI String
uriStr)
        RemoteRepo -> m RemoteRepo
forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo :: RepoName
-> URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo
RemoteRepo
            { remoteRepoName :: RepoName
remoteRepoName           = RepoName
name
            , remoteRepoURI :: URI
remoteRepoURI            = URI
uri
            , remoteRepoSecure :: Maybe Bool
remoteRepoSecure         = Maybe Bool
forall a. Maybe a
Nothing
            , remoteRepoRootKeys :: [String]
remoteRepoRootKeys       = []
            , remoteRepoKeyThreshold :: Int
remoteRepoKeyThreshold   = Int
0
            , remoteRepoShouldTryHttps :: Bool
remoteRepoShouldTryHttps = Bool
False
            }

-- | Construct a partial 'RemoteRepo' value to fold the field parser list over.
emptyRemoteRepo :: RepoName -> RemoteRepo
emptyRemoteRepo :: RepoName -> RemoteRepo
emptyRemoteRepo RepoName
name = RepoName
-> URI -> Maybe Bool -> [String] -> Int -> Bool -> RemoteRepo
RemoteRepo RepoName
name URI
nullURI Maybe Bool
forall a. Maybe a
Nothing [] Int
0 Bool
False

-------------------------------------------------------------------------------
-- Local repository
-------------------------------------------------------------------------------

-- | /no-index/ style local repositories.
--
-- https://github.com/haskell/cabal/issues/6359
data LocalRepo = LocalRepo
    { LocalRepo -> RepoName
localRepoName        :: RepoName
    , LocalRepo -> String
localRepoPath        :: FilePath
    , LocalRepo -> Bool
localRepoSharedCache :: Bool
    }
  deriving (Int -> LocalRepo -> ShowS
[LocalRepo] -> ShowS
LocalRepo -> String
(Int -> LocalRepo -> ShowS)
-> (LocalRepo -> String)
-> ([LocalRepo] -> ShowS)
-> Show LocalRepo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [LocalRepo] -> ShowS
$cshowList :: [LocalRepo] -> ShowS
show :: LocalRepo -> String
$cshow :: LocalRepo -> String
showsPrec :: Int -> LocalRepo -> ShowS
$cshowsPrec :: Int -> LocalRepo -> ShowS
Show, LocalRepo -> LocalRepo -> Bool
(LocalRepo -> LocalRepo -> Bool)
-> (LocalRepo -> LocalRepo -> Bool) -> Eq LocalRepo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: LocalRepo -> LocalRepo -> Bool
$c/= :: LocalRepo -> LocalRepo -> Bool
== :: LocalRepo -> LocalRepo -> Bool
$c== :: LocalRepo -> LocalRepo -> Bool
Eq, Eq LocalRepo
Eq LocalRepo
-> (LocalRepo -> LocalRepo -> Ordering)
-> (LocalRepo -> LocalRepo -> Bool)
-> (LocalRepo -> LocalRepo -> Bool)
-> (LocalRepo -> LocalRepo -> Bool)
-> (LocalRepo -> LocalRepo -> Bool)
-> (LocalRepo -> LocalRepo -> LocalRepo)
-> (LocalRepo -> LocalRepo -> LocalRepo)
-> Ord LocalRepo
LocalRepo -> LocalRepo -> Bool
LocalRepo -> LocalRepo -> Ordering
LocalRepo -> LocalRepo -> LocalRepo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: LocalRepo -> LocalRepo -> LocalRepo
$cmin :: LocalRepo -> LocalRepo -> LocalRepo
max :: LocalRepo -> LocalRepo -> LocalRepo
$cmax :: LocalRepo -> LocalRepo -> LocalRepo
>= :: LocalRepo -> LocalRepo -> Bool
$c>= :: LocalRepo -> LocalRepo -> Bool
> :: LocalRepo -> LocalRepo -> Bool
$c> :: LocalRepo -> LocalRepo -> Bool
<= :: LocalRepo -> LocalRepo -> Bool
$c<= :: LocalRepo -> LocalRepo -> Bool
< :: LocalRepo -> LocalRepo -> Bool
$c< :: LocalRepo -> LocalRepo -> Bool
compare :: LocalRepo -> LocalRepo -> Ordering
$ccompare :: LocalRepo -> LocalRepo -> Ordering
$cp1Ord :: Eq LocalRepo
Ord, (forall x. LocalRepo -> Rep LocalRepo x)
-> (forall x. Rep LocalRepo x -> LocalRepo) -> Generic LocalRepo
forall x. Rep LocalRepo x -> LocalRepo
forall x. LocalRepo -> Rep LocalRepo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep LocalRepo x -> LocalRepo
$cfrom :: forall x. LocalRepo -> Rep LocalRepo x
Generic)

instance Binary LocalRepo
instance Structured LocalRepo

-- | Note: doesn't parse 'localRepoSharedCache' field.
instance Parsec LocalRepo where
    parsec :: m LocalRepo
parsec = do
        RepoName
n <- m RepoName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        Char
_ <- Char -> m Char
forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
        String
p <- (Char -> Bool) -> m String
forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m String
P.munch1 (Bool -> Char -> Bool
forall a b. a -> b -> a
const Bool
True) -- restrict what can be a path?
        LocalRepo -> m LocalRepo
forall (m :: * -> *) a. Monad m => a -> m a
return (RepoName -> String -> Bool -> LocalRepo
LocalRepo RepoName
n String
p Bool
False)

instance Pretty LocalRepo where
    pretty :: LocalRepo -> Doc
pretty (LocalRepo RepoName
n String
p Bool
_) = RepoName -> Doc
forall a. Pretty a => a -> Doc
pretty RepoName
n Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
<<>> String -> Doc
Disp.text String
p

-- | Construct a partial 'LocalRepo' value to fold the field parser list over.
emptyLocalRepo :: RepoName -> LocalRepo
emptyLocalRepo :: RepoName -> LocalRepo
emptyLocalRepo RepoName
name = RepoName -> String -> Bool -> LocalRepo
LocalRepo RepoName
name String
"" Bool
False

-- | Calculate a cache key for local-repo.
--
-- For remote repositories we just use name, but local repositories may
-- all be named "local", so we add a bit of `localRepoPath` into the
-- mix.
localRepoCacheKey :: LocalRepo -> String
localRepoCacheKey :: LocalRepo -> String
localRepoCacheKey LocalRepo
local = RepoName -> String
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local) String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
"-" String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
hashPart where
    hashPart :: String
hashPart
        = HashValue -> String
showHashValue (HashValue -> String) -> HashValue -> String
forall a b. (a -> b) -> a -> b
$ Int -> HashValue -> HashValue
truncateHash Int
8 (HashValue -> HashValue) -> HashValue -> HashValue
forall a b. (a -> b) -> a -> b
$ ByteString -> HashValue
hashValue
        (ByteString -> HashValue) -> ByteString -> HashValue
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> ByteString
toUTF8BS (String -> ByteString) -> String -> ByteString
forall a b. (a -> b) -> a -> b
$ LocalRepo -> String
localRepoPath LocalRepo
local

-------------------------------------------------------------------------------
-- Any repository
-------------------------------------------------------------------------------

-- | Different kinds of repositories
--
-- NOTE: It is important that this type remains serializable.
data Repo
    -- | Local repository, without index.
    --
    -- https://github.com/haskell/cabal/issues/6359
  = RepoLocalNoIndex
      { Repo -> LocalRepo
repoLocal    :: LocalRepo
      , Repo -> String
repoLocalDir :: FilePath
      }

    -- | Standard (unsecured) remote repositories
  | RepoRemote {
        Repo -> RemoteRepo
repoRemote   :: RemoteRepo
      , repoLocalDir :: FilePath
      }

    -- | Secure repositories
    --
    -- Although this contains the same fields as 'RepoRemote', we use a separate
    -- constructor to avoid confusing the two.
    --
    -- Not all access to a secure repo goes through the hackage-security
    -- library currently; code paths that do not still make use of the
    -- 'repoRemote' and 'repoLocalDir' fields directly.
  | RepoSecure {
        repoRemote   :: RemoteRepo
      , repoLocalDir :: FilePath
      }
  deriving (Int -> Repo -> ShowS
[Repo] -> ShowS
Repo -> String
(Int -> Repo -> ShowS)
-> (Repo -> String) -> ([Repo] -> ShowS) -> Show Repo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Repo] -> ShowS
$cshowList :: [Repo] -> ShowS
show :: Repo -> String
$cshow :: Repo -> String
showsPrec :: Int -> Repo -> ShowS
$cshowsPrec :: Int -> Repo -> ShowS
Show, Repo -> Repo -> Bool
(Repo -> Repo -> Bool) -> (Repo -> Repo -> Bool) -> Eq Repo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Repo -> Repo -> Bool
$c/= :: Repo -> Repo -> Bool
== :: Repo -> Repo -> Bool
$c== :: Repo -> Repo -> Bool
Eq, Eq Repo
Eq Repo
-> (Repo -> Repo -> Ordering)
-> (Repo -> Repo -> Bool)
-> (Repo -> Repo -> Bool)
-> (Repo -> Repo -> Bool)
-> (Repo -> Repo -> Bool)
-> (Repo -> Repo -> Repo)
-> (Repo -> Repo -> Repo)
-> Ord Repo
Repo -> Repo -> Bool
Repo -> Repo -> Ordering
Repo -> Repo -> Repo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Repo -> Repo -> Repo
$cmin :: Repo -> Repo -> Repo
max :: Repo -> Repo -> Repo
$cmax :: Repo -> Repo -> Repo
>= :: Repo -> Repo -> Bool
$c>= :: Repo -> Repo -> Bool
> :: Repo -> Repo -> Bool
$c> :: Repo -> Repo -> Bool
<= :: Repo -> Repo -> Bool
$c<= :: Repo -> Repo -> Bool
< :: Repo -> Repo -> Bool
$c< :: Repo -> Repo -> Bool
compare :: Repo -> Repo -> Ordering
$ccompare :: Repo -> Repo -> Ordering
$cp1Ord :: Eq Repo
Ord, (forall x. Repo -> Rep Repo x)
-> (forall x. Rep Repo x -> Repo) -> Generic Repo
forall x. Rep Repo x -> Repo
forall x. Repo -> Rep Repo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Repo x -> Repo
$cfrom :: forall x. Repo -> Rep Repo x
Generic)

instance Binary Repo
instance Structured Repo

-- | Check if this is a remote repo
isRepoRemote :: Repo -> Bool
isRepoRemote :: Repo -> Bool
isRepoRemote RepoLocalNoIndex{} = Bool
False
isRepoRemote Repo
_                  = Bool
True

-- | Extract @RemoteRepo@ from @Repo@ if remote.
maybeRepoRemote :: Repo -> Maybe RemoteRepo
maybeRepoRemote :: Repo -> Maybe RemoteRepo
maybeRepoRemote (RepoLocalNoIndex LocalRepo
_ String
_localDir) = Maybe RemoteRepo
forall a. Maybe a
Nothing
maybeRepoRemote (RepoRemote       RemoteRepo
r String
_localDir) = RemoteRepo -> Maybe RemoteRepo
forall a. a -> Maybe a
Just RemoteRepo
r
maybeRepoRemote (RepoSecure       RemoteRepo
r String
_localDir) = RemoteRepo -> Maybe RemoteRepo
forall a. a -> Maybe a
Just RemoteRepo
r

repoName :: Repo -> RepoName
repoName :: Repo -> RepoName
repoName (RepoLocalNoIndex LocalRepo
r String
_) = LocalRepo -> RepoName
localRepoName LocalRepo
r
repoName (RepoRemote RemoteRepo
r String
_)       = RemoteRepo -> RepoName
remoteRepoName RemoteRepo
r
repoName (RepoSecure RemoteRepo
r String
_)       = RemoteRepo -> RepoName
remoteRepoName RemoteRepo
r