never executed always true always false
1 {-# LANGUAGE DeriveGeneric #-}
2 module Distribution.Client.Types.Repo (
3 -- * Remote repository
4 RemoteRepo (..),
5 emptyRemoteRepo,
6 -- * Local repository (no-index)
7 LocalRepo (..),
8 emptyLocalRepo,
9 localRepoCacheKey,
10 -- * Repository
11 Repo (..),
12 repoName,
13 isRepoRemote,
14 maybeRepoRemote,
15 ) where
16
17 import Distribution.Client.Compat.Prelude
18 import Prelude ()
19
20 import Network.URI (URI (..), nullURI, parseAbsoluteURI, uriToString)
21
22 import Distribution.Simple.Utils (toUTF8BS)
23
24 import Distribution.Client.HashValue (hashValue, showHashValue, truncateHash)
25
26 import qualified Data.ByteString.Lazy.Char8 as LBS
27 import qualified Distribution.Compat.CharParsing as P
28 import qualified Text.PrettyPrint as Disp
29
30 import Distribution.Client.Types.RepoName
31
32 -------------------------------------------------------------------------------
33 -- Remote repository
34 -------------------------------------------------------------------------------
35
36 data RemoteRepo =
37 RemoteRepo {
38 remoteRepoName :: RepoName,
39 remoteRepoURI :: URI,
40
41 -- | Enable secure access?
42 --
43 -- 'Nothing' here represents "whatever the default is"; this is important
44 -- to allow for a smooth transition from opt-in to opt-out security
45 -- (once we switch to opt-out, all access to the central Hackage
46 -- repository should be secure by default)
47 remoteRepoSecure :: Maybe Bool,
48
49 -- | Root key IDs (for bootstrapping)
50 remoteRepoRootKeys :: [String],
51
52 -- | Threshold for verification during bootstrapping
53 remoteRepoKeyThreshold :: Int,
54
55 -- | Normally a repo just specifies an HTTP or HTTPS URI, but as a
56 -- special case we may know a repo supports both and want to try HTTPS
57 -- if we can, but still allow falling back to HTTP.
58 --
59 -- This field is not currently stored in the config file, but is filled
60 -- in automagically for known repos.
61 remoteRepoShouldTryHttps :: Bool
62 }
63
64 deriving (Show, Eq, Ord, Generic)
65
66 instance Binary RemoteRepo
67 instance Structured RemoteRepo
68
69 instance Pretty RemoteRepo where
70 pretty r =
71 pretty (remoteRepoName r) <<>> Disp.colon <<>>
72 Disp.text (uriToString id (remoteRepoURI r) [])
73
74 -- | Note: serialised format represends 'RemoteRepo' only partially.
75 instance Parsec RemoteRepo where
76 parsec = do
77 name <- parsec
78 _ <- P.char ':'
79 uriStr <- P.munch1 (\c -> isAlphaNum c || c `elem` ("+-=._/*()@'$:;&!?~" :: String))
80 uri <- maybe (fail $ "Cannot parse URI:" ++ uriStr) return (parseAbsoluteURI uriStr)
81 return RemoteRepo
82 { remoteRepoName = name
83 , remoteRepoURI = uri
84 , remoteRepoSecure = Nothing
85 , remoteRepoRootKeys = []
86 , remoteRepoKeyThreshold = 0
87 , remoteRepoShouldTryHttps = False
88 }
89
90 -- | Construct a partial 'RemoteRepo' value to fold the field parser list over.
91 emptyRemoteRepo :: RepoName -> RemoteRepo
92 emptyRemoteRepo name = RemoteRepo name nullURI Nothing [] 0 False
93
94 -------------------------------------------------------------------------------
95 -- Local repository
96 -------------------------------------------------------------------------------
97
98 -- | /no-index/ style local repositories.
99 --
100 -- https://github.com/haskell/cabal/issues/6359
101 data LocalRepo = LocalRepo
102 { localRepoName :: RepoName
103 , localRepoPath :: FilePath
104 , localRepoSharedCache :: Bool
105 }
106 deriving (Show, Eq, Ord, Generic)
107
108 instance Binary LocalRepo
109 instance Structured LocalRepo
110
111 -- | Note: doesn't parse 'localRepoSharedCache' field.
112 instance Parsec LocalRepo where
113 parsec = do
114 n <- parsec
115 _ <- P.char ':'
116 p <- P.munch1 (const True) -- restrict what can be a path?
117 return (LocalRepo n p False)
118
119 instance Pretty LocalRepo where
120 pretty (LocalRepo n p _) = pretty n <<>> Disp.colon <<>> Disp.text p
121
122 -- | Construct a partial 'LocalRepo' value to fold the field parser list over.
123 emptyLocalRepo :: RepoName -> LocalRepo
124 emptyLocalRepo name = LocalRepo name "" False
125
126 -- | Calculate a cache key for local-repo.
127 --
128 -- For remote repositories we just use name, but local repositories may
129 -- all be named "local", so we add a bit of `localRepoPath` into the
130 -- mix.
131 localRepoCacheKey :: LocalRepo -> String
132 localRepoCacheKey local = unRepoName (localRepoName local) ++ "-" ++ hashPart where
133 hashPart
134 = showHashValue $ truncateHash 8 $ hashValue
135 $ LBS.fromStrict $ toUTF8BS $ localRepoPath local
136
137 -------------------------------------------------------------------------------
138 -- Any repository
139 -------------------------------------------------------------------------------
140
141 -- | Different kinds of repositories
142 --
143 -- NOTE: It is important that this type remains serializable.
144 data Repo
145 -- | Local repository, without index.
146 --
147 -- https://github.com/haskell/cabal/issues/6359
148 = RepoLocalNoIndex
149 { repoLocal :: LocalRepo
150 , repoLocalDir :: FilePath
151 }
152
153 -- | Standard (unsecured) remote repositores
154 | RepoRemote {
155 repoRemote :: RemoteRepo
156 , repoLocalDir :: FilePath
157 }
158
159 -- | Secure repositories
160 --
161 -- Although this contains the same fields as 'RepoRemote', we use a separate
162 -- constructor to avoid confusing the two.
163 --
164 -- Not all access to a secure repo goes through the hackage-security
165 -- library currently; code paths that do not still make use of the
166 -- 'repoRemote' and 'repoLocalDir' fields directly.
167 | RepoSecure {
168 repoRemote :: RemoteRepo
169 , repoLocalDir :: FilePath
170 }
171 deriving (Show, Eq, Ord, Generic)
172
173 instance Binary Repo
174 instance Structured Repo
175
176 -- | Check if this is a remote repo
177 isRepoRemote :: Repo -> Bool
178 isRepoRemote RepoLocalNoIndex{} = False
179 isRepoRemote _ = True
180
181 -- | Extract @RemoteRepo@ from @Repo@ if remote.
182 maybeRepoRemote :: Repo -> Maybe RemoteRepo
183 maybeRepoRemote (RepoLocalNoIndex _ _localDir) = Nothing
184 maybeRepoRemote (RepoRemote r _localDir) = Just r
185 maybeRepoRemote (RepoSecure r _localDir) = Just r
186
187 repoName :: Repo -> RepoName
188 repoName (RepoLocalNoIndex r _) = localRepoName r
189 repoName (RepoRemote r _) = remoteRepoName r
190 repoName (RepoSecure r _) = remoteRepoName r