-
Notifications
You must be signed in to change notification settings - Fork 842
/
Setup.hs
1429 lines (1339 loc) · 63.3 KB
/
Setup.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 BangPatterns #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE PackageImports #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE TupleSections #-}
module Stack.Setup
( setupEnv
, ensureCompiler
, ensureDockerStackExe
, SetupOpts (..)
, defaultStackSetupYaml
) where
import Control.Applicative
import Control.Exception.Enclosed (catchIO, tryAny)
import Control.Monad (liftM, when, join, void, unless)
import Control.Monad.Catch
import Control.Monad.IO.Class (MonadIO, liftIO)
import Control.Monad.Logger
import Control.Monad.Reader (MonadReader, ReaderT (..), asks)
import Control.Monad.State (get, put, modify)
import Control.Monad.Trans.Control
import "cryptohash" Crypto.Hash (SHA1(SHA1))
import Data.Aeson.Extended
import qualified Data.ByteString as S
import qualified Data.ByteString.Char8 as S8
import qualified Data.ByteString.Lazy as LBS
import Data.Char (isSpace)
import Data.Conduit (Conduit, ($$), (=$), await, yield, awaitForever)
import qualified Data.Conduit.Binary as CB
import Data.Conduit.Lift (evalStateC)
import qualified Data.Conduit.List as CL
import Data.Either
import Data.Foldable hiding (concatMap, or, maximum)
import Data.IORef
import Data.IORef.RunOnce (runOnce)
import Data.List hiding (concat, elem, maximumBy, any)
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Maybe
import Data.Monoid
import Data.Ord (comparing)
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
import qualified Data.Text.Encoding.Error as T
import Data.Time.Clock (NominalDiffTime, diffUTCTime, getCurrentTime)
import Data.Typeable (Typeable)
import qualified Data.Yaml as Yaml
import Distribution.System (OS, Arch (..), Platform (..))
import qualified Distribution.System as Cabal
import Distribution.Text (simpleParse)
import Language.Haskell.TH as TH
import Network.HTTP.Client.Conduit
import Network.HTTP.Download.Verified
import Path
import Path.Extra (toFilePathNoTrailingSep)
import Path.IO
import qualified Paths_stack as Meta
import Prelude hiding (concat, elem, any) -- Fix AMP warning
import Safe (readMay)
import Stack.Build (build)
import Stack.Config (resolvePackageEntry, loadConfig)
import Stack.Constants (distRelativeDir, stackProgName)
import Stack.Exec (defaultEnvSettings)
import Stack.Fetch
import Stack.GhcPkg (createDatabase, getCabalPkgVer, getGlobalDB, mkGhcPackagePath)
import Stack.Setup.Installed
import Stack.Types
import Stack.Types.Internal (HasTerminal, HasReExec, HasLogLevel)
import Stack.Types.StackT
import qualified System.Directory as D
import System.Environment (getExecutablePath)
import System.Exit (ExitCode (ExitSuccess))
import System.FilePath (searchPathSeparator)
import qualified System.FilePath as FP
import System.Process (rawSystem)
import System.Process.Read
import System.Process.Run (runCmd, Cmd(..))
import Text.Printf (printf)
-- | Default location of the stack-setup.yaml file
defaultStackSetupYaml :: String
defaultStackSetupYaml =
"https://raw.githubusercontent.com/fpco/stackage-content/master/stack/stack-setup-2.yaml"
data SetupOpts = SetupOpts
{ soptsInstallIfMissing :: !Bool
, soptsUseSystem :: !Bool
, soptsWantedCompiler :: !CompilerVersion
, soptsCompilerCheck :: !VersionCheck
, soptsStackYaml :: !(Maybe (Path Abs File))
-- ^ If we got the desired GHC version from that file
, soptsForceReinstall :: !Bool
, soptsSanityCheck :: !Bool
-- ^ Run a sanity check on the selected GHC
, soptsSkipGhcCheck :: !Bool
-- ^ Don't check for a compatible GHC version/architecture
, soptsSkipMsys :: !Bool
-- ^ Do not use a custom msys installation on Windows
, soptsUpgradeCabal :: !Bool
-- ^ Upgrade the global Cabal library in the database to the newest
-- version. Only works reliably with a stack-managed installation.
, soptsResolveMissingGHC :: !(Maybe Text)
-- ^ Message shown to user for how to resolve the missing GHC
, soptsStackSetupYaml :: !FilePath
-- ^ Location of the main stack-setup.yaml file
, soptsGHCBindistURL :: !(Maybe String)
-- ^ Alternate GHC binary distribution (requires custom GHCVariant)
}
deriving Show
data SetupException = UnsupportedSetupCombo OS Arch
| MissingDependencies [String]
| UnknownCompilerVersion Text CompilerVersion [CompilerVersion]
| UnknownOSKey Text
| GHCSanityCheckCompileFailed ReadProcessException (Path Abs File)
| WantedMustBeGHC
| RequireCustomGHCVariant
| ProblemWhileDecompressing (Path Abs File)
| SetupInfoMissingSevenz
| GHCJSRequiresStandardVariant
| GHCJSNotBooted
| DockerStackExeNotFound Version Text
deriving Typeable
instance Exception SetupException
instance Show SetupException where
show (UnsupportedSetupCombo os arch) = concat
[ "I don't know how to install GHC for "
, show (os, arch)
, ", please install manually"
]
show (MissingDependencies tools) =
"The following executables are missing and must be installed: " ++
intercalate ", " tools
show (UnknownCompilerVersion oskey wanted known) = concat
[ "No information found for "
, compilerVersionString wanted
, ".\nSupported versions for OS key '" ++ T.unpack oskey ++ "': "
, intercalate ", " (map show known)
]
show (UnknownOSKey oskey) =
"Unable to find installation URLs for OS key: " ++
T.unpack oskey
show (GHCSanityCheckCompileFailed e ghc) = concat
[ "The GHC located at "
, toFilePath ghc
, " failed to compile a sanity check. Please see:\n\n"
, " https://github.com/commercialhaskell/stack/blob/release/doc/install_and_upgrade.md\n\n"
, "for more information. Exception was:\n"
, show e
]
show WantedMustBeGHC =
"The wanted compiler must be GHC"
show RequireCustomGHCVariant =
"A custom --ghc-variant must be specified to use --ghc-bindist"
show (ProblemWhileDecompressing archive) =
"Problem while decompressing " ++ toFilePath archive
show SetupInfoMissingSevenz =
"SetupInfo missing Sevenz EXE/DLL"
show GHCJSRequiresStandardVariant =
"stack does not yet support using --ghc-variant with GHCJS"
show GHCJSNotBooted =
"GHCJS does not yet have its boot packages installed. Use \"stack setup\" to attempt to run ghcjs-boot."
show (DockerStackExeNotFound stackVersion osKey) = concat
[ stackProgName
, "-"
, versionString stackVersion
, " executable not found for "
, T.unpack osKey
, "\nUse the '"
, T.unpack dockerStackExeArgName
, "' option to specify a location"]
-- | Modify the environment variables (like PATH) appropriately, possibly doing installation too
setupEnv :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasBuildConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)
=> Maybe Text -- ^ Message to give user when necessary GHC is not available
-> m EnvConfig
setupEnv mResolveMissingGHC = do
bconfig <- asks getBuildConfig
let platform = getPlatform bconfig
wc = whichCompiler (bcWantedCompiler bconfig)
sopts = SetupOpts
{ soptsInstallIfMissing = configInstallGHC $ bcConfig bconfig
, soptsUseSystem = configSystemGHC $ bcConfig bconfig
, soptsWantedCompiler = bcWantedCompiler bconfig
, soptsCompilerCheck = configCompilerCheck $ bcConfig bconfig
, soptsStackYaml = Just $ bcStackYaml bconfig
, soptsForceReinstall = False
, soptsSanityCheck = False
, soptsSkipGhcCheck = configSkipGHCCheck $ bcConfig bconfig
, soptsSkipMsys = configSkipMsys $ bcConfig bconfig
, soptsUpgradeCabal = False
, soptsResolveMissingGHC = mResolveMissingGHC
, soptsStackSetupYaml = defaultStackSetupYaml
, soptsGHCBindistURL = Nothing
}
mghcBin <- ensureCompiler sopts
-- Modify the initial environment to include the GHC path, if a local GHC
-- is being used
menv0 <- getMinimalEnvOverride
let env = removeHaskellEnvVars
$ augmentPathMap (maybe [] edBins mghcBin)
$ unEnvOverride menv0
menv <- mkEnvOverride platform env
compilerVer <- getCompilerVersion menv wc
cabalVer <- getCabalPkgVer menv wc
packages <- mapM
(resolvePackageEntry menv (bcRoot bconfig))
(bcPackageEntries bconfig)
let envConfig0 = EnvConfig
{ envConfigBuildConfig = bconfig
, envConfigCabalVersion = cabalVer
, envConfigCompilerVersion = compilerVer
, envConfigPackages = Map.fromList $ concat packages
}
-- extra installation bin directories
mkDirs <- runReaderT extraBinDirs envConfig0
let mpath = Map.lookup "PATH" env
mkDirs' = map toFilePath . mkDirs
depsPath = augmentPath (mkDirs' False) mpath
localsPath = augmentPath (mkDirs' True) mpath
deps <- runReaderT packageDatabaseDeps envConfig0
createDatabase menv wc deps
localdb <- runReaderT packageDatabaseLocal envConfig0
createDatabase menv wc localdb
globaldb <- getGlobalDB menv wc
extras <- runReaderT packageDatabaseExtra envConfig0
let mkGPP locals = mkGhcPackagePath locals localdb deps extras globaldb
distDir <- runReaderT distRelativeDir envConfig0
executablePath <- liftIO getExecutablePath
utf8EnvVars <- getUtf8LocaleVars menv
envRef <- liftIO $ newIORef Map.empty
let getEnvOverride' es = do
m <- readIORef envRef
case Map.lookup es m of
Just eo -> return eo
Nothing -> do
eo <- mkEnvOverride platform
$ Map.insert "PATH" (if esIncludeLocals es then localsPath else depsPath)
$ (if esIncludeGhcPackagePath es
then Map.insert
(case wc of { Ghc -> "GHC_PACKAGE_PATH"; Ghcjs -> "GHCJS_PACKAGE_PATH" })
(mkGPP (esIncludeLocals es))
else id)
$ (if esStackExe es
then Map.insert "STACK_EXE" (T.pack executablePath)
else id)
$ (if esLocaleUtf8 es
then Map.union utf8EnvVars
else id)
-- For reasoning and duplication, see: https://github.com/fpco/stack/issues/70
$ Map.insert "HASKELL_PACKAGE_SANDBOX" (T.pack $ toFilePathNoTrailingSep deps)
$ Map.insert "HASKELL_PACKAGE_SANDBOXES"
(T.pack $ if esIncludeLocals es
then intercalate [searchPathSeparator]
[ toFilePathNoTrailingSep localdb
, toFilePathNoTrailingSep deps
, ""
]
else intercalate [searchPathSeparator]
[ toFilePathNoTrailingSep deps
, ""
])
$ Map.insert "HASKELL_DIST_DIR" (T.pack $ toFilePathNoTrailingSep distDir) env
() <- atomicModifyIORef envRef $ \m' ->
(Map.insert es eo m', ())
return eo
return EnvConfig
{ envConfigBuildConfig = bconfig
{ bcConfig = maybe id addIncludeLib mghcBin
(bcConfig bconfig)
{ configEnvOverride = getEnvOverride' }
}
, envConfigCabalVersion = cabalVer
, envConfigCompilerVersion = compilerVer
, envConfigPackages = envConfigPackages envConfig0
}
-- | Add the include and lib paths to the given Config
addIncludeLib :: ExtraDirs -> Config -> Config
addIncludeLib (ExtraDirs _bins includes libs) config = config
{ configExtraIncludeDirs = Set.union
(configExtraIncludeDirs config)
(Set.fromList $ map T.pack includes)
, configExtraLibDirs = Set.union
(configExtraLibDirs config)
(Set.fromList $ map T.pack libs)
}
-- | Ensure compiler (ghc or ghcjs) is installed and provide the PATHs to add if necessary
ensureCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, HasGHCVariant env, MonadBaseControl IO m)
=> SetupOpts
-> m (Maybe ExtraDirs)
ensureCompiler sopts = do
let wc = whichCompiler (soptsWantedCompiler sopts)
when (getGhcVersion (soptsWantedCompiler sopts) < $(mkVersion "7.8")) $ do
$logWarn "stack will almost certainly fail with GHC below version 7.8"
$logWarn "Valiantly attempting to run anyway, but I know this is doomed"
$logWarn "For more information, see: https://github.com/commercialhaskell/stack/issues/648"
$logWarn ""
-- Check the available GHCs
menv0 <- getMinimalEnvOverride
msystem <-
if soptsUseSystem sopts
then getSystemCompiler menv0 wc
else return Nothing
Platform expectedArch _ <- asks getPlatform
let needLocal = case msystem of
Nothing -> True
Just _ | soptsSkipGhcCheck sopts -> False
Just (system, arch) ->
not (isWanted system) ||
arch /= expectedArch
isWanted = isWantedCompiler (soptsCompilerCheck sopts) (soptsWantedCompiler sopts)
-- If we need to install a GHC or MSYS, try to do so
-- Return the additional directory paths of GHC & MSYS.
mtools <- if needLocal
then do
getSetupInfo' <- runOnce (getSetupInfo (soptsStackSetupYaml sopts) =<< asks getHttpManager)
localPrograms <- asks $ configLocalPrograms . getConfig
installed <- listInstalled localPrograms
-- Install GHC
ghcVariant <- asks getGHCVariant
config <- asks getConfig
ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
let installedCompiler =
case wc of
Ghc -> getInstalledTool installed ghcPkgName (isWanted . GhcVersion)
Ghcjs -> getInstalledGhcjs installed isWanted
compilerTool <- case installedCompiler of
Just tool -> return tool
Nothing
| soptsInstallIfMissing sopts -> do
si <- getSetupInfo'
downloadAndInstallCompiler
si
(soptsWantedCompiler sopts)
(soptsCompilerCheck sopts)
(soptsGHCBindistURL sopts)
| otherwise ->
throwM $ CompilerVersionMismatch
msystem
(soptsWantedCompiler sopts, expectedArch)
ghcVariant
(soptsCompilerCheck sopts)
(soptsStackYaml sopts)
(fromMaybe
("Try running \"stack setup\" to install the correct GHC into "
<> T.pack (toFilePath (configLocalPrograms config)))
$ soptsResolveMissingGHC sopts)
-- Install msys2 on windows, if necessary
platform <- asks getPlatform
mmsys2Tool <- case platform of
Platform _ Cabal.Windows | not (soptsSkipMsys sopts) ->
case getInstalledTool installed $(mkPackageName "msys2") (const True) of
Just tool -> return (Just tool)
Nothing
| soptsInstallIfMissing sopts -> do
si <- getSetupInfo'
osKey <- getOSKey platform
VersionedDownloadInfo version info <-
case Map.lookup osKey $ siMsys2 si of
Just x -> return x
Nothing -> error $ "MSYS2 not found for " ++ T.unpack osKey
let tool = Tool (PackageIdentifier $(mkPackageName "msys2") version)
Just <$> downloadAndInstallTool (configLocalPrograms config) si info tool (installMsys2Windows osKey)
| otherwise -> do
$logWarn "Continuing despite missing tool: msys2"
return Nothing
_ -> return Nothing
return $ Just (compilerTool, mmsys2Tool)
else return Nothing
mpaths <- case mtools of
Nothing -> return Nothing
Just (compilerTool, mmsys2Tool) -> do
-- Add GHC's and MSYS's paths to the config.
let idents = catMaybes [Just compilerTool, mmsys2Tool]
paths <- mapM extraDirs idents
return $ Just $ mconcat paths
menv <-
case mpaths of
Nothing -> return menv0
Just ed -> do
config <- asks getConfig
let m = augmentPathMap (edBins ed) (unEnvOverride menv0)
mkEnvOverride (configPlatform config) (removeHaskellEnvVars m)
when (soptsUpgradeCabal sopts) $ do
unless needLocal $ do
$logWarn "Trying to upgrade Cabal library on a GHC not installed by stack."
$logWarn "This may fail, caveat emptor!"
upgradeCabal menv wc
case mtools of
Just (ToolGhcjs cv, _) -> ensureGhcjsBooted menv cv (soptsInstallIfMissing sopts)
_ -> return ()
when (soptsSanityCheck sopts) $ sanityCheck menv wc
return mpaths
-- Ensure Docker container-compatible 'stack' executable is downloaded
ensureDockerStackExe
:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Platform -> m (Path Abs File)
ensureDockerStackExe containerPlatform = do
config <- asks getConfig
containerPlatformDir <- runReaderT platformOnlyRelDir (containerPlatform,PlatformVariantNone)
let programsPath = configLocalProgramsBase config </> containerPlatformDir
stackVersion = fromCabalVersion Meta.version
tool = Tool (PackageIdentifier $(mkPackageName "stack") stackVersion)
stackExePath <- (</> $(mkRelFile "stack")) <$> installDir programsPath tool
stackExeExists <- fileExists stackExePath
unless stackExeExists $
do
$logInfo $ mconcat ["Downloading Docker-compatible ", T.pack stackProgName, " executable"]
si <- getSetupInfo defaultStackSetupYaml =<< asks getHttpManager
osKey <- getOSKey containerPlatform
info <-
case Map.lookup osKey (siStack si) of
Just versions ->
case Map.lookup stackVersion versions of
Just x -> return x
Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)
Nothing -> throwM (DockerStackExeNotFound stackVersion osKey)
_ <-
downloadAndInstallTool
programsPath
si
info
tool
installDockerStackExe
return ()
return stackExePath
-- | Install the newest version of Cabal globally
upgradeCabal :: (MonadIO m, MonadLogger m, MonadReader env m, HasHttpManager env, HasConfig env, MonadBaseControl IO m, MonadMask m)
=> EnvOverride
-> WhichCompiler
-> m ()
upgradeCabal menv wc = do
let name = $(mkPackageName "Cabal")
rmap <- resolvePackages menv Set.empty (Set.singleton name)
newest <-
case Map.keys rmap of
[] -> error "No Cabal library found in index, cannot upgrade"
[PackageIdentifier name' version]
| name == name' -> return version
x -> error $ "Unexpected results for resolvePackages: " ++ show x
installed <- getCabalPkgVer menv wc
if installed >= newest
then $logInfo $ T.concat
[ "Currently installed Cabal is "
, T.pack $ versionString installed
, ", newest is "
, T.pack $ versionString newest
, ". I'm not upgrading Cabal."
]
else withCanonicalizedSystemTempDirectory "stack-cabal-upgrade" $ \tmpdir -> do
$logInfo $ T.concat
[ "Installing Cabal-"
, T.pack $ versionString newest
, " to replace "
, T.pack $ versionString installed
]
let ident = PackageIdentifier name newest
m <- unpackPackageIdents menv tmpdir Nothing (Set.singleton ident)
compilerPath <- join $ findExecutable menv (compilerExeName wc)
newestDir <- parseRelDir $ versionString newest
let installRoot = toFilePath $ parent (parent compilerPath)
</> $(mkRelDir "new-cabal")
</> newestDir
dir <-
case Map.lookup ident m of
Nothing -> error "upgradeCabal: Invariant violated, dir missing"
Just dir -> return dir
runCmd (Cmd (Just dir) (compilerExeName wc) menv ["Setup.hs"]) Nothing
platform <- asks getPlatform
let setupExe = toFilePath $ dir </>
(case platform of
Platform _ Cabal.Windows -> $(mkRelFile "Setup.exe")
_ -> $(mkRelFile "Setup"))
dirArgument name' = concat
[ "--"
, name'
, "dir="
, installRoot FP.</> name'
]
args = ( "configure": map dirArgument (words "lib bin data doc") )
runCmd (Cmd (Just dir) setupExe menv args) Nothing
runCmd (Cmd (Just dir) setupExe menv ["build"]) Nothing
runCmd (Cmd (Just dir) setupExe menv ["install"]) Nothing
$logInfo "New Cabal library installed"
-- | Get the version of the system compiler, if available
getSystemCompiler :: (MonadIO m, MonadLogger m, MonadBaseControl IO m, MonadCatch m) => EnvOverride -> WhichCompiler -> m (Maybe (CompilerVersion, Arch))
getSystemCompiler menv wc = do
let exeName = case wc of
Ghc -> "ghc"
Ghcjs -> "ghcjs"
exists <- doesExecutableExist menv exeName
if exists
then do
eres <- tryProcessStdout Nothing menv exeName ["--info"]
let minfo = do
Right bs <- Just eres
pairs <- readMay $ S8.unpack bs :: Maybe [(String, String)]
version <- lookup "Project version" pairs >>= parseVersionFromString
arch <- lookup "Target platform" pairs >>= simpleParse . takeWhile (/= '-')
return (version, arch)
case (wc, minfo) of
(Ghc, Just (version, arch)) -> return (Just (GhcVersion version, arch))
(Ghcjs, Just (_, arch)) -> do
eversion <- tryAny $ getCompilerVersion menv Ghcjs
case eversion of
Left _ -> return Nothing
Right version -> return (Just (version, arch))
(_, Nothing) -> return Nothing
else return Nothing
-- | Download the most recent SetupInfo
getSetupInfo
:: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader env m, HasConfig env)
=> String -> Manager -> m SetupInfo
getSetupInfo stackSetupYaml manager = do
config <- asks getConfig
setupInfos <-
mapM
loadSetupInfo
(SetupInfoFileOrURL stackSetupYaml :
configSetupInfoLocations config)
return (mconcat setupInfos)
where
loadSetupInfo (SetupInfoInline si) = return si
loadSetupInfo (SetupInfoFileOrURL urlOrFile) = do
bs <-
case parseUrl urlOrFile of
Just req -> do
bss <-
liftIO $
flip runReaderT manager $
withResponse req $
\res ->
responseBody res $$ CL.consume
return $ S8.concat bss
Nothing -> liftIO $ S.readFile urlOrFile
(si,warnings) <- either throwM return (Yaml.decodeEither' bs)
when (urlOrFile /= defaultStackSetupYaml) $
logJSONWarnings urlOrFile warnings
return si
getInstalledTool :: [Tool] -- ^ already installed
-> PackageName -- ^ package to find
-> (Version -> Bool) -- ^ which versions are acceptable
-> Maybe Tool
getInstalledTool installed name goodVersion =
if null available
then Nothing
else Just $ Tool $ maximumBy (comparing packageIdentifierVersion) available
where
available = mapMaybe goodPackage installed
goodPackage (Tool pi') =
if packageIdentifierName pi' == name &&
goodVersion (packageIdentifierVersion pi')
then Just pi'
else Nothing
goodPackage _ = Nothing
getInstalledGhcjs :: [Tool]
-> (CompilerVersion -> Bool)
-> Maybe Tool
getInstalledGhcjs installed goodVersion =
if null available
then Nothing
else Just $ ToolGhcjs $ maximum available
where
available = mapMaybe goodPackage installed
goodPackage (ToolGhcjs cv) = if goodVersion cv then Just cv else Nothing
goodPackage _ = Nothing
downloadAndInstallTool :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Path Abs Dir
-> SetupInfo
-> DownloadInfo
-> Tool
-> (SetupInfo -> Path Abs File -> ArchiveType -> Path Abs Dir -> m ())
-> m Tool
downloadAndInstallTool programsDir si downloadInfo tool installer = do
(file, at) <- downloadFromInfo programsDir downloadInfo tool
dir <- installDir programsDir tool
unmarkInstalled programsDir tool
installer si file at dir
markInstalled programsDir tool
return tool
downloadAndInstallCompiler :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasGHCVariant env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> SetupInfo
-> CompilerVersion
-> VersionCheck
-> Maybe String
-> m Tool
downloadAndInstallCompiler si wanted@(GhcVersion{}) versionCheck mbindistURL = do
ghcVariant <- asks getGHCVariant
(selectedVersion, downloadInfo) <- case mbindistURL of
Just bindistURL -> do
case ghcVariant of
GHCCustom _ -> return ()
_ -> throwM RequireCustomGHCVariant
case wanted of
GhcVersion version ->
return (version, DownloadInfo (T.pack bindistURL) Nothing Nothing)
_ ->
throwM WantedMustBeGHC
_ -> do
ghcKey <- getGhcKey
case Map.lookup ghcKey $ siGHCs si of
Nothing -> throwM $ UnknownOSKey ghcKey
Just pairs -> getWantedCompilerInfo ghcKey versionCheck wanted GhcVersion pairs
config <- asks getConfig
let installer =
case configPlatform config of
Platform _ Cabal.Windows -> installGHCWindows selectedVersion
_ -> installGHCPosix selectedVersion
$logInfo $
"Preparing to install GHC" <>
(case ghcVariant of
GHCStandard -> ""
v -> " (" <> T.pack (ghcVariantName v) <> ")") <>
" to an isolated location."
$logInfo "This will not interfere with any system-level installation."
ghcPkgName <- parsePackageNameFromString ("ghc" ++ ghcVariantSuffix ghcVariant)
let tool = Tool $ PackageIdentifier ghcPkgName selectedVersion
downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer
downloadAndInstallCompiler si wanted versionCheck _mbindistUrl = do
config <- asks getConfig
ghcVariant <- asks getGHCVariant
case ghcVariant of
GHCStandard -> return ()
_ -> throwM GHCJSRequiresStandardVariant
(selectedVersion, downloadInfo) <- case Map.lookup "source" $ siGHCJSs si of
Nothing -> throwM $ UnknownOSKey "source"
Just pairs -> getWantedCompilerInfo "source" versionCheck wanted id pairs
$logInfo "Preparing to install GHCJS to an isolated location."
$logInfo "This will not interfere with any system-level installation."
let tool = ToolGhcjs selectedVersion
installer = installGHCJS $ case selectedVersion of
GhcjsVersion version _ -> version
_ -> error "Invariant violated: expected ghcjs version in downloadAndInstallCompiler."
downloadAndInstallTool (configLocalPrograms config) si downloadInfo tool installer
getWantedCompilerInfo :: (Ord k, MonadThrow m)
=> Text
-> VersionCheck
-> CompilerVersion
-> (k -> CompilerVersion)
-> Map k a
-> m (k, a)
getWantedCompilerInfo key versionCheck wanted toCV pairs =
case mpair of
Just pair -> return pair
Nothing -> throwM $ UnknownCompilerVersion key wanted (map toCV (Map.keys pairs))
where
mpair =
listToMaybe $
sortBy (flip (comparing fst)) $
filter (isWantedCompiler versionCheck wanted . toCV . fst) (Map.toList pairs)
getGhcKey :: (MonadReader env m, MonadThrow m, HasPlatform env, HasGHCVariant env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)
=> m Text
getGhcKey = do
ghcVariant <- asks getGHCVariant
platform <- asks getPlatform
osKey <- getOSKey platform
return $ osKey <> T.pack (ghcVariantSuffix ghcVariant)
getOSKey :: (MonadReader env m, MonadThrow m, HasPlatform env, MonadLogger m, MonadIO m, MonadCatch m, MonadBaseControl IO m)
=> Platform -> m Text
getOSKey platform =
case platform of
Platform I386 Cabal.Linux -> return "linux32"
Platform X86_64 Cabal.Linux -> return "linux64"
Platform I386 Cabal.OSX -> return "macosx"
Platform X86_64 Cabal.OSX -> return "macosx"
Platform I386 Cabal.FreeBSD -> return "freebsd32"
Platform X86_64 Cabal.FreeBSD -> return "freebsd64"
Platform I386 Cabal.OpenBSD -> return "openbsd32"
Platform X86_64 Cabal.OpenBSD -> return "openbsd64"
Platform I386 Cabal.Windows -> return "windows32"
Platform X86_64 Cabal.Windows -> return "windows64"
Platform arch os -> throwM $ UnsupportedSetupCombo os arch
downloadFromInfo
:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Path Abs Dir -> DownloadInfo -> Tool -> m (Path Abs File, ArchiveType)
downloadFromInfo programsDir downloadInfo tool = do
at <-
case extension of
".tar.xz" -> return TarXz
".tar.bz2" -> return TarBz2
".tar.gz" -> return TarGz
".7z.exe" -> return SevenZ
_ -> error $ "Unknown extension for url: " ++ T.unpack url
relfile <- parseRelFile $ toolString tool ++ extension
let path = programsDir </> relfile
chattyDownload (T.pack (toolString tool)) downloadInfo path
return (path, at)
where
url = downloadInfoUrl downloadInfo
extension =
loop $ T.unpack url
where
loop fp
| ext `elem` [".tar", ".bz2", ".xz", ".exe", ".7z", ".gz"] = loop fp' ++ ext
| otherwise = ""
where
(fp', ext) = FP.splitExtension fp
data ArchiveType
= TarBz2
| TarXz
| TarGz
| SevenZ
installGHCPosix :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> Version
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installGHCPosix version _ archiveFile archiveType destDir = do
platform <- asks getPlatform
menv0 <- getMinimalEnvOverride
menv <- mkEnvOverride platform (removeHaskellEnvVars (unEnvOverride menv0))
$logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))
zipTool' <-
case archiveType of
TarXz -> return "xz"
TarBz2 -> return "bzip2"
TarGz -> return "gzip"
SevenZ -> error "Don't know how to deal with .7z files on non-Windows"
(zipTool, makeTool, tarTool) <- checkDependencies $ (,,)
<$> checkDependency zipTool'
<*> (checkDependency "gmake" <|> checkDependency "make")
<*> checkDependency "tar"
$logDebug $ "ziptool: " <> T.pack zipTool
$logDebug $ "make: " <> T.pack makeTool
$logDebug $ "tar: " <> T.pack tarTool
withCanonicalizedSystemTempDirectory "stack-setup" $ \root -> do
dir <-
liftM (root </>) $
parseRelDir $
"ghc-" ++ versionString version
$logSticky $ T.concat ["Unpacking GHC into ", T.pack . toFilePath $ root, " ..."]
$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)
readInNull root tarTool menv ["xf", toFilePath archiveFile] Nothing
$logSticky "Configuring GHC ..."
readInNull dir (toFilePath $ dir </> $(mkRelFile "configure"))
menv ["--prefix=" ++ toFilePath destDir] Nothing
$logSticky "Installing GHC ..."
readInNull dir makeTool menv ["install"] Nothing
$logStickyDone $ "Installed GHC."
$logDebug $ "GHC installed to " <> T.pack (toFilePath destDir)
installGHCJS :: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadBaseControl IO m)
=> Version
-> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installGHCJS version si archiveFile archiveType destDir = do
platform <- asks getPlatform
menv0 <- getMinimalEnvOverride
-- This ensures that locking is disabled for the invocations of
-- stack below.
let removeLockVar = Map.delete "STACK_LOCK"
menv <- mkEnvOverride platform (removeLockVar (removeHaskellEnvVars (unEnvOverride menv0)))
$logDebug $ "menv = " <> T.pack (show (unEnvOverride menv))
-- NOTE: this is a bit of a hack - instead of using a temp
-- directory, leave the unpacked source tarball in the destination
-- directory. This way, the absolute paths in the wrapper scripts
-- will point to executables that exist in
-- src/.stack-work/install/... - see
-- https://github.com/commercialhaskell/stack/issues/1016
--
-- This is also used by 'ensureGhcjsBooted', because it can use the
-- environment of the stack.yaml which came with ghcjs, in order to
-- install cabal-install. This lets us also fix the version of
-- cabal-install used.
let unpackDir = destDir </> $(mkRelDir "src")
tarComponent <- parseRelDir ("ghcjs-" ++ versionString version)
runUnpack <- case platform of
Platform _ Cabal.Windows -> return $
withUnpackedTarball7z "GHCJS" si archiveFile archiveType tarComponent unpackDir
_ -> do
zipTool' <-
case archiveType of
TarXz -> return "xz"
TarBz2 -> return "bzip2"
TarGz -> return "gzip"
SevenZ -> error "Don't know how to deal with .7z files on non-Windows"
(zipTool, tarTool) <- checkDependencies $ (,)
<$> checkDependency zipTool'
<*> checkDependency "tar"
$logDebug $ "ziptool: " <> T.pack zipTool
$logDebug $ "tar: " <> T.pack tarTool
return $ do
removeTreeIfExists unpackDir
readInNull destDir tarTool menv ["xf", toFilePath archiveFile] Nothing
renameDir (destDir </> tarComponent) unpackDir
$logSticky $ T.concat ["Unpacking GHCJS into ", T.pack . toFilePath $ unpackDir, " ..."]
$logDebug $ "Unpacking " <> T.pack (toFilePath archiveFile)
runUnpack
$logSticky "Setting up GHCJS build environment"
let stackYaml = unpackDir </> $(mkRelFile "stack.yaml")
destBinDir = destDir </> $(mkRelDir "bin")
createTree destBinDir
envConfig <- loadGhcjsEnvConfig stackYaml destBinDir
-- On windows we need to copy options files out of the install dir. Argh!
-- This is done before the build, so that if it fails, things fail
-- earlier.
mwindowsInstallDir <- case platform of
Platform _ Cabal.Windows ->
liftM Just $ runInnerStackT envConfig installationRootLocal
_ -> return Nothing
$logSticky "Installing GHCJS (this will take a long time) ..."
runInnerStackT envConfig $
build (\_ -> return ()) Nothing defaultBuildOpts { boptsInstallExes = True }
-- Copy over *.options files needed on windows.
forM_ mwindowsInstallDir $ \dir -> do
(_, files) <- listDirectory (dir </> $(mkRelDir "bin"))
forM_ (filter ((".options" `isSuffixOf`). toFilePath) files) $ \optionsFile -> do
let dest = destDir </> $(mkRelDir "bin") </> filename optionsFile
removeFileIfExists dest
copyFile optionsFile dest
$logStickyDone "Installed GHCJS."
-- Install the downloaded stack binary distribution
installDockerStackExe
:: (MonadIO m, MonadMask m, MonadLogger m, MonadReader env m, HasConfig env, HasHttpManager env, MonadBaseControl IO m)
=> SetupInfo
-> Path Abs File
-> ArchiveType
-> Path Abs Dir
-> m ()
installDockerStackExe _ archiveFile _ destDir = do
(_,tarTool) <-
checkDependencies $
(,) <$> checkDependency "gzip" <*> checkDependency "tar"
menv <- getMinimalEnvOverride
createTree destDir
readInNull
destDir
tarTool
menv
["xf", toFilePath archiveFile, "--strip-components", "1"]
Nothing
ensureGhcjsBooted :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasConfig env, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)
=> EnvOverride -> CompilerVersion -> Bool -> m ()
ensureGhcjsBooted menv cv shouldBoot = do
eres <- try $ sinkProcessStdout Nothing menv "ghcjs" [] (return ())
case eres of
Right () -> return ()
Left (ReadProcessException _ _ _ err) | "no input files" `S.isInfixOf` LBS.toStrict err ->
return ()
Left (ReadProcessException _ _ _ err) | "ghcjs_boot.completed" `S.isInfixOf` LBS.toStrict err ->
if not shouldBoot then throwM GHCJSNotBooted else do
config <- asks getConfig
destDir <- installDir (configLocalPrograms config) (ToolGhcjs cv)
let stackYaml = destDir </> $(mkRelFile "src/stack.yaml")
-- TODO: Remove 'actualStackYaml' and just use
-- 'stackYaml' for a version after 0.1.6. It's for
-- compatibility with the directories setup used for
-- most of the life of the development branch between
-- 0.1.5 and 0.1.6. See
-- https://github.com/commercialhaskell/stack/issues/749#issuecomment-147382783
-- This only affects the case where GHCJS has been
-- installed with an older version and not yet booted.
stackYamlExists <- fileExists stackYaml
actualStackYaml <- if stackYamlExists then return stackYaml
else case cv of
GhcjsVersion version _ ->
liftM ((destDir </> $(mkRelDir "src")) </>) $
parseRelFile $ "ghcjs-" ++ versionString version ++ "/stack.yaml"
_ -> fail "ensureGhcjsBooted invoked on non GhcjsVersion"
actualStackYamlExists <- fileExists actualStackYaml
unless actualStackYamlExists $
fail "Couldn't find GHCJS stack.yaml in old or new location."
bootGhcjs actualStackYaml destDir
Left err -> throwM err
bootGhcjs :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m, HasHttpManager env, HasTerminal env, HasReExec env, HasLogLevel env, MonadReader env m)
=> Path Abs File -> Path Abs Dir -> m ()
bootGhcjs stackYaml destDir = do
envConfig <- loadGhcjsEnvConfig stackYaml (destDir </> $(mkRelDir "bin"))
menv <- liftIO $ configEnvOverride (getConfig envConfig) defaultEnvSettings
-- Install cabal-install if missing, or if the installed one is old.
mcabal <- getCabalInstallVersion menv
shouldInstallCabal <- case mcabal of
Nothing -> do
$logInfo "No cabal-install binary found for use with GHCJS. Installing a local copy of cabal-install from source."
return True
Just v
| v < $(mkVersion "1.22.4") -> do
$logInfo $
"cabal-install found on PATH is too old to be used for booting GHCJS (version " <>
versionText v <>
"). Installing a local copy of cabal-install from source."
return True
| otherwise -> return False
when shouldInstallCabal $ do
$logSticky "Building cabal-install for use by ghcjs-boot ... "
runInnerStackT envConfig $
build (\_ -> return ())
Nothing
defaultBuildOpts { boptsTargets = ["cabal-install"] }
$logSticky "Booting GHCJS (this will take a long time) ..."
let envSettings = defaultEnvSettings { esIncludeGhcPackagePath = False }
menv' <- liftIO $ configEnvOverride (getConfig envConfig) envSettings
runAndLog Nothing "ghcjs-boot" menv' ["--clean"]
$logStickyDone "GHCJS booted."
-- TODO: something similar is done in Stack.Build.Execute. Create some utilities
-- for this?
runAndLog :: (MonadIO m, MonadBaseControl IO m, MonadLogger m)
=> Maybe (Path Abs Dir) -> String -> EnvOverride -> [String] -> m ()
runAndLog mdir name menv args = liftBaseWith $ \restore -> do
let logLines = CB.lines =$ CL.mapM_ (void . restore . monadLoggerLog $(TH.location >>= liftLoc) "" LevelInfo . toLogStr)
void $ restore $ sinkProcessStderrStdout mdir menv name args logLines logLines
loadGhcjsEnvConfig :: (MonadIO m, HasHttpManager r, MonadReader r m, HasTerminal r, HasReExec r, HasLogLevel r)
=> Path Abs File -> Path b t -> m EnvConfig
loadGhcjsEnvConfig stackYaml binPath = runInnerStackLoggingT $ do
lc <- loadConfig
(mempty
{ configMonoidInstallGHC = Just True
, configMonoidLocalBinPath = Just (toFilePath binPath)
})
(Just stackYaml)
Nothing
bconfig <- lcLoadBuildConfig lc Nothing
runInnerStackT bconfig $ setupEnv Nothing
getCabalInstallVersion :: (MonadIO m, MonadBaseControl IO m, MonadLogger m, MonadCatch m)
=> EnvOverride -> m (Maybe Version)
getCabalInstallVersion menv = do
ebs <- tryProcessStdout Nothing menv "cabal" ["--numeric-version"]
case ebs of
Left _ -> return Nothing