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
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
|
module CPM.Manage ( main )
where
import Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
, getAbsolutePath, getCurrentDirectory, getDirectoryContents )
import FilePath ( (</>), replaceExtension )
import IOExts ( evalCmd, readCompleteFile )
import List ( groupBy, intercalate, isPrefixOf, isSuffixOf
, nub, nubBy, partition, sortBy, sum )
import System ( getArgs, exitWith, system )
import Time ( CalendarTime, getLocalTime, toDayString )
import HTML.Base
import HTML.Styles.Bootstrap4
import ShowDotGraph
import Text.CSV ( readCSV, writeCSVFile )
import CPM.Config ( Config, repositoryDir, packageInstallDir
, readConfigurationWith )
import CPM.ErrorLogger
import CPM.FileUtil ( copyDirectory, inDirectory, quote
, recreateDirectory
, removeDirectoryComplete, tempDir )
import CPM.Package
import CPM.PackageCache.Global ( acquireAndInstallPackageFromSource
, checkoutPackage )
import CPM.Package.Helpers ( renderPackageInfo )
import CPM.Repository ( allPackages, listPackages
, readPackageFromRepository )
import CPM.Repository.Update ( addPackageToRepository, updateRepository )
import CPM.Repository.Select ( getBaseRepository, getPackageVersion )
import CPM.Resolution ( isCompatibleToCompiler )
import CPM.Manage.Config
import CPM.Package.HTML
main :: IO ()
main = do
args <- getArgs
case args of
["genhtml"] -> writePackageIndexAsHTML "CPM"
["genhtml",d] -> writePackageIndexAsHTML d
["genhtml",d,p,v] -> writePackageVersionAsHTML d p v
["genreadme"] -> writeReadmeFiles "CPM"
["genreadme",d] -> writeReadmeFiles d
["gendocs"] -> generateDocsOfAllPackages packageDocDir
["gendocs",d] -> getAbsolutePath d >>= generateDocsOfAllPackages
["gentar"] -> genTarOfAllPackages packageTarDir
["gentar",d] -> getAbsolutePath d >>= genTarOfAllPackages
["testall"] -> testAllPackages ""
["testall",d] -> getAbsolutePath d >>= testAllPackages
["sumcsv",d] -> do ad <- getAbsolutePath d
sumCSVStatsOfPkgs ad "SUM.csv"
["add"] -> addNewPackage True
["addnotag"] -> addNewPackage False
["update"] -> updatePackage
["showgraph"] -> showAllPackageDependencies
["writedeps"] -> writeAllPackageDependencies
["copydocs"] -> copyPackageDocumentations packageDocDir
["copydocs",d] -> getAbsolutePath d >>= copyPackageDocumentations
["--help"] -> putStrLn helpText
["-h"] -> putStrLn helpText
_ -> do putStrLn $ "Wrong arguments!\n"
putStrLn helpText
exitWith 1
helpText :: String
helpText = banner ++ unlines
[ "Options:", ""
, "add : add this package version to the central repository"
, " and tag git repository of this package with its version"
, "addnotag : add this package version to the central repository"
, " (do not tag git repository)"
, "update : tag git repository of local package with current version"
, " and update central index with current package specification"
, "genhtml [<d>] : generate HTML pages of central repository into <d>"
, " (default: 'CPM')"
, "genhtml <d> <p> <v>: generate HTML pages for package <p> / version <v>"
, " into directory <d>"
, "genreadme [<d>]: generate README.html files of central repository into <d>"
, " (default: 'CPM') if they are not already present"
, "gendocs [<d>] : generate HTML documentations of all packages into <d>"
, " (default: '" ++ packageDocDir ++ "')"
, "gentar [<d>] : generate tar.gz files of all packages into <d>"
, " (default: '" ++ packageTarDir ++ "')"
, "testall [<d>] : test all packages of the central repository"
, " and write test statistics into directory <d>"
, "sumcsv [<d>] : sum up all CSV package statistic files in <d>"
, "showgraph : visualize all package dependencies as dot graph"
, "writedeps : write all package dependencies as CSV file 'pkgs.csv'"
, "copydocs [<d>]: copy latest package documentations"
, " from <d> (default: '" ++ packageDocDir ++ "')"
, " to '" ++ currygleDocDir ++ "'"
]
getAllPackageSpecs :: Bool -> IO (Config,[[Package]],[Package])
getAllPackageSpecs compat = do
config <- readConfiguration
putStrLn "Reading base repository..."
repo <- getBaseRepository config
let allpkgversions = listPackages repo
allcompatpkgs = sortBy (\ps1 ps2 -> name ps1 <= name ps2)
(concatMap (filterCompatPkgs config)
allpkgversions)
return (config,allpkgversions,allcompatpkgs)
where
filterCompatPkgs cfg pkgs =
let comppkgs = filter (isCompatibleToCompiler cfg) pkgs
in if null comppkgs
then if compat then [] else take 1 pkgs
else [head comppkgs]
writeReadmeFiles :: String -> IO ()
writeReadmeFiles cpmindexdir = do
createDirectoryIfMissing True cpmindexdir
inDirectory cpmindexdir $ do
(config,allpkgversions,_) <- getAllPackageSpecs False
mapM_ genReadmeForPackage
(sortBy (\p1 p2 -> packageId p1 <= packageId p2)
(concat allpkgversions))
genReadmeForPackage :: Package -> IO ()
genReadmeForPackage pkg = do
putStrLn $ "CHECKING PACKAGE: " ++ pkgid
rmfiles <- getReadmeFiles pkgdir
rmexist <- doesFileExist $ docdir </> "README.html"
if null rmfiles || rmexist
then unless rmexist $ putStrLn $ "No README file found"
else do
let readmefile = head rmfiles
formatcmd1 = formatCmd1 (pkgdir </> readmefile)
formatcmd2 = formatCmd2 (pkgdir </> readmefile)
createDirectoryIfMissing True docdir
putStrLn $ "Executing: " ++ formatcmd1
rc1 <- system formatcmd1
putStrLn $ "Executing: " ++ formatcmd2
rc2 <- system formatcmd2
if rc1 == 0 && rc2 == 0
then do
system $ unwords ["chmod -f 644 ", quote outfile1, quote outfile2]
done
else error $ "Error during execution of commands:\n" ++
formatcmd1 ++ "\n" ++ formatcmd2
where
pkgid = packageId pkg
pkgdir = "PACKAGES" </> pkgid
docdir = "DOC" </> pkgid
getReadmeFiles dir = do
entries <- getDirectoryContents dir
return $ filter ("README" `isPrefixOf`) entries
outfile1 = docdir </> "README.html"
outfile2 = docdir </> "README_I.html"
formatCmd1 readme = "pandoc -s -t html -o " ++ outfile1 ++ " " ++ readme
formatCmd2 readme = "pandoc -t html -o " ++ outfile2 ++ " " ++ readme
writePackageIndexAsHTML :: String -> IO ()
writePackageIndexAsHTML cpmindexdir = do
createDirectoryIfMissing True cpmindexdir
inDirectory cpmindexdir $ do
createDirectoryIfMissing True packageHtmlDir
system $ "chmod 755 " ++ packageHtmlDir
(config,allpkgversions,newestpkgs) <- getAllPackageSpecs False
let stats = pkgStatistics allpkgversions newestpkgs
putStrLn "Reading all package specifications..."
allnpkgs <- mapM (fromErrorLogger . readPackageFromRepository config)
newestpkgs
writePackageIndex allnpkgs "index.html" stats 0
allvpkgs <- mapM (fromErrorLogger . readPackageFromRepository config)
(concat
(map reverse
(sortBy (\pg1 pg2 -> name (head pg1) <= name (head pg2))
allpkgversions)))
writePackageIndex allvpkgs "indexv.html" stats 1
writeCategoryIndexAsHTML allnpkgs
mapM_ (writePackageAsHTML allpkgversions newestpkgs) allvpkgs
where
writePackageIndex allpkgs indexfile statistics actindex = do
putStrLn $ "Writing '" ++ indexfile ++ "'..."
indextable <- packageInfosAsHtmlTable allpkgs
let ptitle = "Curry Packages in the CPM Repository"
pagestring <- cpmIndexPage ptitle ([indextable] ++ statistics) actindex
writeReadableFile indexfile pagestring
pkgStatistics allpkgversions newestpkgs =
[h4 [htxt "Statistics:"],
par [htxt $ show (length newestpkgs) ++ " packages", breakline,
htxt $ show (length (concat allpkgversions)) ++ " package versions"]]
writeCategoryIndexAsHTML :: [Package] -> IO ()
writeCategoryIndexAsHTML allpkgs = do
let allcats = sortBy (<=) . nub . concatMap category $ allpkgs
catpkgs = map (\c -> (c, sortBy pidLeq . nubBy pidEq .
filter (\p -> c `elem` category p) $ allpkgs))
allcats
cattables <- mapM formatCat catpkgs
let catlinks = map (\ (c,_) -> hrefPrimBadge ('#':c) [htxt c]) catpkgs
hcats = concatMap (\ (c,t) -> [anchor c [htxt ""], hrule, h1 [htxt c], t])
cattables
ptitle = "Curry Packages by Category"
pagestring <- cpmIndexPage ptitle
(h2 [htxt "All package categories"] : par (hitems catlinks) :
hcats) 2
let catindexfile = "indexc.html"
putStrLn $ "Writing '" ++ catindexfile ++ "'..."
writeReadableFile catindexfile pagestring
where
pidEq p1 p2 = packageId p1 == packageId p2
pidLeq p1 p2 = packageId p1 <= packageId p2
formatCat (c,ps) = do
pstable <- packageInfosAsHtmlTable ps
return (c, pstable)
cpmIndexPage :: String -> [HtmlExp] -> Int -> IO String
cpmIndexPage title maindoc actindex = do
time <- getLocalTime
let dayversion = " (Version: " ++ toDayString time ++ ")"
btbase = "bt4"
return $ showHtmlPage $
bootstrapPage (favIcon btbase) (cssIncludes btbase) (jsIncludes btbase)
title homeBrand
(leftTopMenu False actindex)
rightTopMenu 0 []
[h1 [htxt title, smallMutedText dayversion]]
maindoc (curryDocFooter time)
writePackageVersionAsHTML :: String -> String -> String -> IO ()
writePackageVersionAsHTML cpmindexdir pname pversion = do
case readVersion pversion of
Nothing -> error $ "'" ++ pversion ++ "' is not a valid version"
Just v -> do
(cfg,allpkgs,newestpkgs) <- getAllPackageSpecs False
mbpkg <- getPackageVersion cfg pname v
case mbpkg of
Nothing ->
error $ "Package '" ++ pname ++ "-" ++ pversion ++ "' not found!"
Just pkg -> do
fullpkg <- fromErrorLogger $ readPackageFromRepository cfg pkg
createDirectoryIfMissing True cpmindexdir
putStrLn $ "Changing to directory '" ++ cpmindexdir ++ "'..."
inDirectory cpmindexdir $ do
createDirectoryIfMissing True packageHtmlDir
system $ "chmod 755 " ++ packageHtmlDir
writePackageAsHTML allpkgs newestpkgs fullpkg
writePackageAsHTML :: [[Package]] -> [Package] -> Package -> IO ()
writePackageAsHTML allpkgversions newestpkgs pkg = do
pagestring <- packageToHTML allpkgversions newestpkgs pkg
inDirectory packageHtmlDir $ do
putStrLn $ "Writing '" ++ htmlfile ++ "'..."
writeReadableFile htmlfile pagestring
putStrLn $ "Writing '" ++ htmlsrcfile ++ "'..."
srcdirstring <- directoryContentsPage (".." </> "PACKAGES") pkgid
writeReadableFile htmlsrcfile srcdirstring
writeReadableFile metafile (renderPackageInfo True True True pkg)
system $ unwords
["/bin/rm", "-f", htmllink, "&&", "ln", "-s", htmlfile, htmllink]
done
where
pkgid = packageId pkg
htmlfile = pkgid ++ ".html"
htmlsrcfile = pkgid ++ "-src.html"
htmllink = name pkg ++ ".html"
metafile = pkgid ++ ".txt"
writeReadableFile :: String -> String -> IO ()
writeReadableFile f s = writeFile f s >> system ("chmod 644 " ++ f) >> done
packageInfosAsHtmlTable :: [Package] -> IO HtmlExp
packageInfosAsHtmlTable pkgs = do
rows <- mapM formatPkgAsRow pkgs
return $ borderedHeadedTable
(map ((:[]) . htxt)
["Name", "API", "Doc","Executable","Synopsis", "Version"])
rows
where
formatPkgAsRow :: Package -> IO [[HtmlExp]]
formatPkgAsRow pkg = do
hasapidir <- doesDirectoryExist apiDir
hasapiidx <- doesFileExist $ apiDir </> indexhtml
let docref = maybe [] (\r -> [hrefPrimBadge r [htxt "PDF"]]) (manualURL pkg)
return
[ [hrefPrimSmBlock (packageHtmlDir </> pkgid ++ ".html")
[htxt $ name pkg]]
, if hasapiidx then [ehrefPrimBadge (cpmDocURL ++ pkgid </> indexhtml)
[htxt "API doc"]]
else [nbsp]
, if hasapidir then docref else [nbsp]
, [maybe (htxt "")
(\ (PackageExecutable n _ _) -> kbdInput [htxt n])
(executableSpec pkg)]
, [htxt $ synopsis pkg]
, [htxt $ showVersion (version pkg)] ]
where
pkgid = packageId pkg
apiDir = "DOC" </> pkgid
indexhtml = "index.html"
generateDocsOfAllPackages :: String -> IO ()
generateDocsOfAllPackages packagedocdir = do
(_,_,allpkgs) <- getAllPackageSpecs True
mapM_ genDocOfPackage allpkgs
where
genDocOfPackage pkg = inEmptyTempDir $ do
let pname = name pkg
pversion = showVersion (version pkg)
putStrLn $ unlines [dline, "Documenting: " ++ pname, dline]
let cmd = unwords [ "rm -rf", pname, "&&"
, "cypm","checkout", pname, pversion, "&&"
, "cd", pname, "&&"
, "cypm", "install", "--noexec", "&&"
, "cypm", "doc", "--docdir", packagedocdir
, "--url", cpmDocURL, "&&"
, "cd ..", "&&"
, "rm -rf", pname
]
putStrLn $ "CMD: " ++ cmd
system cmd
testAllPackages :: String -> IO ()
testAllPackages statdir = do
(_,_,allpkgs) <- getAllPackageSpecs True
results <- mapM (checkoutAndTestPackage statdir) allpkgs
if sum (map fst results) == 0
then putStrLn $ show (length allpkgs) ++ " PACKAGES SUCCESSFULLY TESTED!"
else do putStrLn $ "ERRORS OCCURRED IN PACKAGES: " ++
unwords (map snd (filter ((> 0) . fst) results))
exitWith 1
dline :: String
dline = take 78 (repeat '=')
genTarOfAllPackages :: String -> IO ()
genTarOfAllPackages tardir = do
createDirectoryIfMissing True tardir
putStrLn $ "Generating tar.gz of all package versions in '" ++ tardir ++
"'..."
(cfg,allpkgversions,_) <- getAllPackageSpecs False
allpkgs <- mapM (fromErrorLogger . readPackageFromRepository cfg)
(sortBy (\ps1 ps2 -> packageId ps1 <= packageId ps2)
(concat allpkgversions))
mapM_ (writePackageAsTar cfg) allpkgs
where
writePackageAsTar cfg pkg = do
let pkgname = name pkg
pkgid = packageId pkg
pkgdir = tardir </> pkgid
tarfile = pkgdir ++ ".tar.gz"
putStrLn $ "Checking out '" ++ pkgid ++ "'..."
let checkoutdir = pkgname
system $ unwords [ "rm -rf", checkoutdir, pkgdir ]
fromErrorLogger $ fromELM $ do
toELM $ acquireAndInstallPackageFromSource cfg pkg
checkoutPackage cfg pkg
let cmd = unwords [ "cd", checkoutdir, "&&"
, "tar", "cvzf", tarfile, ".", "&&"
, "chmod", "644", tarfile, "&&"
, "cd", "..", "&&", "mv", checkoutdir, pkgdir, "&&"
, "chmod", "-R", "go+rX", pkgdir
]
putStrLn $ "...with command:\n" ++ cmd
ecode <- system cmd
when (ecode>0) $ error $ "ERROR OCCURED IN PACKAGE '" ++ pkgid ++ "'!"
addNewPackage :: Bool -> IO ()
addNewPackage withtag = do
config <- readConfiguration
pkg <- fromErrorLogger (loadPackageSpec ".")
when withtag $ setTagInGit pkg
let pkgIndexDir = name pkg </> showVersion (version pkg)
pkgRepositoryDir = repositoryDir config </> pkgIndexDir
pkgInstallDir = packageInstallDir config </> packageId pkg
fromErrorLogger $ fromELM $ addPackageToRepository config "." False False
putStrLn $ "Package repository directory '" ++ pkgRepositoryDir ++ "' added."
(ecode,_) <- checkoutAndTestPackage "" pkg
when (ecode>0) $ do
removeDirectoryComplete pkgRepositoryDir
removeDirectoryComplete pkgInstallDir
putStrLn "Checkout/test failure, package deleted in repository directory!"
fromELM $ updateRepository config True True True False
exitWith 1
putStrLn $ "\nEverything looks fine..."
putStrLn $ "\nTo publish the new repository directory, run command:\n"
putStrLn $ "pushd " ++ repositoryDir config ++
" && git add " ++ pkgIndexDir </> packageSpecFile ++
" && git commit -m\"" ++ pkgIndexDir ++ " added\" " ++
" && git push origin master && popd"
setTagInGit :: Package -> IO ()
setTagInGit pkg = do
let ts = 'v' : showVersion (version pkg)
(_,gittag,_) <- evalCmd "git" ["tag","-l",ts] ""
let deltag = if null gittag then [] else ["git tag -d",ts,"&&"]
cmd = unwords $ deltag ++ ["git tag -a",ts,"-m",ts,"&&",
"git push --tags -f"]
putStrLn $ "Execute: " ++ cmd
ecode <- system cmd
when (ecode > 0) $ error "ERROR in setting the git tag"
checkoutAndTestPackage :: String -> Package -> IO (Int,String)
checkoutAndTestPackage statdir pkg = inEmptyTempDir $ do
putStrLn $ unlines [dline, "Testing package: " ++ pkgid, dline]
curdir <- getCurrentDirectory
let bindir = curdir </> "pkgbin"
recreateDirectory bindir
let statfile = if null statdir then "" else statdir </> pkgid ++ ".csv"
unless (null statdir) $ createDirectoryIfMissing True statdir
let checkoutdir = pkgname
cmd = unwords $
[ "rm -rf", checkoutdir, "&&"
, "cypm", "checkout", pkgname, showVersion pkgversion, "&&"
, "cd", checkoutdir, "&&"
, "cypm", "-d bin_install_path=" ++ bindir, "install", "&&"
, "export PATH=" ++ bindir ++ ":$PATH", "&&"
, "cypm", "test"] ++
(if null statfile then [] else ["-f", statfile]) ++
[ "&&"
, "cypm", "-d bin_install_path=" ++ bindir, "uninstall"
]
putStrLn $ "...with command:\n" ++ cmd
ecode <- system cmd
when (ecode>0) $ putStrLn $ "ERROR OCCURED IN PACKAGE '" ++ pkgid ++ "'!"
return (ecode,pkgid)
where
pkgname = name pkg
pkgversion = version pkg
pkgid = packageId pkg
sumCSVStatsOfPkgs :: String -> String -> IO ()
sumCSVStatsOfPkgs dir outfile = do
combineCSVFilesInDir readStats showResult addStats ([],[]) dir outfile
putStrLn $ "All results written to file '" ++ outfile ++ "'."
where
readStats rows =
let [pkgid,ct,rc,total,unit,prop,eqv,io,mods] = rows !! 1
in (rows !! 0,
[ (pkgid, ct,
map (\s -> read s :: Int) [rc,total,unit,prop,eqv,io], mods) ])
showResult (header,rows) =
header :
sortBy (<=)
(map (\(pkgid,ct,nums,mods) -> pkgid : ct : map show nums ++ [mods])
rows) ++
["TOTAL:" : "" :
map show
(foldr1 (\nums1 nums2 -> map (uncurry (+)) (zip nums1 nums2))
(map (\ (_,_,ns,_) -> ns) rows))]
addStats (header,rows1) (_,rows2) = (header, rows1 ++ rows2)
combineCSVFilesInDir :: ([[String]] -> a) -> (a -> [[String]]) -> (a -> a -> a)
-> a -> String -> String -> IO ()
combineCSVFilesInDir fromcsv tocsv combine emptycsv statdir outfile = do
dcnts <- getDirectoryContents statdir
let csvfiles = map (statdir </>) (filter (".csv" `isSuffixOf`) dcnts)
stats <- mapM (\f -> readCompleteFile f >>= return . fromcsv . readCSV)
csvfiles
let results = foldr combine emptycsv stats
writeCSVFile outfile (tocsv results)
updatePackage :: IO ()
updatePackage = do
config <- readConfiguration
pkg <- fromErrorLogger (loadPackageSpec ".")
let pkgInstallDir = packageInstallDir config </> packageId pkg
setTagInGit pkg
putStrLn $ "Deleting old repo copy '" ++ pkgInstallDir ++ "'..."
removeDirectoryComplete pkgInstallDir
(ecode,_) <- checkoutAndTestPackage "" pkg
when (ecode > 0) $ do removeDirectoryComplete pkgInstallDir
putStrLn $ "ERROR in package, CPM index not updated!"
exitWith 1
fromErrorLogger $ fromELM $ addPackageToRepository config "." True False
showAllPackageDependencies :: IO ()
showAllPackageDependencies = do
config <- readConfiguration
pkgs <- getBaseRepository config >>= return . allPackages
let alldeps = map (\p -> (name p, map (\ (Dependency p' _) -> p')
(dependencies p)))
pkgs
dotgraph = depsToGraph alldeps
putStrLn $ "Show dot graph..."
viewDotGraph dotgraph
depsToGraph :: [(String, [String])] -> DotGraph
depsToGraph cpmdeps =
dgraph "CPM Dependencies"
(map (\s -> Node s []) (nub (map fst cpmdeps ++ concatMap snd cpmdeps)))
(map (\ (s,t) -> Edge s t [])
(nub (concatMap (\ (p,ds) -> map (\d -> (p,d)) ds) cpmdeps)))
writeAllPackageDependencies :: IO ()
writeAllPackageDependencies = do
(_,_,pkgs) <- getAllPackageSpecs True
let alldeps = map (\p -> (name p, map (\ (Dependency p' _) -> p')
(dependencies p)))
pkgs
writeCSVFile "pkgs.csv" (map (\ (p,ds) -> p:ds) alldeps)
putStrLn $ "Package dependencies written to 'pkgs.csv'"
copyPackageDocumentations :: String -> IO ()
copyPackageDocumentations packagedocdir = do
config <- readConfiguration
allpkgs <- getBaseRepository config >>= return . allPackages
let pkgs = map sortVersions (groupBy (\a b -> name a == name b) allpkgs)
pkgids = sortBy (\xs ys -> head xs <= head ys) (map (map packageId) pkgs)
putStrLn $ "Number of package documentations: " ++ show (length pkgs)
recreateDirectory currygleDocDir
mapM_ copyPackageDoc pkgids
where
sortVersions ps = sortBy (\a b -> version a `vgt` version b) ps
copyPackageDoc [] = done
copyPackageDoc (pid:pids) = do
let pdir = packagedocdir </> pid
exdoc <- doesDirectoryExist pdir
if exdoc
then do putStrLn $ "Copying documentation of " ++ pid ++ "..."
copyDirectory pdir (currygleDocDir </> pid)
else
if null pids
then putStrLn $ "Documentation " ++ pid ++ " does not exist!"
else copyPackageDoc pids
readConfiguration :: IO Config
readConfiguration =
readConfigurationWith [] >>= \c -> case c of
Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err
exitWith 1
Right c' -> return c'
inEmptyTempDir :: IO a -> IO a
inEmptyTempDir a = do
tmp <- tempDir
recreateDirectory tmp
r <- inDirectory tmp a
removeDirectoryComplete tmp
return r
packageSpecFile :: String
packageSpecFile = "package.json"
directoryContentsPage :: String -> String -> IO String
directoryContentsPage base dir = do
time <- getLocalTime
maindoc <- directoryContentsAsHTML 1 base dir
let btbase = "../bt4"
return $ showHtmlPage $
bootstrapPage (favIcon btbase) (cssIncludes btbase) (jsIncludes btbase)
("Browse " ++ dir) homeBrand
(leftTopMenu True (-1)) rightTopMenu 0 []
[h1 [smallMutedText "Contents of ", htxt dir]]
maindoc (curryDocFooter time)
directoryContentsAsHTML :: Int -> String -> String -> IO [HtmlExp]
directoryContentsAsHTML d base dir = do
exdir <- doesDirectoryExist basedir
if exdir
then do
dirfiles <- getDirectoryContents basedir >>= return . filter isReal
if null dirfiles
then return []
else do
ls <- mapM dirElemAsHTML (sortBy (<=) dirfiles)
let (files,dirs) = partition (\hes -> length hes == 1) ls
return [ulist (files ++ dirs) `addAttr` ("style","list-style: none")]
else return []
where
basedir = base </> dir
dirElemAsHTML df = do
isdir <- doesDirectoryExist (basedir </> df)
if isdir && (d < 10)
then do subdir <- directoryContentsAsHTML (d+1) basedir df
return [code [htxt (df ++ "/")], block subdir]
else return [code [href (basedir </> df)
[htxt $ df ++ if isdir then "/" else ""]]]
isReal fn = not ("." `isPrefixOf` fn)
|