git subrepo clone ../cabal-plan cabal-plan

subrepo:
  subdir:   "cabal-plan"
  merged:   "34506ab"
upstream:
  origin:   "../cabal-plan"
  branch:   "master"
  commit:   "34506ab"
git-subrepo:
  version:  "0.3.1"
  origin:   "https://github.com/ingydotnet/git-subrepo.git"
  commit:   "a7ee886"

1 files changed, 271 insertions, 0 deletions

diff --git a/cabal-plan/src-exe/LicenseReport.hs b/cabal-plan/src-exe/LicenseReport.hs
new file mode 100644
index 0000000..9427d7a
--- /dev/null
+++ b/cabal-plan/src-exe/LicenseReport.hs
@@ -0,0 +1,271 @@
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE RecordWildCards   #-}
+
+-- | Implements @cabal-plan license-report@ functionality
+module LicenseReport
+    ( generateLicenseReport
+    ) where
+
+#if defined(MIN_VERSION_Cabal)
+import           Cabal.Plan
+import qualified Codec.Archive.Tar                      as Tar
+import qualified Codec.Archive.Tar.Entry                as Tar
+import qualified Codec.Compression.GZip                 as GZip
+import           Control.Monad.Compat                   (forM, forM_, guard, unless, when)
+import qualified Data.ByteString.Lazy                   as BSL
+import qualified Data.ByteString                        as BS
+import           Data.Map                               (Map)
+import           Data.List                              (nub)
+import qualified Data.Map                               as Map
+import           Data.Semigroup
+import           Data.Set                               (Set)
+import qualified Data.Set                               as Set
+import qualified Data.Text                              as T
+import qualified Data.Text.IO                           as T
+import qualified Data.Version                           as DV
+import           Distribution.PackageDescription
+import           Distribution.PackageDescription.Parsec
+import           Distribution.Pretty
+import           System.Directory
+import           System.FilePath
+import           System.IO                              (stderr)
+import           Text.ParserCombinators.ReadP
+import           Prelude ()
+import           Prelude.Compat
+
+-- | Read tarball lazily (and possibly decompress)
+readTarEntries :: FilePath -> IO [Tar.Entry]
+readTarEntries idxtar = do
+    es <- case takeExtension idxtar of
+            ".gz"  -> Tar.read . GZip.decompress <$> BSL.readFile idxtar
+            ".tar" -> Tar.read                   <$> BSL.readFile idxtar
+            ext    -> error ("unknown extension " ++ show ext)
+
+    return (Tar.foldEntries (:) [] (\err -> error ("readTarEntries " ++ show err)) es)
+
+fp2pid :: FilePath -> Maybe PkgId
+fp2pid fn0 = do
+  [pns,pvs,rest] <- Just (splitDirectories fn0)
+  guard (rest == pns <.> "cabal")
+  pv <- parseVer pvs
+  pure (PkgId (PkgName $ T.pack pns) pv)
+
+
+parseVer :: String -> Maybe Ver
+parseVer str = case reverse $ readP_to_S DV.parseVersion str of
+  (ver, "") : _ | not (null (DV.versionBranch ver)), all (>= 0) (DV.versionBranch ver)
+      -> Just (Ver $ DV.versionBranch ver)
+  _   -> Nothing
+
+
+readHackageIndex :: IO [(PkgId, BSL.ByteString)]
+readHackageIndex = do
+    -- TODO: expose package index configuration as CLI flag
+    cabalPkgCacheDir <- getAppUserDataDirectory "cabal/packages/hackage.haskell.org"
+    ents <- readTarEntries (cabalPkgCacheDir </> "01-index.tar")
+
+    pure [ (maybe (error $ show n) id $ fp2pid n,bsl)
+         | e@(Tar.Entry { Tar.entryContent = Tar.NormalFile bsl _ }) <- ents
+         , let n = Tar.entryPath e
+         , takeExtension n == ".cabal"
+         ]
+
+getLicenseFiles :: PkgId -> UnitId -> [FilePath] -> IO [BS.ByteString]
+getLicenseFiles compilerId (UnitId uidt) fns = do
+  storeDir <- getAppUserDataDirectory "cabal/store"
+  let docDir = storeDir </> T.unpack (dispPkgId compilerId) </> T.unpack uidt </> "share" </> "doc"
+  forM fns $ \fn -> BS.readFile (docDir </> fn)
+
+{- WARNING: the code that follows will make you cry; a safety pig is provided below for your benefit.
+
+                         _
+ _._ _..._ .-',     _.._(`))
+'-. `     '  /-._.-'    ',/
+   )         \            '.
+  / _    _    |             \
+ |  a    a    /              |
+ \   .-.                     ;
+  '-('' ).-'       ,'       ;
+     '-;           |      .'
+        \           \    /
+        | 7  .__  _.-\   \
+        | |  |  ``/  /`  /
+       /,_|  |   /,_/   /
+          /,_/      '`-'
+
+-}
+
+-- TODO: emit report to Text or Text builder
+generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO ()
+generateLicenseReport mlicdir plan uid0 cn0 = do
+    let pidsOfInterest = Set.fromList (map uPId (Map.elems $ pjUnits plan))
+
+    indexDb <- Map.fromList . filter (flip Set.member pidsOfInterest . fst) <$> readHackageIndex
+
+    let -- generally, units belonging to the same package as 'root'
+        rootPkgUnits = [ u | u@(Unit { uPId = PkgId pn' _ }) <- Map.elems (pjUnits plan), pn' == pn0 ]
+        rootPkgUnitIds = Set.fromList (map uId rootPkgUnits)
+
+        -- the component of interest
+        Just root@Unit { uPId = PkgId pn0 _ } = Map.lookup uid0 (pjUnits plan)
+
+        fwdDeps = planJsonIdGraph' plan
+        revDeps = invertMap fwdDeps
+
+    let transUids = transDeps fwdDeps (uId root) Set.\\ rootPkgUnitIds
+
+        indirectDeps = Set.fromList [ u | u <- Set.toList transUids, Set.null (Map.findWithDefault mempty u revDeps `Set.intersection` rootPkgUnitIds) ]
+
+        directDeps = transUids Set.\\ indirectDeps
+
+
+    let printInfo :: UnitId -> IO ()
+        printInfo uid = do
+          let Just u = Map.lookup uid (pjUnits plan)
+
+              PkgId (PkgName pn) pv = uPId u
+
+          case BSL.toStrict <$> Map.lookup (uPId u) indexDb of
+            Nothing
+              | PkgId (PkgName "rts") _ <- uPId u -> pure ()
+              | otherwise -> fail (show u)
+
+            Just x -> do
+              gpd <- maybe (fail "parseGenericPackageDescriptionMaybe") pure $
+                     parseGenericPackageDescriptionMaybe x
+
+              let desc = escapeDesc $ synopsis $ packageDescription gpd
+                  lic  = license  $ packageDescription gpd
+                  -- cr   = copyright $ packageDescription gpd
+                  lfs  = licenseFiles $ packageDescription gpd
+
+                  usedBy = Set.fromList [ uPId (Map.findWithDefault undefined unit (pjUnits plan))
+                                        | unit <- Set.toList (Map.findWithDefault mempty uid revDeps)
+                                        , unit `Set.member` (directDeps <> indirectDeps)
+                                        ]
+
+              let url = "http://hackage.haskell.org/package/" <> dispPkgId (uPId u)
+
+                  isB = uType u == UnitTypeBuiltin
+
+                  -- special core libs whose reverse deps are too noisy
+                  baseLibs = ["base", "ghc-prim", "integer-gmp", "integer-simple", "rts"]
+
+                  licurl = case lfs of
+                             [] -> url
+                             (l:_)
+                               | Just licdir <- mlicdir, uType u == UnitTypeGlobal -> T.pack (licdir </> T.unpack (dispPkgId (uPId u)) </> takeFileName l)
+                               | otherwise              -> url <> "/src/" <> T.pack l
+
+              T.putStrLn $ mconcat
+                [ if isB then "| **`" else "| `", pn, if isB then "`** | [`" else "` | [`", dispVer pv, "`](", url , ")", " | "
+                , "[`", T.pack (prettyShow lic), "`](", licurl , ")", " | "
+                , T.pack desc, " | "
+                , if pn `elem` baseLibs then "*(core library)*"
+                  else T.intercalate ", " [ T.singleton '`' <> (j :: T.Text) <> "`" | PkgId (z@(PkgName j)) _ <- Set.toList usedBy,  z /= pn0], " |"
+                ]
+
+              -- print (pn, pv, prettyShow lic, cr, lfs, [ j | PkgId (PkgName j) _ <- Set.toList usedBy ])
+
+              forM_ mlicdir $ \licdir -> do
+
+                case uType u of
+                  UnitTypeGlobal -> do
+                    let lfs' = nub (map takeFileName lfs)
+
+                    when (length lfs' /= length lfs) $ do
+                      T.hPutStrLn stderr ("WARNING: Overlapping license filenames for " <> dispPkgId (uPId u))
+
+                    crdat <- getLicenseFiles (pjCompilerId plan) uid lfs'
+
+                    forM_ (zip lfs' crdat) $ \(fn,txt) -> do
+                      let d = licdir </> T.unpack (dispPkgId (uPId u))
+                      createDirectoryIfMissing True d
+                      BS.writeFile (d </> fn) txt
+
+                    -- forM_ crdat $ print
+                    pure ()
+
+                  -- TODO:
+                  --   UnitTypeBuiltin
+                  --   UnitTypeLocal
+                  --   UnitTypeInplace
+
+                  UnitTypeBuiltin -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (global/GHC bundled) not copied")
+                  UnitTypeLocal   -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (project-local package) not copied")
+                  UnitTypeInplace -> T.hPutStrLn stderr ("WARNING: license files for " <> dispPkgId (uPId u) <> " (project-inplace package) not copied")
+
+                unless (length lfs == Set.size (Set.fromList lfs)) $
+                  fail ("internal invariant broken for " <> show (uPId u))
+
+          pure ()
+
+    T.putStrLn "# Dependency License Report"
+    T.putStrLn ""
+    T.putStrLn ("Bold-faced **`package-name`**s denote standard libraries bundled with `" <> dispPkgId (pjCompilerId plan) <> "`.")
+    T.putStrLn ""
+
+    T.putStrLn ("## Direct dependencies of `" <> unPkgN pn0 <> ":" <> dispCompName cn0 <> "`")
+    T.putStrLn ""
+    T.putStrLn "| Name | Version | [SPDX](https://spdx.org/licenses/) License Id | Description | Also depended upon by |"
+    T.putStrLn "| --- | --- | --- | --- | --- |"
+    forM_ directDeps $ printInfo
+    T.putStrLn ""
+
+    T.putStrLn "## Indirect transitive dependencies"
+    T.putStrLn ""
+    T.putStrLn "| Name | Version | [SPDX](https://spdx.org/licenses/) License Id | Description | Depended upon by |"
+    T.putStrLn "| --- | --- | --- | --- | --- |"
+    forM_ indirectDeps $ printInfo
+    T.putStrLn ""
+
+    pure ()
+
+escapeDesc :: String -> String
+escapeDesc []          = []
+escapeDesc ('\n':rest) = ' ':escapeDesc rest
+escapeDesc ('|':rest)  = '\\':'|':escapeDesc rest
+escapeDesc (x:xs)      = x:escapeDesc xs
+
+unPkgN :: PkgName -> T.Text
+unPkgN (PkgName t) = t
+
+planItemAllLibDeps :: Unit -> Set.Set UnitId
+planItemAllLibDeps Unit{..} = mconcat [ ciLibDeps | (cn,CompInfo{..}) <- Map.toList uComps, wantC cn ]
+  where
+    wantC (CompNameSetup)   = False
+    wantC (CompNameTest _)  = False
+    wantC (CompNameBench _) = False
+    wantC _                 = True
+
+planJsonIdGraph':: PlanJson -> Map UnitId (Set UnitId)
+planJsonIdGraph' PlanJson{..} = Map.fromList [ (uId unit, planItemAllLibDeps unit) | unit <- Map.elems pjUnits ]
+
+
+
+invertMap :: Ord k => Map k (Set k) -> Map k (Set k)
+invertMap m0 = Map.fromListWith mappend [ (v, Set.singleton k) | (k,vs) <- Map.toList m0, v <- Set.toList vs ]
+
+transDeps :: Map UnitId (Set UnitId) -> UnitId -> Set UnitId
+transDeps g n0 = go mempty [n0]
+  where
+    go :: Set UnitId -> [UnitId] -> Set UnitId
+    go acc [] = acc
+    go acc (n:ns)
+      | Set.member n acc = go acc ns
+      | otherwise = go (Set.insert n acc) (ns ++ Set.toList (Map.findWithDefault undefined n g))
+
+#else
+
+----------------------------------------------------------------------------
+import           Cabal.Plan
+import           System.Exit
+import           System.IO
+
+generateLicenseReport :: Maybe FilePath -> PlanJson -> UnitId -> CompName -> IO ()
+generateLicenseReport _ _ _ _ = do
+  hPutStrLn stderr "ERROR: `cabal-plan license-report` sub-command not available! Please recompile/reinstall `cabal-plan` with the `license-report` Cabal flag activated."
+  exitFailure
+
+#endif