{-# 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 -> [FilePath]
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [RemoteRepo] -> ShowS
$cshowList :: [RemoteRepo] -> ShowS
show :: RemoteRepo -> FilePath
$cshow :: RemoteRepo -> FilePath
showsPrec :: Int -> RemoteRepo -> ShowS
$cshowsPrec :: Int -> RemoteRepo -> ShowS
Show, RemoteRepo -> RemoteRepo -> Bool
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
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
Ord, 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 =
        forall a. Pretty a => a -> Doc
pretty (RemoteRepo -> RepoName
remoteRepoName RemoteRepo
r) Doc -> Doc -> Doc
<<>> Doc
Disp.colon Doc -> Doc -> Doc
<<>>
        FilePath -> Doc
Disp.text (ShowS -> URI -> ShowS
uriToString forall a. a -> a
id (RemoteRepo -> URI
remoteRepoURI RemoteRepo
r) [])

-- | Note: serialised format represents 'RemoteRepo' only partially.
instance Parsec RemoteRepo where
    parsec :: forall (m :: * -> *). CabalParsing m => m RemoteRepo
parsec = do
        RepoName
name <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
        FilePath
uriStr <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m FilePath
P.munch1 (\Char
c -> Char -> Bool
isAlphaNum Char
c Bool -> Bool -> Bool
|| Char
c forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` (FilePath
"+-=._/*()@'$:;&!?~" :: String))
        URI
uri <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => FilePath -> m a
fail forall a b. (a -> b) -> a -> b
$ FilePath
"Cannot parse URI:" forall a. [a] -> [a] -> [a]
++ FilePath
uriStr) forall (m :: * -> *) a. Monad m => a -> m a
return (FilePath -> Maybe URI
parseAbsoluteURI FilePath
uriStr)
        forall (m :: * -> *) a. Monad m => a -> m a
return RemoteRepo
            { remoteRepoName :: RepoName
remoteRepoName           = RepoName
name
            , remoteRepoURI :: URI
remoteRepoURI            = URI
uri
            , remoteRepoSecure :: Maybe Bool
remoteRepoSecure         = forall a. Maybe a
Nothing
            , remoteRepoRootKeys :: [FilePath]
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 -> [FilePath] -> Int -> Bool -> RemoteRepo
RemoteRepo RepoName
name URI
nullURI 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 -> FilePath
localRepoPath        :: FilePath
    , LocalRepo -> Bool
localRepoSharedCache :: Bool
    }
  deriving (Int -> LocalRepo -> ShowS
[LocalRepo] -> ShowS
LocalRepo -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [LocalRepo] -> ShowS
$cshowList :: [LocalRepo] -> ShowS
show :: LocalRepo -> FilePath
$cshow :: LocalRepo -> FilePath
showsPrec :: Int -> LocalRepo -> ShowS
$cshowsPrec :: Int -> LocalRepo -> ShowS
Show, LocalRepo -> LocalRepo -> Bool
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
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
Ord, 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 :: forall (m :: * -> *). CabalParsing m => m LocalRepo
parsec = do
        RepoName
n <- forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
parsec
        Char
_ <- forall (m :: * -> *). CharParsing m => Char -> m Char
P.char Char
':'
        FilePath
p <- forall (m :: * -> *). CharParsing m => (Char -> Bool) -> m FilePath
P.munch1 (forall a b. a -> b -> a
const Bool
True) -- restrict what can be a path?
        forall (m :: * -> *) a. Monad m => a -> m a
return (RepoName -> FilePath -> Bool -> LocalRepo
LocalRepo RepoName
n FilePath
p Bool
False)

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

-- | Construct a partial 'LocalRepo' value to fold the field parser list over.
emptyLocalRepo :: RepoName -> LocalRepo
emptyLocalRepo :: RepoName -> LocalRepo
emptyLocalRepo RepoName
name = RepoName -> FilePath -> Bool -> LocalRepo
LocalRepo RepoName
name FilePath
"" 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 -> FilePath
localRepoCacheKey LocalRepo
local = RepoName -> FilePath
unRepoName (LocalRepo -> RepoName
localRepoName LocalRepo
local) forall a. [a] -> [a] -> [a]
++ FilePath
"-" forall a. [a] -> [a] -> [a]
++ FilePath
hashPart where
    hashPart :: FilePath
hashPart
        = HashValue -> FilePath
showHashValue forall a b. (a -> b) -> a -> b
$ Int -> HashValue -> HashValue
truncateHash Int
8 forall a b. (a -> b) -> a -> b
$ ByteString -> HashValue
hashValue
        forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.fromStrict forall a b. (a -> b) -> a -> b
$ FilePath -> ByteString
toUTF8BS forall a b. (a -> b) -> a -> b
$ LocalRepo -> FilePath
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 -> FilePath
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 -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [Repo] -> ShowS
$cshowList :: [Repo] -> ShowS
show :: Repo -> FilePath
$cshow :: Repo -> FilePath
showsPrec :: Int -> Repo -> ShowS
$cshowsPrec :: Int -> Repo -> ShowS
Show, Repo -> Repo -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Repo -> Repo -> Bool
$c/= :: Repo -> Repo -> Bool
== :: Repo -> Repo -> Bool
$c== :: Repo -> Repo -> Bool
Eq, Eq Repo
Repo -> Repo -> Bool
Repo -> Repo -> Ordering
Repo -> Repo -> Repo
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Repo -> Repo -> Repo
$cmin :: Repo -> Repo -> Repo
max :: Repo -> Repo -> Repo
$cmax :: Repo -> Repo -> Repo
>= :: Repo -> Repo -> Bool
$c>= :: Repo -> Repo -> Bool
> :: Repo -> Repo -> Bool
$c> :: Repo -> Repo -> Bool
<= :: Repo -> Repo -> Bool
$c<= :: Repo -> Repo -> Bool
< :: Repo -> Repo -> Bool
$c< :: Repo -> Repo -> Bool
compare :: Repo -> Repo -> Ordering
$ccompare :: Repo -> Repo -> Ordering
Ord, 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
_ FilePath
_localDir) = forall a. Maybe a
Nothing
maybeRepoRemote (RepoRemote       RemoteRepo
r FilePath
_localDir) = forall a. a -> Maybe a
Just RemoteRepo
r
maybeRepoRemote (RepoSecure       RemoteRepo
r FilePath
_localDir) = forall a. a -> Maybe a
Just RemoteRepo
r

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