{-# LANGUAGE DeriveGeneric #-}

module Distribution.Client.Types.Repo
  ( -- * Remote repository
    RemoteRepo (..)
  , emptyRemoteRepo

    -- * Local repository (no-index)
  , LocalRepo (..)
  , emptyLocalRepo
  , localRepoCacheKey

    -- * Repository
  , Repo (..)
  , repoName
  , isRepoRemote
  , maybeRepoRemote

    -- * Windows
  , normaliseFileNoIndexURI
  ) where

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

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

import Distribution.Simple.Utils (toUTF8BS)
import Distribution.System (OS (Windows))

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

import qualified System.FilePath.Posix as Posix
import qualified System.FilePath.Windows as Windows

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

data RemoteRepo = RemoteRepo
  { RemoteRepo -> RepoName
remoteRepoName :: RepoName
  , RemoteRepo -> URI
remoteRepoURI :: URI
  , RemoteRepo -> Maybe Bool
remoteRepoSecure :: Maybe Bool
  -- ^ 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 -> [String]
remoteRepoRootKeys :: [String]
  -- ^ Root key IDs (for bootstrapping)
  , RemoteRepo -> Int
remoteRepoKeyThreshold :: Int
  -- ^ Threshold for verification during bootstrapping
  , RemoteRepo -> Bool
remoteRepoShouldTryHttps :: Bool
  -- ^ 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.
  }
  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
$cshowsPrec :: Int -> RemoteRepo -> ShowS
showsPrec :: Int -> RemoteRepo -> ShowS
$cshow :: RemoteRepo -> String
show :: RemoteRepo -> String
$cshowList :: [RemoteRepo] -> ShowS
showList :: [RemoteRepo] -> ShowS
Show, RemoteRepo -> RemoteRepo -> Bool
(RemoteRepo -> RemoteRepo -> Bool)
-> (RemoteRepo -> RemoteRepo -> Bool) -> Eq RemoteRepo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RemoteRepo -> RemoteRepo -> Bool
== :: RemoteRepo -> RemoteRepo -> Bool
$c/= :: RemoteRepo -> RemoteRepo -> Bool
/= :: 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
$ccompare :: RemoteRepo -> RemoteRepo -> Ordering
compare :: RemoteRepo -> RemoteRepo -> Ordering
$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
>= :: RemoteRepo -> RemoteRepo -> Bool
$cmax :: RemoteRepo -> RemoteRepo -> RemoteRepo
max :: RemoteRepo -> RemoteRepo -> RemoteRepo
$cmin :: RemoteRepo -> RemoteRepo -> RemoteRepo
min :: RemoteRepo -> RemoteRepo -> 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
$cfrom :: forall x. RemoteRepo -> Rep RemoteRepo x
from :: forall x. RemoteRepo -> Rep RemoteRepo x
$cto :: forall x. Rep RemoteRepo x -> RemoteRepo
to :: forall x. Rep RemoteRepo x -> RemoteRepo
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 :: forall (m :: * -> *). CabalParsing m => m RemoteRepo
parsec = do
    RepoName
name <- m RepoName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RepoName
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 a. Eq a => a -> [a] -> 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 a. String -> m a
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 a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Maybe URI
parseAbsoluteURI String
uriStr)
    RemoteRepo -> m RemoteRepo
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return
      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
