{-# 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 <> ":" <> dispCompNameTarget pn0 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