Switch from JSON to dedicated package type for Pursuit

app/src/App/Effect/Pursuit.purs

@@ -3,9 +3,9 @@ module Registry.App.Effect.Pursuit where
 
 import Registry.App.Prelude
 
-import Data.Argonaut.Core as Argonaut
 import Data.Array as Array
 import Data.Codec.Argonaut as CA
+import Data.Codec.Argonaut.Record as CA.Record
 import Data.HTTP.Method as Method
 import Data.Map as Map
 import Data.Profunctor as Profunctor
@@ -18,6 +18,8 @@ import Registry.App.Effect.Log (LOG)
 import Registry.App.Effect.Log as Log
 import Registry.App.Legacy.LenientVersion (LenientVersion(..))
 import Registry.App.Legacy.LenientVersion as LenientVersion
+import Registry.App.Legacy.Types (RawPackageName, RawVersion, RawVersionRange)
+import Registry.App.Legacy.Types as Legacy.Types
 import Registry.Foreign.Gzip as Gzip
 import Registry.Foreign.Octokit (GitHubToken(..))
 import Registry.PackageName as PackageName
@@ -27,7 +29,7 @@ import Run as Run
 
 -- | An effect for interacting with Pursuit
 data Pursuit a
-  = Publish Json (Either String Unit -> a)
+  = Publish PursuitPackage (Either String Unit -> a)
   | GetPublishedVersions PackageName (Either String (Map Version URL) -> a)
 
 derive instance Functor Pursuit
@@ -38,7 +40,7 @@ _pursuit :: Proxy "pursuit"
 _pursuit = Proxy
 
 -- | Publish a package to Pursuit using the JSON output of the compiler.
-publish :: forall r. Json -> Run (PURSUIT + r) (Either String Unit)
+publish :: forall r. PursuitPackage -> Run (PURSUIT + r) (Either String Unit)
 publish json = Run.lift _pursuit (Publish json identity)
 
 -- | List published versions from Pursuit
@@ -58,12 +60,12 @@ handlePure = case _ of
 -- | Handle Pursuit by executing HTTP requests using the provided auth token.
 handleAff :: forall r a. GitHubToken -> Pursuit a -> Run (RESOURCE_ENV + LOG + AFF + r) a
 handleAff (GitHubToken token) = case _ of
-  Publish payload reply -> do
+  Publish package reply -> do
     { pursuitApiUrl } <- Env.askResourceEnv
     Log.debug "Pushing to Pursuit..."
 
     result <- Run.liftAff do
-      gzipped <- Gzip.compress (Argonaut.stringify payload)
+      gzipped <- Gzip.compress (stringifyJson pursuitPackageCodec package)
       Fetch.withRetryRequest (Array.fold [ pursuitApiUrl, "/packages" ])
         { method: Method.POST
         , body: gzipped
@@ -141,3 +143,69 @@ availableVersionsCodec = Profunctor.dimap toRep fromRep (CA.array (CA.array CA.s
     LenientVersion { version } <- hush $ LenientVersion.parse rawVersion
     url <- Array.index array 1
     pure $ Tuple version url
+
+-- | The definition of a 'Package' according to Pursuit
+--
+-- Taken originally from the compiler repository, which is reused in Pursuit:
+-- https://github.com/purescript/purescript/blob/6b49918b9646863e73bbedd1d47f474ba3783408/src/Language/PureScript/Docs/Types.hs#L51
+--
+-- This should be considered a legacy format; we must follow Pursuit's publishing
+-- rules for now, but eventually we should relax requirements such as being
+-- GitHub-only, or being associated with a specific Git tag on a repository with
+-- a README in root (which forbids monorepos).
+type PursuitPackage =
+  { uploader :: String
+  , packageMeta :: PursuitPackageMeta
+  , tagTime :: String
+  , modules :: Array PursDocs
+  -- Package names must include the 'purescript' prefix.
+  , resolvedDependencies :: Map RawPackageName RawVersion
+  , version :: RawVersion
+  -- The package ref, usually the version prefixed with 'v' (but not always).
+  , versionTag :: String
+  -- Manifest.location (only GitHub allowed) in two parts: [ owner, repo ]
+  , github :: Array String
+  }
+
+pursuitPackageCodec :: JsonCodec PursuitPackage
+pursuitPackageCodec = CA.Record.object "PursuitPackage"
+  { uploader: CA.string
+  , packageMeta: pursuitPackageMetaCodec
+  , tagTime: CA.string
+  , modules: CA.array pursDocsCodec
+  , resolvedDependencies: Legacy.Types.rawPackageNameMapCodec Legacy.Types.rawVersionCodec
+  , version: Legacy.Types.rawVersionCodec
+  , versionTag: CA.string
+  , github: CA.array CA.string
+  }
+
+-- | The package metadata expected by Pursuit, taken from the Bowerfile format.
+--
+-- Original definition used by Pursuit:
+-- https://hackage.haskell.org/package/bower-json-0.8.1/docs/Web-Bower-PackageMeta.html#t:PackageMeta
+--
+-- We don't reproduce all fields because few are actually used by Pursuit:
+-- name, description, license, dependencies, and keywords. The last is omitted
+-- below because we don't yet support them in the registry; see:
+-- https://github.com/purescript/registry-dev/issues/650
+type PursuitPackageMeta =
+  { name :: RawPackageName
+  , description :: Maybe String
+  , license :: Array String
+  , dependencies :: Map RawPackageName RawVersionRange
+  }
+
+pursuitPackageMetaCodec :: JsonCodec PursuitPackageMeta
+pursuitPackageMetaCodec = CA.Record.object "PursuitPackageMeta"
+  { name: Legacy.Types.rawPackageNameCodec
+  , description: CA.Record.optional CA.string
+  , license: CA.array CA.string
+  , dependencies: Legacy.Types.rawPackageNameMapCodec Legacy.Types.rawVersionRangeCodec
+  }
+
+-- | The JSON produced by 'purs docs', as seen in output/<Module>/docs.json.
+-- | FIXME: Unimplemented.
+type PursDocs = {}
+
+pursDocsCodec :: JsonCodec PursDocs
+pursDocsCodec = CA.Record.object "PursDocs" {}