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
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
------------------------------------------------------------------------------
--- This module implements tools to manage the central repository:
---
--- Run "cpm-manage -h" to see all options.
---
------------------------------------------------------------------------------

module CPM.Manage ( main )
  where

import Directory ( createDirectoryIfMissing, doesDirectoryExist, doesFileExist
                 , getAbsolutePath, getCurrentDirectory, getDirectoryContents
                 , getTemporaryDirectory )
import FilePath  ( (</>), replaceExtension )
import IOExts    ( evalCmd, readCompleteFile )
import List      ( groupBy, intercalate, isPrefixOf, isSuffixOf
                 , nub, nubBy, partition, sortBy, sum )
import System    ( getArgs, getPID, 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 )
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 ++ "'"
    ]

------------------------------------------------------------------------------
--- Get all packages from the repository.
--- For each package, get the newest version compatible
--- to the current compiler. If there is no compatible version and the
--- first argument is False, get the newest version, otherwise the package
--- is ignored.
--- In addition to this package list (third component),
--- the first component contains the current configuration and the
--- second component the list of all packages grouped by versions
--- (independent of the compiler compatbility).
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
  -- Returns the first package compatible to the current compiler.
  -- If `compat` is False and there are no compatible packages,
  -- return the first package.
  filterCompatPkgs cfg pkgs =
    let comppkgs = filter (isCompatibleToCompiler cfg) pkgs
    in if null comppkgs
         then if compat then [] else take 1 pkgs
         else [head comppkgs]

------------------------------------------------------------------------------
-- Generate README files used in the HTML index pages into the
-- documentation directories if they are not already there.
-- Thus, for each package p version v, do the following:
-- If there is a README file in directory PACKAGES/p-v but not
-- README.html in directory DOC/p-v, generate the latter by
--     pandoc -s -t html -o ....
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
          -- make them readable:
          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

------------------------------------------------------------------------------
-- Generate main HTML index pages of the CPM repository.
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
   --mapM_ (writePackageAsHTML allpkgversions newestpkgs) $ take 3 allnpkgs
 where
  writePackageIndex allpkgs indexfile statistics actindex = do
    putStrLn $ "Writing '" ++ indexfile ++ "'..."
    indextable <- packageInfosAsHtmlTable allpkgs
    let ptitle   = "Curry Packages in the CPM Repository"
        pkglinks = map (\p -> hrefPrimBadge
                                (packageHtmlDir </> packageId p ++ ".html")
                                [htxt $ if actindex==0 then name p
                                                       else packageId p])
                       allpkgs
        pindex   = [h2 [htxt "Package index:"], par (hitems pkglinks)]
    pagestring <- cpmIndexPage ptitle (pindex ++ [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"]]

-- Generate main category index page.
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 "Category index:"] : 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)

--- Standard HTML page for generated a package index.
cpmIndexPage :: String -> [BaseHtml] -> 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)

--- Generate HTML page for a package in a given version into a directory.
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

--- Write HTML pages for a single package.
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)
    -- set symbolic link to recent package:
    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"

--- Writes a file readable for all:
writeReadableFile :: String -> String -> IO ()
writeReadableFile f s = writeFile f s >> system ("chmod 644 " ++ f) >> done

-- Format a list of packages as an HTML table
packageInfosAsHtmlTable :: [Package] -> IO BaseHtml
packageInfosAsHtmlTable pkgs = do
  rows <- mapM formatPkgAsRow pkgs
  return $ borderedHeadedTable
    (map ((:[]) . htxt)
         ["Name", "API", "Doc","Executable","Synopsis", "Version"])
    rows
 where
  formatPkgAsRow :: Package -> IO [[BaseHtml]]
  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"

------------------------------------------------------------------------------
-- Generate HTML documentation of all packages in the central repository
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

------------------------------------------------------------------------------
-- Run `cypm test` on all packages of the central repository
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 '=')

------------------------------------------------------------------------------
-- Generate tar.gz files of all packages (in the current directory)
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 --(take 3 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 ++ "'!"


------------------------------------------------------------------------------
-- Add a new package (already committed and pushed into its git repo)
-- where the package specification is stored in the current directory.
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"

-- Set the package version as a tag in the git repository.
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"

------------------------------------------------------------------------------
-- Test a specific version of a package by checking it out in a temporary
-- directory, install it (with a local bin dir), and run all tests.
-- Returns the exit code of the package test command and the packaged id.
checkoutAndTestPackage :: String -> Package -> IO (Int,String)
checkoutAndTestPackage statdir pkg = inEmptyTempDir $ do
  putStrLn $ unlines [dline, "Testing package: " ++ pkgid, dline]
  -- create installation bin dir:
  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, "&&"
              -- install possible binaries in bindir:
              , "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

------------------------------------------------------------------------------
-- Combine all CSV statistics files for packages (produced by
-- `cypm test -f ...`) contained in a directory into a result file
-- and sum up the results.
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)

-- Combine all CSV files contained in a directory into one result CSV file
-- according to an operation to read the contents of each CSV file,
-- an operation to write the result into CSV format,
-- an operation to combine the results, and a default value.
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)

------------------------------------------------------------------------------
-- Re-tag the current git version with the current package version
-- and copy the package spec file to the cpm index
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

------------------------------------------------------------------------------
-- Show package dependencies as dot graph
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)))

-- Write package dependencies into CSV file 'pkgs.csv'
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'"

------------------------------------------------------------------------------
-- Copy all package documentations from directory `packagedocdir` into
-- the directory `currygleDocDir` so that the documentations
-- can be used by Currygle to generate the documentation index
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

------------------------------------------------------------------------------
--- Reads to the .cpmrc file from the user's home directory and return
--- the configuration. Terminate in case of some errors.
readConfiguration :: IO Config
readConfiguration =
  readConfigurationWith [] >>= \c -> case c of
    Left err -> do putStrLn $ "Error reading .cpmrc file: " ++ err
                   exitWith 1
    Right c' -> return c'

--- Executes an IO action with the current directory set to a new empty
--- temporary directory. After the execution, the temporary directory
--- is deleted.
inEmptyTempDir :: IO a -> IO a
inEmptyTempDir a = do
  tmp <- newTempDir
  createDirectoryIfMissing True tmp
  r  <- inDirectory tmp a
  removeDirectoryComplete tmp
  return r

--- Returns a new temporary directory.
newTempDir :: IO String
newTempDir = do
  t   <- getTemporaryDirectory
  pid <- getPID
  getNewDir (t </> "cpm" ++ show pid) 0
 where
  getNewDir base i = do
    let tmpdir = base ++ show i
    exdir <- doesDirectoryExist tmpdir
    if exdir then getNewDir base (i+1)
             else return tmpdir

------------------------------------------------------------------------------
-- The name of the package specification file.
packageSpecFile :: String
packageSpecFile = "package.json"

------------------------------------------------------------------------------
-- Generates a HTML representation of the contents of a directory.
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 [BaseHtml]
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) -- to avoid very deep (infinite) dir trees
      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)

------------------------------------------------------------------------------