@@ -3,6 +3,8 @@ module Registry.Scripts.PackageTransferrer where
3
3
import Registry.App.Prelude
4
4
5
5
import Data.Array as Array
6
+ import Data.Codec.Argonaut.Common as CA.Common
7
+ import Data.Codec.Argonaut.Record as CA.Record
6
8
import Data.Formatter.DateTime as Formatter.DateTime
7
9
import Data.Map as Map
8
10
import Data.String as String
@@ -28,8 +30,10 @@ import Registry.Foreign.FSExtra as FS.Extra
28
30
import Registry.Foreign.Octokit (Tag )
29
31
import Registry.Foreign.Octokit as Octokit
30
32
import Registry.Internal.Format as Internal.Format
33
+ import Registry.Location as Location
31
34
import Registry.Operation (AuthenticatedPackageOperation (..))
32
35
import Registry.Operation as Operation
36
+ import Registry.Operation.Validation as Operation.Validation
33
37
import Registry.PackageName as PackageName
34
38
import Registry.Scripts.LegacyImporter as LegacyImporter
35
39
import Run (Run )
@@ -91,15 +95,16 @@ main = launchAff_ do
91
95
transfer :: forall r . Run (API.AuthenticatedEffects + r ) Unit
92
96
transfer = do
93
97
Log .info " Processing legacy registry..."
98
+ allMetadata <- Registry .readAllMetadata
94
99
{ bower, new } <- Registry .readLegacyRegistry
95
100
let packages = Map .union bower new
96
101
Log .info " Reading latest locations for legacy registry packages..."
97
- locations <- latestLocations packages
102
+ locations <- latestLocations allMetadata packages
98
103
let needsTransfer = Map .catMaybes locations
99
104
case Map .size needsTransfer of
100
105
0 -> Log .info " No packages require transferring."
101
106
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 ]
103
108
_ <- transferAll packages needsTransfer
104
109
Log .info " Completed transfers!"
105
110
@@ -136,27 +141,45 @@ transferPackage rawPackageName newLocation = do
136
141
}
137
142
138
143
type PackageLocations =
139
- { metadataLocation :: Location
144
+ { registeredLocation :: Location
140
145
, tagLocation :: Location
141
146
}
142
147
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
145
156
let rawName = RawPackageName (stripPureScriptPrefix package)
146
157
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
147
170
Left _ -> pure Nothing
148
171
Right packageResult | Array .null packageResult.tags -> pure Nothing
149
172
Right packageResult -> do
150
173
Registry .readMetadata packageResult.name >>= case _ of
151
174
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
154
177
Just metadata -> case latestPackageLocations packageResult metadata of
155
178
Left error -> do
156
179
Log .warn $ " Could not verify location of " <> PackageName .print packageResult.name <> " : " <> error
157
180
pure Nothing
158
181
Right locations
159
- | locationsMatch locations.metadataLocation locations.tagLocation -> pure Nothing
182
+ | locationsMatch locations.registeredLocation locations.tagLocation -> pure Nothing
160
183
| otherwise -> pure $ Just locations
161
184
where
162
185
-- The eq instance for locations has case sensitivity, but GitHub doesn't care.
@@ -183,7 +206,7 @@ latestPackageLocations package (Metadata { location, published }) = do
183
206
note " No versions match repo tags" $ Array .find (isMatchingTag version) package.tags
184
207
tagUrl <- note (" Could not parse tag url " <> matchingTag.url) $ LegacyImporter .tagUrlToRepoUrl matchingTag.url
185
208
let tagLocation = GitHub { owner: tagUrl.owner, repo: tagUrl.repo, subdir: Nothing }
186
- pure { metadataLocation : location, tagLocation }
209
+ pure { registeredLocation : location, tagLocation }
187
210
188
211
locationToPackageUrl :: Location -> String
189
212
locationToPackageUrl = case _ of
0 commit comments