-
Notifications
You must be signed in to change notification settings - Fork 142
/
Main.hs
2041 lines (1784 loc) · 83.4 KB
/
Main.hs
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
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
941
942
943
944
945
946
947
948
949
950
951
952
953
954
955
956
957
958
959
960
961
962
963
964
965
966
967
968
969
970
971
972
973
974
975
976
977
978
979
980
981
982
983
984
985
986
987
988
989
990
991
992
993
994
995
996
997
998
999
1000
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE EmptyCase #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-----------------------------------------------------------------------------
--
-- (c) The University of Glasgow 2004-2009.
--
-- Package management tool
--
-----------------------------------------------------------------------------
module Main (main) where
import qualified Eta.PackageDb as EtaPkg
import Eta.PackageDb (BinaryStringRep(..))
import qualified Distribution.Simple.PackageIndex as PackageIndex
import qualified Data.Graph as Graph
import qualified Distribution.ModuleName as ModuleName
import Distribution.ModuleName (ModuleName)
import Distribution.InstalledPackageInfo as EtlasCabal
import Distribution.Compat.ReadP hiding (get)
import Distribution.ParseUtils
import Distribution.Package hiding (installedUnitId)
import Distribution.Text
import Distribution.Version
import Distribution.Backpack
import Distribution.Types.UnqualComponentName
import Distribution.Simple.Utils (fromUTF8, toUTF8, writeUTF8File, readUTF8File)
import qualified Data.Version as Version
import System.FilePath as FilePath
import qualified System.FilePath.Posix as FilePath.Posix
import System.Directory ( getAppUserDataDirectory, createDirectoryIfMissing,
getModificationTime )
import Text.Printf
import Prelude
import System.Console.GetOpt
import qualified Control.Exception as Exception
import Data.Maybe
import Data.Char ( isSpace, toLower )
import Control.Monad
import System.Directory ( doesDirectoryExist, getDirectoryContents,
doesFileExist, removeFile,
getCurrentDirectory )
import System.Exit ( exitWith, ExitCode(..) )
import System.Environment ( getArgs, getEnv )
import System.IO
import System.IO.Error
import GHC.IO.Exception (IOErrorType(InappropriateType))
import Data.List
import qualified Data.Foldable as F
import qualified Data.Traversable as F
import qualified Data.Set as Set
import qualified Data.Map as Map
import qualified Data.ByteString.Char8 as BS
-- | Short-circuit 'any' with a \"monadic predicate\".
anyM :: (Monad m) => (a -> m Bool) -> [a] -> m Bool
anyM _ [] = return False
anyM p (x:xs) = do
b <- p x
if b
then return True
else anyM p xs
-- -----------------------------------------------------------------------------
-- Entry point
main :: IO ()
main = do
args <- getArgs
case getOpt Permute (flags ++ deprecFlags) args of
(cli,_,[]) | FlagHelp `elem` cli -> do
prog <- getProgramName
bye (usageInfo (usageHeader prog) flags)
(cli,_,[]) | FlagVersion `elem` cli ->
bye ourCopyright
(cli,nonopts,[]) ->
case getVerbosity Normal cli of
Right v -> runit v cli nonopts
Left err -> die err
(_,_,errors) -> do
prog <- getProgramName
die (concat errors ++ shortUsage prog)
-- @VERSION_CHANGE@
-- @BUILD_NUMBER@
-- @BUILD_NUMBER_INTERNAL@
myVersion :: String
myVersion = "0.7.0.2"
-- -----------------------------------------------------------------------------
-- Command-line syntax
data Flag
= FlagUser
| FlagGlobal
| FlagHelp
| FlagVersion
| FlagConfig FilePath
| FlagGlobalConfig FilePath
| FlagUserConfig FilePath
| FlagForce
| FlagForceFiles
| FlagMultiInstance
| FlagExpandEnvVars
| FlagExpandPkgroot
| FlagNoExpandPkgroot
| FlagSimpleOutput
| FlagNamesOnly
| FlagIgnoreCase
| FlagNoUserDb
| FlagVerbosity (Maybe String)
| FlagUnitId
-- | FlagIPId
-- | FlagPackageKey
deriving Eq
flags :: [OptDescr Flag]
flags = [
Option [] ["user"] (NoArg FlagUser)
"use the current user's package database",
Option [] ["global"] (NoArg FlagGlobal)
"use the global package database",
Option ['f'] ["package-db"] (ReqArg FlagConfig "FILE/DIR")
"use the specified package database",
Option [] ["package-conf"] (ReqArg FlagConfig "FILE/DIR")
"use the specified package database (DEPRECATED)",
Option [] ["global-package-db"] (ReqArg FlagGlobalConfig "DIR")
"location of the global package database",
Option [] ["no-user-package-db"] (NoArg FlagNoUserDb)
"never read the user package database",
Option [] ["user-package-db"] (ReqArg FlagUserConfig "DIR")
"location of the user package database (use instead of default)",
Option [] ["no-user-package-conf"] (NoArg FlagNoUserDb)
"never read the user package database (DEPRECATED)",
Option [] ["force"] (NoArg FlagForce)
"ignore missing dependencies, directories, and libraries",
Option [] ["force-files"] (NoArg FlagForceFiles)
"ignore missing directories and libraries only",
Option [] ["enable-multi-instance"] (NoArg FlagMultiInstance)
"allow registering multiple instances of the same package version",
Option [] ["expand-env-vars"] (NoArg FlagExpandEnvVars)
"expand environment variables (${name}-style) in input package descriptions",
Option [] ["expand-pkgroot"] (NoArg FlagExpandPkgroot)
"expand ${pkgroot}-relative paths to absolute in output package descriptions",
Option [] ["no-expand-pkgroot"] (NoArg FlagNoExpandPkgroot)
"preserve ${pkgroot}-relative paths in output package descriptions",
Option ['?'] ["help"] (NoArg FlagHelp)
"display this help and exit",
Option ['V'] ["version"] (NoArg FlagVersion)
"output version information and exit",
Option [] ["simple-output"] (NoArg FlagSimpleOutput)
"print output in easy-to-parse format for some commands",
Option [] ["names-only"] (NoArg FlagNamesOnly)
"only print package names, not versions; can only be used with list --simple-output",
Option [] ["ignore-case"] (NoArg FlagIgnoreCase)
"ignore case for substring matching",
Option [] ["ipid", "unit-id"] (NoArg FlagUnitId)
"interpret package arguments as unit IDs (e.g. installed package IDs)",
-- Option [] ["ipid"] (NoArg FlagIPId)
-- "interpret package arguments as installed package IDs",
-- Option [] ["package-key"] (NoArg FlagPackageKey)
-- "interpret package arguments as installed package keys",
Option ['v'] ["verbose"] (OptArg FlagVerbosity "Verbosity")
"verbosity level (0-2, default 1)"
]
data Verbosity = Silent | Normal | Verbose
deriving (Show, Eq, Ord)
getVerbosity :: Verbosity -> [Flag] -> Either String Verbosity
getVerbosity v [] = Right v
getVerbosity _ (FlagVerbosity Nothing : fs) = getVerbosity Verbose fs
getVerbosity _ (FlagVerbosity (Just "0") : fs) = getVerbosity Silent fs
getVerbosity _ (FlagVerbosity (Just "1") : fs) = getVerbosity Normal fs
getVerbosity _ (FlagVerbosity (Just "2") : fs) = getVerbosity Verbose fs
getVerbosity _ (FlagVerbosity v : _) = Left ("Bad verbosity: " ++ show v)
getVerbosity v (_ : fs) = getVerbosity v fs
deprecFlags :: [OptDescr Flag]
deprecFlags = [
-- put deprecated flags here
]
ourCopyright :: String
ourCopyright = "Eta Package Manager Version " ++ myVersion ++ "\n"
shortUsage :: String -> String
shortUsage prog = "For usage information see '" ++ prog ++ " --help'."
usageHeader :: String -> String
usageHeader prog = substProg prog $
"Usage:\n" ++
" $p init {path}\n" ++
" Create and initialise a package database at the location {path}.\n" ++
" Packages can be registered in the new database using the register\n" ++
" command with --package-db={path}. To use the new database with Eta,\n" ++
" use Eta's -package-db flag.\n" ++
"\n" ++
" $p register {filename | -}\n" ++
" Register the package using the specified installed package\n" ++
" description. The syntax for the latter is given in the $p\n" ++
" documentation. The input file should be encoded in UTF-8.\n" ++
"\n" ++
" $p update {filename | -}\n" ++
" Register the package, overwriting any other package with the\n" ++
" same name. The input file should be encoded in UTF-8.\n" ++
"\n" ++
" $p unregister [pkg-id]\n" ++
" Unregister the specified package in the order given.\n" ++
"\n" ++
" $p expose {pkg-id}\n" ++
" Expose the specified package.\n" ++
"\n" ++
" $p hide {pkg-id}\n" ++
" Hide the specified package.\n" ++
"\n" ++
" $p trust {pkg-id}\n" ++
" Trust the specified package.\n" ++
"\n" ++
" $p distrust {pkg-id}\n" ++
" Distrust the specified package.\n" ++
"\n" ++
" $p list [pkg]\n" ++
" List registered packages in the global database, and also the\n" ++
" user database if --user is given. If a package name is given\n" ++
" all the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
" $p dot\n" ++
" Generate a graph of the package dependencies in a form suitable\n" ++
" for input for the graphviz tools. For example, to generate a PDF\n" ++
" of the dependency graph: eta-pkg dot | tred | dot -Tpdf >pkgs.pdf\n" ++
"\n" ++
" $p find-module {module}\n" ++
" List registered packages exposing module {module} in the global\n" ++
" database, and also the user database if --user is given.\n" ++
" All the registered versions will be listed in ascending order.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
" $p latest {pkg-id}\n" ++
" Prints the highest registered version of a package.\n" ++
"\n" ++
" $p check\n" ++
" Check the consistency of package dependencies and list broken packages.\n" ++
" Accepts the --simple-output flag.\n" ++
"\n" ++
" $p describe {pkg}\n" ++
" Give the registered description for the specified package. The\n" ++
" description is returned in precisely the syntax required by $p\n" ++
" register.\n" ++
"\n" ++
" $p field {pkg} {field}\n" ++
" Extract the specified field of the package description for the\n" ++
" specified package. Accepts comma-separated multiple fields.\n" ++
"\n" ++
" $p dump\n" ++
" Dump the registered description for every package. This is like\n" ++
" \"eta-pkg describe '*'\", except that it is intended to be used\n" ++
" by tools that parse the results, rather than humans. The output is\n" ++
" always encoded in UTF-8, regardless of the current locale.\n" ++
"\n" ++
" $p recache\n" ++
" Regenerate the package database cache. This command should only be\n" ++
" necessary if you added a package to the database by dropping a file\n" ++
" into the database directory manually. By default, the global DB\n" ++
" is recached; to recache a different DB use --user or --package-db\n" ++
" as appropriate.\n" ++
"\n" ++
" Substring matching is supported for {module} in find-module and\n" ++
" for {pkg} in list, describe, and field, where a '*' indicates\n" ++
" open substring ends (prefix*, *suffix, *infix*). Use --ipid to\n" ++
" match against the installed package ID instead.\n" ++
"\n" ++
" When asked to modify a database (register, unregister, update,\n"++
" hide, expose, and also check), eta-pkg modifies the global database by\n"++
" default. Specifying --user causes it to act on the user database,\n"++
" or --package-db can be used to act on another database\n"++
" entirely. When multiple of these options are given, the rightmost\n"++
" one is used as the database to act upon.\n"++
"\n"++
" Commands that query the package database (list, tree, latest, describe,\n"++
" field) operate on the list of databases specified by the flags\n"++
" --user, --global, and --package-db. If none of these flags are\n"++
" given, the default is --global --user.\n"++
"\n" ++
" The following optional flags are also accepted:\n"
substProg :: String -> String -> String
substProg _ [] = []
substProg prog ('$':'p':xs) = prog ++ substProg prog xs
substProg prog (c:xs) = c : substProg prog xs
-- -----------------------------------------------------------------------------
-- Do the business
data Force = NoForce | ForceFiles | ForceAll | CannotForce
deriving (Eq,Ord)
-- | Enum flag representing argument type
data AsPackageArg
= AsUnitId
-- AsIpid
-- AsPackageKey
| AsDefault
-- | Represents how a package may be specified by a user on the command line.
data PackageArg
-- | A package identifier foo-0.1, or a glob foo-*.
= Id GlobPackageIdentifier
-- | An installed package ID foo-0.1-HASH. This is guaranteed to uniquely
-- match a single entry in the package database.
| IUId UnitId
-- | A glob against the package name. The first string is the literal
-- glob, the second is a function which returns @True@ if the the argument
-- matches.
| Substring String (String->Bool)
runit :: Verbosity -> [Flag] -> [String] -> IO ()
runit verbosity cli nonopts = do
when (verbosity >= Verbose)
(putStr ourCopyright)
prog <- getProgramName
let
force
| FlagForce `elem` cli = ForceAll
| FlagForceFiles `elem` cli = ForceFiles
| otherwise = NoForce
as_arg | FlagUnitId `elem` cli = AsUnitId
-- | FlagIPId `elem` cli = AsIpid
-- | FlagPackageKey `elem` cli = AsPackageKey
| otherwise = AsDefault
multi_instance = FlagMultiInstance `elem` cli
expand_env_vars= FlagExpandEnvVars `elem` cli
mexpand_pkgroot= foldl' accumExpandPkgroot Nothing cli
where accumExpandPkgroot _ FlagExpandPkgroot = Just True
accumExpandPkgroot _ FlagNoExpandPkgroot = Just False
accumExpandPkgroot x _ = x
splitFields fields = unfoldr splitComma (',':fields)
where splitComma "" = Nothing
splitComma fs = Just $ break (==',') (tail fs)
-- | Parses a glob into a predicate which tests if a string matches
-- the glob. Returns Nothing if the string in question is not a glob.
-- At the moment, we only support globs at the beginning and/or end of
-- strings. This function respects case sensitivity.
--
-- >>> fromJust (substringCheck "*") "anything"
-- True
--
-- >>> fromJust (substringCheck "string") "string"
-- True
--
-- >>> fromJust (substringCheck "*bar") "foobar"
-- True
--
-- >>> fromJust (substringCheck "foo*") "foobar"
-- True
--
-- >>> fromJust (substringCheck "*ooba*") "foobar"
-- True
--
-- >>> fromJust (substringCheck "f*bar") "foobar"
-- False
substringCheck :: String -> Maybe (String -> Bool)
substringCheck "" = Nothing
substringCheck "*" = Just (const True)
substringCheck [_] = Nothing
substringCheck (h:t) =
case (h, init t, last t) of
('*',s,'*') -> Just (isInfixOf (f s) . f)
('*',_, _ ) -> Just (isSuffixOf (f t) . f)
( _ ,s,'*') -> Just (isPrefixOf (f (h:s)) . f)
_ -> Nothing
where f | FlagIgnoreCase `elem` cli = map toLower
| otherwise = id
--
-- first, parse the command
case nonopts of
["init", filename] ->
initPackageDB filename verbosity cli
["register", filename] ->
registerPackage filename verbosity cli
multi_instance
expand_env_vars False force
["update", filename] ->
registerPackage filename verbosity cli
multi_instance
expand_env_vars True force
["unregister", pkgarg_str] -> do
pkgarg <- readPackageArg as_arg pkgarg_str
unregisterPackage pkgarg verbosity cli force
["expose", pkgarg_str] -> do
pkgarg <- readPackageArg as_arg pkgarg_str
exposePackage pkgarg verbosity cli force
["hide", pkgarg_str] -> do
pkgarg <- readPackageArg as_arg pkgarg_str
hidePackage pkgarg verbosity cli force
["trust", pkgarg_str] -> do
pkgarg <- readPackageArg as_arg pkgarg_str
trustPackage pkgarg verbosity cli force
["distrust", pkgarg_str] -> do
pkgarg <- readPackageArg as_arg pkgarg_str
distrustPackage pkgarg verbosity cli force
["list"] -> do
listPackages verbosity cli Nothing Nothing
["list", pkgarg_str] ->
case substringCheck pkgarg_str of
Nothing -> do pkgarg <- readPackageArg as_arg pkgarg_str
listPackages verbosity cli (Just pkgarg) Nothing
Just m -> listPackages verbosity cli
(Just (Substring pkgarg_str m)) Nothing
["dot"] -> do
showPackageDot verbosity cli
["find-module", moduleName] -> do
let match = maybe (==moduleName) id (substringCheck moduleName)
listPackages verbosity cli Nothing (Just match)
["latest", pkgid_str] -> do
pkgid <- readGlobPkgId pkgid_str
latestPackage verbosity cli pkgid
["describe", pkgid_str] -> do
pkgarg <- case substringCheck pkgid_str of
Nothing -> readPackageArg as_arg pkgid_str
Just m -> return (Substring pkgid_str m)
describePackage verbosity cli pkgarg (fromMaybe False mexpand_pkgroot)
["field", pkgid_str, fields] -> do
pkgarg <- case substringCheck pkgid_str of
Nothing -> readPackageArg as_arg pkgid_str
Just m -> return (Substring pkgid_str m)
describeField verbosity cli pkgarg
(splitFields fields) (fromMaybe True mexpand_pkgroot)
["check"] -> do
checkConsistency verbosity cli
["dump"] -> do
dumpPackages verbosity cli (fromMaybe False mexpand_pkgroot)
["recache"] -> do
recache verbosity cli
[] -> do
die ("missing command\n" ++ shortUsage prog)
(_cmd:_) -> do
die ("command-line syntax error\n" ++ shortUsage prog)
parseCheck :: ReadP a a -> String -> String -> IO a
parseCheck parser str what =
case [ x | (x,ys) <- readP_to_S parser str, all isSpace ys ] of
[x] -> return x
_ -> die ("cannot parse \'" ++ str ++ "\' as a " ++ what)
-- | Either an exact 'PackageIdentifier', or a glob for all packages
-- matching 'PackageName'.
data GlobPackageIdentifier
= ExactPackageIdentifier PackageIdentifier
| GlobPackageIdentifier PackageName
displayGlobPkgId :: GlobPackageIdentifier -> String
displayGlobPkgId (ExactPackageIdentifier pid) = display pid
displayGlobPkgId (GlobPackageIdentifier pn) = display pn ++ "-*"
readGlobPkgId :: String -> IO GlobPackageIdentifier
readGlobPkgId str = parseCheck parseGlobPackageId str "package identifier"
parseGlobPackageId :: ReadP r GlobPackageIdentifier
parseGlobPackageId =
fmap ExactPackageIdentifier parse
+++
(do n <- parse
_ <- string "-*"
return (GlobPackageIdentifier n))
readPackageArg :: AsPackageArg -> String -> IO PackageArg
readPackageArg AsUnitId str =
parseCheck (IUId `fmap` parse) str "installed package id"
-- readPackageArg AsIpid str =
-- parseCheck (IPId `fmap` parse) str "installed package id"
-- readPackageArg AsPackageKey str =
-- parseCheck (PkgKey `fmap` parse) str "package key"
readPackageArg AsDefault str = Id `fmap` readGlobPkgId str
-- globVersion means "all versions"
-- globVersion :: Version
-- globVersion = Version [] ["*"]
-- -----------------------------------------------------------------------------
-- Package databases
-- Some commands operate on a single database:
-- register, unregister, expose, hide, trust, distrust
-- however these commands also check the union of the available databases
-- in order to check consistency. For example, register will check that
-- dependencies exist before registering a package.
--
-- Some commands operate on multiple databases, with overlapping semantics:
-- list, describe, field
data PackageDB (mode :: EtaPkg.DbMode)
= PackageDB {
location, locationAbsolute :: !FilePath,
-- We need both possibly-relative and definately-absolute package
-- db locations. This is because the relative location is used as
-- an identifier for the db, so it is important we do not modify it.
-- On the other hand we need the absolute path in a few places
-- particularly in relation to the ${pkgroot} stuff.
packageDbLock :: !(EtaPkg.DbOpenMode mode EtaPkg.PackageDbLock),
-- If package db is open in read write mode, we keep its lock around for
-- transactional updates.
packages :: [InstalledPackageInfo]
}
type PackageDBStack = [PackageDB 'EtaPkg.DbReadOnly]
-- A stack of package databases. Convention: head is the topmost
-- in the stack.
-- | Selector for picking the right package DB to modify as 'register' and
-- 'recache' operate on the database on top of the stack, whereas 'modify'
-- changes the first database that contains a specific package.
data DbModifySelector = TopOne | ContainsPkg PackageArg
allPackagesInStack :: PackageDBStack -> [InstalledPackageInfo]
allPackagesInStack = concatMap packages
getPkgDatabases :: Verbosity
-> EtaPkg.DbOpenMode mode DbModifySelector
-> Bool -- use the user db
-> Bool -- read caches, if available
-> Bool -- expand vars, like ${pkgroot} and $topdir
-> [Flag]
-> IO (PackageDBStack,
-- the real package DB stack: [global,user] ++
-- DBs specified on the command line with -f.
EtaPkg.DbOpenMode mode (PackageDB mode),
PackageDBStack)
-- the package DBs specified on the command
-- line, or [global,user] otherwise. This
-- is used as the list of package DBs for
-- commands that just read the DB, such as 'list'.
getPkgDatabases verbosity mode use_user use_cache expand_vars my_flags = do
-- first we determine the location of the global package config. On Windows,
-- this is found relative to the eta-pkg.exe binary, whereas on Unix the
-- location is passed to the binary using the --global-package-db flag by the
-- wrapper script.
-- TODO: We don't have a global package db yet
let err_msg = "missing --global-package-db option, location of global package database unknown\n"
-- NOTE: This mean eta-pkg and eta should ALWAYS have the same version
e_appdir <- tryIO $ fmap (</> myVersion) $ getAppUserDataDirectory "eta"
global_conf <-
case [ f | FlagGlobalConfig f <- my_flags ] of
[] -> case e_appdir of
Left _ -> die err_msg
Right dir -> do
r <- lookForPackageDBIn dir
case r of
Nothing -> do
let globalDb = dir </> "package.conf.d"
initPackageDB globalDb verbosity []
return globalDb
Just path -> return path
fs -> return (last fs)
-- The value of the $topdir variable used in some package descriptions
-- Note that the way we calculate this is slightly different to how it
-- is done in eta itself. We rely on the convention that the global
-- package db lives in eta's libdir.
top_dir <- absolutePath (takeDirectory global_conf)
let no_user_db = FlagNoUserDb `elem` my_flags
-- get the location of the user package database, and create it if necessary
-- getAppUserDataDirectory can fail (e.g. if $HOME isn't set)
mb_user_conf <-
case [ f | FlagUserConfig f <- my_flags ] of
_ | no_user_db -> return Nothing
[] -> case e_appdir of
Left _ -> return Nothing
Right appdir -> do
let dir = appdir
r <- lookForPackageDBIn dir
case r of
Nothing -> return (Just (dir </> "package.conf.d", False))
Just f -> return (Just (f, True))
fs -> return (Just (last fs, True))
-- If the user database exists, and for "use_user" commands (which includes
-- "eta-pkg check" and all commands that modify the db) we will attempt to
-- use the user db.
let sys_databases
| Just (user_conf,user_exists) <- mb_user_conf,
use_user || user_exists = [user_conf, global_conf]
| otherwise = [global_conf]
e_pkg_path <- tryIO (System.Environment.getEnv "ETA_PACKAGE_PATH")
let env_stack =
case e_pkg_path of
Left _ -> sys_databases
Right path
| not (null path) && isSearchPathSeparator (last path)
-> splitSearchPath (init path) ++ sys_databases
| otherwise
-> splitSearchPath path
-- The "global" database is always the one at the bottom of the stack.
-- This is the database we modify by default.
virt_global_conf = last env_stack
let db_flags = [ f | Just f <- map is_db_flag my_flags ]
where is_db_flag FlagUser
| Just (user_conf, _user_exists) <- mb_user_conf
= Just user_conf
is_db_flag FlagGlobal = Just virt_global_conf
is_db_flag (FlagConfig f) = Just f
is_db_flag _ = Nothing
let flag_db_names | null db_flags = env_stack
| otherwise = reverse (nub db_flags)
-- For a "modify" command, treat all the databases as
-- a stack, where we are modifying the top one, but it
-- can refer to packages in databases further down the
-- stack.
-- -f flags on the command line add to the database
-- stack, unless any of them are present in the stack
-- already.
let final_stack = filter (`notElem` env_stack)
[ f | FlagConfig f <- reverse my_flags ]
++ env_stack
top_db = if null db_flags
then virt_global_conf
else last db_flags
(db_stack, db_to_operate_on) <- getDatabases top_dir mb_user_conf
flag_db_names final_stack top_db
let flag_db_stack = [ db | db_name <- flag_db_names,
db <- db_stack, location db == db_name ]
when (verbosity > Normal) $ do
infoLn ("db stack: " ++ show (map location db_stack))
F.forM_ db_to_operate_on $ \db ->
infoLn ("modifying: " ++ (location db))
infoLn ("flag db stack: " ++ show (map location flag_db_stack))
return (db_stack, db_to_operate_on, (etaPkgDB flag_db_stack))
where
-- Right now Eta has both the global and the user package
-- databases as the same. So we just pass a single element from
-- the PackageDBStack for the list command.
etaPkgDB [] = []
etaPkgDB (x:_) = [x]
getDatabases top_dir mb_user_conf flag_db_names
final_stack top_db = case mode of
-- When we open in read only mode, we simply read all of the databases/
EtaPkg.DbOpenReadOnly -> do
db_stack <- mapM readDatabase final_stack
return (db_stack, EtaPkg.DbOpenReadOnly)
-- The only package db we open in read write mode is the one on the top of
-- the stack.
EtaPkg.DbOpenReadWrite TopOne -> do
(db_stack, mto_modify) <- stateSequence Nothing
[ \case
to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
Nothing -> if db_path /= top_db
then (, Nothing) <$> readDatabase db_path
else do
db <- readParseDatabase verbosity mb_user_conf
mode use_cache db_path
`Exception.catch` couldntOpenDbForModification db_path
let ro_db = db { packageDbLock = EtaPkg.DbOpenReadOnly }
return (ro_db, Just db)
| db_path <- final_stack ]
to_modify <- case mto_modify of
Just db -> return db
Nothing -> die "no database selected for modification"
return (db_stack, EtaPkg.DbOpenReadWrite to_modify)
-- The package db we open in read write mode is the first one included in
-- flag_db_names that contains specified package. Therefore we need to
-- open each one in read/write mode first and decide whether it's for
-- modification based on its contents.
EtaPkg.DbOpenReadWrite (ContainsPkg pkgarg) -> do
(db_stack, mto_modify) <- stateSequence Nothing
[ \case
to_modify@(Just _) -> (, to_modify) <$> readDatabase db_path
Nothing -> if db_path `notElem` flag_db_names
then (, Nothing) <$> readDatabase db_path
else do
let hasPkg :: PackageDB mode -> Bool
hasPkg = not . null . findPackage pkgarg . packages
openRo (e::IOError) = do
db <- readDatabase db_path
if hasPkg db
then couldntOpenDbForModification db_path e
else return (db, Nothing)
-- If we fail to open the database in read/write mode, we need
-- to check if it's for modification first before throwing an
-- error, so we attempt to open it in read only mode.
Exception.handle openRo $ do
db <- readParseDatabase verbosity mb_user_conf
mode use_cache db_path
let ro_db = db { packageDbLock = EtaPkg.DbOpenReadOnly }
if hasPkg db
then return (ro_db, Just db)
else do
-- If the database is not for modification after all,
-- drop the write lock as we are already finished with
-- the database.
case packageDbLock db of
EtaPkg.DbOpenReadWrite lock ->
EtaPkg.unlockPackageDb lock
_ -> case undefined of {}
return (ro_db, Nothing)
| db_path <- final_stack ]
to_modify <- case mto_modify of
Just db -> return db
Nothing -> cannotFindPackage pkgarg Nothing
return (db_stack, EtaPkg.DbOpenReadWrite to_modify)
where
couldntOpenDbForModification :: FilePath -> IOError -> IO a
couldntOpenDbForModification db_path e = die $ "Couldn't open database "
++ db_path ++ " for modification: " ++ show e
-- Parse package db in read-only mode.
readDatabase :: FilePath -> IO (PackageDB 'EtaPkg.DbReadOnly)
readDatabase db_path = do
db <- readParseDatabase verbosity mb_user_conf
EtaPkg.DbOpenReadOnly use_cache db_path
if expand_vars
then return $ mungePackageDBPaths top_dir db
else return db
stateSequence :: Monad m => s -> [s -> m (a, s)] -> m ([a], s)
stateSequence s [] = return ([], s)
stateSequence s (m:ms) = do
(a, s') <- m s
(as, s'') <- stateSequence s' ms
return (a : as, s'')
lookForPackageDBIn :: FilePath -> IO (Maybe FilePath)
lookForPackageDBIn dir = do
let path_dir = dir </> "package.conf.d"
exists_dir <- doesDirectoryExist path_dir
if exists_dir then return (Just path_dir) else do
let path_file = dir </> "package.conf"
exists_file <- doesFileExist path_file
if exists_file then return (Just path_file) else return Nothing
readParseDatabase :: forall mode t. Verbosity
-> Maybe (FilePath,Bool)
-> EtaPkg.DbOpenMode mode t
-> Bool -- use cache
-> FilePath
-> IO (PackageDB mode)
readParseDatabase verbosity mb_user_conf mode use_cache path
-- the user database (only) is allowed to be non-existent
| Just (user_conf,False) <- mb_user_conf, path == user_conf
= do lock <- F.forM mode $ \_ -> do
createDirectoryIfMissing True path
EtaPkg.lockPackageDb cache
mkPackageDB [] lock
| otherwise
= do e <- tryIO $ getDirectoryContents path
case e of
Left err
| ioeGetErrorType err == InappropriateType -> do
-- We provide a limited degree of backwards compatibility for
-- old single-file style db:
mdb <- tryReadParseOldFileStyleDatabase verbosity
mb_user_conf mode use_cache path
case mdb of
Just db -> return db
Nothing ->
die $ "eta no longer supports single-file style package "
++ "databases (" ++ path ++ ") use 'eta-pkg init'"
++ "to create the database with the correct format."
| otherwise -> ioError err
Right fs
| not use_cache -> ignore_cache (const $ return ())
| otherwise -> do
e_tcache <- tryIO $ getModificationTime cache
case e_tcache of
Left ex -> do
whenReportCacheErrors $
if isDoesNotExistError ex
then do
-- It's fine if the cache is not there as long as the
-- database is empty.
when (not $ null confs) $ do
warn ("WARNING: cache does not exist: " ++ cache)
warn ("ghc will fail to read this package db. " ++
recacheAdvice)
else do
warn ("WARNING: cache cannot be read: " ++ show ex)
warn "eta will fail to read this package db."
ignore_cache (const $ return ())
Right tcache -> do
when (verbosity >= Verbose) $ do
warn ("Timestamp " ++ show tcache ++ " for " ++ cache)
-- If any of the .conf files is newer than package.cache, we
-- assume that cache is out of date.
cache_outdated <- (`anyM` confs) $ \conf ->
(tcache <) <$> getModificationTime conf
if not cache_outdated
then do
when (verbosity > Normal) $
infoLn ("using cache: " ++ cache)
EtaPkg.readPackageDbForEtaPkg cache mode
>>= uncurry mkPackageDB
else do
whenReportCacheErrors $ do
warn ("WARNING: cache is out of date: " ++ cache)
warn ("eta will see an old view of this " ++
"package db. " ++ recacheAdvice)
ignore_cache $ \file -> do
when (verbosity >= Verbose) $ do
tFile <- getModificationTime file
let rel = case tcache `compare` tFile of
LT -> " (NEWER than cache)"
GT -> " (older than cache)"
EQ -> " (same as cache)"
warn ("Timestamp " ++ show tFile
++ " for " ++ file ++ rel)
where
confs = map (path </>) $ filter (".conf" `isSuffixOf`) fs
ignore_cache :: (FilePath -> IO ()) -> IO (PackageDB mode)
ignore_cache checkTime = do
-- If we're opening for modification, we need to acquire a
-- lock even if we don't open the cache now, because we are
-- going to modify it later.
lock <- F.mapM (const $ EtaPkg.lockPackageDb cache) mode
let doFile f = do checkTime f
parseSingletonPackageConf verbosity f
pkgs <- mapM doFile $ map (path </>) confs
mkPackageDB pkgs lock
-- We normally report cache errors for read-only commands,
-- since modify commands will usually fix the cache.
whenReportCacheErrors = when $ verbosity > Normal
|| verbosity >= Normal && EtaPkg.isDbOpenReadMode mode
where
cache = path </> cachefilename
recacheAdvice
| Just (user_conf, True) <- mb_user_conf, path == user_conf
= "Use 'eta-pkg recache --user' to fix."
| otherwise
= "Use 'eta-pkg recache' to fix."
mkPackageDB :: [InstalledPackageInfo]
-> EtaPkg.DbOpenMode mode EtaPkg.PackageDbLock
-> IO (PackageDB mode)
mkPackageDB pkgs lock = do
path_abs <- absolutePath path
return PackageDB {
location = path,
locationAbsolute = path_abs,
packageDbLock = lock,
packages = pkgs
}
parseSingletonPackageConf :: Verbosity -> FilePath -> IO InstalledPackageInfo
parseSingletonPackageConf verbosity file = do
when (verbosity > Normal) $ infoLn ("reading package config: " ++ file)
readUTF8File file >>= fmap fst . parsePackageInfo
cachefilename :: FilePath
cachefilename = "package.cache"
mungePackageDBPaths :: FilePath -> PackageDB mode -> PackageDB mode
mungePackageDBPaths top_dir db@PackageDB { packages = pkgs } =
db { packages = map (mungePackagePaths top_dir pkgroot) pkgs }
where
pkgroot = takeDirectory $ dropTrailingPathSeparator (locationAbsolute db)
-- It so happens that for both styles of package db ("package.conf"
-- files and "package.conf.d" dirs) the pkgroot is the parent directory
-- ${pkgroot}/package.conf or ${pkgroot}/package.conf.d/
-- TODO: This code is duplicated in compiler/main/Packages.lhs
mungePackagePaths :: FilePath -> FilePath
-> InstalledPackageInfo -> InstalledPackageInfo
-- Perform path/URL variable substitution as per the Cabal ${pkgroot} spec
-- (http://www.haskell.org/pipermail/libraries/2009-May/011772.html)
-- Paths/URLs can be relative to ${pkgroot} or ${pkgrooturl}.
-- The "pkgroot" is the directory containing the package database.
--
-- Also perform a similar substitution for the older ETA-specific
-- "$topdir" variable. The "topdir" is the location of the eta
-- installation (obtained from the -B option).
mungePackagePaths top_dir pkgroot pkg =
pkg {
importDirs = munge_paths (importDirs pkg),
includeDirs = munge_paths (includeDirs pkg),
libraryDirs = munge_paths (libraryDirs pkg),
libraryDynDirs = munge_paths (libraryDynDirs pkg),
frameworkDirs = munge_paths (frameworkDirs pkg),
haddockInterfaces = munge_paths (haddockInterfaces pkg),
-- haddock-html is allowed to be either a URL or a file
haddockHTMLs = munge_paths (munge_urls (haddockHTMLs pkg))
}
where
munge_paths = map munge_path
munge_urls = map munge_url
munge_path p
| Just p' <- stripVarPrefix "${pkgroot}" p = pkgroot ++ p'
| Just p' <- stripVarPrefix "$topdir" p = top_dir ++ p'
| otherwise = p
munge_url p
| Just p' <- stripVarPrefix "${pkgrooturl}" p = toUrlPath pkgroot p'
| Just p' <- stripVarPrefix "$httptopdir" p = toUrlPath top_dir p'
| otherwise = p
toUrlPath r p = "file:///"
-- URLs always use posix style '/' separators:
++ FilePath.Posix.joinPath
(r : -- We need to drop a leading "/" or "\\"
-- if there is one:
dropWhile (all isPathSeparator)
(FilePath.splitDirectories p))
-- We could drop the separator here, and then use </> above. However,
-- by leaving it in and using ++ we keep the same path separator
-- rather than letting FilePath change it to use \ as the separator
stripVarPrefix var path = case stripPrefix var path of
Just [] -> Just []
Just cs@(c : _) | isPathSeparator c -> Just cs
_ -> Nothing
-- -----------------------------------------------------------------------------
-- Workaround for old single-file style package dbs
-- Single-file style package dbs have been deprecated for some time, but
-- it turns out that Cabal was using them in one place. So this code is for a
-- workaround to allow older Cabal versions to use this newer eta.
-- We check if the file db contains just "[]" and if so, we look for a new
-- dir-style db in path.d/, ie in a dir next to the given file.
-- We cannot just replace the file with a new dir style since Cabal still
-- assumes it's a file and tries to overwrite with 'writeFile'.
-- eta itself also cooperates in this workaround
tryReadParseOldFileStyleDatabase :: Verbosity -> Maybe (FilePath, Bool)
-> EtaPkg.DbOpenMode mode t -> Bool -> FilePath
-> IO (Maybe (PackageDB mode))
tryReadParseOldFileStyleDatabase verbosity mb_user_conf
mode use_cache path = do
-- assumes we've already established that path exists and is not a dir
content <- readFile path `catchIO` \_ -> return ""
if take 2 content == "[]"
then do
path_abs <- absolutePath path
let path_dir = adjustOldDatabasePath path
warn $ "Warning: ignoring old file-style db and trying " ++ path_dir
direxists <- doesDirectoryExist path_dir
if direxists
then do
db <- readParseDatabase verbosity mb_user_conf mode use_cache path_dir
-- but pretend it was at the original location
return $ Just db {
location = path,
locationAbsolute = path_abs
}
else do
lock <- F.forM mode $ \_ -> do