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
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
|
{-# LANGUAGE CPP, OverloadedStrings, RankNTypes, ScopedTypeVariables, StandaloneDeriving #-}
{-# OPTIONS_GHC -Wall -fno-warn-orphans #-}
module Main where
import Debian.Debianize.Optparse(_flags, parseProgramArguments)
import Control.Lens
#if MIN_VERSION_Diff(1,0,0)
import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff, unnumber)
#else
import Data.Algorithm.DiffContext (getContextDiff, prettyContextDiff)
#endif
import Data.Bool (bool)
import Data.Function (on)
import Data.List (sortBy)
import Data.Map as Map (differenceWithKey, insert, intersectionWithKey)
import qualified Data.Map as Map (elems, Map, toList)
import Data.Maybe (fromMaybe)
import Data.Set as Set (fromList, union, insert)
import Data.Text as Text (intercalate, split, Text, unlines, unpack)
import Debian.Changes (ChangeLog(..), ChangeLogEntry(..), parseEntry)
import Debian.Codename (parseCodename)
import Debian.Debianize.BasicInfo (compilerFlavor, Flags, verbosity)
import qualified Debian.Debianize.Bundled as Bundled (tests)
import qualified Debian.Debianize.BinaryDebDescription as B
import Debian.Debianize.CabalInfo as A (CabalInfo, debInfo, epochMap, newCabalInfo)
import Debian.Debianize.CopyrightDescription
import Debian.Debianize.DebianName (mapCabal, splitCabal)
import qualified Debian.Debianize.DebInfo as D
import Debian.Debianize.Details (debianDefaults)
import Debian.Debianize.Files (debianizationFileMap)
import Debian.Debianize.Finalize (debianize {-, finalizeDebianization-})
import Debian.Debianize.Goodies (doBackups, doExecutable, doServer, doWebsite, tightDependencyFixup)
import Debian.Debianize.InputDebian (inputDebianization)
import Debian.Debianize.Monad (CabalT, evalCabalT, execCabalM, execCabalT, liftCabal, execDebianT, DebianT, evalDebianT)
import Debian.Debianize.Output (performDebianization)
import Debian.Debianize.Prelude (mkPackageName, withCurrentDirectory)
import qualified Debian.Debianize.SourceDebDescription as S
import Debian.Debianize.VersionSplits (DebBase(DebBase))
import Debian.Pretty (ppShow)
import Debian.Policy (databaseDirectory, PackageArchitectures(All), PackagePriority(Extra), parseMaintainer, Section(MainSection), SourceFormat(Native3), StandardsVersion(..) {-, getDebhelperCompatLevel, getDebianStandardsVersion, License(..)-})
import Debian.Relation (BinPkgName(..), Relation(..), SrcPkgName(..), VersionReq(..))
import Debian.Version (parseDebianVersion')
import Distribution.Compiler (CompilerFlavor({-GHC,-} GHCJS))
import Prelude hiding (log)
import System.Directory (doesDirectoryExist)
import System.Exit (exitWith, ExitCode(..))
import System.FilePath ((</>))
import System.Git (gitResetSubdir)
import System.Process (readProcessWithExitCode)
import Test.HUnit
import Text.Parsec.Rfc2822 (NameAddr(..))
import Text.PrettyPrint.HughesPJClass (pPrint, text, Doc)
-- | Backward compatibility. Should be fixed.
newFlags :: IO Flags
newFlags = _flags <$> parseProgramArguments
-- | A suitable defaultAtoms value for the debian repository.
defaultAtoms :: Monad m => CabalT m ()
defaultAtoms =
do A.epochMap %= Map.insert (mkPackageName "HaXml") 1
A.epochMap %= Map.insert (mkPackageName "HTTP") 1
mapCabal (mkPackageName "parsec") (DebBase "parsec3")
splitCabal (mkPackageName "parsec") (DebBase "parsec2") (read "3")
mapCabal (mkPackageName "QuickCheck") (DebBase "quickcheck2")
splitCabal (mkPackageName "QuickCheck") (DebBase "quickcheck1") (read "2")
mapCabal (mkPackageName "gtk2hs-buildtools") (DebBase "gtk2hs-buildtools")
-- | Force the compiler version to 7.6 to get predictable outputs
testAtoms :: IO CabalInfo
testAtoms = ghc763 <$> (newFlags >>= newCabalInfo)
where
ghc763 :: Either String CabalInfo -> CabalInfo
ghc763 (Left s) = error $ "testAtoms - failed to build CabalInfo: " ++ s
ghc763 (Right atoms) = {-set (A.debInfo . D.flags . compilerFlavor) GHC-} atoms
-- | Create a Debianization based on a changelog entry and a license
-- value. Uses the currently installed versions of debhelper and
-- debian-policy to set the compatibility levels.
newDebianization :: Monad m => ChangeLog -> Maybe Int -> Maybe StandardsVersion -> CabalT m ()
newDebianization (ChangeLog (WhiteSpace {} : _)) _ _ = error "defaultDebianization: Invalid changelog entry"
newDebianization (log@(ChangeLog (entry : _))) level standards =
do (A.debInfo . D.changelog) .= Just log
(A.debInfo . D.compat) .= level
(A.debInfo . D.control . S.source) .= Just (SrcPkgName (logPackage entry))
(A.debInfo . D.control . S.maintainer) .= either error Right (parseMaintainer (logWho entry))
(A.debInfo . D.control . S.standardsVersion) .= standards
newDebianization _ _ _ = error "Invalid changelog"
newDebianization' :: Monad m => Maybe Int -> Maybe StandardsVersion -> CabalT m ()
newDebianization' level standards =
do (A.debInfo . D.compat) .= level
(A.debInfo . D.control . S.standardsVersion) .= standards
tests :: Test
tests = TestLabel "Debianization Tests" (TestList [Bundled.tests,
-- 1 and 2 do not input a cabal package - we're not ready to
-- debianize without a cabal package.
{- test1 "test1",
test2 "test2", -}
-- test3 "test3", -- not a cabal package
test4 "test4 - test-data/clckwrks-dot-com",
-- test5 "test5 - test-data/creativeprompts",
test6 "test6 - test-data/artvaluereport2",
-- test7 "test7 - debian/Debianize.hs",
-- test8 "test8 - test-data/artvaluereport-data",
-- test9 "test9 - test-data/alex",
test10 "test10 - test-data/archive" {-,
-- This works, but it adds a dependency on ghcjs to the test suite
-- test11 "test11 - test-data/diff",
-- And this requires ghc-8.0.1 from the hvr compiler repo
-- test12 "test12 - test-data/diff",
issue23 "issue23" -}])
issue23 :: String -> Test
issue23 label =
TestLabel label $
TestCase (withCurrentDirectory "test-data/alex/input" $
do atoms <- testAtoms
actual <- evalCabalT (do (A.debInfo . D.changelog) .= Just (ChangeLog [testEntry])
(A.debInfo . D.compat) .= Just 9
(A.debInfo . D.official) .= True
Map.toList <$> liftCabal debianizationFileMap) atoms
assertEqual label
[]
actual)
#if 0
test1 :: String -> Test
test1 label =
TestLabel label $
TestCase (do level <- getDebhelperCompatLevel
standards <- getDebianStandardsVersion :: IO (Maybe StandardsVersion)
atoms <- testAtoms
deb <- execCabalT
(do -- let top = Top "."
defaultAtoms
newDebianization (ChangeLog [testEntry]) level standards
(D.copyright . debInfo) %= (\ f -> (\ pkgDesc -> f pkgDesc >>= \ c -> return $ c { _summaryLicense = Just BSD_3_Clause }))
-- inputCabalization top
finalizeDebianization)
atoms
diff <- diffDebianizations (view debInfo (testDeb1 atoms)) (view debInfo deb)
assertEqual label [] diff)
where
testDeb1 :: CabalInfo -> CabalInfo
testDeb1 atoms =
execCabalM
(do defaultAtoms
newDebianization log (Just 9) (Just (StandardsVersion 3 9 3 (Just 1)))
(D.rulesHead . debInfo) %= (const (Just (Text.unlines $
[ "#!/usr/bin/make -f"
, ""
, "include /usr/share/cdbs/1/rules/debhelper.mk"
, "include /usr/share/cdbs/1/class/hlibrary.mk" ])))
(D.compat . debInfo) .= Just 9 -- This will change as new version of debhelper are released
(D.copyright . debInfo) %= (\ f -> (\ pkgDesc -> f pkgDesc >>= \ c -> return $ c { _summaryLicense = Just BSD_3_Clause }))
(S.source . D.control . debInfo) .= Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"})
(S.maintainer . D.control . debInfo) .= Just (NameAddr (Just "David Fox") "dsf@seereason.com")
(S.standardsVersion . D.control . debInfo) .= Just (StandardsVersion 3 9 3 (Just 1)) -- This will change as new versions of debian-policy are released
(S.buildDepends . D.control . debInfo) %=
(++ [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("9" :: String)))) Nothing],
[Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.9" :: String)))) Nothing],
[Rel (BinPkgName "cdbs") Nothing Nothing],
[Rel (BinPkgName "ghc") Nothing Nothing],
[Rel (BinPkgName "ghc-prof") Nothing Nothing]])
(S.buildDependsIndep . D.control . debInfo) %= (++ [[Rel (BinPkgName "ghc-doc") Nothing Nothing]]))
atoms
log = ChangeLog [Entry { logPackage = "haskell-cabal-debian"
, logVersion = buildDebianVersion Nothing "2.6.2" Nothing
, logDists = [parseCodename "unstable"]
, logUrgency = "low"
, logComments = " * Fix a bug constructing the destination pathnames that was dropping\n files that were supposed to be installed into packages.\n"
, logWho = "David Fox <dsf@seereason.com>"
, logDate = "Thu, 20 Dec 2012 06:49:25 -0800" }]
test2 :: String -> Test
test2 label =
TestLabel label $
TestCase (do level <- getDebhelperCompatLevel
standards <- getDebianStandardsVersion
atoms <- testAtoms
deb <- execCabalT
(do -- let top = Top "."
defaultAtoms
newDebianization (ChangeLog [testEntry]) level standards
(D.copyright . debInfo) %= (\ f -> (\ pkgDesc -> f pkgDesc >>= \ c -> return $ c { _summaryLicense = Just BSD_3_Clause }))
-- inputCabalization top
finalizeDebianization)
atoms
diff <- diffDebianizations (view debInfo (expect atoms)) (view debInfo deb)
assertEmptyDiff label diff)
where
expect atoms =
execCabalM
(do defaultAtoms
newDebianization log (Just 9) (Just (StandardsVersion 3 9 3 (Just 1)))
(D.rulesHead . debInfo) %= (const (Just (Text.unlines $
["#!/usr/bin/make -f",
"",
"include /usr/share/cdbs/1/rules/debhelper.mk",
"include /usr/share/cdbs/1/class/hlibrary.mk"])))
(D.compat . debInfo) .= Just 9
(D.copyright . debInfo) %= (\ f -> (\ pkgDesc -> f pkgDesc >>= \ c -> return $ c { _summaryLicense = Just BSD_3_Clause }))
(S.source . D.control . debInfo) .= Just (SrcPkgName {unSrcPkgName = "haskell-cabal-debian"})
(S.maintainer . D.control . debInfo) .= Just (NameAddr {nameAddr_name = Just "David Fox", nameAddr_addr = "dsf@seereason.com"})
(S.standardsVersion . D.control . debInfo) .= Just (StandardsVersion 3 9 3 (Just 1))
(S.buildDepends . D.control . debInfo)
%= (++ [[Rel (BinPkgName "debhelper") (Just (GRE (parseDebianVersion ("7.0" :: String)))) Nothing],
[Rel (BinPkgName "haskell-devscripts") (Just (GRE (parseDebianVersion ("0.8" :: String)))) Nothing],
[Rel (BinPkgName "cdbs") Nothing Nothing],
[Rel (BinPkgName "ghc") Nothing Nothing],
[Rel (BinPkgName "ghc-prof") Nothing Nothing]])
(S.buildDependsIndep . D.control . debInfo) %= (++ [[Rel (BinPkgName "ghc-doc") Nothing Nothing]]))
atoms
log = ChangeLog [Entry {logPackage = "haskell-cabal-debian",
logVersion = Debian.Version.parseDebianVersion ("2.6.2" :: String),
logDists = [ReleaseName {relName = "unstable"}],
logUrgency = "low",
logComments = Prelude.unlines [" * Fix a bug constructing the destination pathnames that was dropping",
" files that were supposed to be installed into packages."],
logWho = "David Fox <dsf@seereason.com>",
logDate = "Thu, 20 Dec 2012 06:49:25 -0800"}]
#endif
testEntry :: ChangeLogEntry
testEntry =
either (error "Error in test changelog entry") fst
(parseEntry (Prelude.unlines
[ "haskell-cabal-debian (2.6.2) unstable; urgency=low"
, ""
, " * Fix a bug constructing the destination pathnames that was dropping"
, " files that were supposed to be installed into packages."
, ""
, " -- David Fox <dsf@seereason.com> Thu, 20 Dec 2012 06:49:25 -0800" ]))
test3 :: String -> Test
test3 label =
TestLabel label $
TestCase (let top = "test-data/haskell-devscripts" in
withCurrentDirectory top $
do atoms <- testAtoms
deb <- (execCabalT (liftCabal inputDebianization) atoms)
diff <- diffDebianizations (view debInfo (testDeb2 atoms)) (view debInfo deb)
assertEmptyDiff label diff)
where
testDeb2 :: CabalInfo -> CabalInfo
testDeb2 atoms =
execCabalM
(do defaultAtoms
newDebianization log (Just 7) (Just (StandardsVersion 3 9 4 Nothing))
(debInfo . D.sourceFormat) .= Native3
(debInfo . D.rulesHead) .=
Just (Text.unlines ["#!/usr/bin/make -f",
"# -*- makefile -*-",
"",
"# Uncomment this to turn on verbose mode.",
"#export DH_VERBOSE=1",
"",
"DEB_VERSION := $(shell dpkg-parsechangelog | egrep '^Version:' | cut -f 2 -d ' ')",
"",
"manpages = $(shell cat debian/manpages)",
"",
"%.1: %.pod",
"\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@",
"",
"%.1: %",
"\tpod2man -c 'Haskell devscripts documentation' -r 'Haskell devscripts $(DEB_VERSION)' $< > $@",
"",
".PHONY: build",
"build: $(manpages)",
"",
"install-stamp:",
"\tdh install",
"",
".PHONY: install",
"install: install-stamp",
"",
"binary-indep-stamp: install-stamp",
"\tdh binary-indep",
"\ttouch $@",
"",
".PHONY: binary-indep",
"binary-indep: binary-indep-stamp",
"",
".PHONY: binary-arch",
"binary-arch: install-stamp",
"",
".PHONY: binary",
"binary: binary-indep-stamp",
"",
".PHONY: clean",
"clean:",
"\tdh clean",
"\trm -f $(manpages)",
"",
""])
(debInfo . D.compat) .= Just 9
(debInfo . D.copyright) %= (Just . id . fromMaybe (readCopyrightDescription "This package was debianized by John Goerzen <jgoerzen@complete.org> on\nWed, 6 Oct 2004 09:46:14 -0500.\n\nCopyright information removed from this test data.\n"))
(debInfo . D.control . S.source) .= Just (SrcPkgName {unSrcPkgName = "haskell-devscripts"})
(debInfo . D.control . S.maintainer) .= Right (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"})
(debInfo . D.control . S.uploaders) .= [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}]
(debInfo . D.control . S.priority) .= Just Extra
(debInfo . D.control . S.section) .= Just (MainSection "haskell")
(debInfo . D.control . S.buildDepends) %= (++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion' ("7" :: String)))) Nothing]])
(debInfo . D.control . S.buildDependsIndep) %= (++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]])
(debInfo . D.control . S.standardsVersion) .= Just (StandardsVersion 3 9 4 Nothing)
(debInfo . D.control . S.vcsFields) %= Set.union (Set.fromList [ S.VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts"
, S.VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"])
(debInfo . D.binaryDebDescription (BinPkgName "haskell-devscripts") . B.architecture) .= Just All
(debInfo . D.binaryDebDescription (BinPkgName "haskell-devscripts") . B.description) .=
Just
(intercalate "\n" ["Tools to help Debian developers build Haskell packages",
" This package provides a collection of scripts to help build Haskell",
" packages for Debian. Unlike haskell-utils, this package is not",
" expected to be installed on the machines of end users.",
" .",
" This package is designed to support Cabalized Haskell libraries. It",
" is designed to build a library for each supported Debian compiler or",
" interpreter, generate appropriate postinst/prerm files for each one,",
" generate appropriate substvars entries for each one, and install the",
" package in the Debian temporary area as part of the build process."])
(debInfo . D.binaryDebDescription (BinPkgName "haskell-devscripts") . B.relations . B.depends) .=
[ [Rel (BinPkgName {unBinPkgName = "dctrl-tools"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "debhelper"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "dh-buildinfo"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "ghc"}) (Just (GRE (Debian.Version.parseDebianVersion'("7.6" :: String)))) Nothing]
, [Rel (BinPkgName {unBinPkgName = "cdbs"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "${misc:Depends}"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "html-xml-utils"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "hscolour"}) (Just (GRE (Debian.Version.parseDebianVersion'("1.8" :: String)))) Nothing]
, [Rel (BinPkgName {unBinPkgName = "ghc-haddock"}) (Just (GRE (Debian.Version.parseDebianVersion'("7.4" :: String)))) Nothing] ]
{-
control %= (\ y -> y { S.source =
, S.maintainer = Just (NameAddr {nameAddr_name = Just "Debian Haskell Group", nameAddr_addr = "pkg-haskell-maintainers@lists.alioth.debian.org"})
, S.uploaders = [NameAddr {nameAddr_name = Just "Marco Silva", nameAddr_addr = "marcot@debian.org"},NameAddr {nameAddr_name = Just "Joachim Breitner", nameAddr_addr = "nomeata@debian.org"}]
, S.priority = Just Extra
, S.section = Just (MainSection "haskell")
, S.buildDepends = (S.buildDepends y) ++ [[Rel (BinPkgName {unBinPkgName = "debhelper"}) (Just (GRE (Debian.Version.parseDebianVersion'("7" :: String)))) Nothing]]
, S.buildDependsIndep = (S.buildDependsIndep y) ++ [[Rel (BinPkgName {unBinPkgName = "perl"}) Nothing Nothing]]
, S.standardsVersion = Just (StandardsVersion 3 9 4 Nothing)
, S.vcsFields = Set.union (S.vcsFields y) (Set.fromList [ S.VCSBrowser "http://darcs.debian.org/cgi-bin/darcsweb.cgi?r=pkg-haskell/haskell-devscripts"
, S.VCSDarcs "http://darcs.debian.org/pkg-haskell/haskell-devscripts"])
, S.binaryPackages = [S.BinaryDebDescription { B.package = BinPkgName {unBinPkgName = "haskell-devscripts"}
, B.architecture = All
, B.binarySection = Nothing
, B.binaryPriority = Nothing
, B.essential = False
, B.description = Just $
(T.intercalate "\n"
["Tools to help Debian developers build Haskell packages",
" This package provides a collection of scripts to help build Haskell",
" packages for Debian. Unlike haskell-utils, this package is not",
" expected to be installed on the machines of end users.",
" .",
" This package is designed to support Cabalized Haskell libraries. It",
" is designed to build a library for each supported Debian compiler or",
" interpreter, generate appropriate postinst/prerm files for each one,",
" generate appropriate substvars entries for each one, and install the",
" package in the Debian temporary area as part of the build process."])
, B.relations =
B.PackageRelations
{ B.depends =
[ [Rel (BinPkgName {unBinPkgName = "dctrl-tools"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "debhelper"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "dh-buildinfo"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "ghc"}) (Just (GRE (Debian.Version.parseDebianVersion'("7.6" :: String)))) Nothing]
, [Rel (BinPkgName {unBinPkgName = "cdbs"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "${misc:Depends}"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "html-xml-utils"}) Nothing Nothing]
, [Rel (BinPkgName {unBinPkgName = "hscolour"}) (Just (GRE (Debian.Version.parseDebianVersion'("1.8" :: String)))) Nothing]
, [Rel (BinPkgName {unBinPkgName = "ghc-haddock"}) (Just (GRE (Debian.Version.parseDebianVersion'("7.4" :: String)))) Nothing] ]
, B.recommends = []
, B.suggests = []
, B.preDepends = []
, B.breaks = []
, B.conflicts = []
, B.provides_ = []
, B.replaces_ = []
, B.builtUsing = [] }}]})
-}
)
atoms
log = ChangeLog [Entry { logPackage = "haskell-devscripts"
, logVersion = Debian.Version.parseDebianVersion'("0.8.13" :: String)
, logDists = [parseCodename "experimental"]
, logUrgency = "low"
, logComments = " [ Joachim Breitner ]\n * Improve parsing of \"Setup register\" output, patch by David Fox\n * Enable creation of hoogle files, thanks to Kiwamu Okabe for the\n suggestion. \n\n [ Kiwamu Okabe ]\n * Need --html option to fix bug that --hoogle option don't output html file.\n * Support to create /usr/lib/ghc-doc/hoogle/*.txt for hoogle package.\n\n [ Joachim Breitner ]\n * Symlink hoogle\8217s txt files to /usr/lib/ghc-doc/hoogle/\n * Bump ghc dependency to 7.6 \n * Bump standards version\n"
, logWho = "Joachim Breitner <nomeata@debian.org>"
, logDate = "Mon, 08 Oct 2012 21:14:50 +0200" },
Entry { logPackage = "haskell-devscripts"
, logVersion = Debian.Version.parseDebianVersion'("0.8.12" :: String)
, logDists = [parseCodename "unstable"]
, logUrgency = "low"
, logComments = " * Depend on ghc >= 7.4, adjusting to its haddock --interface-version\n behaviour.\n"
, logWho = "Joachim Breitner <nomeata@debian.org>"
, logDate = "Sat, 04 Feb 2012 10:50:33 +0100"}]
test4 :: String -> Test
test4 label =
TestLabel label $
TestCase (do let outTop = "test-data/clckwrks-dot-com/output"
let inTop = "test-data/clckwrks-dot-com/input"
atoms <- withCurrentDirectory inTop $ testAtoms
old <- withCurrentDirectory outTop $ do
execCabalT (liftCabal inputDebianization) atoms
let log = view (debInfo . D.changelog) old
new <- withCurrentDirectory inTop $ do
execCabalT (debianize (defaultAtoms >> customize log)) atoms
diff <- diffDebianizations (view debInfo old) (view debInfo ({-copyFirstLogEntry old-} new))
assertEmptyDiff label diff)
where
customize :: Maybe ChangeLog -> CabalT IO ()
customize log =
do (debInfo . D.flags . verbosity) .= 1
(debInfo . D.changelog) .= log
liftCabal tight
fixRules
doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups"
doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production"))
(A.debInfo . D.revision) .= Nothing
(A.debInfo . D.missingDependencies) %= Set.insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")
(A.debInfo . D.sourceFormat) .= Native3
(A.debInfo . D.control . S.homepage) .= Just "http://www.clckwrks.com/"
newDebianization' (Just 13) (Just (StandardsVersion 3 9 6 Nothing))
{-
customize log = modifyM (lift . customize' log)
customize' :: Maybe ChangeLog -> CabalInfo -> IO CabalInfo
customize' log atoms =
execCabalT (newDebianization' (Just 7) (Just (StandardsVersion 3 9 4 Nothing))) .
over T.control (\ y -> y {T.homepage = Just "http://www.clckwrks.com/"}) .
set T.sourceFormat (Just Native3) .
over T.missingDependencies (insert (BinPkgName "libghc-clckwrks-theme-clckwrks-doc")) .
set T.revision Nothing .
execCabalM (doWebsite (BinPkgName "clckwrks-dot-com-production") (theSite (BinPkgName "clckwrks-dot-com-production"))) .
execCabalM (doBackups (BinPkgName "clckwrks-dot-com-backups") "clckwrks-dot-com-backups") .
fixRules .
execCabalM tight .
set T.changelog log
-}
-- A log entry gets added when the Debianization is generated,
-- it won't match so drop it for the comparison.
serverNames = map BinPkgName ["clckwrks-dot-com-production"] -- , "clckwrks-dot-com-staging", "clckwrks-dot-com-development"]
-- Insert a line just above the debhelper.mk include
fixRules =
(debInfo . D.rulesSettings) %= (++ ["export DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups"])
{-
mapAtoms f deb
where
f :: DebAtomKey -> DebAtom -> Set (DebAtomKey, DebAtom)
f Source (DebRulesHead t) =
singleton (Source, DebRulesHead (T.unlines $ concat $
map (\ line -> if line == "include /usr/share/cdbs/1/rules/debhelper.mk"
then ["export DEB_SETUP_GHC_CONFIGURE_ARGS = -fbackups", "", line] :: [T.Text]
else [line] :: [T.Text]) (T.lines t)))
f k a = singleton (k, a)
-}
tight = mapM_ (tightDependencyFixup [(BinPkgName "libghc-clckwrks-theme-clckwrks-dev", BinPkgName "haskell-clckwrks-theme-clckwrks-utils"),
(BinPkgName "libghc-clckwrks-plugin-media-dev", BinPkgName "haskell-clckwrks-plugin-media-utils"),
(BinPkgName "libghc-clckwrks-plugin-bugs-dev", BinPkgName "haskell-clckwrks-plugin-bugs-utils"),
(BinPkgName "libghc-clckwrks-dev", BinPkgName "haskell-clckwrks-utils")]) serverNames
theSite :: BinPkgName -> D.Site
theSite deb =
D.Site { D.domain = hostname'
, D.serverAdmin = "logic@seereason.com"
, D.server = theServer deb }
theServer :: BinPkgName -> D.Server
theServer deb =
D.Server { D.hostname =
case deb of
BinPkgName "clckwrks-dot-com-production" -> hostname'
_ -> hostname'
, D.port = portNum deb
, D.headerMessage = "Generated by clckwrks-dot-com/Setup.hs"
, D.retry = "60"
, D.serverFlags =
[ "--http-port", show (portNum deb)
, "--hide-port"
, "--hostname", hostname'
, "--top", databaseDirectory deb
, "--enable-analytics"
, "--jquery-path", "/usr/share/javascript/jquery/"
, "--jqueryui-path", "/usr/share/javascript/jquery-ui/"
, "--jstree-path", jstreePath
, "--json2-path",json2Path
]
, D.installFile =
D.InstallFile { D.execName = "clckwrks-dot-com-server"
, D.destName = ppShow deb
, D.sourceDir = Nothing
, D.destDir = Nothing }
}
hostname' = "clckwrks.com"
portNum :: BinPkgName -> Int
portNum (BinPkgName deb) =
case deb of
"clckwrks-dot-com-production" -> 9029
"clckwrks-dot-com-staging" -> 9038
"clckwrks-dot-com-development" -> 9039
_ -> error $ "Unexpected package name: " ++ deb
jstreePath = "/usr/share/clckwrks-0.13.2/jstree"
json2Path = "/usr/share/clckwrks-0.13.2/json2"
anyrel :: BinPkgName -> Relation
anyrel b = Rel b Nothing Nothing
test5 :: String -> Test
test5 label =
TestLabel label $
TestCase (do let inTop = "test-data/creativeprompts/input"
outTop = "test-data/creativeprompts/output"
atoms <- withCurrentDirectory inTop testAtoms
old <- withCurrentDirectory outTop $ newFlags >>= execDebianT inputDebianization . D.makeDebInfo
let standards = view (D.control . S.standardsVersion) old
level = view D.compat old
new <- withCurrentDirectory inTop (execCabalT (debianize (defaultAtoms >> customize old level standards)) atoms)
diff <- diffDebianizations old (view debInfo new)
assertEmptyDiff label diff)
where
customize old level standards =
do (debInfo . D.flags . verbosity) .= 1
(A.debInfo . D.utilsPackageNameBase) .= Just "creativeprompts-data"
newDebianization' level standards
(debInfo . D.changelog) .= (view D.changelog old)
doWebsite (BinPkgName "creativeprompts-production") (theSite (BinPkgName "creativeprompts-production"))
doServer (BinPkgName "creativeprompts-development") (theServer (BinPkgName "creativeprompts-development"))
doBackups (BinPkgName "creativeprompts-backups") "creativeprompts-backups"
(A.debInfo . D.execMap) %= Map.insert "trhsx" [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]]
mapM_ (\ b -> (debInfo . D.binaryDebDescription b . B.relations . B.depends) %= \ deps -> deps ++ [[anyrel (BinPkgName "markdown")]])
[(BinPkgName "creativeprompts-production"), (BinPkgName "creativeprompts-development")]
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-development") . B.description) .=
Just (intercalate "\n" [ "Configuration for running the creativeprompts.com server"
, " Testing version of the blog server, runs on port"
, " 8000 with HTML validation turned on." ])
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-data") . B.description) .=
Just (intercalate "\n" [ "creativeprompts.com data files"
, " Static data files for creativeprompts.com"])
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-production") . B.description) .=
Just (intercalate "\n" [ "Configuration for running the creativeprompts.com server"
, " Production version of the blog server, runs on port"
, " 9021 with HTML validation turned off." ])
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-backups") . B.description) .=
Just (intercalate "\n" [ "backup program for creativeprompts.com"
, " Install this somewhere other than creativeprompts.com to run automated"
, " backups of the database."])
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-production") . B.architecture) .= Just All
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-data") . B.architecture) .= Just All
(debInfo . D.binaryDebDescription (BinPkgName "creativeprompts-development") . B.architecture) .= Just All
(debInfo . D.sourceFormat) .= Native3
theSite :: BinPkgName -> D.Site
theSite deb =
D.Site { D.domain = hostname'
, D.serverAdmin = "logic@seereason.com"
, D.server = theServer deb }
theServer :: BinPkgName -> D.Server
theServer deb =
D.Server
{ D.hostname =
case deb of
BinPkgName "clckwrks-dot-com-production" -> hostname'
_ -> hostname'
, D.port = portNum deb
, D.headerMessage = "Generated by creativeprompts-dot-com/debian/Debianize.hs"
, D.retry = "60"
, D.serverFlags =
[ "--http-port", show (portNum deb)
, "--hide-port"
, "--hostname", hostname'
, "--top", databaseDirectory deb
, "--enable-analytics"
, "--jquery-path", "/usr/share/javascript/jquery/"
, "--jqueryui-path", "/usr/share/javascript/jquery-ui/"
, "--jstree-path", jstreePath
, "--json2-path",json2Path
]
, D.installFile =
D.InstallFile { D.execName = "creativeprompts-server"
, D.destName = ppShow deb
, D.sourceDir = Nothing
, D.destDir = Nothing }
}
hostname' = "creativeprompts.com"
portNum :: BinPkgName -> Int
portNum (BinPkgName deb) =
case deb of
"creativeprompts-production" -> 9022
"creativeprompts-staging" -> 9033
"creativeprompts-development" -> 9034
_ -> error $ "Unexpected package name: " ++ deb
jstreePath = "/usr/share/clckwrks-0.13.2/jstree"
json2Path = "/usr/share/clckwrks-0.13.2/json2"
-- | Obviously this is a hack, but the builddir is set to "dist-ghc"
-- by haskell-devscripts, while by default cabal sets it to "dist".
findBuildDir :: IO FilePath
findBuildDir = doesDirectoryExist "dist-ghc" >>= return . bool "dist" "dist-ghc"
test6 :: String -> Test
test6 label =
TestLabel label $
TestCase (do dist <- findBuildDir
(code, out, err) <- readProcessWithExitCode "runhaskell" ["--ghc-arg=-package-db=" ++ dist ++ "/package.conf.inplace", "test-data/artvaluereport2/input/debian/Debianize.hs", "--dry-run", "--verbose"] ""
assertEqual label (ExitFailure 1, "", err) (code, out, err))
test7 :: String -> Test
test7 label =
TestLabel label $
TestCase (do dist <- findBuildDir
(code, out, _err) <- readProcessWithExitCode "runhaskell" ["--ghc-arg=-package-db=" ++ dist ++ "/package.conf.inplace", "debian/Debianize.hs", "--dry-run", "--native", "--verbose"] ""
assertEqual label (ExitSuccess, "Ignored debianization file: debian/cabal-debian.1\nIgnored debianization file: debian/cabal-debian.manpages\nDebianization (dry run):\n No changes\n\n") (code, out)
{-
assertBool label (elem new [(ExitSuccess, "Ignored debianization file: debian/cabal-debian.1\nIgnored debianization file: debian/cabal-debian.manpages\nDebianization (dry run):\n No changes\n\n", ""),
(ExitSuccess, "Ignored debianization file: debian/cabal-debian.manpages\nIgnored debianization file: debian/cabal-debian.1\nDebianization (dry run):\n No changes\n\n", "")]) -})
test8 :: String -> Test
test8 label =
TestLabel label $
TestCase ( do let inTop = "test-data/artvaluereport-data/input"
outTop = "test-data/artvaluereport-data/output"
(old :: D.DebInfo) <- withCurrentDirectory outTop $ newFlags >>= execDebianT inputDebianization . D.makeDebInfo
let log = view D.changelog old
new <- withCurrentDirectory inTop $
newFlags >>= newCabalInfo >>=
either (error "test8 - newCabalInfo failed") (execCabalT (debianize (defaultAtoms >> customize log)))
diff <- diffDebianizations old (view debInfo new)
assertEmptyDiff label diff
)
where
customize Nothing = error "Missing changelog"
customize (Just log) =
do (debInfo . D.flags . verbosity) .= 1
(debInfo . D.control . S.buildDepends) %= (++ [[Rel (BinPkgName "haskell-hsx-utils") Nothing Nothing]])
(debInfo . D.control . S.homepage) .= Just "https://artvaluereportonline.com"
(debInfo . D.sourceFormat) .= Native3
(debInfo . D.changelog) .= Just log
newDebianization' (Just 9) (Just (StandardsVersion 3 9 6 Nothing))
test9 :: String -> Test
test9 label =
TestLabel label $
TestCase (do let inTop = "test-data/alex/input"
outTop = "test-data/alex/output"
new <- withCurrentDirectory inTop $
newFlags >>= newCabalInfo >>=
either (error "test9 - newCabalInfo failed") (execCabalT (debianize (defaultAtoms >> customize)))
let Just (ChangeLog (entry : _)) = view (debInfo . D.changelog) new
old <- withCurrentDirectory outTop $ newFlags >>= execDebianT (inputDebianization >> copyChangelogDate (logDate entry)) . D.makeDebInfo
diff <- diffDebianizations old (view debInfo new)
assertEmptyDiff label diff)
where
customize =
do newDebianization' (Just 9) (Just (StandardsVersion 3 9 6 Nothing))
mapM_ (\ name -> (debInfo . D.atomSet) %= (Set.insert $ D.InstallData (BinPkgName "alex") name name))
[ "AlexTemplate"
, "AlexTemplate-debug"
, "AlexTemplate-ghc"
, "AlexTemplate-ghc-debug"
, "AlexWrapper-basic"
, "AlexWrapper-basic-bytestring"
, "AlexWrapper-gscan"
, "AlexWrapper-monad"
, "AlexWrapper-monad-bytestring"
, "AlexWrapper-monadUserState"
, "AlexWrapper-monadUserState-bytestring"
, "AlexWrapper-posn"
, "AlexWrapper-posn-bytestring"
, "AlexWrapper-strict-bytestring"]
(debInfo . D.flags . verbosity) .= 1
(debInfo . D.control . S.homepage) .= Just "https://www.haskell.org/alex/"
(debInfo . D.sourceFormat) .= Native3
(debInfo . D.debVersion) .= Just (parseDebianVersion'("3.0.2-1~hackage1" :: String))
doExecutable (BinPkgName "alex")
(D.InstallFile {D.execName = "alex", D.destName = "alex", D.sourceDir = Nothing, D.destDir = Nothing})
-- Bootstrap self-dependency
(debInfo . D.allowDebianSelfBuildDeps) .= True
(debInfo . D.control . S.buildDepends) %= (++ [[Rel (BinPkgName "alex") Nothing Nothing]])
test10 :: String -> Test
test10 label =
TestLabel label $
TestCase (do let inTop = "test-data/archive/input"
outTop = "test-data/archive/output"
old <- withCurrentDirectory outTop $ newFlags >>= execDebianT inputDebianization . D.makeDebInfo
let Just (ChangeLog (entry : _)) = view D.changelog old
new <- withCurrentDirectory inTop $
newFlags >>= newCabalInfo >>= react entry
diff <- diffDebianizations old (view debInfo new)
assertEmptyDiff label diff)
where
customize :: CabalT IO ()
customize =
do (A.debInfo . D.flags . verbosity) .= 1
(A.debInfo . D.sourceFormat) .= Native3
(A.debInfo . D.sourcePackageName) .= Just (SrcPkgName "seereason-darcs-backups")
(A.debInfo . D.compat) .= Just 13
(A.debInfo . D.control . S.standardsVersion) .= Just (StandardsVersion 3 8 1 Nothing)
(A.debInfo . D.control . S.maintainer) .= parseMaintainer "David Fox <dsf@seereason.com>"
(A.debInfo . D.binaryDebDescription (BinPkgName "seereason-darcs-backups") . B.relations . B.depends) %= (++ [[Rel (BinPkgName "anacron") Nothing Nothing]])
(A.debInfo . D.control . S.section) .= Just (MainSection "haskell")
(A.debInfo . D.utilsPackageNameBase) .= Just "seereason-darcs-backups"
(A.debInfo . D.atomSet) %= (Set.insert $ D.InstallCabalExec (BinPkgName "seereason-darcs-backups") "seereason-darcs-backups" "/etc/cron.hourly")
react :: ChangeLogEntry -> Either String CabalInfo -> IO CabalInfo
react _ (Left e) = error ("test10 - newCabalInfo failed: " ++ e)
react entry (Right c) = execCabalT (debianize (defaultAtoms >> customize >> (liftCabal $ copyChangelogDate $ logDate entry))) c
copyChangelogDate :: Monad m => String -> DebianT m ()
copyChangelogDate date =
D.changelog %= (\ (Just (ChangeLog (entry : older))) -> Just (ChangeLog (entry {logDate = date} : older)))
data Change k a
= Created k a
| Deleted k a
| Modified k a a
| Unchanged k a
deriving (Eq, Show)
diffMaps :: (Ord k, Eq a, Show k, Show a) => Map.Map k a -> Map.Map k a -> [Change k a]
diffMaps old new =
Map.elems (intersectionWithKey combine1 old new) ++
map (uncurry Deleted) (Map.toList (differenceWithKey combine2 old new)) ++
map (uncurry Created) (Map.toList (differenceWithKey combine2 new old))
where
combine1 k a b = if a == b then Unchanged k a else Modified k a b
combine2 _ _ _ = Nothing
diffDebianizations :: D.DebInfo -> D.DebInfo -> IO String -- [Change FilePath T.Text]
diffDebianizations old new =
do old' <- evalDebianT (sortBinaryDebs >> debianizationFileMap) old
new' <- evalDebianT (sortBinaryDebs >> debianizationFileMap) new
return $ show $ mconcat $ map prettyChange $ filter (not . isUnchanged) $ diffMaps old' new'
where
isUnchanged (Unchanged _ _) = True
isUnchanged _ = False
prettyChange :: Change FilePath Text -> Doc
prettyChange (Unchanged p _) = text "Unchanged: " <> pPrint p <> text "\n"
prettyChange (Deleted p _) = text "Deleted: " <> pPrint p <> text "\n"
prettyChange (Created p b) =
text "Created: " <> pPrint p <> text "\n" <>
#if MIN_VERSION_Diff(1,0,0)
prettyContextDiff (text ("old" </> p)) (text ("new" </> p)) (text . unpack . unnumber)
-- We use split here instead of lines so we can
-- detect whether the file has a final newline
-- character.
(getContextDiff (Just 2) mempty (split (== '\n') b))
#else
prettyContextDiff (text ("old" </> p)) (text ("new" </> p)) (text . unpack)
-- We use split here instead of lines so we can
-- detect whether the file has a final newline
-- character.
(getContextDiff 2 mempty (split (== '\n') b))
#endif
prettyChange (Modified p a b) =
text "Modified: " <> pPrint p <> text "\n" <>
#if MIN_VERSION_Diff(1,0,0)
prettyContextDiff (text ("old" </> p)) (text ("new" </> p)) (text . unpack . unnumber)
(getContextDiff (Just 2) (split (== '\n') a) (split (== '\n') b))
#else
prettyContextDiff (text ("old" </> p)) (text ("new" </> p)) (text . unpack)
(getContextDiff 2 (split (== '\n') a) (split (== '\n') b))
#endif
sortBinaryDebs :: DebianT IO ()
sortBinaryDebs = (D.control . S.binaryPackages) %= sortBy (compare `on` view B.package)
test11 :: String -> Test
test11 label =
TestLabel label $
TestCase $ do let input = "test-data/diff/input"
expected = "test-data/diff/expected.ghcjs"
gitResetSubdir input
withCurrentDirectory input (performDebianization (do debianDefaults
(debInfo . D.flags . compilerFlavor) .= GHCJS
(debInfo . D.testsStatus) .= D.TestsDisable
(debInfo . D.sourceFormat) .= Native3))
assertEmptyDiff expected input
test12 :: String -> Test
test12 label =
TestLabel label $
TestCase $ do let input = "test-data/diff/input"
expected = "test-data/diff/expected.hvr"
gitResetSubdir input
withCurrentDirectory input (performDebianization (do debianDefaults
(debInfo . D.testsStatus) .= D.TestsDisable
(debInfo . D.sourceFormat) .= Native3))
assertEmptyDiff expected input
main :: IO ()
main = do
cts <- runTestTT tests
exitWith $ if errors cts + failures cts > 0
then ExitFailure 1
else ExitSuccess
-- Cusstom HUnit assertion, which prints the diffs without using 'show'
assertEmptyDiff :: String -- ^ The message prefix
-> String -- ^ The actual diff
-> Assertion
assertEmptyDiff _preface "" = return ()
assertEmptyDiff preface diff = assertFailure $
(if null preface then "" else preface ++ "\n") ++
"diff not empty:\n" ++
diff
|
