1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
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 <> ":" <> 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
|