Compat.hs

-- | A compatibility module that allows a restricted set of purs.json manifest
-- | files to be used for publishing. The manifest must described a package
-- | available on GitHub, and it must be convertable to a Bower manifest.
-- |
-- | Fully supporting the registry manifest format will require `purs publish`
-- | and by extension Pursuit to relax the requirement that packages are hosted
-- | on GitHub, because the registry does not have this requirement.
module Language.PureScript.Publish.Registry.Compat where

import Protolude
import Data.Map qualified as Map
import Web.Bower.PackageMeta qualified as Bower
import Data.Bitraversable (Bitraversable(..))
import Data.Aeson.BetterErrors (key, asText, keyMay, eachInObject, Parse, throwCustomError)

-- | Convert a valid purs.json manifest into a bower.json manifest
toBowerPackage :: PursJson -> Either Bower.BowerError Bower.PackageMeta
toBowerPackage PursJson{..} = do
  bowerName <- Bower.parsePackageName ("purescript-" <> pursJsonName)
  let
    bowerDescription = pursJsonDescription
    bowerMain = []
    bowerModuleType = []
    bowerLicense = [ pursJsonLicense ]
    bowerIgnore = []
    bowerKeywords = []
    bowerAuthors = []
    bowerHomepage = Just pursJsonLocation
    bowerRepository = Just $ Bower.Repository { repositoryUrl = pursJsonLocation, repositoryType = "git" }
    bowerDevDependencies = []
    bowerResolutions = []
    bowerPrivate = False

  let parseDependencies = traverse (bitraverse (Bower.parsePackageName . ("purescript-" <>)) (pure . Bower.VersionRange))
  bowerDependencies <- parseDependencies $ Map.toAscList pursJsonDependencies
  pure $ Bower.PackageMeta {..}

-- | A partial representation of the purs.json manifest format, including only
-- | the fields required for publishing.
-- |
-- | https://github.com/purescript/registry/blob/master/v1/Manifest.dhall
--
-- This type is intended for compatibility with the Bower publishing pipeline,
-- and does not accurately reflect all possible purs.json manifests. However,
-- supporting purs.json manifests properly introduces breaking changes to the
-- compiler and to Pursuit.
data PursJson = PursJson
  { -- | The name of the package
    pursJsonName :: Text
    -- | The SPDX identifier representing the package license
  , pursJsonLicense :: Text
    -- | The GitHub repository hosting the package
  , pursJsonLocation :: Text
    -- | An optional description of the package
  , pursJsonDescription :: Maybe Text
    -- | A map of dependencies, where keys are package names and values are
    -- | dependency ranges of the form '>=X.Y.Z <X.Y.Z'
  , pursJsonDependencies :: Map Text Text
  }

data PursJsonError
  = MalformedLocationField
  deriving (Eq, Show, Ord, Generic)

instance NFData PursJsonError

showPursJsonError :: PursJsonError -> Text
showPursJsonError = \case
  MalformedLocationField ->
    "The 'location' field must be either '{ \"githubOwner\": OWNER, \"githubRepo\": REPO }' or '{ \"gitUrl\": URL }'."

asPursJson :: Parse PursJsonError PursJson
asPursJson = do
  pursJsonName <- key "name" asText
  pursJsonDescription <- keyMay "description" asText
  pursJsonLicense <- key "license" asText
  pursJsonDependencies <- key "dependencies" (Map.fromAscList <$> eachInObject asText)
  -- Packages are required to come from GitHub in PureScript 0.14.x, but the
  -- PureScript registry does not require this, nor does it require that
  -- packages are Git repositories. This restriction should be lifted when
  -- we fully support purs.json manifests in the compiler and on Pursuit.
  --
  -- For the time being, we only parse manifests that include a GitHub owner
  -- and repo pair, or which specify a Git URL, which we use to try and get
  -- the package from GitHub.
  pursJsonLocation <- key "location" asOwnerRepoOrGitUrl
  pure $ PursJson{..}
  where
  asOwnerRepoOrGitUrl =
    catchError asOwnerRepo (\_ -> catchError asGitUrl (\_ -> throwCustomError MalformedLocationField))

  asGitUrl =
    key "gitUrl" asText

  asOwnerRepo = do
    githubOwner <- key "githubOwner" asText
    githubRepo <- key "githubRepo" asText
    pure $ "https://github.com/" <> githubOwner <> "/" <> githubRepo <> ".git"