diff options
Diffstat (limited to 'cabal-plan/src-exe/LicenseReport.hs')
| -rw-r--r-- | cabal-plan/src-exe/LicenseReport.hs | 271 |
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 |