Adds perl support (#428)

Changelog.md

@@ -1,5 +1,9 @@
 # Spectrometer Changelog
 
+## v2.19.8
+
+- Perl: Adds support for Perl with parsing of `META.json`, `META.yml`, `MYMETA.yml`, `MYMETA.json`. ([#428](https://github.com/fossas/spectrometer/pull/428))
+
 ## v2.19.7
 
 - Resolves a regression when parsing npm `package-lock.json` files that do not contain a `version` field ([#445](https://github.com/fossas/spectrometer/pull/445))

docs/references/files/fossa-yml.v3.schema.json

@@ -201,6 +201,10 @@
                         {
                             "const": "setuptools",
                             "description": "For setuptools targets (python)"
+                        },
+                        {
+                            "const": "perl",
+                            "description": "For perl targets (using *META.{json,yml})"
                         }
                     ],
                     "description": "Target (package manager)"

docs/references/strategies/README.md

@@ -68,6 +68,10 @@
 - [carthage](platforms/ios/carthage.md)
 - [cocoapods](platforms/ios/cocoapods.md)
 
+### perl
+
+- [perl](languages/perl/perl.md)
+
 ### php
 
 - [php](languages/php/composer.md)

docs/references/strategies/languages/perl/perl.md

@@ -0,0 +1,38 @@
+# Perl Analysis
+
+| Strategy           | Direct Deps        | Deep Deps          | Edges | Classifies Dev Dependencies |
+| ------------------ | ------------------ | ------------------ | ----- | --------------------------- |
+| `*META.{yml, json} | :white_check_mark: | :white_check_mark: | :x:   | :white_check_mark:          |
+
+## Project Discovery
+
+Find a file named `MYMETA.json`, `MYMETA.yml`, `META.json`, or `META.yml`.
+
+## Analysis
+
+1. Parse `MYMETA.{yml, json}` or `META.{yml, json}` to identify dependencies.
+
+## Limitation
+
+- Dependency required for `runtime` only will be reported.
+- Reported analysis will not have any edges.
+
+## Example 
+
+1. Build your perl target. When you do this, you should have `MYMETA.yml` and `MYMETA.json`.
+2. Execute `fossa analyze -o` on the project to print analyzed dependency graphing (this will not upload any analysis to any endpoint)
+
+## FAQ
+
+### How do I *only perform analysis* for Perl?
+
+You can explicitly specify an analysis target in `.fossa.yml` file. The example below will exclude all analysis targets except for the composer. 
+
+```yaml
+# .fossa.yml 
+
+version: 3
+targets:
+  only:
+    - type: perl
+```

spectrometer.cabal

@@ -295,6 +295,7 @@ library
     Strategy.NuGet.Paket
     Strategy.NuGet.ProjectAssetsJson
     Strategy.NuGet.ProjectJson
+    Strategy.Perl
     Strategy.Pub
     Strategy.Python.Pipenv
     Strategy.Python.Poetry
@@ -399,6 +400,7 @@ test-suite unit-tests
     NuGet.PaketSpec
     NuGet.ProjectAssetsJsonSpec
     NuGet.ProjectJsonSpec
+    Perl.PerlSpec
     Python.PipenvSpec
     Python.Poetry.CommonSpec
     Python.Poetry.PoetryLockSpec

src/App/Fossa/Analyze.hs

@@ -125,6 +125,7 @@ import Strategy.NuGet.PackagesConfig qualified as PackagesConfig
 import Strategy.NuGet.Paket qualified as Paket
 import Strategy.NuGet.ProjectAssetsJson qualified as ProjectAssetsJson
 import Strategy.NuGet.ProjectJson qualified as ProjectJson
+import Strategy.Perl qualified as Perl
 import Strategy.Pub qualified as Pub
 import Strategy.Python.Pipenv qualified as Pipenv
 import Strategy.Python.Poetry qualified as Poetry
@@ -285,6 +286,7 @@ discoverFuncs =
   , DiscoverFunc PackageReference.discover
   , DiscoverFunc PackagesConfig.discover
   , DiscoverFunc Paket.discover
+  , DiscoverFunc Perl.discover
   , DiscoverFunc Pipenv.discover
   , DiscoverFunc Poetry.discover
   , DiscoverFunc ProjectAssetsJson.discover

src/Path/Extra.hs

@@ -1,11 +1,12 @@
 module Path.Extra (
   tryMakeRelative,
   renderRelative,
+  extensionOf,
 ) where
 
 import Data.String.Conversion (toText)
 import Data.Text (Text)
-import Path (Abs, Dir, File, Path, SomeBase (..), stripProperPrefix)
+import Path (Abs, Dir, File, Path, SomeBase (..), fileExtension, stripProperPrefix)
 
 -- tryMakeRelative returns the path of an absolute file (Path Abs File) relative to an absolute directory (Path Abs Dir).
 -- If the file is not within the directory, then the absolute file path will be returned
@@ -19,3 +20,6 @@ tryMakeRelative absDir absFile =
 -- Intended for convenience when displaying the newly relative path; to interact with it use `tryMakeRelative` instead.
 renderRelative :: Path Abs Dir -> Path Abs File -> Text
 renderRelative absDir absFile = toText $ tryMakeRelative absDir absFile
+
+extensionOf :: Path Abs File -> Maybe Text
+extensionOf absFile = toText <$> fileExtension absFile

src/Strategy/Perl.hs

@@ -0,0 +1,202 @@
+module Strategy.Perl (
+  discover,
+
+  -- * for testing
+  PackageName (..),
+  PerlMeta (..),
+  buildGraph,
+) where
+
+import App.Fossa.Analyze.Types (AnalyzeProject, analyzeProject)
+import Control.Applicative ((<|>))
+import Control.Effect.Diagnostics (Diagnostics, context)
+import Data.Aeson (Object, ToJSON)
+import Data.Aeson.Types (FromJSONKey, Parser, withObject)
+import Data.Aeson.Types qualified as AesonTypes
+import Data.Foldable (asum)
+import Data.Map (Map, toList)
+import Data.Maybe (fromMaybe)
+import Data.Set qualified as Set
+import Data.Text (Text)
+import Data.Yaml (FromJSON (parseJSON), (.:), (.:?))
+import DepTypes (
+  DepEnvironment (..),
+  DepType (CpanType),
+  Dependency (..),
+  VerConstraint (CEq),
+ )
+import Discovery.Walk (
+  WalkStep (WalkContinue),
+  findFileNamed,
+  walk',
+ )
+import Effect.Exec (Has)
+import Effect.ReadFS (ReadFS, readContentsJson, readContentsYaml)
+import GHC.Generics (Generic)
+import Graphing (Graphing, deeps)
+import Path
+import Path.Extra (extensionOf)
+import Text.Read (readMaybe)
+import Types (
+  DependencyResults (..),
+  DiscoveredProject (..),
+  GraphBreadth (Partial),
+ )
+
+discover :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [DiscoveredProject PerlProject]
+discover dir = context "Perl" $ do
+  projects <- context "Finding projects" $ findProjects dir
+  pure (map mkProject projects)
+
+findProjects :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs Dir -> m [PerlProject]
+findProjects = walk' $ \dir _ files -> do
+  -- We prefer MYMETA over META.
+  -- Reference: https://metacpan.org/dist/App-mymeta_requires/view/bin/mymeta-requires
+  case asum $ map (`findFileNamed` files) ["MYMETA.json", "MYMETA.yml", "META.json", "META.yml"] of
+    Nothing -> pure ([], WalkContinue)
+    Just f -> pure ([PerlProject dir f], WalkContinue)
+
+data PerlProject = PerlProject
+  { perlDir :: Path Abs Dir
+  , perlMetaFile :: Path Abs File
+  }
+  deriving (Eq, Ord, Show, Generic)
+
+instance ToJSON PerlProject
+instance AnalyzeProject PerlProject where
+  analyzeProject _ = getDeps
+
+mkProject :: PerlProject -> DiscoveredProject PerlProject
+mkProject project =
+  DiscoveredProject
+    { projectType = "perl"
+    , projectBuildTargets = mempty
+    , projectPath = perlDir project
+    , projectData = project
+    }
+
+getDeps :: (Has ReadFS sig m, Has Diagnostics sig m) => PerlProject -> m DependencyResults
+getDeps project = do
+  graph <- analyze (perlMetaFile project)
+  pure $
+    DependencyResults
+      { dependencyGraph = graph
+      , dependencyGraphBreadth = Partial
+      , dependencyManifestFiles = [perlMetaFile project]
+      }
+
+analyze :: (Has ReadFS sig m, Has Diagnostics sig m) => Path Abs File -> m (Graphing Dependency)
+analyze metaFile = do
+  content <- context "Identifying dependencies in meta file" $
+    case extensionOf metaFile of
+      Just "json" -> readContentsJson metaFile
+      _ -> readContentsYaml metaFile
+
+  pure $ buildGraph (content)
+
+newtype PackageName = PackageName {unPackageName :: Text} deriving (Show, Eq, Ord, FromJSONKey)
+
+-- | Represents Metafile for various versions.
+-- References:
+-- v1.0: http://module-build.sourceforge.net/META-spec-v1.0.html
+-- v1.1: http://module-build.sourceforge.net/META-spec-v1.1.html
+-- v1.2: http://module-build.sourceforge.net/META-spec-v1.2.html
+-- v1.3: http://module-build.sourceforge.net/META-spec-v1.3.html
+-- v1.4: https://metacpan.org/release/DAGOLDEN/CPAN-Meta-2.101090
+-- v2.0: https://metacpan.org/release/DAGOLDEN/CPAN-Meta-2.150010
+data PerlMeta = PerlMeta
+  { version :: Double
+  , runtimeRequires :: Maybe (Map PackageName (Maybe Text))
+  , buildRequires :: Maybe (Map PackageName (Maybe Text))
+  , testRequires :: Maybe (Map PackageName (Maybe Text))
+  , developRequires :: Maybe (Map PackageName (Maybe Text))
+  , configureRequires :: Maybe (Map PackageName (Maybe Text))
+  }
+  deriving (Generic, Show, Eq, Ord)
+
+instance FromJSON PackageName where
+  parseJSON (AesonTypes.String packageName) = pure $ PackageName packageName
+  parseJSON _ = fail "failed to parse package's name"
+
+instance FromJSON PerlMeta where
+  parseJSON = withObject "meta content" $ \o -> do
+    -- spec_version can be either be string or number
+    -- in yaml, version is provided as string, where as in json, it is numeric
+    specVersion :: Double <-
+      (o .: "meta-spec" |> "version")
+        <|> ( do
+                v <- o .: "meta-spec" |> "version"
+                case readMaybe v of
+                  Nothing -> fail ("Expected numeric value for version field, but got: " <> show v)
+                  Just x -> pure x
+            )
+
+    if specVersion > 1.4
+      then parseAboveV1_4 o specVersion
+      else parseBelowV1_5 o specVersion
+    where
+      (|>) :: FromJSON a => Parser Object -> Text -> Parser a
+      (|>) parser key = do
+        obj <- parser
+        obj .: key
+
+      (|?>) :: FromJSON a => Parser (Maybe Object) -> Text -> Parser (Maybe a)
+      (|?>) parser key = do
+        obj <- parser
+        case obj of
+          Nothing -> pure Nothing
+          Just o -> o .:? key
+
+      -- Reference: https://metacpan.org/release/DAGOLDEN/CPAN-Meta-2.101090
+      parseAboveV1_4 obj version = do
+        runtimeRequires <- obj .:? "prereqs" |?> "runtime" |?> "requires"
+        buildRequires <- obj .:? "prereqs" |?> "build" |?> "requires"
+        testRequires <- obj .:? "prereqs" |?> "test" |?> "requires"
+        developRequires <- obj .:? "prereqs" |?> "develop" |?> "requires"
+        configureRequires <- obj .:? "prereqs" |?> "configure" |?> "requires"
+
+        pure $
+          PerlMeta
+            version
+            runtimeRequires
+            buildRequires
+            testRequires
+            developRequires
+            configureRequires
+
+      -- Reference: http://module-build.sourceforge.net/META-spec-v1.4.html
+      parseBelowV1_5 obj version = do
+        runtimeRequires <- obj .:? "requires"
+        buildRequires <- obj .:? "build_requires"
+        configureRequires1 <- obj .:? "configure_requires"
+        pure $ PerlMeta version runtimeRequires buildRequires Nothing Nothing configureRequires1
+
+buildGraph :: PerlMeta -> Graphing Dependency
+buildGraph meta =
+  deeps $
+    filter
+      notNamedPerl
+      (runtimeDeps ++ testDeps ++ developDeps ++ buildDeps ++ configureDeps)
+  where
+    runtimeDeps = getDepsOf EnvProduction runtimeRequires
+    testDeps = getDepsOf EnvTesting testRequires
+    developDeps = getDepsOf EnvDevelopment developRequires
+    buildDeps = getDepsOf EnvDevelopment buildRequires
+    configureDeps = getDepsOf EnvDevelopment configureRequires
+
+    notNamedPerl :: Dependency -> Bool
+    notNamedPerl dep = dependencyName dep /= "perl"
+
+    getDepsOf :: DepEnvironment -> (PerlMeta -> Maybe (Map PackageName (Maybe Text))) -> [Dependency]
+    getDepsOf env getter = map (toDependency env) (toList $ fromMaybe mempty (getter meta))
+
+    toDependency :: DepEnvironment -> (PackageName, Maybe Text) -> Dependency
+    toDependency env (pkgName, version) =
+      Dependency
+        { dependencyName = unPackageName pkgName
+        , dependencyType = CpanType
+        , dependencyVersion = CEq <$> version
+        , dependencyLocations = []
+        , dependencyEnvironments = Set.singleton env
+        , dependencyTags = mempty
+        }

test/App/Fossa/AnalyzeSpec.hs

@@ -16,5 +16,5 @@ spec :: Spec
 spec =
   -- this test only exists to prevent merging the commented out analyzers
   describe "Discovery function list" $
-    it "should be length 32" $
-      length (discoverFuncs :: [DiscoverFunc SomeMonad]) `shouldBe` 32
+    it "should be length 33" $
+      length (discoverFuncs :: [DiscoverFunc SomeMonad]) `shouldBe` 33