-- | 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 qualified Data.Map as Map
import qualified Web.Bower.PackageMeta 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 -> Either BowerError PackageMeta
toBowerPackage PursJson{Maybe Text
Map Text Text
Text
pursJsonDependencies :: PursJson -> Map Text Text
pursJsonDescription :: PursJson -> Maybe Text
pursJsonLocation :: PursJson -> Text
pursJsonLicense :: PursJson -> Text
pursJsonName :: PursJson -> Text
pursJsonDependencies :: Map Text Text
pursJsonDescription :: Maybe Text
pursJsonLocation :: Text
pursJsonLicense :: Text
pursJsonName :: Text
..} = do
  PackageName
bowerName <- Text -> Either BowerError PackageName
Bower.parsePackageName (Text
"purescript-" forall a. Semigroup a => a -> a -> a
<> Text
pursJsonName)
  let
    bowerDescription :: Maybe Text
bowerDescription = Maybe Text
pursJsonDescription
    bowerMain :: [a]
bowerMain = []
    bowerModuleType :: [a]
bowerModuleType = []
    bowerLicense :: [Text]
bowerLicense = [ Text
pursJsonLicense ]
    bowerIgnore :: [a]
bowerIgnore = []
    bowerKeywords :: [a]
bowerKeywords = []
    bowerAuthors :: [a]
bowerAuthors = []
    bowerHomepage :: Maybe Text
bowerHomepage = forall a. a -> Maybe a
Just Text
pursJsonLocation
    bowerRepository :: Maybe Repository
bowerRepository = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Bower.Repository { repositoryUrl :: Text
repositoryUrl = Text
pursJsonLocation, repositoryType :: Text
repositoryType = Text
"git" }
    bowerDevDependencies :: [a]
bowerDevDependencies = []
    bowerResolutions :: [a]
bowerResolutions = []
    bowerPrivate :: Bool
bowerPrivate = Bool
False

  let parseDependencies :: [(Text, Text)] -> Either BowerError [(PackageName, VersionRange)]
parseDependencies = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (t :: * -> * -> *) (f :: * -> *) a c b d.
(Bitraversable t, Applicative f) =>
(a -> f c) -> (b -> f d) -> t a b -> f (t c d)
bitraverse (Text -> Either BowerError PackageName
Bower.parsePackageName forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text
"purescript-" forall a. Semigroup a => a -> a -> a
<>)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> VersionRange
Bower.VersionRange))
  [(PackageName, VersionRange)]
bowerDependencies <- [(Text, Text)] -> Either BowerError [(PackageName, VersionRange)]
parseDependencies forall a b. (a -> b) -> a -> b
$ forall k a. Map k a -> [(k, a)]
Map.toAscList Map Text Text
pursJsonDependencies
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Bower.PackageMeta {Bool
[(PackageName, VersionRange)]
[Text]
Maybe Text
Maybe Repository
PackageName
forall a. [a]
bowerName :: PackageName
bowerDescription :: Maybe Text
bowerMain :: [FilePath]
bowerModuleType :: [ModuleType]
bowerLicense :: [Text]
bowerIgnore :: [Text]
bowerKeywords :: [Text]
bowerAuthors :: [Author]
bowerHomepage :: Maybe Text
bowerRepository :: Maybe Repository
bowerDependencies :: [(PackageName, VersionRange)]
bowerDevDependencies :: [(PackageName, VersionRange)]
bowerResolutions :: [(PackageName, Version)]
bowerPrivate :: Bool
bowerDependencies :: [(PackageName, VersionRange)]
bowerPrivate :: Bool
bowerResolutions :: forall a. [a]
bowerDevDependencies :: forall a. [a]
bowerRepository :: Maybe Repository
bowerHomepage :: Maybe Text
bowerAuthors :: forall a. [a]
bowerKeywords :: forall a. [a]
bowerIgnore :: forall a. [a]
bowerLicense :: [Text]
bowerModuleType :: forall a. [a]
bowerMain :: forall a. [a]
bowerDescription :: Maybe Text
bowerName :: PackageName
..}

-- | 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
    PursJson -> Text
pursJsonName :: Text
    -- | The SPDX identifier representing the package license
  , PursJson -> Text
pursJsonLicense :: Text
    -- | The GitHub repository hosting the package
  , PursJson -> Text
pursJsonLocation :: Text
    -- | An optional description of the package
  , PursJson -> Maybe Text
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'
  , PursJson -> Map Text Text
pursJsonDependencies :: Map Text Text
  }