$cshowsPrec :: Int -> LocalRepo -> ShowS
showsPrec :: Int -> LocalRepo -> ShowS
$cshow :: LocalRepo -> String
show :: LocalRepo -> String
$cshowList :: [LocalRepo] -> ShowS
showList :: [LocalRepo] -> ShowS
Show, LocalRepo -> LocalRepo -> Bool
(LocalRepo -> LocalRepo -> Bool)
-> (LocalRepo -> LocalRepo -> Bool) -> Eq LocalRepo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LocalRepo -> LocalRepo -> Bool
== :: LocalRepo -> LocalRepo -> Bool
$c/= :: LocalRepo -> LocalRepo -> Bool
/= :: 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
$ccompare :: LocalRepo -> LocalRepo -> Ordering
compare :: LocalRepo -> LocalRepo -> Ordering
$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
>= :: LocalRepo -> LocalRepo -> Bool
$cmax :: LocalRepo -> LocalRepo -> LocalRepo
max :: LocalRepo -> LocalRepo -> LocalRepo
$cmin :: LocalRepo -> LocalRepo -> LocalRepo
min :: LocalRepo -> LocalRepo -> 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
$cfrom :: forall x. LocalRepo -> Rep LocalRepo x
from :: forall x. LocalRepo -> Rep LocalRepo x
$cto :: forall x. Rep LocalRepo x -> LocalRepo
to :: forall x. Rep LocalRepo x -> LocalRepo
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 <- m RepoName
forall a (m :: * -> *). (Parsec a, CabalParsing m) => m a
forall (m :: * -> *). CabalParsing m => m RepoName
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 a. a -> m a
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
$cshowsPrec :: Int -> Repo -> ShowS
showsPrec :: Int -> Repo -> ShowS
$cshow :: Repo -> String
show :: Repo -> String
$cshowList :: [Repo] -> ShowS
showList :: [Repo] -> ShowS
Show, Repo -> Repo -> Bool
(Repo -> Repo -> Bool) -> (Repo -> Repo -> Bool) -> Eq Repo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Repo -> Repo -> Bool
== :: Repo -> Repo -> Bool
$c/= :: Repo -> Repo -> Bool
/= :: 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
$ccompare :: Repo -> Repo -> Ordering
compare :: Repo -> Repo -> Ordering
$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
>= :: Repo -> Repo -> Bool
$cmax :: Repo -> Repo -> Repo
max :: Repo -> Repo -> Repo
$cmin :: Repo -> Repo -> Repo
min :: Repo -> Repo -> 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
$cfrom :: forall x. Repo -> Rep Repo x
from :: forall x. Repo -> Rep Repo x
$cto :: forall x. Rep Repo x -> Repo
to :: forall x. Rep Repo x -> Repo
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

-------------------------------------------------------------------------------

-- * Windows utils

-------------------------------------------------------------------------------

-- | When on Windows, we need to convert the paths in URIs to be POSIX-style.
--
-- >>> import Network.URI
-- >>> normaliseFileNoIndexURI Windows (URI "file+noindex:" (Just nullURIAuth) "C:\\dev\\foo" "" "")
-- file+noindex:C:/dev/foo
--
-- Other formats of file paths are not understood by @network-uri@:
--
-- >>> import Network.URI
-- >>> uriPath <$> parseURI "file+noindex://C:/foo.txt"
-- Just "/foo.txt"
-- >>> parseURI "file+noindex://C:\foo.txt"
-- Nothing
-- >>> uriPath <$> parseURI "file+noindex:///C:/foo.txt"
-- Just "/C:/foo.txt"
-- >>> uriPath <$> parseURI "file+noindex:C:/foo.txt"
-- Just "C:/foo.txt"
--
-- Out of the ones above, only the last one can be used from anywhere in the
-- system.
normaliseFileNoIndexURI :: OS -> URI -> URI
normaliseFileNoIndexURI :: OS -> URI -> URI
normaliseFileNoIndexURI OS
os uri :: URI
uri@(URI String
scheme Maybe URIAuth
_auth String
path String
query String
fragment)
  | String
"file+noindex:" <- String
scheme
  , OS
Windows <- OS
os =
      String -> Maybe URIAuth -> String -> String -> String -> URI
URI String
scheme Maybe URIAuth
forall a. Maybe a
Nothing (ShowS
asPosixPath String
path) String
query String
fragment
  | Bool
otherwise = URI
uri
  where
    asPosixPath :: ShowS
asPosixPath String
p =
      -- We don't use 'isPathSeparator' because @Windows.isPathSeparator
      -- Posix.pathSeparator == True@.
      [if Char
x Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
Windows.pathSeparator then Char
Posix.pathSeparator else Char
x | Char
x <- String
p]