Skip to content

Commit 14674c9

Browse files
Update package transferrer so it doesn't hide PackageURLRedirects errors (#670)
1 parent f686858 commit 14674c9

File tree

1 file changed

+32
-9
lines changed

1 file changed

+32
-9
lines changed

scripts/src/PackageTransferrer.purs

Lines changed: 32 additions & 9 deletions
Original file line numberDiff line numberDiff line change
@@ -3,6 +3,8 @@ module Registry.Scripts.PackageTransferrer where
33
import Registry.App.Prelude
44

55
import Data.Array as Array
6+
import Data.Codec.Argonaut.Common as CA.Common
7+
import Data.Codec.Argonaut.Record as CA.Record
68
import Data.Formatter.DateTime as Formatter.DateTime
79
import Data.Map as Map
810
import Data.String as String
@@ -28,8 +30,10 @@ import Registry.Foreign.FSExtra as FS.Extra
2830
import Registry.Foreign.Octokit (Tag)
2931
import Registry.Foreign.Octokit as Octokit
3032
import Registry.Internal.Format as Internal.Format
33+
import Registry.Location as Location
3134
import Registry.Operation (AuthenticatedPackageOperation(..))
3235
import Registry.Operation as Operation
36+
import Registry.Operation.Validation as Operation.Validation
3337
import Registry.PackageName as PackageName
3438
import Registry.Scripts.LegacyImporter as LegacyImporter
3539
import Run (Run)
@@ -91,15 +95,16 @@ main = launchAff_ do
9195
transfer :: forall r. Run (API.AuthenticatedEffects + r) Unit
9296
transfer = do
9397
Log.info "Processing legacy registry..."
98+
allMetadata <- Registry.readAllMetadata
9499
{ bower, new } <- Registry.readLegacyRegistry
95100
let packages = Map.union bower new
96101
Log.info "Reading latest locations for legacy registry packages..."
97-
locations <- latestLocations packages
102+
locations <- latestLocations allMetadata packages
98103
let needsTransfer = Map.catMaybes locations
99104
case Map.size needsTransfer of
100105
0 -> Log.info "No packages require transferring."
101106
n -> do
102-
Log.info $ Array.fold [ show n, " packages need transferring." ]
107+
Log.info $ Array.fold [ show n, " packages need transferring: ", printJson (CA.Common.strMap packageLocationsCodec) needsTransfer ]
103108
_ <- transferAll packages needsTransfer
104109
Log.info "Completed transfers!"
105110

@@ -136,27 +141,45 @@ transferPackage rawPackageName newLocation = do
136141
}
137142

138143
type PackageLocations =
139-
{ metadataLocation :: Location
144+
{ registeredLocation :: Location
140145
, tagLocation :: Location
141146
}
142147

143-
latestLocations :: forall r. Map String String -> Run (REGISTRY + GITHUB + LOG + EXCEPT String + r) (Map String (Maybe PackageLocations))
144-
latestLocations packages = forWithIndex packages \package location -> do
148+
packageLocationsCodec :: JsonCodec PackageLocations
149+
packageLocationsCodec = CA.Record.object "PackageLocations"
150+
{ registeredLocation: Location.codec
151+
, tagLocation: Location.codec
152+
}
153+
154+
latestLocations :: forall r. Map PackageName Metadata -> Map String String -> Run (REGISTRY + GITHUB + LOG + EXCEPT String + r) (Map String (Maybe PackageLocations))
155+
latestLocations allMetadata packages = forWithIndex packages \package location -> do
145156
let rawName = RawPackageName (stripPureScriptPrefix package)
146157
Run.Except.runExceptAt LegacyImporter._exceptPackage (LegacyImporter.validatePackage rawName location) >>= case _ of
158+
Left { error: LegacyImporter.PackageURLRedirects { received, registered } } -> do
159+
let newLocation = GitHub { owner: received.owner, repo: received.repo, subdir: Nothing }
160+
Log.info $ "Package " <> package <> " has moved to " <> locationToPackageUrl newLocation
161+
if Operation.Validation.locationIsUnique newLocation allMetadata then do
162+
Log.info "New location is unique; package will be transferred."
163+
pure $ Just
164+
{ registeredLocation: GitHub { owner: registered.owner, repo: registered.repo, subdir: Nothing }
165+
, tagLocation: newLocation
166+
}
167+
else do
168+
Log.info "Package will not be transferred! New location is already in use."
169+
pure Nothing
147170
Left _ -> pure Nothing
148171
Right packageResult | Array.null packageResult.tags -> pure Nothing
149172
Right packageResult -> do
150173
Registry.readMetadata packageResult.name >>= case _ of
151174
Nothing -> do
152-
Log.error $ "No metadata exists for package " <> package
153-
Except.throw $ "Cannot verify location of " <> PackageName.print packageResult.name <> " because it has no metadata."
175+
Log.error $ "Cannot verify location of " <> PackageName.print packageResult.name <> " because it has no metadata."
176+
pure Nothing
154177
Just metadata -> case latestPackageLocations packageResult metadata of
155178
Left error -> do
156179
Log.warn $ "Could not verify location of " <> PackageName.print packageResult.name <> ": " <> error
157180
pure Nothing
158181
Right locations
159-
| locationsMatch locations.metadataLocation locations.tagLocation -> pure Nothing
182+
| locationsMatch locations.registeredLocation locations.tagLocation -> pure Nothing
160183
| otherwise -> pure $ Just locations
161184
where
162185
-- The eq instance for locations has case sensitivity, but GitHub doesn't care.
@@ -183,7 +206,7 @@ latestPackageLocations package (Metadata { location, published }) = do
183206
note "No versions match repo tags" $ Array.find (isMatchingTag version) package.tags
184207
tagUrl <- note ("Could not parse tag url " <> matchingTag.url) $ LegacyImporter.tagUrlToRepoUrl matchingTag.url
185208
let tagLocation = GitHub { owner: tagUrl.owner, repo: tagUrl.repo, subdir: Nothing }
186-
pure { metadataLocation: location, tagLocation }
209+
pure { registeredLocation: location, tagLocation }
187210

188211
locationToPackageUrl :: Location -> String
189212
locationToPackageUrl = case _ of

0 commit comments

Comments
 (0)