Collect manifest information from multiple files, not just Bowerfile

.github/workflows/main.yml

@@ -51,7 +51,7 @@ jobs:
         run: ./ci/scripts/verify-dhall.sh
 
       - name: "Run tests"
-        run: cd ci && npm ci && nix-shell ../default.nix --run "spago test" && cd ..
+        run: cd ci && npm ci && nix-shell --run "spago test" && cd ..
 
       - name: "Check all the example Manifests roundtrip (read+write) through PureScript"
         run: cd ci && npm ci && nix-shell ../default.nix --run "spago run -m Registry.Scripts.ManifestRoundtrip"

ci/.gitignore

@@ -15,6 +15,6 @@ generated-docs/
 # Keep it secret, keep it safe.
 .env
 
-# Files generated as part of the Bower import process
+# Files generated as part of the legacy import process.
 bower-exclusions.json
 registry-index

ci/README.md

@@ -14,7 +14,7 @@ If you are running scripts in the repository, such as the legacy registry import
 $ nix-shell
 ```
 
-## Bower Import
+## Legacy Import
 
 You can execute the legacy registry import script with the following command:
 

ci/shell.nix

@@ -21,6 +21,8 @@ in pkgs.stdenv.mkDerivation {
 
     pkgs.nodejs-14_x
 
+    pkgs.dhall-json
+
     pkgs.licensee
   ];
 }

ci/spago.dhall

@@ -1,4 +1,5 @@
 { name = "registry-ci"
+, license = "BSD-3-Clause"
 , dependencies =
   [ "aff"
   , "aff-promise"
@@ -7,6 +8,7 @@
   , "argonaut-core"
   , "argonaut-generic"
   , "arrays"
+  , "avar"
   , "bifunctors"
   , "console"
   , "control"
@@ -34,6 +36,7 @@
   , "now"
   , "nullable"
   , "ordered-collections"
+  , "parallel"
   , "partial"
   , "prelude"
   , "profunctor-lenses"

ci/src/Foreign/Dhall.purs

@@ -2,9 +2,13 @@ module Foreign.Dhall where
 
 import Registry.Prelude
 
+import Data.Argonaut as Json
+import Foreign.Jsonic as Jsonic
 import Node.ChildProcess as NodeProcess
 import Sunde as Process
 
+-- | Attempt to convert a JSON file representing a PureScript manifest into
+-- | the corresponding `Manifest.dhall` type using the `json-to-dhall` CLI.
 jsonToDhallManifest :: String -> Aff (Either String String)
 jsonToDhallManifest jsonStr = do
   let cmd = "json-to-dhall"
@@ -14,3 +18,15 @@ jsonToDhallManifest jsonStr = do
   pure $ case result.exit of
     NodeProcess.Normally 0 -> Right jsonStr
     _ -> Left result.stderr
+
+-- | Convert a string representing a Dhall expression into JSON using the
+-- | `dhall-to-json` CLI.
+dhallToJson :: { dhall :: String, cwd :: Maybe FilePath } -> Aff (Either String Json.Json)
+dhallToJson { dhall, cwd } = do
+  let cmd = "dhall-to-json"
+  let stdin = Just dhall
+  let args = []
+  result <- Process.spawn { cmd, stdin, args } (NodeProcess.defaultSpawnOptions { cwd = cwd })
+  pure $ case result.exit of
+    NodeProcess.Normally 0 -> lmap Json.printJsonDecodeError $ Jsonic.parseJson result.stdout
+    _ -> Left result.stderr

ci/src/Foreign/Jsonic.purs

@@ -1,11 +1,19 @@
-module Foreign.Jsonic (parse) where
-
-import Registry.Prelude
+module Foreign.Jsonic (parseJson) where
 
 import Data.Argonaut (Json)
+import Data.Argonaut as Json
+import Data.Bifunctor (lmap)
+import Data.Either (Either(..))
 import Data.Function.Uncurried (Fn3, runFn3)
 
-parse :: String -> Either String Json
-parse = runFn3 parseJsonicImpl Left Right
+-- | A drop-in replacement for `Data.Argonaut.parseJson` that uses a lenient
+-- | JSON parser.
+parseJson :: String -> Either Json.JsonDecodeError Json
+parseJson input = do
+  let toJsonError e = Json.Named "Malformed JSON" (Json.UnexpectedValue (Json.fromString e))
+  lmap toJsonError (parseJsonic input)
 
 foreign import parseJsonicImpl :: forall r. Fn3 (String -> r) (Json -> r) String r
+
+parseJsonic :: String -> Either String Json
+parseJsonic = runFn3 parseJsonicImpl Left Right

ci/src/Foreign/Licensee.purs

@@ -0,0 +1,52 @@
+module Foreign.Licensee where
+
+import Registry.Prelude
+
+import Control.Parallel as Parallel
+import Data.Argonaut as Json
+import Data.String as String
+import Foreign.Tmp as Tmp
+import Node.ChildProcess as NodeProcess
+import Node.FS.Aff as FS
+import Sunde as Process
+
+-- | Attempt to detect the license associated with a set of provided files
+detectFiles :: Array { name :: FilePath, contents :: String } -> Aff (Either String (Array String))
+detectFiles files = do
+  tmp <- liftEffect Tmp.mkTmpDir
+  files # Parallel.parTraverse_ \{ name, contents } ->
+    FS.writeTextFile UTF8 (tmp <> "/" <> name) contents
+  detect tmp
+
+-- | Attempt to detect the license for the package in the given directory using
+-- | the `licensee` CLI tool.
+detect :: FilePath -> Aff (Either String (Array String))
+detect directory = do
+  let cmd = "licensee"
+  let stdin = Nothing
+  let args = [ "detect", "--json", directory ]
+  result <- Process.spawn { cmd, stdin, args } NodeProcess.defaultSpawnOptions
+  case result.exit of
+    -- Licensee will exit with `Normally 1` if it didn't parse any licenses,
+    -- but we consider this valid Licensee output.
+    NodeProcess.Normally n | n == 0 || n == 1 -> do
+      let
+        parse :: String -> Either Json.JsonDecodeError (Array String)
+        parse str = Json.parseJson (String.trim str) >>= \json -> do
+          obj <- Json.decodeJson json
+          licenses <- obj `Json.getField` "licenses"
+          spdxIds <- traverse (_ `Json.getField` "spdx_id") licenses
+          pure spdxIds
+
+      case parse result.stdout of
+        Left err -> do
+          let printed = Json.printJsonDecodeError err
+          log "Licensee failed to decode output: "
+          log printed
+          log "arising from the result: "
+          log result.stdout
+          pure $ Left printed
+        Right out ->
+          pure $ Right out
+    _ ->
+      pure $ Left result.stderr

ci/src/Foreign/SemVer.purs

@@ -97,7 +97,7 @@ parseRange original = do
   converted <- case toMaybe (parseRangeImpl original) of
     Just c -> pure c
     Nothing ->
-      -- when parsing a version from a Bowerfile it could be that it's specified
+      -- when parsing a version from a BowerFile it could be that it's specified
       -- in the https://giturl#version, or owner/repo#version, so we try to parse that here.
       case String.split (String.Pattern "#") original of
         [ _url, version ] -> case toMaybe (parseRangeImpl version) of

ci/src/Registry/API.purs

@@ -28,7 +28,6 @@ import Registry.PackageUpload as Upload
 import Registry.RegistryM (Env, RegistryM, closeIssue, comment, commitToTrunk, readPackagesMetadata, runRegistryM, throwWithComment, updatePackagesMetadata, uploadPackage)
 import Registry.Schema (Manifest, Metadata, Operation(..), Repo(..), addVersionToMetadata, mkNewMetadata)
 import Registry.Scripts.BowerImport as BowerImport
-import Registry.Scripts.BowerImport.BowerFile (BowerFile)
 import Registry.Scripts.BowerImport.BowerFile as BowerFile
 import Sunde as Process
 import Text.Parsing.StringParser as StringParser
@@ -166,27 +165,32 @@ addOrUpdate { ref, fromBower, packageName } metadata = do
   let manifestPath = absoluteFolderPath <> "/purs.json"
   log $ "Package extracted in " <> absoluteFolderPath
 
-  -- If we're importing from Bower then we need to convert the Bowerfile
+  -- If we're importing from Bower then we need to convert the BowerFile
   -- to a Registry Manifest
   when fromBower do
-    liftAff (readBowerfile (absoluteFolderPath <> "/bower.json")) >>= case _ of
+    liftAff (try (readJsonFile (absoluteFolderPath <> "/bower.json"))) >>= case _ of
       Left err ->
-        throwWithComment $ "Error while reading Bowerfile: " <> err
-      Right bowerfile -> do
+        throwWithComment $ "Error while reading BowerFile: " <> Aff.message err
+      Right (Left err) ->
+        throwWithComment $ "Could not decode BowerFile: " <> Json.printJsonDecodeError err
+      Right (Right bowerfile) -> do
         let
           printErrors =
             Json.stringifyWithIndent 2 <<< Json.encodeJson <<< NEA.toArray
 
+          manifestFields =
+            BowerFile.toManifestFields bowerfile
+
           runManifest =
             Except.runExceptT <<< Except.mapExceptT (liftAff <<< map (lmap printErrors))
 
         semVer <- case SemVer.parseSemVer ref of
           Nothing -> throwWithComment $ "Not a valid SemVer version: " <> ref
           Just result -> pure result
 
-        runManifest (BowerImport.toManifest packageName metadata.location semVer bowerfile) >>= case _ of
+        runManifest (BowerImport.toManifest packageName metadata.location semVer manifestFields) >>= case _ of
           Left err ->
-            throwWithComment $ "Unable to convert Bowerfile to a manifest: " <> err
+            throwWithComment $ "Unable to convert BowerFile to a manifest: " <> err
           Right manifest ->
             liftAff $ writeJsonFile manifestPath manifest
 
@@ -318,13 +322,3 @@ pushToMaster packageName path = Except.runExceptT do
         info result.stderr
         pure $ Right unit
       _ -> pure $ Left result.stderr
-
-readBowerfile :: String -> Aff (Either String BowerFile)
-readBowerfile path = do
-  let
-    fromJson' = BowerFile.parse >>> lmap BowerFile.printBowerFileParseError
-  ifM (not <$> FS.exists path)
-    (pure $ Left $ "Bowerfile not found at " <> path)
-    do
-      strResult <- FS.readTextFile UTF8 path
-      pure $ fromJson' strResult

ci/src/Registry/Prelude.purs

@@ -44,6 +44,7 @@ import Effect.Aff.Class (liftAff, class MonadAff) as Extra
 import Effect.Class (liftEffect, class MonadEffect) as Extra
 import Effect.Class.Console (error, log, info) as Extra
 import Effect.Ref (Ref) as Extra
+import Foreign.Jsonic as Jsonic
 import Foreign.Object (Object) as Extra
 import Foreign.Object as Object
 import Node.Buffer (Buffer) as Extra
@@ -66,7 +67,7 @@ writeJsonFile path = FS.writeTextFile Extra.UTF8 path <<< Json.stringifyWithInde
 readJsonFile :: forall a. Json.DecodeJson a => Extra.FilePath -> Extra.Aff (Either.Either Json.JsonDecodeError a)
 readJsonFile path = do
   contents <- FS.readTextFile Extra.UTF8 path
-  pure $ Json.decodeJson =<< Json.parseJson contents
+  pure $ Json.decodeJson =<< Jsonic.parseJson contents
 
 -- | Convert a Map into an Object, converting its keys to strings along the way.
 objectFromMap :: forall k a. Ord k => (k -> String) -> Extra.Map k a -> Extra.Object a