-
Notifications
You must be signed in to change notification settings - Fork 134
Expand file tree
/
Copy pathRegistry.purs
More file actions
350 lines (312 loc) Β· 14.7 KB
/
Registry.purs
File metadata and controls
350 lines (312 loc) Β· 14.7 KB
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
module Spago.Command.Registry where
import Spago.Prelude
import Data.Array as Array
import Data.Array.NonEmpty as NEA
import Data.Codec.JSON as CJ
import Data.Codec.JSON.Record as CJ.Record
import Data.DateTime (DateTime(..))
import Data.Formatter.DateTime as DateTime
import Data.Map as Map
import Data.String (Pattern(..))
import Data.String as String
import Effect.Uncurried (EffectFn1, runEffectFn1)
import Registry.Internal.Codec as Internal
import Registry.Internal.Codec as Internal.Codec
import Registry.Internal.Format as Internal.Format
import Registry.Metadata as Metadata
import Registry.Operation as Operation
import Registry.PackageName as PackageName
import Registry.SSH as SSH
import Registry.Version as Version
import Spago.Command.Fetch (FetchEnv)
import Spago.Config as Config
import Spago.Db as Db
import Spago.FS as FS
import Spago.Git as Git
import Spago.Json as Json
import Spago.Path as Path
import Spago.Paths as Paths
import Spago.Registry (RegistryEnv)
import Spago.Registry as Registry
type RegistrySearchArgs =
{ package :: String
, json :: Boolean
}
-- TODO: I guess we could also search in (1) the tags and (2) the description
search :: β r. RegistrySearchArgs -> Spago (RegistryEnv r) Unit
search { package: searchString, json } = do
logInfo $ "Searching for " <> show searchString <> " in the Registry package names..."
metadataFiles <- Registry.listMetadataFiles
let matches = Array.filter (String.contains (Pattern searchString)) (Array.mapMaybe (String.stripSuffix (Pattern ".json")) metadataFiles)
if Array.null matches then do
logError "Did not find any packages matching the search string."
else do
-- We have only the match names, at least we get the time of the last release to be even a little useful
infos <- map (Map.fromFoldable <<< Array.catMaybes) $ for matches \match -> case PackageName.parse match of
Left err -> do
logWarn $ "Couldn't parse package name: " <> err
pure Nothing
Right packageName -> Registry.getMetadata packageName >>= case _ of
Left err -> do
logWarn $ "Couldn't read metadata for package " <> PackageName.print packageName <> ", error: " <> err
pure Nothing
Right (Metadata meta) -> pure $ Just $ case Map.findMax meta.published of
Nothing -> Tuple packageName { version: Nothing, publishedTime: Nothing }
Just { key: version, value: { publishedTime } } -> Tuple packageName { version: Just version, publishedTime: Just publishedTime }
-- Finally print all this stuff
logInfo "Use `spago registry info $package` to get more details on a package."
output $ case json of
true ->
let
infoDataCodec = CJ.named "InfoData" $ CJ.Record.object
{ publishedTime: CJ.Record.optional Internal.Codec.iso8601DateTime
, version: CJ.Record.optional Version.codec
}
in
OutputJson (Internal.packageMap infoDataCodec) infos
false -> OutputTable
{ titles: [ "NAME", "VERSION", "PUBLISHED TIME" ]
, rows: infos # Map.toUnfoldable # map \(Tuple name { version, publishedTime }) ->
[ PackageName.print name
, maybe "-" Version.print version
, maybe "-" (DateTime.format Internal.Format.iso8601DateTime) publishedTime
]
}
type RegistryInfoArgs =
{ package :: String
, json :: Boolean
}
info :: β r. RegistryInfoArgs -> Spago (RegistryEnv r) Unit
info { package, json } = do
packageName <- case PackageName.parse package of
Left err -> die [ toDoc "Could not parse package name, error:", indent (toDoc $ show err) ]
Right name -> pure name
Registry.getMetadata packageName >>= case _ of
Left err -> do
logDebug err
die $ "Could not find package " <> PackageName.print packageName
Right meta@(Metadata.Metadata { published }) -> do
-- Get package sets for each published version
{ db } <- ask
let versions = Array.fromFoldable $ Map.keys published
packageSetsByVersion <- for versions \version -> do
entries <- liftEffect $ Db.selectPackageSetEntriesByPackage db packageName version
let setVersions = map _.packageSetVersion entries
pure { version, packageSets: Array.sort setVersions }
case json of
true -> do
-- For JSON, we include package sets in a combined output
let
versionSetsCodec = CJ.named "VersionPackageSets" $ CJ.Record.object
{ version: Version.codec
, packageSets: CJ.array Version.codec
}
combinedCodec = CJ.named "PackageInfoWithSets" $ CJ.Record.object
{ metadata: Metadata.codec
, packageSets: CJ.array versionSetsCodec
}
output $ OutputJson combinedCodec { metadata: meta, packageSets: packageSetsByVersion }
false -> do
-- For YAML/text output, print metadata then add package sets table
output $ OutputYaml Metadata.codec meta
-- Only show the package sets table if there are any
let nonEmptySets = Array.filter (\r -> not (Array.null r.packageSets)) packageSetsByVersion
when (not (Array.null nonEmptySets)) do
logInfo ""
logInfo "Package Sets containing each version:"
output $ OutputTable
{ titles: [ "VERSION", "PACKAGE SETS" ]
, rows: nonEmptySets # map \{ version, packageSets: sets } ->
[ Version.print version
, String.joinWith ", " (map Version.print sets)
]
}
type RegistryPackageSetsArgs =
{ latest :: Boolean
, json :: Boolean
, set :: Maybe String
}
packageSets :: β r. RegistryPackageSetsArgs -> Spago (RegistryEnv r) Unit
packageSets { latest, json, set } = do
case set of
Just setVersionStr -> do
-- Query packages in a specific package set
setVersion <- case parseLenientVersion setVersionStr of
Left err -> die [ "Could not parse package set version. Error:", show err ]
Right v -> pure v
{ db } <- ask
entries <- liftEffect $ Db.selectPackageSetEntriesBySet db setVersion
when (Array.null entries) do
die $ "No packages found in package set " <> Version.print setVersion
-- Sort entries by package name for consistent output
let sortedEntries = Array.sortWith _.packageName entries
output case json of
true ->
let
entryCodec = CJ.named "PackageSetEntryOutput" $ CJ.Record.object
{ packageName: PackageName.codec
, packageVersion: Version.codec
}
toOutput e = { packageName: e.packageName, packageVersion: e.packageVersion }
in
OutputJson (CJ.array entryCodec) (map toOutput sortedEntries)
false -> OutputTable
{ titles: [ "PACKAGE", "VERSION" ]
, rows: sortedEntries # map \{ packageName, packageVersion } ->
[ PackageName.print packageName
, Version.print packageVersion
]
}
Nothing -> do
-- Original behavior: list all package sets
availableSets <- Registry.listPackageSets
let
sets = case latest of
false -> availableSets
true ->
-- here we need to keep only the highest version of all the sets with the same compiler version
Array.fromFoldable
$ Map.values
$
foldl
( \acc newSet -> case Map.lookup newSet.compiler acc of
Nothing -> Map.insert newSet.compiler newSet acc
Just { version } -> case newSet.version > version of
true -> Map.insert newSet.compiler newSet acc
false -> acc
)
Map.empty
availableSets
output case json of
true -> OutputJson (CJ.array Db.packageSetCodec) sets
false -> OutputTable
{ titles: [ "VERSION", "DATE", "COMPILER" ]
, rows: sets # map \{ version, date, compiler } ->
[ Version.print version
, DateTime.format Internal.Format.iso8601Date $ DateTime date bottom
, Version.print compiler
]
}
type RegistryTransferArgs = { privateKeyPath :: RawFilePath }
transfer :: β r. RegistryTransferArgs -> Spago (FetchEnv r) Unit
transfer { privateKeyPath } = do
logDebug $ "Running package transfer"
{ workspace, offline, rootPath } <- ask
selected <- case workspace.selected of
Just s -> pure s
Nothing ->
let
workspacePackages = Config.getWorkspacePackages workspace.packageSet
in
-- If there's only one package, select that one
case NEA.length workspacePackages of
1 -> pure $ NEA.head workspacePackages
_ -> do
logDebug $ unsafeStringify workspacePackages
die
[ toDoc "No package was selected for running. Please select (with -p) one of the following packages:"
, indent (toDoc $ map _.package.name workspacePackages)
]
newLocation <- case selected.package.publish >>= _.location of
Just loc -> pure loc
Nothing -> die
-- TODO: once we have automatic detection for git remotes we should try that first.
[ "The package does not have a location set in the config file: add a valid one in `package.publish`."
, "See the configuration file's documentation: https://github.com/purescript/spago#the-configuration-file"
]
_owners <- case selected.package.publish >>= _.owners of
Just owners | Array.length owners > 0 -> pure owners
_ -> die
[ "The package does not have any owners set in the config file."
, "Please run `spago auth` to add your SSH public key to the owners list in the spago.yaml file."
]
-- Check that the git tree is clean - since the transfer will obey the new content
-- of the config file, it makes sense to have it commited before transferring
Git.getStatus rootPath >>= case _ of
Left _err -> do
die $ toDoc
[ toDoc "Could not verify whether the git tree is clean. Error was:"
, indent _err
]
Right statusResult | statusResult /= "" ->
die $ toDoc
[ toDoc "The git tree is not clean. Please commit or stash these files:"
, indent $ toDoc (String.split (String.Pattern "\n") statusResult)
]
_ -> pure unit
-- Has the package ever been published before? We pull the metadata to verify that.
-- Note! This getMetadata is going through two layers of caching:
-- 1. the registry is only fetched every 15 mins
-- 2. the metadata is then cached in the db for 15 mins
-- When we transfer a package we want to make sure we have the latest everything,
-- so we bypass both caches here.
local (_ { offline = OnlineBypassCache }) (Registry.getMetadata selected.package.name) >>= case _ of
Left err -> do
logDebug err
die
[ "Could not find package '" <> PackageName.print selected.package.name <> "' in the Registry Index. Has it ever been published?"
, "If not, please run `spago publish` first. Otherwise this is a bug - please report it on the Spago repo."
]
Right (Metadata { location }) -> do
-- We have a package, now need to check that the new location is different from the current one
when (newLocation == location) do
die
[ "Cannot transfer package: the new location is the same as the current one."
, "Please edit the `publish.location` field of your `spago.yaml` with the new location."
]
-- We construct the payload that we'll later sign
let dataToSign = { name: selected.package.name, newLocation }
let rawPayload = Json.stringifyJson Operation.transferCodec dataToSign
key <- getPrivateKeyForSigning privateKeyPath
-- We have a key! We can sign the payload with it, and submit the whole package to the Registry
let signature = SSH.sign key rawPayload
-- At this point we check if the offline flag has been set. If it has, we abort the operation.
-- Crucially, this is done _after_ the signing, which allows us to test that too.
case offline of
Offline -> die [ "Cannot perform Registry operations while offline." ]
_ -> Registry.submitRegistryOperation $ Operation.Authenticated
{ signature
, rawPayload
, payload: Operation.Transfer dataToSign
}
getPrivateKeyForSigning :: β e. RawFilePath -> Spago (LogEnv e) SSH.PrivateKey
getPrivateKeyForSigning privateKeyPath' = do
here <- Paths.cwd
let privateKeyPath = here </> privateKeyPath'
-- If all is well we read in the private key
privateKey <- try (FS.readTextFile privateKeyPath) >>= case _ of
Right key -> pure key
Left err -> do
logDebug $ show err
die "Could not read the private key at the given path. Please check it and try again."
let
decodeKeyInteractive { requiresPassword, attemptsLeft } = do
case requiresPassword of
-- If there are no attempts yet we first try to decode the key without a passphrase, silently.
-- In case we succeed then happy days, can just proceed. If not, we move to asking the user for
-- the key.
false -> do
case SSH.parsePrivateKey { key: privateKey, passphrase: Nothing } of
Right key -> pure key
Left _ -> do
decodeKeyInteractive { requiresPassword: true, attemptsLeft }
true -> do
let prompt = "Enter passphrase for " <> Path.quote privateKeyPath <> ": "
passphrase <- liftEffect $ runEffectFn1 questionPassword prompt
case SSH.parsePrivateKey { key: privateKey, passphrase: Just passphrase } of
Left SSH.RequiresPassphrase -> case attemptsLeft of
0 -> die [ "Too many incorrect attempts, exiting." ]
_ -> do
logError "The passphrase you entered is incorrect. Please trygain."
decodeKeyInteractive { requiresPassword: true, attemptsLeft: attemptsLeft - 1 }
Left err -> die [ toDoc "Could not parse the private key:", indent $ toDoc $ SSH.printPrivateKeyParseError err ]
Right key -> pure key
decodeKeyInteractive { requiresPassword: false, attemptsLeft: 3 }
type RegistryUnpublishArgs = { version :: Version, reason :: Maybe String }
unpublish :: β r. RegistryUnpublishArgs -> Spago (RegistryEnv r) Unit
unpublish _a = do -- { version, reason } = do
logError "Unpublishing packages is not supported yet."
die [ "Please contact the maintainers if you need to unpublish a package." ]
-- We have custom FFI here because we want to ask for the passphrase in the terminal,
-- and the stock ReadLine implementation is not good at passwords
foreign import questionPassword :: EffectFn1 String String