data PursJsonError
  = MalformedLocationField
  deriving (PursJsonError -> PursJsonError -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PursJsonError -> PursJsonError -> Bool
$c/= :: PursJsonError -> PursJsonError -> Bool
== :: PursJsonError -> PursJsonError -> Bool
$c== :: PursJsonError -> PursJsonError -> Bool
Eq, Int -> PursJsonError -> ShowS
[PursJsonError] -> ShowS
PursJsonError -> FilePath
forall a.
(Int -> a -> ShowS) -> (a -> FilePath) -> ([a] -> ShowS) -> Show a
showList :: [PursJsonError] -> ShowS
$cshowList :: [PursJsonError] -> ShowS
show :: PursJsonError -> FilePath
$cshow :: PursJsonError -> FilePath
showsPrec :: Int -> PursJsonError -> ShowS
$cshowsPrec :: Int -> PursJsonError -> ShowS
Show, Eq PursJsonError
PursJsonError -> PursJsonError -> Bool
PursJsonError -> PursJsonError -> Ordering
PursJsonError -> PursJsonError -> PursJsonError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: PursJsonError -> PursJsonError -> PursJsonError
$cmin :: PursJsonError -> PursJsonError -> PursJsonError
max :: PursJsonError -> PursJsonError -> PursJsonError
$cmax :: PursJsonError -> PursJsonError -> PursJsonError
>= :: PursJsonError -> PursJsonError -> Bool
$c>= :: PursJsonError -> PursJsonError -> Bool
> :: PursJsonError -> PursJsonError -> Bool
$c> :: PursJsonError -> PursJsonError -> Bool
<= :: PursJsonError -> PursJsonError -> Bool
$c<= :: PursJsonError -> PursJsonError -> Bool
< :: PursJsonError -> PursJsonError -> Bool
$c< :: PursJsonError -> PursJsonError -> Bool
compare :: PursJsonError -> PursJsonError -> Ordering
$ccompare :: PursJsonError -> PursJsonError -> Ordering
Ord, forall x. Rep PursJsonError x -> PursJsonError
forall x. PursJsonError -> Rep PursJsonError x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep PursJsonError x -> PursJsonError
$cfrom :: forall x. PursJsonError -> Rep PursJsonError x
Generic)

instance NFData PursJsonError

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

asPursJson :: Parse PursJsonError PursJson
asPursJson :: Parse PursJsonError PursJson
asPursJson = do
  Text
pursJsonName <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"name" forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
asText
  Maybe Text
pursJsonDescription <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m (Maybe a)
keyMay Text
"description" forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
asText
  Text
pursJsonLicense <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"license" forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
asText
  Map Text Text
pursJsonDependencies <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"dependencies" (forall k a. Eq k => [(k, a)] -> Map k a
Map.fromAscList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) err a.
(Functor m, Monad m) =>
ParseT err m a -> ParseT err m [(Text, a)]
eachInObject forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
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.
  Text
pursJsonLocation <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"location" ParseT PursJsonError Identity Text
asOwnerRepoOrGitUrl
  forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ PursJson{Maybe Text
Map Text Text
Text
pursJsonLocation :: Text
pursJsonDependencies :: Map Text Text
pursJsonLicense :: Text
pursJsonDescription :: Maybe Text
pursJsonName :: Text
pursJsonDependencies :: Map Text Text
pursJsonDescription :: Maybe Text
pursJsonLocation :: Text
pursJsonLicense :: Text
pursJsonName :: Text
..}
  where
  asOwnerRepoOrGitUrl :: ParseT PursJsonError Identity Text
asOwnerRepoOrGitUrl =
    forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError forall {err}. ParseT err Identity Text
asOwnerRepo (\ParseError PursJsonError
_ -> forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError forall {err}. ParseT err Identity Text
asGitUrl (\ParseError PursJsonError
_ -> forall (m :: * -> *) err a.
(Functor m, Monad m) =>
err -> ParseT err m a
throwCustomError PursJsonError
MalformedLocationField))

  asGitUrl :: ParseT err Identity Text
asGitUrl =
    forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"gitUrl" forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
asText

  asOwnerRepo :: ParseT err Identity Text
asOwnerRepo = do
    Text
githubOwner <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"githubOwner" forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
asText
    Text
githubRepo <- forall (m :: * -> *) err a.
(Functor m, Monad m) =>
Text -> ParseT err m a -> ParseT err m a
key Text
"githubRepo" forall (m :: * -> *) err. (Functor m, Monad m) => ParseT err m Text
asText
    forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Text
"https://github.com/" forall a. Semigroup a => a -> a -> a
<> Text
githubOwner forall a. Semigroup a => a -> a -> a
<> Text
"/" forall a. Semigroup a => a -> a -> a
<> Text
githubRepo forall a. Semigroup a => a -> a -> a
<> Text
".git"