From 284542509988a54c003c958cf8f638a847cd3631 Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Sat, 21 May 2022 22:54:18 +0200 Subject: [PATCH] Restructure modules --- app/ghcup/BrickMain.hs | 7 +- app/ghcup/GHCup/OptParse/ChangeLog.hs | 8 +- app/ghcup/GHCup/OptParse/Common.hs | 8 +- app/ghcup/GHCup/OptParse/Compile.hs | 5 +- app/ghcup/GHCup/OptParse/Config.hs | 7 +- app/ghcup/GHCup/OptParse/DInfo.hs | 6 +- app/ghcup/GHCup/OptParse/GC.hs | 4 +- app/ghcup/GHCup/OptParse/Install.hs | 4 +- app/ghcup/GHCup/OptParse/List.hs | 2 +- app/ghcup/GHCup/OptParse/Nuke.hs | 2 +- app/ghcup/GHCup/OptParse/Prefetch.hs | 6 +- app/ghcup/GHCup/OptParse/Rm.hs | 4 +- app/ghcup/GHCup/OptParse/Run.hs | 11 +- app/ghcup/GHCup/OptParse/Set.hs | 4 +- app/ghcup/GHCup/OptParse/ToolRequirements.hs | 6 +- app/ghcup/GHCup/OptParse/UnSet.hs | 4 +- app/ghcup/GHCup/OptParse/Upgrade.hs | 3 +- app/ghcup/GHCup/OptParse/Whereis.hs | 4 +- app/ghcup/Main.hs | 6 +- ghcup.cabal | 40 +- lib/GHCup.hs | 2508 +---------------- lib/GHCup/Cabal.hs | 279 ++ lib/GHCup/Download.hs | 7 +- lib/GHCup/Download/IOStreams.hs | 2 +- lib/GHCup/Download/Utils.hs | 2 +- lib/GHCup/GHC.hs | 1078 +++++++ lib/GHCup/HLS.hs | 620 ++++ lib/GHCup/List.hs | 410 +++ lib/GHCup/Platform.hs | 8 +- lib/GHCup/Prelude.hs | 54 + lib/GHCup/{Utils => Prelude}/File.hs | 112 +- lib/GHCup/Prelude/File/Posix.hs | 324 +++ .../{Utils => Prelude}/File/Posix/Foreign.hsc | 2 +- .../File/Posix/Traversals.hs | 4 +- .../File/Common.hs => Prelude/File/Search.hs} | 19 +- lib/GHCup/{Utils => Prelude}/File/Windows.hs | 239 +- .../{Utils/Prelude.hs => Prelude/Internal.hs} | 93 +- lib/GHCup/Prelude/Logger.hs | 61 + .../Logger.hs => Prelude/Logger/Internal.hs} | 37 +- lib/GHCup/{Utils => Prelude}/MegaParsec.hs | 2 +- lib/GHCup/{Utils => Prelude}/Posix.hs | 7 +- lib/GHCup/Prelude/Process.hs | 25 + .../{Utils/File => Prelude/Process}/Posix.hs | 297 +- lib/GHCup/Prelude/Process/Windows.hs | 251 ++ lib/GHCup/{Utils => Prelude}/String/QQ.hs | 2 +- lib/GHCup/{Utils => Prelude}/Version/QQ.hs | 2 +- lib/GHCup/{Utils => Prelude}/Windows.hs | 7 +- lib/GHCup/Stack.hs | 278 ++ lib/GHCup/Types.hs | 3 +- lib/GHCup/Types/JSON.hs | 2 +- lib/GHCup/Utils.hs | 163 +- lib/GHCup/Utils.hs-boot | 4 - lib/GHCup/Utils/Dirs.hs | 43 +- lib/GHCup/Utils/File.hs-boot | 14 - lib/GHCup/Utils/File/Common.hs-boot | 5 - lib/GHCup/Utils/Logger.hs-boot | 19 - lib/GHCup/Utils/Prelude/Posix.hs | 8 - lib/GHCup/Utils/Prelude/Windows.hs | 6 - lib/GHCup/Version.hs | 68 +- test/GHCup/Utils/FileSpec.hs | 2 +- 60 files changed, 3857 insertions(+), 3351 deletions(-) create mode 100644 lib/GHCup/Cabal.hs create mode 100644 lib/GHCup/GHC.hs create mode 100644 lib/GHCup/HLS.hs create mode 100644 lib/GHCup/List.hs create mode 100644 lib/GHCup/Prelude.hs rename lib/GHCup/{Utils => Prelude}/File.hs (79%) create mode 100644 lib/GHCup/Prelude/File/Posix.hs rename lib/GHCup/{Utils => Prelude}/File/Posix/Foreign.hsc (97%) rename lib/GHCup/{Utils => Prelude}/File/Posix/Traversals.hs (96%) rename lib/GHCup/{Utils/File/Common.hs => Prelude/File/Search.hs} (86%) rename lib/GHCup/{Utils => Prelude}/File/Windows.hs (52%) rename lib/GHCup/{Utils/Prelude.hs => Prelude/Internal.hs} (80%) create mode 100644 lib/GHCup/Prelude/Logger.hs rename lib/GHCup/{Utils/Logger.hs => Prelude/Logger/Internal.hs} (70%) rename lib/GHCup/{Utils => Prelude}/MegaParsec.hs (98%) rename lib/GHCup/{Utils => Prelude}/Posix.hs (78%) create mode 100644 lib/GHCup/Prelude/Process.hs rename lib/GHCup/{Utils/File => Prelude/Process}/Posix.hs (54%) create mode 100644 lib/GHCup/Prelude/Process/Windows.hs rename lib/GHCup/{Utils => Prelude}/String/QQ.hs (97%) rename lib/GHCup/{Utils => Prelude}/Version/QQ.hs (98%) rename lib/GHCup/{Utils => Prelude}/Windows.hs (93%) create mode 100644 lib/GHCup/Stack.hs delete mode 100644 lib/GHCup/Utils.hs-boot delete mode 100644 lib/GHCup/Utils/File.hs-boot delete mode 100644 lib/GHCup/Utils/File/Common.hs-boot delete mode 100644 lib/GHCup/Utils/Logger.hs-boot delete mode 100644 lib/GHCup/Utils/Prelude/Posix.hs delete mode 100644 lib/GHCup/Utils/Prelude/Windows.hs diff --git a/app/ghcup/BrickMain.hs b/app/ghcup/BrickMain.hs index aae119f..f1fb54d 100644 --- a/app/ghcup/BrickMain.hs +++ b/app/ghcup/BrickMain.hs @@ -13,9 +13,10 @@ import GHCup.Errors import GHCup.Types.Optics ( getDirs ) import GHCup.Types hiding ( LeanAppState(..) ) import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.Prelude ( decUTF8Safe ) -import GHCup.Utils.File +import GHCup.Prelude ( decUTF8Safe ) +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process import Brick import Brick.Widgets.Border diff --git a/app/ghcup/GHCup/OptParse/ChangeLog.hs b/app/ghcup/GHCup/OptParse/ChangeLog.hs index 7c8db99..652d850 100644 --- a/app/ghcup/GHCup/OptParse/ChangeLog.hs +++ b/app/ghcup/GHCup/OptParse/ChangeLog.hs @@ -12,9 +12,11 @@ module GHCup.OptParse.ChangeLog where import GHCup.Types -import GHCup.Utils.Logger import GHCup.OptParse.Common -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Process (exec) #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -34,8 +36,6 @@ import GHCup.Types.Optics import GHCup.Utils import Data.Versions import URI.ByteString (serializeURIRef') -import GHCup.Utils.Prelude -import GHCup.Utils.File (exec) import Data.Char (toLower) diff --git a/app/ghcup/GHCup/OptParse/Common.hs b/app/ghcup/GHCup/OptParse/Common.hs index a12303a..234fcbb 100644 --- a/app/ghcup/GHCup/OptParse/Common.hs +++ b/app/ghcup/GHCup/OptParse/Common.hs @@ -16,10 +16,10 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude +import GHCup.Prelude +import GHCup.Prelude.Process +import GHCup.Prelude.Logger +import GHCup.Prelude.MegaParsec import Control.DeepSeq import Control.Concurrent diff --git a/app/ghcup/GHCup/OptParse/Compile.hs b/app/ghcup/GHCup/OptParse/Compile.hs index f578c46..5c2019a 100644 --- a/app/ghcup/GHCup/OptParse/Compile.hs +++ b/app/ghcup/GHCup/OptParse/Compile.hs @@ -13,13 +13,12 @@ module GHCup.OptParse.Compile where import GHCup import GHCup.Errors -import GHCup.Utils.File import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.Logger +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Config.hs b/app/ghcup/GHCup/OptParse/Config.hs index c8072ab..c03b849 100644 --- a/app/ghcup/GHCup/OptParse/Config.hs +++ b/app/ghcup/GHCup/OptParse/Config.hs @@ -7,7 +7,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE RankNTypes #-} -{-# LANGUAGE ExplicitForAll #-} module GHCup.OptParse.Config where @@ -15,9 +14,9 @@ module GHCup.OptParse.Config where import GHCup.Errors import GHCup.Types import GHCup.Utils -import GHCup.Utils.Prelude -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/DInfo.hs b/app/ghcup/GHCup/OptParse/DInfo.hs index 46c3d3d..23ced6e 100644 --- a/app/ghcup/GHCup/OptParse/DInfo.hs +++ b/app/ghcup/GHCup/OptParse/DInfo.hs @@ -17,9 +17,10 @@ import GHCup import GHCup.Errors import GHCup.Version import GHCup.Types -import GHCup.Utils.Prelude import GHCup.Utils.Dirs -import GHCup.Utils.Logger +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.Process #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -36,7 +37,6 @@ import Text.PrettyPrint.HughesPJClass ( prettyShow ) import qualified Data.Text as T import Control.Exception.Safe (MonadMask) -import GHCup.Utils.File import Language.Haskell.TH diff --git a/app/ghcup/GHCup/OptParse/GC.hs b/app/ghcup/GHCup/OptParse/GC.hs index e51edbc..d74dd8e 100644 --- a/app/ghcup/GHCup/OptParse/GC.hs +++ b/app/ghcup/GHCup/OptParse/GC.hs @@ -14,8 +14,8 @@ module GHCup.OptParse.GC where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Install.hs b/app/ghcup/GHCup/OptParse/Install.hs index 905ae64..a67b183 100644 --- a/app/ghcup/GHCup/OptParse/Install.hs +++ b/app/ghcup/GHCup/OptParse/Install.hs @@ -19,8 +19,8 @@ import GHCup import GHCup.Errors import GHCup.Types import GHCup.Utils.Dirs -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import Codec.Archive #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/List.hs b/app/ghcup/GHCup/OptParse/List.hs index d1bfc65..72cd2bb 100644 --- a/app/ghcup/GHCup/OptParse/List.hs +++ b/app/ghcup/GHCup/OptParse/List.hs @@ -11,7 +11,7 @@ module GHCup.OptParse.List where import GHCup -import GHCup.Utils.Prelude +import GHCup.Prelude import GHCup.Types import GHCup.OptParse.Common diff --git a/app/ghcup/GHCup/OptParse/Nuke.hs b/app/ghcup/GHCup/OptParse/Nuke.hs index 43bcc7c..84712d4 100644 --- a/app/ghcup/GHCup/OptParse/Nuke.hs +++ b/app/ghcup/GHCup/OptParse/Nuke.hs @@ -14,7 +14,7 @@ module GHCup.OptParse.Nuke where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Prefetch.hs b/app/ghcup/GHCup/OptParse/Prefetch.hs index 7d43c10..221ecef 100644 --- a/app/ghcup/GHCup/OptParse/Prefetch.hs +++ b/app/ghcup/GHCup/OptParse/Prefetch.hs @@ -14,10 +14,10 @@ module GHCup.OptParse.Prefetch where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.File -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Rm.hs b/app/ghcup/GHCup/OptParse/Rm.hs index d91faef..26d7471 100644 --- a/app/ghcup/GHCup/OptParse/Rm.hs +++ b/app/ghcup/GHCup/OptParse/Rm.hs @@ -18,9 +18,9 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.Logger +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.OptParse.Common -import GHCup.Utils.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Run.hs b/app/ghcup/GHCup/OptParse/Run.hs index c5bc1ac..90938f6 100644 --- a/app/ghcup/GHCup/OptParse/Run.hs +++ b/app/ghcup/GHCup/OptParse/Run.hs @@ -10,14 +10,17 @@ module GHCup.OptParse.Run where import GHCup import GHCup.Utils -import GHCup.Utils.Prelude -import GHCup.Utils.File import GHCup.OptParse.Common import GHCup.Errors import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.File +#ifdef IS_WINDOWS +import GHCup.Prelude.Process +#endif +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import Control.Exception.Safe ( MonadMask, MonadCatch ) #if !MIN_VERSION_base(4,13,0) diff --git a/app/ghcup/GHCup/OptParse/Set.hs b/app/ghcup/GHCup/OptParse/Set.hs index 5514085..22f8da6 100644 --- a/app/ghcup/GHCup/OptParse/Set.hs +++ b/app/ghcup/GHCup/OptParse/Set.hs @@ -17,8 +17,8 @@ import GHCup.OptParse.Common import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/ToolRequirements.hs b/app/ghcup/GHCup/OptParse/ToolRequirements.hs index f7048ea..f917a05 100644 --- a/app/ghcup/GHCup/OptParse/ToolRequirements.hs +++ b/app/ghcup/GHCup/OptParse/ToolRequirements.hs @@ -11,8 +11,8 @@ module GHCup.OptParse.ToolRequirements where import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) @@ -30,7 +30,7 @@ import qualified Data.Text.IO as T import Control.Exception.Safe (MonadMask) import GHCup.Types.Optics import GHCup.Platform -import GHCup.Utils.Prelude +import GHCup.Prelude import GHCup.Requirements import System.IO diff --git a/app/ghcup/GHCup/OptParse/UnSet.hs b/app/ghcup/GHCup/OptParse/UnSet.hs index fd3c4fa..08e804d 100644 --- a/app/ghcup/GHCup/OptParse/UnSet.hs +++ b/app/ghcup/GHCup/OptParse/UnSet.hs @@ -16,8 +16,8 @@ module GHCup.OptParse.UnSet where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Upgrade.hs b/app/ghcup/GHCup/OptParse/Upgrade.hs index bceb4dc..193d178 100644 --- a/app/ghcup/GHCup/OptParse/Upgrade.hs +++ b/app/ghcup/GHCup/OptParse/Upgrade.hs @@ -14,7 +14,8 @@ module GHCup.OptParse.Upgrade where import GHCup import GHCup.Errors import GHCup.Types -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.Logger #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/GHCup/OptParse/Whereis.hs b/app/ghcup/GHCup/OptParse/Whereis.hs index 89ef8ed..ed86697 100644 --- a/app/ghcup/GHCup/OptParse/Whereis.hs +++ b/app/ghcup/GHCup/OptParse/Whereis.hs @@ -18,8 +18,8 @@ import GHCup.Errors import GHCup.OptParse.Common import GHCup.Types import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.String.QQ +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index df636d7..ee2cf08 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -22,9 +22,9 @@ import GHCup.Platform import GHCup.Types import GHCup.Types.Optics hiding ( toolRequirements ) import GHCup.Utils -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.Version import Cabal.Plan ( findPlanJson, SearchPlanJson(..) ) diff --git a/ghcup.cabal b/ghcup.cabal index 8484a50..ee0f476 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -44,31 +44,39 @@ flag internal-downloader manual: True flag no-exe - description: Don't build any executables + description: Don't build any executables default: False manual: True library exposed-modules: GHCup + GHCup.Cabal GHCup.Download GHCup.Download.Utils GHCup.Errors + GHCup.GHC + GHCup.HLS + GHCup.List GHCup.Platform + GHCup.Prelude + GHCup.Prelude.File + GHCup.Prelude.File.Search + GHCup.Prelude.Internal + GHCup.Prelude.Logger + GHCup.Prelude.Logger.Internal + GHCup.Prelude.MegaParsec + GHCup.Prelude.Process + GHCup.Prelude.String.QQ + GHCup.Prelude.Version.QQ GHCup.Requirements + GHCup.Stack GHCup.Types GHCup.Types.JSON GHCup.Types.JSON.Utils GHCup.Types.Optics GHCup.Utils GHCup.Utils.Dirs - GHCup.Utils.File - GHCup.Utils.File.Common - GHCup.Utils.Logger - GHCup.Utils.MegaParsec - GHCup.Utils.Prelude - GHCup.Utils.String.QQ - GHCup.Utils.Version.QQ GHCup.Version hs-source-dirs: lib @@ -155,9 +163,9 @@ library if os(windows) cpp-options: -DIS_WINDOWS other-modules: - GHCup.Utils.File.Windows - GHCup.Utils.Prelude.Windows - GHCup.Utils.Windows + GHCup.Prelude.File.Windows + GHCup.Prelude.Process.Windows + GHCup.Prelude.Windows build-depends: , bzlib @@ -166,11 +174,11 @@ library else other-modules: - GHCup.Utils.File.Posix - GHCup.Utils.File.Posix.Foreign - GHCup.Utils.File.Posix.Traversals - GHCup.Utils.Posix - GHCup.Utils.Prelude.Posix + GHCup.Prelude.File.Posix + GHCup.Prelude.File.Posix.Foreign + GHCup.Prelude.File.Posix.Traversals + GHCup.Prelude.Posix + GHCup.Prelude.Process.Posix c-sources: cbits/dirutils.c build-depends: diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 60a963f..ffeca3a 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -6,7 +6,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-| Module : GHCup @@ -23,9 +22,21 @@ and so on. These are the entry points. -} -module GHCup where +module GHCup ( + module GHCup, + module GHCup.Cabal, + module GHCup.GHC, + module GHCup.HLS, + module GHCup.Stack, + module GHCup.List +) where +import GHCup.Cabal +import GHCup.GHC +import GHCup.HLS +import GHCup.Stack +import GHCup.List import GHCup.Download import GHCup.Errors import GHCup.Platform @@ -33,14 +44,12 @@ import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics import GHCup.Utils -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ -import GHCup.Utils.Version.QQ +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.String.QQ import GHCup.Version -import Codec.Archive ( ArchiveResult ) import Control.Applicative import Control.Exception.Safe import Control.Monad @@ -54,46 +63,22 @@ import Data.ByteString ( ByteString ) import Data.Either import Data.List import Data.Maybe -import Data.List.NonEmpty ( NonEmpty((:|)) ) -import Data.String ( fromString ) -import Data.Text ( Text ) -import Data.Time.Clock -import Data.Time.Format.ISO8601 import Data.Versions hiding ( patch ) -import Distribution.Types.Version hiding ( Version ) -import Distribution.Types.PackageId -import Distribution.Types.PackageDescription -import Distribution.Types.GenericPackageDescription -import Distribution.PackageDescription.Parsec import GHC.IO.Exception import Haskus.Utils.Variant.Excepts -import Language.Haskell.TH -import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) import Optics import Prelude hiding ( abs , writeFile ) -import Safe hiding ( at ) import System.Environment import System.FilePath import System.IO.Error -import Text.PrettyPrint.HughesPJClass ( prettyShow ) import Text.Regex.Posix -import URI.ByteString -import qualified Crypto.Hash.SHA256 as SHA256 -import qualified Data.List.NonEmpty as NE -import qualified Data.ByteString.Base16 as B16 -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map import qualified Data.Text as T -import qualified Data.Text.IO as T -import qualified Data.Text.Encoding as E -import qualified Text.Megaparsec as MP import qualified Streamly.Prelude as S -import GHCup.Utils.MegaParsec -import Control.Concurrent (threadDelay) + + --------------------- @@ -130,1876 +115,14 @@ fetchToolBindist v t mfp = do liftE $ downloadCached' dlinfo Nothing mfp -fetchGHCSrc :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => Version - -> Maybe FilePath - -> Excepts - '[ DigestError - , GPGError - , DownloadFailed - , NoDownload - ] - m - FilePath -fetchGHCSrc v mfp = do - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - dlInfo <- - preview (ix GHC % ix v % viSourceDL % _Just) dls - ?? NoDownload - liftE $ downloadCached' dlInfo Nothing mfp + ------------ + --[ Nuke ]-- + ------------ - ------------------------- - --[ Tool installation ]-- - ------------------------- --- | Like 'installGHCBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installGHCBindist :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => DownloadInfo -- ^ where/how to download - -> Version -- ^ the version to install - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - , UninstallFailed - , MergeFileTreeError - ] - m - () -installGHCBindist dlinfo ver installDir forceInstall = do - let tver = mkTVer ver - - lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver - - regularGHCInstalled <- lift $ checkIfToolInstalled GHC ver - - if - | not forceInstall - , regularGHCInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled GHC ver - - | forceInstall - , regularGHCInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed GHC version first!" - liftE $ rmGHCVer tver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - - toolchainSanityChecks - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall - GHCupInternal -> do -- regular install - -- prepare paths - ghcdir <- lift $ ghcupGHCDir tver - - liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall - - -- make symlinks & stuff when regular install, - liftE $ postGHCInstall tver - - where - toolchainSanityChecks = do - r <- forM ["CC", "LD"] (liftIO . lookupEnv) - case catMaybes r of - [] -> pure () - _ -> do - lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker" - <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" - <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall." - - --- | Install a packed GHC distribution. This only deals with unpacking and the GHC --- build system and nothing else. -installPackedGHC :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasSettings env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadFail m - , MonadResource m - ) - => FilePath -- ^ Path to the packed GHC bindist - -> Maybe TarDir -- ^ Subdir of the archive - -> InstallDirResolved - -> Version -- ^ The GHC version - -> Bool -- ^ Force install - -> Excepts - '[ BuildFailed - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - , MergeFileTreeError - ] m () -installPackedGHC dl msubdir inst ver forceInstall = do - PlatformRequest {..} <- lift getPlatformReq - - unless forceInstall - (liftE $ installDestSanityCheck inst) - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - msubdir - - liftE $ runBuildAction tmpUnpack - (installUnpackedGHC workdir inst ver forceInstall) - - --- | Install an unpacked GHC distribution. This only deals with the GHC --- build system and nothing else. -installUnpackedGHC :: ( MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadMask m - , MonadResource m - , MonadFail m - ) - => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) - -> InstallDirResolved -- ^ Path to install to - -> Version -- ^ The GHC version - -> Bool -- ^ Force install - -> Excepts '[ProcessError, MergeFileTreeError] m () -installUnpackedGHC path inst ver forceInstall - | isWindows = do - lift $ logInfo "Installing GHC (this may take a while)" - -- Windows bindists are relocatable and don't need - -- to run configure. - -- We also must make sure to preserve mtime to not confuse ghc-pkg. - liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do - mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) - when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest - liftIO $ moveFilePortable source dest - forM_ mtime $ liftIO . setModificationTime dest - | otherwise = do - PlatformRequest {..} <- lift getPlatformReq - - let alpineArgs - | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform - = ["--disable-ld-override"] - | otherwise - = [] - - lift $ logInfo "Installing GHC (this may take a while)" - lEM $ execLogged "sh" - ("./configure" : ("--prefix=" <> fromInstallDir inst) - : alpineArgs - ) - (Just $ fromGHCupPath path) - "ghc-configure" - Nothing - tmpInstallDest <- lift withGHCupTmpDir - lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) - liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) - inst - GHC - (mkTVer ver) - (\f t -> liftIO $ do - mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) - install f t (not forceInstall) - forM_ mtime $ setModificationTime t) - - pure () - - --- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the --- following symlinks in @~\/.ghcup\/bin@: --- --- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ --- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) -installGHCBin :: ( MonadFail m - , MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - ) - => Version -- ^ the version to install - -> InstallDir - -> Bool -- ^ force install - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , DirNotEmpty - , ArchiveResult - , ProcessError - , UninstallFailed - , MergeFileTreeError - ] - m - () -installGHCBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo GHC ver - liftE $ installGHCBindist dlinfo ver installDir forceInstall - - --- | Like 'installCabalBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installCabalBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installCabalBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - -- check if we already have a regular cabal already installed - regularCabalInstalled <- lift $ checkIfToolInstalled Cabal ver - - if - | not forceInstall - , regularCabalInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled Cabal ver - - | forceInstall - , regularCabalInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed version first!" - liftE $ rmCabalVer ver - - | otherwise -> pure () - - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir - liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - - GHCupInternal -> do -- regular install - liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall - - --- | Install an unpacked cabal distribution.Symbol -installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) - => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool -- ^ Force Install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installCabalUnpacked path inst ver forceInstall = do - lift $ logInfo "Installing cabal" - let cabalFile = "cabal" - liftIO $ createDirRecursive' (fromInstallDir inst) - let destFileName = cabalFile - <> (case inst of - IsolateDirResolved _ -> "" - _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - let destPath = fromInstallDir inst destFileName - - copyFileE - (path cabalFile <> exeExt) - destPath - (not forceInstall) - lift $ chmod_755 destPath - --- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and --- creates a default @cabal -> cabal-x.y.z.q@ symlink for --- the latest installed version. -installCabalBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installCabalBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo Cabal ver - installCabalBindist dlinfo ver installDir forceInstall - - --- | Like 'installHLSBin, except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installHLSBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir -- ^ isolated install path, if user passed any - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - , ProcessError - , DirNotEmpty - , UninstallFailed - , MergeFileTreeError - ] - m - () -installHLSBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install hls version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - regularHLSInstalled <- lift $ checkIfToolInstalled HLS ver - - if - | not forceInstall - , regularHLSInstalled - , GHCupInternal <- installDir -> do -- regular install - throwE $ AlreadyInstalled HLS ver - - | forceInstall - , regularHLSInstalled - , GHCupInternal <- installDir -> do -- regular forced install - lift $ logInfo "Removing the currently installed version of HLS before force installing!" - liftE $ rmHLSVer ver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - legacy <- liftIO $ isLegacyHLSBindist workdir - - if - | not forceInstall - , not legacy - , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) - | otherwise -> pure () - - case installDir of - IsolateDir isoDir -> do - lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - if legacy - then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall - else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - - GHCupInternal -> do - if legacy - then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall - else do - inst <- ghcupHLSDir ver - liftE $ runBuildAction tmpUnpack - $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall - liftE $ setHLS ver SetHLS_XYZ Nothing - - -isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist - -> IO Bool -isLegacyHLSBindist path = do - not <$> doesFileExist (path "GNUmakefile") - --- | Install an unpacked hls distribution. -installHLSUnpacked :: ( MonadMask m - , MonadUnliftIO m - , MonadReader env m - , MonadFail m - , HasLog env - , HasDirs env - , HasSettings env - , MonadCatch m - , MonadIO m - , MonadResource m - , HasPlatformReq env - ) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool - -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m () -installHLSUnpacked path inst ver forceInstall = do - PlatformRequest { .. } <- lift getPlatformReq - lift $ logInfo "Installing HLS" - tmpInstallDest <- lift withGHCupTmpDir - lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) - liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) - inst - HLS - (mkTVer ver) - (\f t -> liftIO $ do - mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) - install f t (not forceInstall) - forM_ mtime $ setModificationTime t) - --- | Install an unpacked hls distribution (legacy). -installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) - => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) - -> InstallDirResolved -- ^ Path to install to - -> Version - -> Bool -- ^ is it a force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installHLSUnpackedLegacy path installDir ver forceInstall = do - lift $ logInfo "Installing HLS" - liftIO $ createDirRecursive' (fromInstallDir installDir) - - -- install haskell-language-server- - bins@(_:_) <- liftIO $ findFiles - path - (makeRegexOpts compExtended - execBlank - ([s|^haskell-language-server-[0-9].*$|] :: ByteString) - ) - forM_ bins $ \f -> do - let toF = dropSuffix exeExt f - <> (case installDir of - IsolateDirResolved _ -> "" - _ -> ("~" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - - let srcPath = path f - let destPath = fromInstallDir installDir toF - - -- destination could be an existing symlink - -- for new make-based HLSes - liftIO $ rmFileForce destPath - - copyFileE - srcPath - destPath - (not forceInstall) - lift $ chmod_755 destPath - - -- install haskell-language-server-wrapper - let wrapper = "haskell-language-server-wrapper" - toF = wrapper - <> (case installDir of - IsolateDirResolved _ -> "" - _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - srcWrapperPath = path wrapper <> exeExt - destWrapperPath = fromInstallDir installDir toF - - liftIO $ rmFileForce destWrapperPath - copyFileE - srcWrapperPath - destWrapperPath - (not forceInstall) - - lift $ chmod_755 destWrapperPath - - - --- | Installs hls binaries @haskell-language-server-\@ --- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. -installHLSBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasGHCupInfo env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - , ProcessError - , DirNotEmpty - , UninstallFailed - , MergeFileTreeError - ] - m - () -installHLSBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo HLS ver - installHLSBindist dlinfo ver installDir forceInstall - - -compileHLS :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Either Version GitBranch - -> [Version] - -> Maybe Int - -> Maybe Version - -> InstallDir - -> Maybe (Either FilePath URI) - -> Maybe URI - -> Maybe (Either FilePath [URI]) -- ^ patches - -> [Text] -- ^ additional args to cabal install - -> Excepts '[ NoDownload - , GPGError - , DownloadFailed - , DigestError - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , BuildFailed - , NotInstalled - ] m Version -compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do - PlatformRequest { .. } <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - Dirs { .. } <- lift getDirs - - - (workdir, tver) <- case targetHLS of - -- unpack from version tarball - Left tver -> do - lift $ logDebug $ "Requested to compile: " <> prettyVer tver - - -- download source tarball - dlInfo <- - preview (ix HLS % ix tver % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - - pure (workdir, tver) - - -- clone from git - Right GitBranch{..} -> do - tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do - let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo - lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" - lEM $ git [ "init" ] - lEM $ git [ "remote" - , "add" - , "origin" - , fromString rep ] - - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args - - lEM $ git [ "checkout", "FETCH_HEAD" ] - (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack "haskell-language-server.cabal")) - pure . (\c -> Version Nothing c [] Nothing) - . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) - . versionNumbers - . pkgVersion - . package - . packageDescription - $ gpd - - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver - - pure (tmpUnpack, tver) - - -- the version that's installed may differ from the - -- compiled version, so the user can overwrite it - let installVer = fromMaybe tver ov - - liftE $ runBuildAction - workdir - (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do - let tmpInstallDir = fromGHCupPath workdir "out" - liftIO $ createDirRecursive' tmpInstallDir - - -- apply patches - liftE $ applyAnyPatch patches (fromGHCupPath workdir) - - -- set up project files - cp <- case cabalProject of - Just (Left cp) - | isAbsolute cp -> do - copyFileE cp (fromGHCupPath workdir "cabal.project") False - pure "cabal.project" - | otherwise -> pure (takeFileName cp) - Just (Right uri) -> do - tmpUnpack <- lift withGHCupTmpDir - cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False - copyFileE cp (fromGHCupPath workdir "cabal.project") False - pure "cabal.project" - Nothing -> pure "cabal.project" - forM_ cabalProjectLocal $ \uri -> do - tmpUnpack <- lift withGHCupTmpDir - cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False - copyFileE cpl (fromGHCupPath workdir cp <.> "local") False - artifacts <- forM (sort ghcs) $ \ghc -> do - let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) - liftIO $ createDirRecursive' tmpInstallDir - lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc - liftE $ lEM @_ @'[ProcessError] $ - execLogged "cabal" ( [ "v2-install" - , "-w" - , "ghc-" <> T.unpack (prettyVer ghc) - , "--install-method=copy" - ] ++ - maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ - [ "--overwrite-policy=always" - , "--disable-profiling" - , "--disable-tests" - , "--installdir=" <> ghcInstallDir - , "--project-file=" <> cp - ] ++ fmap T.unpack cabalArgs ++ [ - "exe:haskell-language-server" - , "exe:haskell-language-server-wrapper"] - ) - (Just $ fromGHCupPath workdir) - "cabal" - Nothing - pure ghcInstallDir - - forM_ artifacts $ \artifact -> do - liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) - (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) - liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) - (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) - - case installDir of - IsolateDir isoDir -> do - lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir - liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True - GHCupInternal -> do - liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True - ) - - pure installVer - - - --- | Installs stack into @~\/.ghcup\/bin/stack-\@ and --- creates a default @stack -> stack-x.y.z.q@ symlink for --- the latest installed version. -installStackBin :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , HasGHCupInfo env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installStackBin ver installDir forceInstall = do - dlinfo <- liftE $ getDownloadInfo Stack ver - installStackBindist dlinfo ver installDir forceInstall - - --- | Like 'installStackBin', except takes the 'DownloadInfo' as --- argument instead of looking it up from 'GHCupDownloads'. -installStackBindist :: ( MonadMask m - , MonadCatch m - , MonadReader env m - , HasPlatformReq env - , HasDirs env - , HasSettings env - , HasLog env - , MonadResource m - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => DownloadInfo - -> Version - -> InstallDir - -> Bool -- ^ Force install - -> Excepts - '[ AlreadyInstalled - , CopyError - , DigestError - , GPGError - , DownloadFailed - , NoDownload - , NotInstalled - , UnknownArchive - , TarDirDoesNotExist - , ArchiveResult - , FileAlreadyExistsError - ] - m - () -installStackBindist dlinfo ver installDir forceInstall = do - lift $ logDebug $ "Requested to install stack version " <> prettyVer ver - - PlatformRequest {..} <- lift getPlatformReq - Dirs {..} <- lift getDirs - - regularStackInstalled <- lift $ checkIfToolInstalled Stack ver - - if - | not forceInstall - , regularStackInstalled - , GHCupInternal <- installDir -> do - throwE $ AlreadyInstalled Stack ver - - | forceInstall - , regularStackInstalled - , GHCupInternal <- installDir -> do - lift $ logInfo "Removing the currently installed version of Stack first!" - liftE $ rmStackVer ver - - | otherwise -> pure () - - -- download (or use cached version) - dl <- liftE $ downloadCached dlinfo Nothing - - -- unpack - tmpUnpack <- lift withGHCupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - - -- the subdir of the archive where we do the work - workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) - - case installDir of - IsolateDir isoDir -> do -- isolated install - lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir - liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall - GHCupInternal -> do -- regular install - liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall - - --- | Install an unpacked stack distribution. -installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) - => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides) - -> InstallDirResolved - -> Version - -> Bool -- ^ Force install - -> Excepts '[CopyError, FileAlreadyExistsError] m () -installStackUnpacked path installDir ver forceInstall = do - lift $ logInfo "Installing stack" - let stackFile = "stack" - liftIO $ createDirRecursive' (fromInstallDir installDir) - let destFileName = stackFile - <> (case installDir of - IsolateDirResolved _ -> "" - _ -> ("-" <>) . T.unpack . prettyVer $ ver - ) - <> exeExt - destPath = fromInstallDir installDir destFileName - - copyFileE - (fromGHCupPath path stackFile <> exeExt) - destPath - (not forceInstall) - lift $ chmod_755 destPath - - - --------------------- - --[ Set GHC/cabal ]-- - --------------------- - - - --- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends --- on `SetGHC`: --- --- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ --- --- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ --- for 'SetGHCOnly' constructor. -setGHC :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> SetGHC - -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin - -- and don't want mess with other versions - -> Excepts '[NotInstalled] m GHCTargetVersion -setGHC ver sghc mBinDir = do - let verS = T.unpack $ prettyVer (_tvVersion ver) - ghcdir <- lift $ ghcupGHCDir ver - - whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) - - -- symlink destination - binDir <- case mBinDir of - Just x -> pure x - Nothing -> do - Dirs {binDir = f} <- lift getDirs - pure f - - -- first delete the old symlinks (this fixes compatibility issues - -- with old ghcup) - when (isNothing mBinDir) $ - case sghc of - SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) - SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver - SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver - - -- for ghc tools (ghc, ghci, haddock, ...) - verfiles <- ghcToolFiles ver - forM_ verfiles $ \file -> do - mTargetFile <- case sghc of - SetGHCOnly -> pure $ Just file - SetGHC_XY -> do - handle - (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ do - (mj, mi) <- getMajorMinorV (_tvVersion ver) - let major' = intToText mj <> "." <> intToText mi - pure $ Just (file <> "-" <> T.unpack major') - SetGHC_XYZ -> - pure $ Just (file <> "-" <> verS) - - -- create symlink - forM_ mTargetFile $ \targetFile -> do - bindir <- ghcInternalBinDir ver - let fullF = binDir targetFile <> exeExt - fileWithExt = bindir file <> exeExt - destL <- binarySymLinkDestination binDir fileWithExt - lift $ createLink destL fullF - - when (isNothing mBinDir) $ do - -- create symlink for share dir - when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS - - when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility - - pure ver - - where - - symlinkShareDir :: ( MonadReader env m - , HasDirs env - , MonadIO m - , HasLog env - , MonadCatch m - , MonadMask m - ) - => FilePath - -> String - -> m () - symlinkShareDir ghcdir ver' = do - Dirs {..} <- getDirs - let destdir = fromGHCupPath baseDir - case sghc of - SetGHCOnly -> do - let sharedir = "share" - let fullsharedir = ghcdir sharedir - logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir - whenM (liftIO $ doesDirectoryExist fullsharedir) $ do - let fullF = destdir sharedir - let targetF = "." "ghc" ver' sharedir - logDebug $ "rm -f " <> T.pack fullF - hideError doesNotExistErrorType $ rmDirectoryLink fullF - logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF - - if isWindows - then liftIO - -- On windows we need to be more permissive - -- in case symlinks can't be created, be just - -- give up here. This symlink isn't strictly necessary. - $ hideError permissionErrorType - $ hideError illegalOperationErrorType - $ createDirectoryLink targetF fullF - else liftIO - $ createDirectoryLink targetF fullF - _ -> pure () - -unsetGHC :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadMask m - ) - => Maybe Text - -> Excepts '[NotInstalled] m () -unsetGHC = rmPlainGHC - - --- | Set the @~\/.ghcup\/bin\/cabal@ symlink. -setCabal :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasLog env - , MonadFail m - , MonadIO m - , MonadUnliftIO m) - => Version - -> Excepts '[NotInstalled] m () -setCabal ver = do - let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt - - -- symlink destination - Dirs {..} <- lift getDirs - - whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) - $ throwE - $ NotInstalled Cabal (GHCTargetVersion Nothing ver) - - let cabalbin = binDir "cabal" <> exeExt - - -- create link - let destL = targetFile - lift $ createLink destL cabalbin - - pure () - -unsetCabal :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetCabal = do - Dirs {..} <- getDirs - let cabalbin = binDir "cabal" <> exeExt - hideError doesNotExistErrorType $ rmLink cabalbin - - --- | Set the haskell-language-server symlinks. -setHLS :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadIO m - , MonadMask m - , MonadFail m - , MonadUnliftIO m - ) - => Version - -> SetHLS - -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin - -- and don't want mess with other versions - -> Excepts '[NotInstalled] m () -setHLS ver shls mBinDir = do - whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) - - -- symlink destination - binDir <- case mBinDir of - Just x -> pure x - Nothing -> do - Dirs {binDir = f} <- lift getDirs - pure f - - -- first delete the old symlinks - when (isNothing mBinDir) $ - case shls of - -- not for legacy - SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver - -- legacy and new - SetHLSOnly -> liftE rmPlainHLS - - case shls of - -- not for legacy - SetHLS_XYZ -> do - bins <- lift $ hlsInternalServerScripts ver Nothing - - forM_ bins $ \f -> do - let fname = takeFileName f - destL <- binarySymLinkDestination binDir f - let target = if "haskell-language-server-wrapper" `isPrefixOf` fname - then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt - else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt - lift $ createLink destL (binDir target) - - -- legacy and new - SetHLSOnly -> do - -- set haskell-language-server- symlinks - bins <- lift $ hlsServerBinaries ver Nothing - when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) - - forM_ bins $ \f -> do - let destL = f - let target = (<> exeExt) . head . splitOn "~" $ f - lift $ createLink destL (binDir target) - - -- set haskell-language-server-wrapper symlink - let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - - lift $ createLink destL wrapper - - when (isNothing mBinDir) $ - lift warnAboutHlsCompatibility - - -unsetHLS :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetHLS = do - Dirs {..} <- getDirs - let wrapper = binDir "haskell-language-server-wrapper" <> exeExt - bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' - binDir - (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) - forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) - hideError doesNotExistErrorType $ rmLink wrapper - - --- | Set the @~\/.ghcup\/bin\/stack@ symlink. -setStack :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -setStack ver = do - let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt - - -- symlink destination - Dirs {..} <- lift getDirs - - whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) - $ throwE - $ NotInstalled Stack (GHCTargetVersion Nothing ver) - - let stackbin = binDir "stack" <> exeExt - - lift $ createLink targetFile stackbin - - pure () - - -unsetStack :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadIO m) - => m () -unsetStack = do - Dirs {..} <- getDirs - let stackbin = binDir "stack" <> exeExt - hideError doesNotExistErrorType $ rmLink stackbin - - --- | Warn if the installed and set HLS is not compatible with the installed and --- set GHC version. -warnAboutHlsCompatibility :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadCatch m - , MonadIO m - ) - => m () -warnAboutHlsCompatibility = do - supportedGHC <- hlsGHCVersions - currentGHC <- fmap _tvVersion <$> ghcSet Nothing - currentHLS <- hlsSet - - case (currentGHC, currentHLS) of - (Just gv, Just hv) | gv `notElem` supportedGHC -> do - logWarn $ - "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <> - "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <> - "Haskell IDE support may not work until this is fixed." <> "\n" <> - "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> - T.pack (prettyShow supportedGHC) - - _ -> return () - - ------------------ - --[ List tools ]-- - ------------------ - - --- | Filter data type for 'listVersions'. -data ListCriteria = ListInstalled - | ListSet - | ListAvailable - deriving Show - --- | A list result describes a single tool version --- and various of its properties. -data ListResult = ListResult - { lTool :: Tool - , lVer :: Version - , lCross :: Maybe Text -- ^ currently only for GHC - , lTag :: [Tag] - , lInstalled :: Bool - , lSet :: Bool -- ^ currently active version - , fromSrc :: Bool -- ^ compiled from source - , lStray :: Bool -- ^ not in download info - , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch - , hlsPowered :: Bool - } - deriving (Eq, Ord, Show) - - --- | Extract all available tool versions and their tags. -availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo -availableToolVersions av tool = view - (at tool % non Map.empty) - av - - --- | List all versions from the download info, as well as stray --- versions. -listVersions :: ( MonadCatch m - , HasLog env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasGHCupInfo env - ) - => Maybe Tool - -> Maybe ListCriteria - -> m [ListResult] -listVersions lt' criteria = do - -- some annoying work to avoid too much repeated IO - cSet <- cabalSet - cabals <- getInstalledCabals - hlsSet' <- hlsSet - hlses <- getInstalledHLSs - sSet <- stackSet - stacks <- getInstalledStacks - - go lt' cSet cabals hlsSet' hlses sSet stacks - where - go lt cSet cabals hlsSet' hlses sSet stacks = do - case lt of - Just t -> do - GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo - -- get versions from GHCupDownloads - let avTools = availableToolVersions dls t - lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) - - case t of - GHC -> do - slr <- strayGHCs avTools - pure (sort (slr ++ lr)) - Cabal -> do - slr <- strayCabals avTools cSet cabals - pure (sort (slr ++ lr)) - HLS -> do - slr <- strayHLS avTools hlsSet' hlses - pure (sort (slr ++ lr)) - Stack -> do - slr <- strayStacks avTools sSet stacks - pure (sort (slr ++ lr)) - GHCup -> do - let cg = maybeToList $ currentGHCup avTools - pure (sort (cg ++ lr)) - Nothing -> do - ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks - cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks - hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks - ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks - stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks - pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) - strayGHCs :: ( MonadCatch m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> m [ListResult] - strayGHCs avTools = do - ghcs <- getInstalledGHCs - fmap catMaybes $ forM ghcs $ \case - Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do - case Map.lookup _tvVersion avTools of - Just _ -> pure Nothing - Nothing -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup _tvVersion avTools) - , lNoBindist = False - , .. - } - Right tver@GHCTargetVersion{ .. } -> do - lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions - pure $ Just $ ListResult - { lTool = GHC - , lVer = _tvVersion - , lCross = _tvTarget - , lTag = [] - , lInstalled = True - , lStray = True -- NOTE: cross currently cannot be installed via bindist - , lNoBindist = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayCabals :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayCabals avTools cSet cabals = do - fmap catMaybes $ forM cabals $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = cSet == Just ver - pure $ Just $ ListResult - { lTool = Cabal - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayHLS :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayHLS avTools hlsSet' hlss = do - fmap catMaybes $ forM hlss $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = hlsSet' == Just ver - pure $ Just $ ListResult - { lTool = HLS - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - strayStacks :: ( MonadReader env m - , HasDirs env - , MonadCatch m - , MonadThrow m - , HasLog env - , MonadIO m - ) - => Map.Map Version VersionInfo - -> Maybe Version - -> [Either FilePath Version] - -> m [ListResult] - strayStacks avTools stackSet' stacks = do - fmap catMaybes $ forM stacks $ \case - Right ver -> - case Map.lookup ver avTools of - Just _ -> pure Nothing - Nothing -> do - let lSet = stackSet' == Just ver - pure $ Just $ ListResult - { lTool = Stack - , lVer = ver - , lCross = Nothing - , lTag = [] - , lInstalled = True - , lStray = isNothing (Map.lookup ver avTools) - , lNoBindist = False - , fromSrc = False -- actually, we don't know :> - , hlsPowered = False - , .. - } - Left e -> do - logWarn - $ "Could not parse version of stray directory" <> T.pack e - pure Nothing - - currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult - currentGHCup av = - let currentVer = fromJust $ pvpToVersion ghcUpVer "" - listVer = Map.lookup currentVer av - latestVer = fst <$> headOf (getTagged Latest) av - recommendedVer = fst <$> headOf (getTagged Latest) av - isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer - in if | Map.member currentVer av -> Nothing - | otherwise -> Just $ ListResult { lVer = currentVer - , lTag = maybe (if isOld then [Old] else []) _viTags listVer - , lCross = Nothing - , lTool = GHCup - , fromSrc = False - , lStray = isNothing listVer - , lSet = True - , lInstalled = True - , lNoBindist = False - , hlsPowered = False - } - - -- NOTE: this are not cross ones, because no bindists - toListResult :: ( HasLog env - , MonadReader env m - , HasDirs env - , HasGHCupInfo env - , HasPlatformReq env - , MonadIO m - , MonadCatch m - ) - => Tool - -> Maybe Version - -> [Either FilePath Version] - -> Maybe Version - -> [Either FilePath Version] - -> Maybe Version - -> [Either FilePath Version] - -> (Version, VersionInfo) - -> m ListResult - toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do - case t of - GHC -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v - let tver = mkTVer v - lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing - lInstalled <- ghcInstalled tver - fromSrc <- ghcSrcInstalled tver - hlsPowered <- fmap (elem v) hlsGHCVersions - pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } - Cabal -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v - let lSet = cSet == Just v - let lInstalled = elem v $ rights cabals - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - GHCup -> do - let lSet = prettyPVP ghcUpVer == prettyVer v - let lInstalled = lSet - pure ListResult { lVer = v - , lTag = tags - , lCross = Nothing - , lTool = t - , fromSrc = False - , lStray = False - , lNoBindist = False - , hlsPowered = False - , .. - } - HLS -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v - let lSet = hlsSet' == Just v - let lInstalled = elem v $ rights hlses - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - Stack -> do - lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v - let lSet = stackSet' == Just v - let lInstalled = elem v $ rights stacks - pure ListResult { lVer = v - , lCross = Nothing - , lTag = tags - , lTool = t - , fromSrc = False - , lStray = False - , hlsPowered = False - , .. - } - - - filter' :: [ListResult] -> [ListResult] - filter' lr = case criteria of - Nothing -> lr - Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr - Just ListSet -> filter (\ListResult {..} -> lSet) lr - Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr - - - - -------------------- - --[ GHC/cabal rm ]-- - -------------------- - - --- | Delete a ghc version and all its symlinks. --- --- This may leave GHCup without a "set" version. --- Will try to fix the ghc-x.y symlink after removal (e.g. to an --- older version). -rmGHCVer :: ( MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> Excepts '[NotInstalled, UninstallFailed] m () -rmGHCVer ver = do - isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) - - whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) - - -- this isn't atomic, order matters - when isSetGHC $ do - lift $ logInfo "Removing ghc symlinks" - liftE $ rmPlainGHC (_tvTarget ver) - - lift $ logInfo "Removing ghc-x.y.z symlinks" - liftE $ rmMinorGHCSymlinks ver - - lift $ logInfo "Removing/rewiring ghc-x.y symlinks" - -- first remove - handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver - -- then fix them (e.g. with an earlier version) - - dir' <- lift $ ghcupGHCDir ver - let dir = fromGHCupPath dir' - lift (getInstalledFiles GHC ver) >>= \case - Just files -> do - lift $ logInfo $ "Removing files safely from: " <> T.pack dir - forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir dropDrive f)) - removeEmptyDirsRecursive dir - survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir - f <- recordedInstallationFile GHC ver - lift $ recycleFile f - when (not (null survivors)) $ throwE $ UninstallFailed dir survivors - Nothing -> do - lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir - lift $ recyclePathForcibly dir' - - v' <- - handle - (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ fmap Just - $ getMajorMinorV (_tvVersion ver) - forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) - >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) - - Dirs {..} <- lift getDirs - - lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir "share") - - --- | Delete a cabal version. Will try to fix the @cabal@ symlink --- after removal (e.g. setting it to an older version). -rmCabalVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmCabalVer ver = do - whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) - - cSet <- lift cabalSet - - Dirs {..} <- lift getDirs - - let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt - lift $ hideError doesNotExistErrorType $ recycleFile (binDir cabalFile) - - when (Just ver == cSet) $ do - cVers <- lift $ fmap rights getInstalledCabals - case headMay . reverse . sort $ cVers of - Just latestver -> setCabal latestver - Nothing -> lift $ rmLink (binDir "cabal" <> exeExt) - - --- | Delete a hls version. Will try to fix the hls symlinks --- after removal (e.g. setting it to an older version). -rmHLSVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled, UninstallFailed] m () -rmHLSVer ver = do - whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) - - isHlsSet <- lift hlsSet - - liftE $ rmMinorHLSSymlinks ver - - when (Just ver == isHlsSet) $ do - -- delete all set symlinks - liftE rmPlainHLS - - hlsDir' <- ghcupHLSDir ver - let hlsDir = fromGHCupPath hlsDir' - lift (getInstalledFiles HLS (mkTVer ver)) >>= \case - Just files -> do - lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir - forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir dropDrive f)) - removeEmptyDirsRecursive hlsDir - survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir - f <- recordedInstallationFile HLS (mkTVer ver) - lift $ recycleFile f - when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors - Nothing -> do - lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir - recyclePathForcibly hlsDir' - - when (Just ver == isHlsSet) $ do - -- set latest hls - hlsVers <- lift $ fmap rights getInstalledHLSs - case headMay . reverse . sort $ hlsVers of - Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing - Nothing -> pure () - - --- | Delete a stack version. Will try to fix the @stack@ symlink --- after removal (e.g. setting it to an older version). -rmStackVer :: ( MonadMask m - , MonadReader env m - , HasDirs env - , MonadThrow m - , HasLog env - , MonadIO m - , MonadFail m - , MonadCatch m - , MonadUnliftIO m - ) - => Version - -> Excepts '[NotInstalled] m () -rmStackVer ver = do - whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver)) - - sSet <- lift stackSet - - Dirs {..} <- lift getDirs - - let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt - lift $ hideError doesNotExistErrorType $ recycleFile (binDir stackFile) - - when (Just ver == sSet) $ do - sVers <- lift $ fmap rights getInstalledStacks - case headMay . reverse . sort $ sVers of - Just latestver -> setStack latestver - Nothing -> lift $ rmLink (binDir "stack" <> exeExt) - - --- assuming the current scheme of having just 1 ghcup bin, no version info is required. -rmGhcup :: ( MonadReader env m - , HasDirs env - , MonadIO m - , MonadCatch m - , HasLog env - , MonadMask m - , MonadUnliftIO m - ) - => m () -rmGhcup = do - Dirs { .. } <- getDirs - let ghcupFilename = "ghcup" <> exeExt - let ghcupFilepath = binDir ghcupFilename - - currentRunningExecPath <- liftIO getExecutablePath - - -- if paths do no exist, warn user, and continue to compare them, as is, - -- which should eventually fail and result in a non-standard install warning - - p1 <- handleIO' doesNotExistErrorType - (handlePathNotPresent currentRunningExecPath) - (liftIO $ canonicalizePath currentRunningExecPath) - - p2 <- handleIO' doesNotExistErrorType - (handlePathNotPresent ghcupFilepath) - (liftIO $ canonicalizePath ghcupFilepath) - - let areEqualPaths = equalFilePath p1 p2 - - unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath - - if isWindows - then do - -- since it doesn't seem possible to delete a running exe on windows - -- we move it to temp dir, to be deleted at next reboot - tempFilepath <- mkGhcupTmpDir - hideError UnsupportedOperation $ - liftIO $ hideError NoSuchThing $ - moveFile ghcupFilepath (fromGHCupPath tempFilepath "ghcup") - else - -- delete it. - hideError doesNotExistErrorType $ rmFile ghcupFilepath - - where - handlePathNotPresent fp _err = do - logDebug $ "Error: The path does not exist, " <> T.pack fp - pure fp - - nonStandardInstallLocationMsg path = T.pack $ - "current ghcup is invoked from a non-standard location: \n" - <> path <> - "\n you may have to uninstall it manually." - rmTool :: ( MonadReader env m , HasDirs env , HasLog env @@ -2135,480 +258,9 @@ getDebugInfo = do - --------------- - --[ Compile ]-- - --------------- - - --- | Compile a GHC from source. This behaves wrt symlinks and installation --- the same as 'installGHCBin'. -compileGHC :: ( MonadMask m - , MonadReader env m - , HasDirs env - , HasPlatformReq env - , HasGHCupInfo env - , HasSettings env - , MonadThrow m - , MonadResource m - , HasLog env - , MonadIO m - , MonadUnliftIO m - , MonadFail m - ) - => Either GHCTargetVersion GitBranch -- ^ version to install - -> Maybe Version -- ^ overwrite version - -> Either Version FilePath -- ^ version to bootstrap with - -> Maybe Int -- ^ jobs - -> Maybe FilePath -- ^ build config - -> Maybe (Either FilePath [URI]) -- ^ patches - -> [Text] -- ^ additional args to ./configure - -> Maybe String -- ^ build flavour - -> Bool - -> InstallDir - -> Excepts - '[ AlreadyInstalled - , BuildFailed - , DigestError - , GPGError - , DownloadFailed - , GHCupSetError - , NoDownload - , NotFoundInPATH - , PatchFailed - , UnknownArchive - , TarDirDoesNotExist - , NotInstalled - , DirNotEmpty - , ArchiveResult - , FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , ProcessError - , CopyError - , BuildFailed - , UninstallFailed - , MergeFileTreeError - ] - m - GHCTargetVersion -compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir - = do - PlatformRequest { .. } <- lift getPlatformReq - GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo - - (workdir, tmpUnpack, tver) <- case targetGhc of - -- unpack from version tarball - Left tver -> do - lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap - - -- download source tarball - dlInfo <- - preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls - ?? NoDownload - dl <- liftE $ downloadCached dlInfo Nothing - - -- unpack - tmpUnpack <- lift mkGhcupTmpDir - liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack - - workdir <- maybe (pure tmpUnpack) - (liftE . intoSubdir tmpUnpack) - (view dlSubdir dlInfo) - liftE $ applyAnyPatch patches (fromGHCupPath workdir) - - pure (workdir, tmpUnpack, tver) - - -- clone from git - Right GitBranch{..} -> do - tmpUnpack <- lift mkGhcupTmpDir - let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing - tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do - let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo - lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" - lEM $ git [ "init" ] - lEM $ git [ "remote" - , "add" - , "origin" - , fromString rep ] - - let fetch_args = - [ "fetch" - , "--depth" - , "1" - , "--quiet" - , "origin" - , fromString ref ] - lEM $ git fetch_args - - lEM $ git [ "checkout", "FETCH_HEAD" ] - lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] - liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) - lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" - lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" - CapturedProcess {..} <- lift $ makeOut - ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) - case _exitCode of - ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut - ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) - - liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) - lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver - - pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) - -- the version that's installed may differ from the - -- compiled version, so the user can overwrite it - let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov - - alreadyInstalled <- lift $ ghcInstalled installVer - alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) - - when alreadyInstalled $ do - case installDir of - IsolateDir isoDir -> - lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir - GHCupInternal -> - lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." - lift $ logWarn - "...waiting for 10 seconds before continuing, you can still abort..." - liftIO $ threadDelay 10000000 -- give the user a sec to intervene - - ghcdir <- case installDir of - IsolateDir isoDir -> pure $ IsolateDirResolved isoDir - GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) - - (mBindist, bmk) <- liftE $ runBuildAction - tmpUnpack - (do - b <- if hadrian - then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir - else compileMakeBindist tver (fromGHCupPath workdir) ghcdir - bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) - pure (b, bmk) - ) - - case installDir of - GHCupInternal -> - -- only remove old ghc in regular installs - when alreadyInstalled $ do - lift $ logInfo "Deleting existing installation" - liftE $ rmGHCVer installVer - - _ -> pure () - - forM_ mBindist $ \bindist -> do - liftE $ installPackedGHC bindist - (Just $ RegexDir "ghc-.*") - ghcdir - (installVer ^. tvVersion) - False -- not a force install, since we already overwrite when compiling. - - liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk - - case installDir of - -- set and make symlinks for regular (non-isolated) installs - GHCupInternal -> do - reThrowAll GHCupSetError $ postGHCInstall installVer - -- restore - when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing - - _ -> pure () - - pure installVer - - where - defaultConf = - let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) - default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) - in case targetGhc of - Left (GHCTargetVersion (Just _) _) -> cross_mk - _ -> default_mk - - compileHadrianBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError] - m - (Maybe FilePath) -- ^ output path of bindist, None for cross - compileHadrianBindist tver workdir ghcdir = do - lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" - - liftE $ configureBindist tver workdir ghcdir - - lift $ logInfo "Building (this may take a while)..." - hadrian_build <- liftE $ findHadrianFile workdir - lEM $ execWithGhcEnv hadrian_build - ( maybe [] (\j -> ["-j" <> show j] ) jobs - ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour - ++ ["binary-dist"] - ) - (Just workdir) "ghc-make" - [tar] <- liftIO $ findFiles - (workdir "_build" "bindist") - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - liftE $ fmap Just $ copyBindist tver tar (workdir "_build" "bindist") - - findHadrianFile :: (MonadIO m) - => FilePath - -> Excepts - '[HadrianNotFound] - m - FilePath - findHadrianFile workdir = do - let possible_files = if isWindows - then ((workdir "hadrian") ) <$> ["build.bat"] - else ((workdir "hadrian") ) <$> ["build", "build.sh"] - exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f)) - case filter fst exsists of - [] -> throwE HadrianNotFound - ((_, x):_) -> pure x - - compileMakeBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , HadrianNotFound - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError] - m - (Maybe FilePath) -- ^ output path of bindist, None for cross - compileMakeBindist tver workdir ghcdir = do - liftE $ configureBindist tver workdir ghcdir - - case mbuildConfig of - Just bc -> liftIOException - doesNotExistErrorType - (FileDoesNotExistError bc) - (liftIO $ copyFile bc (build_mk workdir) False) - Nothing -> - liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) - - liftE $ checkBuildConfig (build_mk workdir) - - lift $ logInfo "Building (this may take a while)..." - lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) - - if | isCross tver -> do - lift $ logInfo "Installing cross toolchain..." - lEM $ make ["install"] (Just workdir) - pure Nothing - | otherwise -> do - lift $ logInfo "Creating bindist..." - lEM $ make ["binary-dist"] (Just workdir) - [tar] <- liftIO $ findFiles - workdir - (makeRegexOpts compExtended - execBlank - ([s|^ghc-.*\.tar\..*$|] :: ByteString) - ) - liftE $ fmap Just $ copyBindist tver tar workdir - - build_mk workdir = workdir "mk" "build.mk" - - copyBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadIO m - , MonadThrow m - , MonadCatch m - , HasLog env - ) - => GHCTargetVersion - -> FilePath -- ^ tar file - -> FilePath -- ^ workdir - -> Excepts - '[CopyError] - m - FilePath - copyBindist tver tar workdir = do - Dirs {..} <- lift getDirs - pfreq <- lift getPlatformReq - c <- liftIO $ BL.readFile (workdir tar) - cDigest <- - fmap (T.take 8) - . lift - . throwEither - . E.decodeUtf8' - . B16.encode - . SHA256.hashlazy - $ c - cTime <- liftIO getCurrentTime - let tarName = makeValid ("ghc-" - <> T.unpack (tVerToText tver) - <> "-" - <> pfReqToString pfreq - <> "-" - <> iso8601Show cTime - <> "-" - <> T.unpack cDigest - <> ".tar" - <> takeExtension tar) - let tarPath = fromGHCupPath cacheDir tarName - copyFileE (workdir tar) tarPath False - lift $ logInfo $ "Copied bindist to " <> T.pack tarPath - pure tarPath - - checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env) - => FilePath - -> Excepts - '[FileDoesNotExistError, InvalidBuildConfig] - m - () - checkBuildConfig bc = do - c <- liftIOException - doesNotExistErrorType - (FileDoesNotExistError bc) - (liftIO $ B.readFile bc) - let lines' = fmap T.strip . T.lines $ decUTF8Safe c - - -- for cross, we need Stage1Only - case targetGhc of - Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE - (InvalidBuildConfig - [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] - ) - _ -> pure () - - forM_ buildFlavour $ \bf -> - when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do - lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." - liftIO $ threadDelay 5000000 - - addBuildFlavourToConf bc = case buildFlavour of - Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc - Nothing -> bc - - isCross :: GHCTargetVersion -> Bool - isCross = isJust . _tvTarget - - - configureBindist :: ( MonadReader env m - , HasDirs env - , HasSettings env - , HasPlatformReq env - , MonadThrow m - , MonadCatch m - , HasLog env - , MonadIO m - , MonadFail m - ) - => GHCTargetVersion - -> FilePath - -> InstallDirResolved - -> Excepts - '[ FileDoesNotExistError - , InvalidBuildConfig - , PatchFailed - , ProcessError - , NotFoundInPATH - , CopyError - ] - m - () - configureBindist tver workdir (fromInstallDir -> ghcdir) = do - lift $ logInfo [s|configuring build|] - - if | _tvVersion tver >= [vver|8.8.0|] -> do - lEM $ execWithGhcEnv - "sh" - ("./configure" : maybe mempty - (\x -> ["--target=" <> T.unpack x]) - (_tvTarget tver) - ++ ["--prefix=" <> ghcdir] - ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) - ++ fmap T.unpack aargs - ) - (Just workdir) - "ghc-conf" - | otherwise -> do - lEM $ execLogged - "sh" - ( [ "./configure", "--with-ghc=" <> either id id bghc - ] - ++ maybe mempty - (\x -> ["--target=" <> T.unpack x]) - (_tvTarget tver) - ++ ["--prefix=" <> ghcdir] - ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) - ++ fmap T.unpack aargs - ) - (Just workdir) - "ghc-conf" - Nothing - pure () - - execWithGhcEnv :: ( MonadReader env m - , HasSettings env - , HasDirs env - , HasLog env - , MonadIO m - , MonadThrow m) - => FilePath -- ^ thing to execute - -> [String] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> FilePath -- ^ log filename (opened in append mode) - -> m (Either ProcessError ()) - execWithGhcEnv fp args dir logf = do - env <- ghcEnv - execLogged fp args dir logf (Just env) - - bghc = case bstrap of - Right g -> Right g - Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) - - ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] - ghcEnv = do - cEnv <- liftIO getEnvironment - bghcPath <- case bghc of - Right ghc' -> pure ghc' - Left bver -> do - spaths <- liftIO getSearchPath - throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) - pure (("GHC", bghcPath) : cEnv) - - - - - - - --------------------- - --[ Upgrade GHCup ]-- - --------------------- + ------------------------- + --[ GHCup upgrade etc ]-- + ------------------------- -- | Upgrade ghcup and place it in @~\/.ghcup\/bin\/ghcup@, @@ -2685,38 +337,66 @@ upgradeGHCup mtarget force' fatal = do pure latestVer +-- assuming the current scheme of having just 1 ghcup bin, no version info is required. +rmGhcup :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadCatch m + , HasLog env + , MonadMask m + , MonadUnliftIO m + ) + => m () +rmGhcup = do + Dirs { .. } <- getDirs + let ghcupFilename = "ghcup" <> exeExt + let ghcupFilepath = binDir ghcupFilename - ------------- - --[ Other ]-- - ------------- + currentRunningExecPath <- liftIO getExecutablePath + + -- if paths do no exist, warn user, and continue to compare them, as is, + -- which should eventually fail and result in a non-standard install warning + + p1 <- handleIO' doesNotExistErrorType + (handlePathNotPresent currentRunningExecPath) + (liftIO $ canonicalizePath currentRunningExecPath) + + p2 <- handleIO' doesNotExistErrorType + (handlePathNotPresent ghcupFilepath) + (liftIO $ canonicalizePath ghcupFilepath) + + let areEqualPaths = equalFilePath p1 p2 + + unless areEqualPaths $ logWarn $ nonStandardInstallLocationMsg currentRunningExecPath + + if isWindows + then do + -- since it doesn't seem possible to delete a running exe on windows + -- we move it to temp dir, to be deleted at next reboot + tempFilepath <- mkGhcupTmpDir + hideError UnsupportedOperation $ + liftIO $ hideError NoSuchThing $ + moveFile ghcupFilepath (fromGHCupPath tempFilepath "ghcup") + else + -- delete it. + hideError doesNotExistErrorType $ rmFile ghcupFilepath + + where + handlePathNotPresent fp _err = do + logDebug $ "Error: The path does not exist, " <> T.pack fp + pure fp + + nonStandardInstallLocationMsg path = T.pack $ + "current ghcup is invoked from a non-standard location: \n" + <> path <> + "\n you may have to uninstall it manually." --- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for --- both installing from source and bindist. -postGHCInstall :: ( MonadReader env m - , HasDirs env - , HasLog env - , MonadThrow m - , MonadFail m - , MonadIO m - , MonadCatch m - , MonadMask m - , MonadUnliftIO m - ) - => GHCTargetVersion - -> Excepts '[NotInstalled] m () -postGHCInstall ver@GHCTargetVersion {..} = do - void $ liftE $ setGHC ver SetGHC_XYZ Nothing + --------------- + --[ Whereis ]-- + --------------- - -- Create ghc-x.y symlinks. This may not be the current - -- version, create it regardless. - v' <- - handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) - $ fmap Just - $ getMajorMinorV _tvVersion - forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) - >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) -- | Reports the binary location of a given tool: @@ -2769,6 +449,7 @@ whereIsTool tool ver@GHCTargetVersion {..} = do currentRunningExecPath <- liftIO getExecutablePath liftIO $ canonicalizePath currentRunningExecPath + -- | Doesn't work for cross GHC. checkIfToolInstalled :: ( MonadIO m , MonadReader env m @@ -2779,6 +460,7 @@ checkIfToolInstalled :: ( MonadIO m m Bool checkIfToolInstalled tool ver = checkIfToolInstalled' tool (mkTVer ver) + checkIfToolInstalled' :: ( MonadIO m , MonadReader env m , HasDirs env @@ -2794,12 +476,6 @@ checkIfToolInstalled' tool ver = GHC -> ghcInstalled ver _ -> pure False -throwIfFileAlreadyExists :: ( MonadIO m ) => - FilePath -> - Excepts '[FileAlreadyExistsError] m () - -throwIfFileAlreadyExists fp = whenM (checkFileAlreadyExists fp) - (throwE $ FileAlreadyExistsError fp) @@ -2938,23 +614,3 @@ rmTmp = do rmPathForcibly f -applyAnyPatch :: ( MonadReader env m - , HasDirs env - , HasLog env - , HasSettings env - , MonadUnliftIO m - , MonadCatch m - , MonadResource m - , MonadThrow m - , MonadMask m - , MonadIO m) - => Maybe (Either FilePath [URI]) - -> FilePath - -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () -applyAnyPatch Nothing _ = pure () -applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir -applyAnyPatch (Just (Right uris)) workdir = do - tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir - forM_ uris $ \uri -> do - patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False - liftE $ applyPatch patch workdir diff --git a/lib/GHCup/Cabal.hs b/lib/GHCup/Cabal.hs new file mode 100644 index 0000000..9f6fe67 --- /dev/null +++ b/lib/GHCup/Cabal.hs @@ -0,0 +1,279 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Cabal +Description : GHCup installation functions for Cabal +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Cabal where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error + +import qualified Data.Text as T + + + + ------------------------- + --[ Tool installation ]-- + ------------------------- + + +-- | Like 'installCabalBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installCabalBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installCabalBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install cabal version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + -- check if we already have a regular cabal already installed + regularCabalInstalled <- lift $ cabalInstalled ver + + if + | not forceInstall + , regularCabalInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled Cabal ver + + | forceInstall + , regularCabalInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed version first!" + liftE $ rmCabalVer ver + + | otherwise -> pure () + + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing Cabal to " <> T.pack isoDir + liftE $ installCabalUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + + GHCupInternal -> do -- regular install + liftE $ installCabalUnpacked workdir (GHCupBinDir binDir) ver forceInstall + + +-- | Install an unpacked cabal distribution.Symbol +installCabalUnpacked :: (MonadCatch m, HasLog env, MonadIO m, MonadReader env m) + => FilePath -- ^ Path to the unpacked cabal bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool -- ^ Force Install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installCabalUnpacked path inst ver forceInstall = do + lift $ logInfo "Installing cabal" + let cabalFile = "cabal" + liftIO $ createDirRecursive' (fromInstallDir inst) + let destFileName = cabalFile + <> (case inst of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + let destPath = fromInstallDir inst destFileName + + copyFileE + (path cabalFile <> exeExt) + destPath + (not forceInstall) + lift $ chmod_755 destPath + +-- | Installs cabal into @~\/.ghcup\/bin/cabal-\@ and +-- creates a default @cabal -> cabal-x.y.z.q@ symlink for +-- the latest installed version. +installCabalBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installCabalBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo Cabal ver + installCabalBindist dlinfo ver installDir forceInstall + + + ----------------- + --[ Set cabal ]-- + ----------------- + + +-- | Set the @~\/.ghcup\/bin\/cabal@ symlink. +setCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadFail m + , MonadIO m + , MonadUnliftIO m) + => Version + -> Excepts '[NotInstalled] m () +setCabal ver = do + let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt + + -- symlink destination + Dirs {..} <- lift getDirs + + whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) + $ throwE + $ NotInstalled Cabal (GHCTargetVersion Nothing ver) + + let cabalbin = binDir "cabal" <> exeExt + + -- create link + let destL = targetFile + lift $ createLink destL cabalbin + + pure () + +unsetCabal :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetCabal = do + Dirs {..} <- getDirs + let cabalbin = binDir "cabal" <> exeExt + hideError doesNotExistErrorType $ rmLink cabalbin + + + ---------------- + --[ Rm cabal ]-- + ---------------- + + +-- | Delete a cabal version. Will try to fix the @cabal@ symlink +-- after removal (e.g. setting it to an older version). +rmCabalVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +rmCabalVer ver = do + whenM (lift $ fmap not $ cabalInstalled ver) $ throwE (NotInstalled Cabal (GHCTargetVersion Nothing ver)) + + cSet <- lift cabalSet + + Dirs {..} <- lift getDirs + + let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt + lift $ hideError doesNotExistErrorType $ recycleFile (binDir cabalFile) + + when (Just ver == cSet) $ do + cVers <- lift $ fmap rights getInstalledCabals + case headMay . reverse . sort $ cVers of + Just latestver -> setCabal latestver + Nothing -> lift $ rmLink (binDir "cabal" <> exeExt) diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index c768a47..382f6bc 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -34,9 +34,10 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger.Internal +import GHCup.Prelude.Process import GHCup.Version import Control.Applicative diff --git a/lib/GHCup/Download/IOStreams.hs b/lib/GHCup/Download/IOStreams.hs index 9682a64..8f96f38 100644 --- a/lib/GHCup/Download/IOStreams.hs +++ b/lib/GHCup/Download/IOStreams.hs @@ -10,7 +10,7 @@ module GHCup.Download.IOStreams where import GHCup.Download.Utils import GHCup.Errors import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude +import GHCup.Prelude import Control.Applicative import Control.Exception.Safe diff --git a/lib/GHCup/Download/Utils.hs b/lib/GHCup/Download/Utils.hs index 7a7e3ba..ba5cdaf 100644 --- a/lib/GHCup/Download/Utils.hs +++ b/lib/GHCup/Download/Utils.hs @@ -10,7 +10,7 @@ module GHCup.Download.Utils where import GHCup.Errors import GHCup.Types.Optics import GHCup.Types.JSON ( ) -import GHCup.Utils.Prelude +import GHCup.Prelude import Control.Applicative import Control.Monad diff --git a/lib/GHCup/GHC.hs b/lib/GHCup/GHC.hs new file mode 100644 index 0000000..0e8ea65 --- /dev/null +++ b/lib/GHCup/GHC.hs @@ -0,0 +1,1078 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TemplateHaskell #-} + +{-| +Module : GHCup.GHC +Description : GHCup installation functions for GHC +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.GHC where + + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Version.QQ +import GHCup.Prelude.MegaParsec + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Concurrent ( threadDelay ) +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.List.NonEmpty ( NonEmpty((:|)) ) +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Time.Clock +import Data.Time.Format.ISO8601 +import Data.Versions hiding ( patch ) +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Language.Haskell.TH +import Language.Haskell.TH.Syntax ( Quasi(qAddDependentFile) ) +import Optics +import Prelude hiding ( abs + , writeFile + ) +import System.Environment +import System.FilePath +import System.IO.Error +import Text.PrettyPrint.HughesPJClass ( prettyShow ) +import Text.Regex.Posix +import URI.ByteString + +import qualified Crypto.Hash.SHA256 as SHA256 +import qualified Data.ByteString.Base16 as B16 +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +import qualified Data.Text as T +import qualified Data.Text.IO as T +import qualified Data.Text.Encoding as E +import qualified Text.Megaparsec as MP + + + --------------------- + --[ Tool fetching ]-- + --------------------- + + + +fetchGHCSrc :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Maybe FilePath + -> Excepts + '[ DigestError + , GPGError + , DownloadFailed + , NoDownload + ] + m + FilePath +fetchGHCSrc v mfp = do + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + dlInfo <- + preview (ix GHC % ix v % viSourceDL % _Just) dls + ?? NoDownload + liftE $ downloadCached' dlInfo Nothing mfp + + + + ------------------------- + --[ Tool installation ]-- + ------------------------- + + +-- | Like 'installGHCBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installGHCBindist :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => DownloadInfo -- ^ where/how to download + -> Version -- ^ the version to install + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , UninstallFailed + , MergeFileTreeError + ] + m + () +installGHCBindist dlinfo ver installDir forceInstall = do + let tver = mkTVer ver + + lift $ logDebug $ "Requested to install GHC with " <> prettyVer ver + + regularGHCInstalled <- lift $ ghcInstalled tver + + if + | not forceInstall + , regularGHCInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled GHC ver + + | forceInstall + , regularGHCInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed GHC version first!" + liftE $ rmGHCVer tver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + + toolchainSanityChecks + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing GHC to " <> T.pack isoDir + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + -- prepare paths + ghcdir <- lift $ ghcupGHCDir tver + + liftE $ installPackedGHC dl (view dlSubdir dlinfo) (GHCupDir ghcdir) ver forceInstall + + -- make symlinks & stuff when regular install, + liftE $ postGHCInstall tver + + where + toolchainSanityChecks = do + r <- forM ["CC", "LD"] (liftIO . lookupEnv) + case catMaybes r of + [] -> pure () + _ -> do + lift $ logWarn $ "CC/LD environment variable is set. This will change the compiler/linker" + <> "\n" <> "GHC uses internally and can cause defunct GHC in some cases (e.g. in Anaconda" + <> "\n" <> "environments). If you encounter problems, unset CC and LD and reinstall." + + +-- | Install a packed GHC distribution. This only deals with unpacking and the GHC +-- build system and nothing else. +installPackedGHC :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasSettings env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadFail m + , MonadResource m + ) + => FilePath -- ^ Path to the packed GHC bindist + -> Maybe TarDir -- ^ Subdir of the archive + -> InstallDirResolved + -> Version -- ^ The GHC version + -> Bool -- ^ Force install + -> Excepts + '[ BuildFailed + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , MergeFileTreeError + ] m () +installPackedGHC dl msubdir inst ver forceInstall = do + PlatformRequest {..} <- lift getPlatformReq + + unless forceInstall + (liftE $ installDestSanityCheck inst) + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + msubdir + + liftE $ runBuildAction tmpUnpack + (installUnpackedGHC workdir inst ver forceInstall) + + +-- | Install an unpacked GHC distribution. This only deals with the GHC +-- build system and nothing else. +installUnpackedGHC :: ( MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadMask m + , MonadResource m + , MonadFail m + ) + => GHCupPath -- ^ Path to the unpacked GHC bindist (where the configure script resides) + -> InstallDirResolved -- ^ Path to install to + -> Version -- ^ The GHC version + -> Bool -- ^ Force install + -> Excepts '[ProcessError, MergeFileTreeError] m () +installUnpackedGHC path inst ver forceInstall + | isWindows = do + lift $ logInfo "Installing GHC (this may take a while)" + -- Windows bindists are relocatable and don't need + -- to run configure. + -- We also must make sure to preserve mtime to not confuse ghc-pkg. + liftE $ mergeFileTree path inst GHC (mkTVer ver) $ \source dest -> do + mtime <- liftIO $ ifM (pathIsSymbolicLink source) (pure Nothing) (Just <$> getModificationTime source) + when forceInstall $ hideError doesNotExistErrorType $ hideError InappropriateType $ recycleFile dest + liftIO $ moveFilePortable source dest + forM_ mtime $ liftIO . setModificationTime dest + | otherwise = do + PlatformRequest {..} <- lift getPlatformReq + + let alpineArgs + | ver >= [vver|8.2.2|], Linux Alpine <- _rPlatform + = ["--disable-ld-override"] + | otherwise + = [] + + lift $ logInfo "Installing GHC (this may take a while)" + lEM $ execLogged "sh" + ("./configure" : ("--prefix=" <> fromInstallDir inst) + : alpineArgs + ) + (Just $ fromGHCupPath path) + "ghc-configure" + Nothing + tmpInstallDest <- lift withGHCupTmpDir + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "install"] (Just $ fromGHCupPath path) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + GHC + (mkTVer ver) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + + pure () + + +-- | Installs GHC into @~\/.ghcup\/ghc/\@ and places the +-- following symlinks in @~\/.ghcup\/bin@: +-- +-- * @ghc-x.y.z -> ..\/ghc\/x.y.z\/bin/ghc@ +-- * @ghc-x.y -> ..\/ghc\/x.y.z\/bin/ghc@ (if x.y.z is the latest x.y version) +installGHCBin :: ( MonadFail m + , MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + ) + => Version -- ^ the version to install + -> InstallDir + -> Bool -- ^ force install + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , DirNotEmpty + , ArchiveResult + , ProcessError + , UninstallFailed + , MergeFileTreeError + ] + m + () +installGHCBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo GHC ver + liftE $ installGHCBindist dlinfo ver installDir forceInstall + + + + + + --------------- + --[ Set GHC ]-- + --------------- + + + +-- | Set GHC symlinks in @~\/.ghcup\/bin@ for the requested GHC version. The behavior depends +-- on `SetGHC`: +-- +-- * SetGHCOnly: @~\/.ghcup\/bin\/ghc -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- * SetGHC_XY: @~\/.ghcup\/bin\/ghc-X.Y -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- * SetGHC_XYZ: @~\/.ghcup\/bin\/ghc-\ -> ~\/.ghcup\/ghc\/\\/bin\/ghc@ +-- +-- Additionally creates a @~\/.ghcup\/share -> ~\/.ghcup\/ghc\/\\/share symlink@ +-- for 'SetGHCOnly' constructor. +setGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> SetGHC + -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin + -- and don't want mess with other versions + -> Excepts '[NotInstalled] m GHCTargetVersion +setGHC ver sghc mBinDir = do + let verS = T.unpack $ prettyVer (_tvVersion ver) + ghcdir <- lift $ ghcupGHCDir ver + + whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver)) + + -- symlink destination + binDir <- case mBinDir of + Just x -> pure x + Nothing -> do + Dirs {binDir = f} <- lift getDirs + pure f + + -- first delete the old symlinks (this fixes compatibility issues + -- with old ghcup) + when (isNothing mBinDir) $ + case sghc of + SetGHCOnly -> liftE $ rmPlainGHC (_tvTarget ver) + SetGHC_XY -> liftE $ rmMajorGHCSymlinks ver + SetGHC_XYZ -> liftE $ rmMinorGHCSymlinks ver + + -- for ghc tools (ghc, ghci, haddock, ...) + verfiles <- ghcToolFiles ver + forM_ verfiles $ \file -> do + mTargetFile <- case sghc of + SetGHCOnly -> pure $ Just file + SetGHC_XY -> do + handle + (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ do + (mj, mi) <- getMajorMinorV (_tvVersion ver) + let major' = intToText mj <> "." <> intToText mi + pure $ Just (file <> "-" <> T.unpack major') + SetGHC_XYZ -> + pure $ Just (file <> "-" <> verS) + + -- create symlink + forM_ mTargetFile $ \targetFile -> do + bindir <- ghcInternalBinDir ver + let fullF = binDir targetFile <> exeExt + fileWithExt = bindir file <> exeExt + destL <- binarySymLinkDestination binDir fileWithExt + lift $ createLink destL fullF + + when (isNothing mBinDir) $ do + -- create symlink for share dir + when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir (fromGHCupPath ghcdir) verS + + when (sghc == SetGHCOnly) $ lift warnAboutHlsCompatibility + + pure ver + + where + + symlinkShareDir :: ( MonadReader env m + , HasDirs env + , MonadIO m + , HasLog env + , MonadCatch m + , MonadMask m + ) + => FilePath + -> String + -> m () + symlinkShareDir ghcdir ver' = do + Dirs {..} <- getDirs + let destdir = fromGHCupPath baseDir + case sghc of + SetGHCOnly -> do + let sharedir = "share" + let fullsharedir = ghcdir sharedir + logDebug $ "Checking for sharedir existence: " <> T.pack fullsharedir + whenM (liftIO $ doesDirectoryExist fullsharedir) $ do + let fullF = destdir sharedir + let targetF = "." "ghc" ver' sharedir + logDebug $ "rm -f " <> T.pack fullF + hideError doesNotExistErrorType $ rmDirectoryLink fullF + logDebug $ "ln -s " <> T.pack targetF <> " " <> T.pack fullF + + if isWindows + then liftIO + -- On windows we need to be more permissive + -- in case symlinks can't be created, be just + -- give up here. This symlink isn't strictly necessary. + $ hideError permissionErrorType + $ hideError illegalOperationErrorType + $ createDirectoryLink targetF fullF + else liftIO + $ createDirectoryLink targetF fullF + _ -> pure () + +unsetGHC :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadMask m + ) + => Maybe Text + -> Excepts '[NotInstalled] m () +unsetGHC = rmPlainGHC + + + + + + -------------- + --[ GHC rm ]-- + -------------- + + +-- | Delete a ghc version and all its symlinks. +-- +-- This may leave GHCup without a "set" version. +-- Will try to fix the ghc-x.y symlink after removal (e.g. to an +-- older version). +rmGHCVer :: ( MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> Excepts '[NotInstalled, UninstallFailed] m () +rmGHCVer ver = do + isSetGHC <- lift $ fmap (== Just ver) $ ghcSet (_tvTarget ver) + + whenM (lift $ fmap not $ ghcInstalled ver) (throwE (NotInstalled GHC ver)) + + -- this isn't atomic, order matters + when isSetGHC $ do + lift $ logInfo "Removing ghc symlinks" + liftE $ rmPlainGHC (_tvTarget ver) + + lift $ logInfo "Removing ghc-x.y.z symlinks" + liftE $ rmMinorGHCSymlinks ver + + lift $ logInfo "Removing/rewiring ghc-x.y symlinks" + -- first remove + handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorGHCSymlinks ver + -- then fix them (e.g. with an earlier version) + + dir' <- lift $ ghcupGHCDir ver + let dir = fromGHCupPath dir' + lift (getInstalledFiles GHC ver) >>= \case + Just files -> do + lift $ logInfo $ "Removing files safely from: " <> T.pack dir + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> dir dropDrive f)) + removeEmptyDirsRecursive dir + survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory dir + f <- recordedInstallationFile GHC ver + lift $ recycleFile f + when (not (null survivors)) $ throwE $ UninstallFailed dir survivors + Nothing -> do + lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack dir + lift $ recyclePathForcibly dir' + + v' <- + handle + (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ fmap Just + $ getMajorMinorV (_tvVersion ver) + forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) (_tvTarget ver)) + >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + + Dirs {..} <- lift getDirs + + lift $ hideError doesNotExistErrorType $ rmDirectoryLink (fromGHCupPath baseDir "share") + + + + + --------------- + --[ Compile ]-- + --------------- + + +-- | Compile a GHC from source. This behaves wrt symlinks and installation +-- the same as 'installGHCBin'. +compileGHC :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + , HasSettings env + , MonadThrow m + , MonadResource m + , HasLog env + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either GHCTargetVersion GitBranch -- ^ version to install + -> Maybe Version -- ^ overwrite version + -> Either Version FilePath -- ^ version to bootstrap with + -> Maybe Int -- ^ jobs + -> Maybe FilePath -- ^ build config + -> Maybe (Either FilePath [URI]) -- ^ patches + -> [Text] -- ^ additional args to ./configure + -> Maybe String -- ^ build flavour + -> Bool + -> InstallDir + -> Excepts + '[ AlreadyInstalled + , BuildFailed + , DigestError + , GPGError + , DownloadFailed + , GHCupSetError + , NoDownload + , NotFoundInPATH + , PatchFailed + , UnknownArchive + , TarDirDoesNotExist + , NotInstalled + , DirNotEmpty + , ArchiveResult + , FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , ProcessError + , CopyError + , BuildFailed + , UninstallFailed + , MergeFileTreeError + ] + m + GHCTargetVersion +compileGHC targetGhc ov bstrap jobs mbuildConfig patches aargs buildFlavour hadrian installDir + = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + + (workdir, tmpUnpack, tver) <- case targetGhc of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> tVerToText tver <> " with " <> either prettyVer T.pack bstrap + + -- download source tarball + dlInfo <- + preview (ix GHC % ix (tver ^. tvVersion) % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform $ fromGHCupPath tmpUnpack + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + liftE $ applyAnyPatch patches (fromGHCupPath workdir) + + pure (workdir, tmpUnpack, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[PatchFailed, ProcessError, NotFoundInPATH, DigestError, DownloadFailed, GPGError] DownloadFailed $ do + let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + lEM $ git [ "submodule", "update", "--init", "--depth", "1" ] + liftE $ applyAnyPatch patches (fromGHCupPath tmpUnpack) + lEM $ execWithGhcEnv "python3" ["./boot"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + lEM $ execWithGhcEnv "sh" ["./configure"] (Just $ fromGHCupPath tmpUnpack) "ghc-bootstrap" + CapturedProcess {..} <- lift $ makeOut + ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just $ fromGHCupPath tmpUnpack) + case _exitCode of + ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut + ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr)) + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to GHC version " <> prettyVer tver + + pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver) + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = maybe tver (\ov' -> tver { _tvVersion = ov' }) ov + + alreadyInstalled <- lift $ ghcInstalled installVer + alreadySet <- fmap (== Just installVer) $ lift $ ghcSet (_tvTarget installVer) + + when alreadyInstalled $ do + case installDir of + IsolateDir isoDir -> + lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Isolate installing to " <> T.pack isoDir + GHCupInternal -> + lift $ logWarn $ "GHC " <> T.pack (prettyShow installVer) <> " already installed. Will overwrite existing version." + lift $ logWarn + "...waiting for 10 seconds before continuing, you can still abort..." + liftIO $ threadDelay 10000000 -- give the user a sec to intervene + + ghcdir <- case installDir of + IsolateDir isoDir -> pure $ IsolateDirResolved isoDir + GHCupInternal -> GHCupDir <$> lift (ghcupGHCDir installVer) + + (mBindist, bmk) <- liftE $ runBuildAction + tmpUnpack + (do + b <- if hadrian + then compileHadrianBindist tver (fromGHCupPath workdir) ghcdir + else compileMakeBindist tver (fromGHCupPath workdir) ghcdir + bmk <- liftIO $ handleIO (\_ -> pure "") $ B.readFile (build_mk $ fromGHCupPath workdir) + pure (b, bmk) + ) + + case installDir of + GHCupInternal -> + -- only remove old ghc in regular installs + when alreadyInstalled $ do + lift $ logInfo "Deleting existing installation" + liftE $ rmGHCVer installVer + + _ -> pure () + + forM_ mBindist $ \bindist -> do + liftE $ installPackedGHC bindist + (Just $ RegexDir "ghc-.*") + ghcdir + (installVer ^. tvVersion) + False -- not a force install, since we already overwrite when compiling. + + liftIO $ B.writeFile (fromInstallDir ghcdir ghcUpSrcBuiltFile) bmk + + case installDir of + -- set and make symlinks for regular (non-isolated) installs + GHCupInternal -> do + reThrowAll GHCupSetError $ postGHCInstall installVer + -- restore + when alreadySet $ liftE $ void $ setGHC installVer SetGHCOnly Nothing + + _ -> pure () + + pure installVer + + where + defaultConf = + let cross_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/cross" >> runIO (readFile "data/build_mk/cross"))) + default_mk = $(LitE . StringL <$> (qAddDependentFile "data/build_mk/default" >> runIO (readFile "data/build_mk/default"))) + in case targetGhc of + Left (GHCTargetVersion (Just _) _) -> cross_mk + _ -> default_mk + + compileHadrianBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError] + m + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileHadrianBindist tver workdir ghcdir = do + lEM $ execWithGhcEnv "python3" ["./boot"] (Just workdir) "ghc-bootstrap" + + liftE $ configureBindist tver workdir ghcdir + + lift $ logInfo "Building (this may take a while)..." + hadrian_build <- liftE $ findHadrianFile workdir + lEM $ execWithGhcEnv hadrian_build + ( maybe [] (\j -> ["-j" <> show j] ) jobs + ++ maybe [] (\bf -> ["--flavour=" <> bf]) buildFlavour + ++ ["binary-dist"] + ) + (Just workdir) "ghc-make" + [tar] <- liftIO $ findFiles + (workdir "_build" "bindist") + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + liftE $ fmap Just $ copyBindist tver tar (workdir "_build" "bindist") + + findHadrianFile :: (MonadIO m) + => FilePath + -> Excepts + '[HadrianNotFound] + m + FilePath + findHadrianFile workdir = do + let possible_files = if isWindows + then ((workdir "hadrian") ) <$> ["build.bat"] + else ((workdir "hadrian") ) <$> ["build", "build.sh"] + exsists <- forM possible_files (\f -> liftIO (doesFileExist f) <&> (,f)) + case filter fst exsists of + [] -> throwE HadrianNotFound + ((_, x):_) -> pure x + + compileMakeBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , HadrianNotFound + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError] + m + (Maybe FilePath) -- ^ output path of bindist, None for cross + compileMakeBindist tver workdir ghcdir = do + liftE $ configureBindist tver workdir ghcdir + + case mbuildConfig of + Just bc -> liftIOException + doesNotExistErrorType + (FileDoesNotExistError bc) + (liftIO $ copyFile bc (build_mk workdir) False) + Nothing -> + liftIO $ T.writeFile (build_mk workdir) (addBuildFlavourToConf defaultConf) + + liftE $ checkBuildConfig (build_mk workdir) + + lift $ logInfo "Building (this may take a while)..." + lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) + + if | isCross tver -> do + lift $ logInfo "Installing cross toolchain..." + lEM $ make ["install"] (Just workdir) + pure Nothing + | otherwise -> do + lift $ logInfo "Creating bindist..." + lEM $ make ["binary-dist"] (Just workdir) + [tar] <- liftIO $ findFiles + workdir + (makeRegexOpts compExtended + execBlank + ([s|^ghc-.*\.tar\..*$|] :: ByteString) + ) + liftE $ fmap Just $ copyBindist tver tar workdir + + build_mk workdir = workdir "mk" "build.mk" + + copyBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadIO m + , MonadThrow m + , MonadCatch m + , HasLog env + ) + => GHCTargetVersion + -> FilePath -- ^ tar file + -> FilePath -- ^ workdir + -> Excepts + '[CopyError] + m + FilePath + copyBindist tver tar workdir = do + Dirs {..} <- lift getDirs + pfreq <- lift getPlatformReq + c <- liftIO $ BL.readFile (workdir tar) + cDigest <- + fmap (T.take 8) + . lift + . throwEither + . E.decodeUtf8' + . B16.encode + . SHA256.hashlazy + $ c + cTime <- liftIO getCurrentTime + let tarName = makeValid ("ghc-" + <> T.unpack (tVerToText tver) + <> "-" + <> pfReqToString pfreq + <> "-" + <> iso8601Show cTime + <> "-" + <> T.unpack cDigest + <> ".tar" + <> takeExtension tar) + let tarPath = fromGHCupPath cacheDir tarName + copyFileE (workdir tar) tarPath False + lift $ logInfo $ "Copied bindist to " <> T.pack tarPath + pure tarPath + + checkBuildConfig :: (MonadReader env m, MonadCatch m, MonadIO m, HasLog env) + => FilePath + -> Excepts + '[FileDoesNotExistError, InvalidBuildConfig] + m + () + checkBuildConfig bc = do + c <- liftIOException + doesNotExistErrorType + (FileDoesNotExistError bc) + (liftIO $ B.readFile bc) + let lines' = fmap T.strip . T.lines $ decUTF8Safe c + + -- for cross, we need Stage1Only + case targetGhc of + Left (GHCTargetVersion (Just _) _) -> when ("Stage1Only = YES" `notElem` lines') $ throwE + (InvalidBuildConfig + [s|Cross compiling needs to be a Stage1 build, add "Stage1Only = YES" to your config!|] + ) + _ -> pure () + + forM_ buildFlavour $ \bf -> + when (T.pack ("BuildFlavour = " <> bf) `notElem` lines') $ do + lift $ logWarn $ "Customly specified build config overwrites --flavour=" <> T.pack bf <> " switch! Waiting 5 seconds..." + liftIO $ threadDelay 5000000 + + addBuildFlavourToConf bc = case buildFlavour of + Just bf -> "BuildFlavour = " <> T.pack bf <> "\n" <> bc + Nothing -> bc + + isCross :: GHCTargetVersion -> Bool + isCross = isJust . _tvTarget + + + configureBindist :: ( MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , MonadThrow m + , MonadCatch m + , HasLog env + , MonadIO m + , MonadFail m + ) + => GHCTargetVersion + -> FilePath + -> InstallDirResolved + -> Excepts + '[ FileDoesNotExistError + , InvalidBuildConfig + , PatchFailed + , ProcessError + , NotFoundInPATH + , CopyError + ] + m + () + configureBindist tver workdir (fromInstallDir -> ghcdir) = do + lift $ logInfo [s|configuring build|] + + if | _tvVersion tver >= [vver|8.8.0|] -> do + lEM $ execWithGhcEnv + "sh" + ("./configure" : maybe mempty + (\x -> ["--target=" <> T.unpack x]) + (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] + ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + ++ fmap T.unpack aargs + ) + (Just workdir) + "ghc-conf" + | otherwise -> do + lEM $ execLogged + "sh" + ( [ "./configure", "--with-ghc=" <> either id id bghc + ] + ++ maybe mempty + (\x -> ["--target=" <> T.unpack x]) + (_tvTarget tver) + ++ ["--prefix=" <> ghcdir] + ++ (if isWindows then ["--enable-tarballs-autodownload"] else []) + ++ fmap T.unpack aargs + ) + (Just workdir) + "ghc-conf" + Nothing + pure () + + execWithGhcEnv :: ( MonadReader env m + , HasSettings env + , HasDirs env + , HasLog env + , MonadIO m + , MonadThrow m) + => FilePath -- ^ thing to execute + -> [String] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> FilePath -- ^ log filename (opened in append mode) + -> m (Either ProcessError ()) + execWithGhcEnv fp args dir logf = do + env <- ghcEnv + execLogged fp args dir logf (Just env) + + bghc = case bstrap of + Right g -> Right g + Left bver -> Left ("ghc-" <> (T.unpack . prettyVer $ bver) <> exeExt) + + ghcEnv :: (MonadThrow m, MonadIO m) => m [(String, String)] + ghcEnv = do + cEnv <- liftIO getEnvironment + bghcPath <- case bghc of + Right ghc' -> pure ghc' + Left bver -> do + spaths <- liftIO getSearchPath + throwMaybeM (NotFoundInPATH bver) $ liftIO (searchPath spaths bver) + pure (("GHC", bghcPath) : cEnv) + + + + + ------------- + --[ Other ]-- + ------------- + + + +-- | Creates @ghc-x.y.z@ and @ghc-x.y@ symlinks. This is used for +-- both installing from source and bindist. +postGHCInstall :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadCatch m + , MonadMask m + , MonadUnliftIO m + ) + => GHCTargetVersion + -> Excepts '[NotInstalled] m () +postGHCInstall ver@GHCTargetVersion {..} = do + void $ liftE $ setGHC ver SetGHC_XYZ Nothing + + -- Create ghc-x.y symlinks. This may not be the current + -- version, create it regardless. + v' <- + handle (\(e :: ParseError) -> lift $ logWarn (T.pack $ displayException e) >> pure Nothing) + $ fmap Just + $ getMajorMinorV _tvVersion + forM_ v' $ \(mj, mi) -> lift (getGHCForPVP (PVP (fromIntegral mj :| [fromIntegral mi])) _tvTarget) + >>= mapM_ (\v -> liftE $ setGHC v SetGHC_XY Nothing) + diff --git a/lib/GHCup/HLS.hs b/lib/GHCup/HLS.hs new file mode 100644 index 0000000..0f4f131 --- /dev/null +++ b/lib/GHCup/HLS.hs @@ -0,0 +1,620 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE BangPatterns #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} + +{-| +Module : GHCup.HLS +Description : GHCup installation functions for HLS +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.HLS where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.ByteString ( ByteString ) +import Data.Either +import Data.List +import Data.Maybe +import Data.String ( fromString ) +import Data.Text ( Text ) +import Data.Versions hiding ( patch ) +import Distribution.Types.Version hiding ( Version ) +import Distribution.Types.PackageId +import Distribution.Types.PackageDescription +import Distribution.Types.GenericPackageDescription +import Distribution.PackageDescription.Parsec +import GHC.IO.Exception +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error +import Text.Regex.Posix +import URI.ByteString + +import qualified Data.List.NonEmpty as NE +import qualified Data.ByteString as B +import qualified Data.Text as T +import qualified Text.Megaparsec as MP + + + + -------------------- + --[ Installation ]-- + -------------------- + + +-- | Like 'installHLSBin, except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installHLSBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir -- ^ isolated install path, if user passed any + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + , ProcessError + , DirNotEmpty + , UninstallFailed + , MergeFileTreeError + ] + m + () +installHLSBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install hls version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + regularHLSInstalled <- lift $ hlsInstalled ver + + if + | not forceInstall + , regularHLSInstalled + , GHCupInternal <- installDir -> do -- regular install + throwE $ AlreadyInstalled HLS ver + + | forceInstall + , regularHLSInstalled + , GHCupInternal <- installDir -> do -- regular forced install + lift $ logInfo "Removing the currently installed version of HLS before force installing!" + liftE $ rmHLSVer ver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- fromGHCupPath <$> maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + legacy <- liftIO $ isLegacyHLSBindist workdir + + if + | not forceInstall + , not legacy + , (IsolateDir fp) <- installDir -> liftE $ installDestSanityCheck (IsolateDirResolved fp) + | otherwise -> pure () + + case installDir of + IsolateDir isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + if legacy + then liftE $ installHLSUnpackedLegacy workdir (IsolateDirResolved isoDir) ver forceInstall + else liftE $ runBuildAction tmpUnpack $ installHLSUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + + GHCupInternal -> do + if legacy + then liftE $ installHLSUnpackedLegacy workdir (GHCupBinDir binDir) ver forceInstall + else do + inst <- ghcupHLSDir ver + liftE $ runBuildAction tmpUnpack + $ installHLSUnpacked workdir (GHCupDir inst) ver forceInstall + liftE $ setHLS ver SetHLS_XYZ Nothing + + +isLegacyHLSBindist :: FilePath -- ^ Path to the unpacked hls bindist + -> IO Bool +isLegacyHLSBindist path = do + not <$> doesFileExist (path "GNUmakefile") + +-- | Install an unpacked hls distribution. +installHLSUnpacked :: ( MonadMask m + , MonadUnliftIO m + , MonadReader env m + , MonadFail m + , HasLog env + , HasDirs env + , HasSettings env + , MonadCatch m + , MonadIO m + , MonadResource m + , HasPlatformReq env + ) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool + -> Excepts '[ProcessError, CopyError, FileAlreadyExistsError, NotInstalled, MergeFileTreeError] m () +installHLSUnpacked path inst ver forceInstall = do + PlatformRequest { .. } <- lift getPlatformReq + lift $ logInfo "Installing HLS" + tmpInstallDest <- lift withGHCupTmpDir + lEM $ make ["DESTDIR=" <> fromGHCupPath tmpInstallDest, "PREFIX=" <> fromInstallDir inst, "install"] (Just path) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpInstallDest) + liftE $ mergeFileTree (tmpInstallDest `appendGHCupPath` dropDrive (fromInstallDir inst)) + inst + HLS + (mkTVer ver) + (\f t -> liftIO $ do + mtime <- ifM (pathIsSymbolicLink f) (pure Nothing) (Just <$> getModificationTime f) + install f t (not forceInstall) + forM_ mtime $ setModificationTime t) + +-- | Install an unpacked hls distribution (legacy). +installHLSUnpackedLegacy :: (MonadReader env m, MonadFail m, HasLog env, MonadCatch m, MonadIO m) + => FilePath -- ^ Path to the unpacked hls bindist (where the executable resides) + -> InstallDirResolved -- ^ Path to install to + -> Version + -> Bool -- ^ is it a force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installHLSUnpackedLegacy path installDir ver forceInstall = do + lift $ logInfo "Installing HLS" + liftIO $ createDirRecursive' (fromInstallDir installDir) + + -- install haskell-language-server- + bins@(_:_) <- liftIO $ findFiles + path + (makeRegexOpts compExtended + execBlank + ([s|^haskell-language-server-[0-9].*$|] :: ByteString) + ) + forM_ bins $ \f -> do + let toF = dropSuffix exeExt f + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("~" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + + let srcPath = path f + let destPath = fromInstallDir installDir toF + + -- destination could be an existing symlink + -- for new make-based HLSes + liftIO $ rmFileForce destPath + + copyFileE + srcPath + destPath + (not forceInstall) + lift $ chmod_755 destPath + + -- install haskell-language-server-wrapper + let wrapper = "haskell-language-server-wrapper" + toF = wrapper + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + srcWrapperPath = path wrapper <> exeExt + destWrapperPath = fromInstallDir installDir toF + + liftIO $ rmFileForce destWrapperPath + copyFileE + srcWrapperPath + destWrapperPath + (not forceInstall) + + lift $ chmod_755 destWrapperPath + + + +-- | Installs hls binaries @haskell-language-server-\@ +-- into @~\/.ghcup\/bin/@, as well as @haskell-languager-server-wrapper@. +installHLSBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasGHCupInfo env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + , ProcessError + , DirNotEmpty + , UninstallFailed + , MergeFileTreeError + ] + m + () +installHLSBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo HLS ver + installHLSBindist dlinfo ver installDir forceInstall + + +compileHLS :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Either Version GitBranch + -> [Version] + -> Maybe Int + -> Maybe Version + -> InstallDir + -> Maybe (Either FilePath URI) + -> Maybe URI + -> Maybe (Either FilePath [URI]) -- ^ patches + -> [Text] -- ^ additional args to cabal install + -> Excepts '[ NoDownload + , GPGError + , DownloadFailed + , DigestError + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , BuildFailed + , NotInstalled + ] m Version +compileHLS targetHLS ghcs jobs ov installDir cabalProject cabalProjectLocal patches cabalArgs = do + PlatformRequest { .. } <- lift getPlatformReq + GHCupInfo { _ghcupDownloads = dls } <- lift getGHCupInfo + Dirs { .. } <- lift getDirs + + + (workdir, tver) <- case targetHLS of + -- unpack from version tarball + Left tver -> do + lift $ logDebug $ "Requested to compile: " <> prettyVer tver + + -- download source tarball + dlInfo <- + preview (ix HLS % ix tver % viSourceDL % _Just) dls + ?? NoDownload + dl <- liftE $ downloadCached dlInfo Nothing + + -- unpack + tmpUnpack <- lift mkGhcupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + workdir <- maybe (pure tmpUnpack) + (liftE . intoSubdir tmpUnpack) + (view dlSubdir dlInfo) + + pure (workdir, tver) + + -- clone from git + Right GitBranch{..} -> do + tmpUnpack <- lift mkGhcupTmpDir + let git args = execLogged "git" ("--no-pager":args) (Just $ fromGHCupPath tmpUnpack) "git" Nothing + tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do + let rep = fromMaybe "https://github.com/haskell/haskell-language-server.git" repo + lift $ logInfo $ "Fetching git repo " <> T.pack rep <> " at ref " <> T.pack ref <> " (this may take a while)" + lEM $ git [ "init" ] + lEM $ git [ "remote" + , "add" + , "origin" + , fromString rep ] + + let fetch_args = + [ "fetch" + , "--depth" + , "1" + , "--quiet" + , "origin" + , fromString ref ] + lEM $ git fetch_args + + lEM $ git [ "checkout", "FETCH_HEAD" ] + (Just gpd) <- parseGenericPackageDescriptionMaybe <$> liftIO (B.readFile (fromGHCupPath tmpUnpack "haskell-language-server.cabal")) + pure . (\c -> Version Nothing c [] Nothing) + . NE.fromList . fmap (NE.fromList . (:[]) . digits . fromIntegral) + . versionNumbers + . pkgVersion + . package + . packageDescription + $ gpd + + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + lift $ logInfo $ "Git version " <> T.pack ref <> " corresponds to HLS version " <> prettyVer tver + + pure (tmpUnpack, tver) + + -- the version that's installed may differ from the + -- compiled version, so the user can overwrite it + let installVer = fromMaybe tver ov + + liftE $ runBuildAction + workdir + (reThrowAll @_ @'[GPGError, DownloadFailed, DigestError, PatchFailed, ProcessError, FileAlreadyExistsError, CopyError] @'[BuildFailed] (BuildFailed $ fromGHCupPath workdir) $ do + let tmpInstallDir = fromGHCupPath workdir "out" + liftIO $ createDirRecursive' tmpInstallDir + + -- apply patches + liftE $ applyAnyPatch patches (fromGHCupPath workdir) + + -- set up project files + cp <- case cabalProject of + Just (Left cp) + | isAbsolute cp -> do + copyFileE cp (fromGHCupPath workdir "cabal.project") False + pure "cabal.project" + | otherwise -> pure (takeFileName cp) + Just (Right uri) -> do + tmpUnpack <- lift withGHCupTmpDir + cp <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just "cabal.project") False + copyFileE cp (fromGHCupPath workdir "cabal.project") False + pure "cabal.project" + Nothing -> pure "cabal.project" + forM_ cabalProjectLocal $ \uri -> do + tmpUnpack <- lift withGHCupTmpDir + cpl <- liftE $ download uri Nothing Nothing (fromGHCupPath tmpUnpack) (Just (cp <.> "local")) False + copyFileE cpl (fromGHCupPath workdir cp <.> "local") False + artifacts <- forM (sort ghcs) $ \ghc -> do + let ghcInstallDir = tmpInstallDir T.unpack (prettyVer ghc) + liftIO $ createDirRecursive' tmpInstallDir + lift $ logInfo $ "Building HLS " <> prettyVer installVer <> " for GHC version " <> prettyVer ghc + liftE $ lEM @_ @'[ProcessError] $ + execLogged "cabal" ( [ "v2-install" + , "-w" + , "ghc-" <> T.unpack (prettyVer ghc) + , "--install-method=copy" + ] ++ + maybe [] (\j -> ["--jobs=" <> show j]) jobs ++ + [ "--overwrite-policy=always" + , "--disable-profiling" + , "--disable-tests" + , "--installdir=" <> ghcInstallDir + , "--project-file=" <> cp + ] ++ fmap T.unpack cabalArgs ++ [ + "exe:haskell-language-server" + , "exe:haskell-language-server-wrapper"] + ) + (Just $ fromGHCupPath workdir) + "cabal" + Nothing + pure ghcInstallDir + + forM_ artifacts $ \artifact -> do + logInfo $ T.pack (show artifact) + liftIO $ renameFile (artifact "haskell-language-server" <.> exeExt) + (tmpInstallDir "haskell-language-server-" <> takeFileName artifact <.> exeExt) + liftIO $ renameFile (artifact "haskell-language-server-wrapper" <.> exeExt) + (tmpInstallDir "haskell-language-server-wrapper" <.> exeExt) + + case installDir of + IsolateDir isoDir -> do + lift $ logInfo $ "isolated installing HLS to " <> T.pack isoDir + liftE $ installHLSUnpackedLegacy tmpInstallDir (IsolateDirResolved isoDir) installVer True + GHCupInternal -> do + liftE $ installHLSUnpackedLegacy tmpInstallDir (GHCupBinDir binDir) installVer True + ) + + pure installVer + + + ----------------- + --[ Set/Unset ]-- + ----------------- + +-- | Set the haskell-language-server symlinks. +setHLS :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadIO m + , MonadMask m + , MonadFail m + , MonadUnliftIO m + ) + => Version + -> SetHLS + -> Maybe FilePath -- if set, signals that we're not operating in ~/.ghcup/bin + -- and don't want mess with other versions + -> Excepts '[NotInstalled] m () +setHLS ver shls mBinDir = do + whenM (lift $ not <$> hlsInstalled ver) (throwE (NotInstalled HLS (GHCTargetVersion Nothing ver))) + + -- symlink destination + binDir <- case mBinDir of + Just x -> pure x + Nothing -> do + Dirs {binDir = f} <- lift getDirs + pure f + + -- first delete the old symlinks + when (isNothing mBinDir) $ + case shls of + -- not for legacy + SetHLS_XYZ -> liftE $ rmMinorHLSSymlinks ver + -- legacy and new + SetHLSOnly -> liftE rmPlainHLS + + case shls of + -- not for legacy + SetHLS_XYZ -> do + bins <- lift $ hlsInternalServerScripts ver Nothing + + forM_ bins $ \f -> do + let fname = takeFileName f + destL <- binarySymLinkDestination binDir f + let target = if "haskell-language-server-wrapper" `isPrefixOf` fname + then fname <> "-" <> T.unpack (prettyVer ver) <> exeExt + else fname <> "~" <> T.unpack (prettyVer ver) <> exeExt + lift $ createLink destL (binDir target) + + -- legacy and new + SetHLSOnly -> do + -- set haskell-language-server- symlinks + bins <- lift $ hlsServerBinaries ver Nothing + when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver) + + forM_ bins $ \f -> do + let destL = f + let target = (<> exeExt) . head . splitOn "~" $ f + lift $ createLink destL (binDir target) + + -- set haskell-language-server-wrapper symlink + let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + + lift $ createLink destL wrapper + + when (isNothing mBinDir) $ + lift warnAboutHlsCompatibility + + +unsetHLS :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetHLS = do + Dirs {..} <- getDirs + let wrapper = binDir "haskell-language-server-wrapper" <> exeExt + bins <- liftIO $ handleIO (\_ -> pure []) $ findFiles' + binDir + (MP.chunk "haskell-language-server-" <* pvp' <* MP.chunk (T.pack exeExt) <* MP.eof) + forM_ bins (hideError doesNotExistErrorType . rmLink . (binDir )) + hideError doesNotExistErrorType $ rmLink wrapper + + + + + --------------- + --[ Removal ]-- + --------------- + + +-- | Delete a hls version. Will try to fix the hls symlinks +-- after removal (e.g. setting it to an older version). +rmHLSVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled, UninstallFailed] m () +rmHLSVer ver = do + whenM (lift $ fmap not $ hlsInstalled ver) $ throwE (NotInstalled HLS (GHCTargetVersion Nothing ver)) + + isHlsSet <- lift hlsSet + + liftE $ rmMinorHLSSymlinks ver + + when (Just ver == isHlsSet) $ do + -- delete all set symlinks + liftE rmPlainHLS + + hlsDir' <- ghcupHLSDir ver + let hlsDir = fromGHCupPath hlsDir' + lift (getInstalledFiles HLS (mkTVer ver)) >>= \case + Just files -> do + lift $ logInfo $ "Removing files safely from: " <> T.pack hlsDir + forM_ files (lift . hideError NoSuchThing . recycleFile . (\f -> hlsDir dropDrive f)) + removeEmptyDirsRecursive hlsDir + survivors <- liftIO $ hideErrorDef [doesNotExistErrorType] [] $ listDirectory hlsDir + f <- recordedInstallationFile HLS (mkTVer ver) + lift $ recycleFile f + when (not (null survivors)) $ throwE $ UninstallFailed hlsDir survivors + Nothing -> do + lift $ logInfo $ "Removing legacy directory recursively: " <> T.pack hlsDir + recyclePathForcibly hlsDir' + + when (Just ver == isHlsSet) $ do + -- set latest hls + hlsVers <- lift $ fmap rights getInstalledHLSs + case headMay . reverse . sort $ hlsVers of + Just latestver -> liftE $ setHLS latestver SetHLSOnly Nothing + Nothing -> pure () diff --git a/lib/GHCup/List.hs b/lib/GHCup/List.hs new file mode 100644 index 0000000..91ba381 --- /dev/null +++ b/lib/GHCup/List.hs @@ -0,0 +1,410 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.List +Description : Listing versions and tools +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.List where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude.Logger +import GHCup.Version + +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Data.Either +import Data.List +import Data.Maybe +import Data.Text ( Text ) +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) + +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + + + + + + + + + + + ------------------ + --[ List tools ]-- + ------------------ + + +-- | Filter data type for 'listVersions'. +data ListCriteria = ListInstalled + | ListSet + | ListAvailable + deriving Show + +-- | A list result describes a single tool version +-- and various of its properties. +data ListResult = ListResult + { lTool :: Tool + , lVer :: Version + , lCross :: Maybe Text -- ^ currently only for GHC + , lTag :: [Tag] + , lInstalled :: Bool + , lSet :: Bool -- ^ currently active version + , fromSrc :: Bool -- ^ compiled from source + , lStray :: Bool -- ^ not in download info + , lNoBindist :: Bool -- ^ whether the version is available for this platform/arch + , hlsPowered :: Bool + } + deriving (Eq, Ord, Show) + + +-- | Extract all available tool versions and their tags. +availableToolVersions :: GHCupDownloads -> Tool -> Map.Map Version VersionInfo +availableToolVersions av tool = view + (at tool % non Map.empty) + av + + +-- | List all versions from the download info, as well as stray +-- versions. +listVersions :: ( MonadCatch m + , HasLog env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadReader env m + , HasDirs env + , HasPlatformReq env + , HasGHCupInfo env + ) + => Maybe Tool + -> Maybe ListCriteria + -> m [ListResult] +listVersions lt' criteria = do + -- some annoying work to avoid too much repeated IO + cSet <- cabalSet + cabals <- getInstalledCabals + hlsSet' <- hlsSet + hlses <- getInstalledHLSs + sSet <- stackSet + stacks <- getInstalledStacks + + go lt' cSet cabals hlsSet' hlses sSet stacks + where + go lt cSet cabals hlsSet' hlses sSet stacks = do + case lt of + Just t -> do + GHCupInfo { _ghcupDownloads = dls } <- getGHCupInfo + -- get versions from GHCupDownloads + let avTools = availableToolVersions dls t + lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks) + + case t of + GHC -> do + slr <- strayGHCs avTools + pure (sort (slr ++ lr)) + Cabal -> do + slr <- strayCabals avTools cSet cabals + pure (sort (slr ++ lr)) + HLS -> do + slr <- strayHLS avTools hlsSet' hlses + pure (sort (slr ++ lr)) + Stack -> do + slr <- strayStacks avTools sSet stacks + pure (sort (slr ++ lr)) + GHCup -> do + let cg = maybeToList $ currentGHCup avTools + pure (sort (cg ++ lr)) + Nothing -> do + ghcvers <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks + cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks + hlsvers <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks + ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks + stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks + pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers) + strayGHCs :: ( MonadCatch m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> m [ListResult] + strayGHCs avTools = do + ghcs <- getInstalledGHCs + fmap catMaybes $ forM ghcs $ \case + Right tver@GHCTargetVersion{ _tvTarget = Nothing, .. } -> do + case Map.lookup _tvVersion avTools of + Just _ -> pure Nothing + Nothing -> do + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet Nothing + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions + pure $ Just $ ListResult + { lTool = GHC + , lVer = _tvVersion + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup _tvVersion avTools) + , lNoBindist = False + , .. + } + Right tver@GHCTargetVersion{ .. } -> do + lSet <- fmap (maybe False (\(GHCTargetVersion _ v ) -> v == _tvVersion)) $ ghcSet _tvTarget + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem _tvVersion) hlsGHCVersions + pure $ Just $ ListResult + { lTool = GHC + , lVer = _tvVersion + , lCross = _tvTarget + , lTag = [] + , lInstalled = True + , lStray = True -- NOTE: cross currently cannot be installed via bindist + , lNoBindist = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayCabals :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayCabals avTools cSet cabals = do + fmap catMaybes $ forM cabals $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = cSet == Just ver + pure $ Just $ ListResult + { lTool = Cabal + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayHLS :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayHLS avTools hlsSet' hlss = do + fmap catMaybes $ forM hlss $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = hlsSet' == Just ver + pure $ Just $ ListResult + { lTool = HLS + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + strayStacks :: ( MonadReader env m + , HasDirs env + , MonadCatch m + , MonadThrow m + , HasLog env + , MonadIO m + ) + => Map.Map Version VersionInfo + -> Maybe Version + -> [Either FilePath Version] + -> m [ListResult] + strayStacks avTools stackSet' stacks = do + fmap catMaybes $ forM stacks $ \case + Right ver -> + case Map.lookup ver avTools of + Just _ -> pure Nothing + Nothing -> do + let lSet = stackSet' == Just ver + pure $ Just $ ListResult + { lTool = Stack + , lVer = ver + , lCross = Nothing + , lTag = [] + , lInstalled = True + , lStray = isNothing (Map.lookup ver avTools) + , lNoBindist = False + , fromSrc = False -- actually, we don't know :> + , hlsPowered = False + , .. + } + Left e -> do + logWarn + $ "Could not parse version of stray directory" <> T.pack e + pure Nothing + + currentGHCup :: Map.Map Version VersionInfo -> Maybe ListResult + currentGHCup av = + let currentVer = fromJust $ pvpToVersion ghcUpVer "" + listVer = Map.lookup currentVer av + latestVer = fst <$> headOf (getTagged Latest) av + recommendedVer = fst <$> headOf (getTagged Latest) av + isOld = maybe True (> currentVer) latestVer && maybe True (> currentVer) recommendedVer + in if | Map.member currentVer av -> Nothing + | otherwise -> Just $ ListResult { lVer = currentVer + , lTag = maybe (if isOld then [Old] else []) _viTags listVer + , lCross = Nothing + , lTool = GHCup + , fromSrc = False + , lStray = isNothing listVer + , lSet = True + , lInstalled = True + , lNoBindist = False + , hlsPowered = False + } + + -- NOTE: this are not cross ones, because no bindists + toListResult :: ( HasLog env + , MonadReader env m + , HasDirs env + , HasGHCupInfo env + , HasPlatformReq env + , MonadIO m + , MonadCatch m + ) + => Tool + -> Maybe Version + -> [Either FilePath Version] + -> Maybe Version + -> [Either FilePath Version] + -> Maybe Version + -> [Either FilePath Version] + -> (Version, VersionInfo) + -> m ListResult + toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, _viTags -> tags) = do + case t of + GHC -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo GHC v + let tver = mkTVer v + lSet <- fmap (maybe False (\(GHCTargetVersion _ v') -> v' == v)) $ ghcSet Nothing + lInstalled <- ghcInstalled tver + fromSrc <- ghcSrcInstalled tver + hlsPowered <- fmap (elem v) hlsGHCVersions + pure ListResult { lVer = v, lCross = Nothing , lTag = tags, lTool = t, lStray = False, .. } + Cabal -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Cabal v + let lSet = cSet == Just v + let lInstalled = elem v $ rights cabals + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + GHCup -> do + let lSet = prettyPVP ghcUpVer == prettyVer v + let lInstalled = lSet + pure ListResult { lVer = v + , lTag = tags + , lCross = Nothing + , lTool = t + , fromSrc = False + , lStray = False + , lNoBindist = False + , hlsPowered = False + , .. + } + HLS -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo HLS v + let lSet = hlsSet' == Just v + let lInstalled = elem v $ rights hlses + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + Stack -> do + lNoBindist <- fmap (isLeft . veitherToEither) $ runE @'[NoDownload] $ getDownloadInfo Stack v + let lSet = stackSet' == Just v + let lInstalled = elem v $ rights stacks + pure ListResult { lVer = v + , lCross = Nothing + , lTag = tags + , lTool = t + , fromSrc = False + , lStray = False + , hlsPowered = False + , .. + } + + + filter' :: [ListResult] -> [ListResult] + filter' lr = case criteria of + Nothing -> lr + Just ListInstalled -> filter (\ListResult {..} -> lInstalled) lr + Just ListSet -> filter (\ListResult {..} -> lSet) lr + Just ListAvailable -> filter (\ListResult {..} -> not lNoBindist) lr + diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index ec1e7c8..58722af 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -24,10 +24,10 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Prelude +import GHCup.Prelude.Logger +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ #if !MIN_VERSION_base(4,13,0) import Control.Monad.Fail ( MonadFail ) diff --git a/lib/GHCup/Prelude.hs b/lib/GHCup/Prelude.hs new file mode 100644 index 0000000..63c2490 --- /dev/null +++ b/lib/GHCup/Prelude.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} + +{-| +Module : GHCup.Prelude +Description : MegaParsec utilities +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +GHCup specific prelude. Lots of Excepts functionality. +-} +module GHCup.Prelude + (module GHCup.Prelude, + module GHCup.Prelude.Internal, +#if defined(IS_WINDOWS) + module GHCup.Prelude.Windows +#else + module GHCup.Prelude.Posix +#endif + ) +where + +import GHCup.Prelude.Internal +import GHCup.Types.Optics (HasLog) +import GHCup.Prelude.Logger (logWarn) +#if defined(IS_WINDOWS) +import GHCup.Prelude.Windows +#else +import GHCup.Prelude.Posix +#endif + +import Control.Monad.IO.Class +import Control.Monad.Reader +import Haskus.Utils.Variant.Excepts +import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) +import qualified Data.Text as T + + + +-- for some obscure reason... this won't type-check if we move it to a different module +catchWarn :: forall es m env . ( Pretty (V es) + , MonadReader env m + , HasLog env + , MonadIO m + , Monad m) => Excepts es m () -> Excepts '[] m () +catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) + diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Prelude/File.hs similarity index 79% rename from lib/GHCup/Utils/File.hs rename to lib/GHCup/Prelude/File.hs index 493c531..a79cd10 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Prelude/File.hs @@ -8,7 +8,7 @@ {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} -module GHCup.Utils.File ( +module GHCup.Prelude.File ( mergeFileTree, copyFileE, findFilesDeep, @@ -19,12 +19,8 @@ module GHCup.Utils.File ( getDirectoryContentsRecursiveBFSUnsafe, getDirectoryContentsRecursiveDFSUnsafe, recordedInstallationFile, - module GHCup.Utils.File.Common, + module GHCup.Prelude.File.Search, - executeOut, - execLogged, - exec, - toProcessError, chmod_755, isBrokenSymlink, copyFile, @@ -41,25 +37,38 @@ module GHCup.Utils.File ( rmFile, rmDirectoryLink, moveFilePortable, - moveFile + moveFile, + rmPathForcibly, + + exeExt, + exeExt', + getLinkTarget, + pathIsLink, + rmLink, + createLink ) where import GHCup.Utils.Dirs -import GHCup.Utils.File.Common +import GHCup.Prelude.Logger.Internal (logInfo, logDebug) +import GHCup.Prelude.Internal +import GHCup.Prelude.File.Search #if IS_WINDOWS -import GHCup.Utils.File.Windows +import GHCup.Prelude.File.Windows +import GHCup.Prelude.Windows #else -import GHCup.Utils.File.Posix +import GHCup.Prelude.File.Posix +import GHCup.Prelude.Posix #endif import GHCup.Errors import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.Prelude import Text.Regex.Posix +import Control.Monad.IO.Unlift ( MonadUnliftIO ) import Control.Exception.Safe -import Haskus.Utils.Variant.Excepts import Control.Monad.Reader +import Data.ByteString ( ByteString ) +import Haskus.Utils.Variant.Excepts import System.FilePath import Text.PrettyPrint.HughesPJClass (prettyShow) @@ -69,7 +78,6 @@ import Control.DeepSeq (force) import Control.Exception (evaluate) import GHC.IO.Exception import System.IO.Error -import GHCup.Utils.Logger -- | Merge one file tree to another given a copy operation. @@ -338,3 +346,81 @@ rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) rmDirectoryLink fp | isWindows = recover (liftIO $ removeDirectoryLink fp) | otherwise = liftIO $ removeDirectoryLink fp + + +rmPathForcibly :: ( MonadIO m + , MonadMask m + ) + => GHCupPath + -> m () +rmPathForcibly fp + | isWindows = recover (liftIO $ removePathForcibly fp) + | otherwise = liftIO $ removePathForcibly fp + + +-- | The file extension for executables. +exeExt :: String +exeExt + | isWindows = ".exe" + | otherwise = "" + +-- | The file extension for executables. +exeExt' :: ByteString +exeExt' + | isWindows = ".exe" + | otherwise = "" + + +rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () +rmLink fp + | isWindows = do + hideError doesNotExistErrorType . recycleFile $ fp + hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") + | otherwise = hideError doesNotExistErrorType . recycleFile $ fp + + +-- | Creates a symbolic link on unix and a fake symlink on windows for +-- executables, which: +-- 1. is a shim exe +-- 2. has a corresponding .shim file in the same directory that +-- contains the target +-- +-- This overwrites previously existing files. +-- +-- On windows, this requires that 'ensureGlobalTools' was run beforehand. +createLink :: ( MonadMask m + , MonadThrow m + , HasLog env + , MonadIO m + , MonadReader env m + , HasDirs env + , MonadUnliftIO m + , MonadFail m + ) + => FilePath -- ^ path to the target executable + -> FilePath -- ^ path to be created + -> m () +createLink link exe + | isWindows = do + dirs <- getDirs + let shimGen = fromGHCupPath (cacheDir dirs) "gs.exe" + + let shim = dropExtension exe <.> "shim" + -- For hardlinks, link needs to be absolute. + -- If link is relative, it's relative to the target exe. + -- Note that () drops lhs when rhs is absolute. + fullLink = takeDirectory exe link + shimContents = "path = " <> fullLink + + logDebug $ "rm -f " <> T.pack exe + rmLink exe + + logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe + liftIO $ copyFile shimGen exe False + liftIO $ writeFile shim shimContents + | otherwise = do + logDebug $ "rm -f " <> T.pack exe + hideError doesNotExistErrorType $ recycleFile exe + + logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe + liftIO $ createFileLink link exe diff --git a/lib/GHCup/Prelude/File/Posix.hs b/lib/GHCup/Prelude/File/Posix.hs new file mode 100644 index 0000000..1b774ac --- /dev/null +++ b/lib/GHCup/Prelude/File/Posix.hs @@ -0,0 +1,324 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE CApiFFI #-} + +{-| +Module : GHCup.Utils.File.Posix +Description : File and directory handling for unix +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : POSIX +-} +module GHCup.Prelude.File.Posix where + +import GHCup.Prelude.File.Posix.Traversals + +import Control.Exception.Safe +import Control.Monad.Reader +import Foreign.C.String +import Foreign.C.Error +import Foreign.C.Types +import System.IO ( hClose, hSetBinaryMode ) +import System.IO.Error hiding ( catchIOError ) +import System.FilePath +import System.Directory ( removeFile, pathIsSymbolicLink, getSymbolicLinkTarget, doesPathExist ) +import System.Posix.Directory +import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) +import System.Posix.Internals ( withFilePath ) +import System.Posix.Files +import System.Posix.Types + + +import qualified System.Posix.Directory as PD +import qualified System.Posix.Files as PF +import qualified System.Posix.IO as SPI +import qualified System.Posix as Posix +import qualified Streamly.FileSystem.Handle as FH +import qualified Streamly.Internal.FileSystem.Handle + as IFH +import qualified Streamly.Prelude as S +import qualified GHCup.Prelude.File.Posix.Foreign as FD +import qualified Streamly.Internal.Data.Stream.StreamD.Type + as D +import Streamly.Internal.Data.Unfold.Type +import qualified Streamly.Internal.Data.Unfold as U +import Streamly.Internal.Control.Concurrent ( withRunInIO ) +import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) + + +-- | On unix, we can use symlinks, so we just get the +-- symbolic link target. +-- +-- On windows, we have to emulate symlinks via shims, +-- see 'createLink'. +getLinkTarget :: FilePath -> IO FilePath +getLinkTarget = getSymbolicLinkTarget + + +-- | Checks whether the path is a link. +pathIsLink :: FilePath -> IO Bool +pathIsLink = pathIsSymbolicLink + + +chmod_755 :: MonadIO m => FilePath -> m () +chmod_755 fp = do + let exe_mode = + nullFileMode + `unionFileModes` ownerExecuteMode + `unionFileModes` ownerReadMode + `unionFileModes` ownerWriteMode + `unionFileModes` groupExecuteMode + `unionFileModes` groupReadMode + `unionFileModes` otherExecuteMode + `unionFileModes` otherReadMode + liftIO $ setFileMode fp exe_mode + + +-- |Default permissions for a new file. +newFilePerms :: FileMode +newFilePerms = + ownerWriteMode + `unionFileModes` ownerReadMode + `unionFileModes` groupWriteMode + `unionFileModes` groupReadMode + `unionFileModes` otherWriteMode + `unionFileModes` otherReadMode + + +-- | Checks whether the binary is a broken link. +isBrokenSymlink :: FilePath -> IO Bool +isBrokenSymlink fp = do + try (pathIsSymbolicLink fp) >>= \case + Right True -> do + let symDir = takeDirectory fp + tfp <- getSymbolicLinkTarget fp + not <$> doesPathExist + -- this drops 'symDir' if 'tfp' is absolute + (symDir tfp) + Right b -> pure b + Left e | isDoesNotExistError e -> pure False + | otherwise -> throwIO e + +copyFile :: FilePath -- ^ source file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if file exists + -> IO () +copyFile from to fail' = do + bracket + (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) + (hClose . snd) + $ \(fromFd, fH) -> do + sourceFileMode <- fileMode <$> getFdStatus fromFd + let dflags = [ FD.oNofollow + , if fail' then FD.oExcl else FD.oTrunc + ] + bracket + (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) + (hClose . snd) + $ \(_, tH) -> do + hSetBinaryMode fH True + hSetBinaryMode tH True + streamlyCopy (fH, tH) + where + openFdHandle fp omode flags fM = do + fd <- openFd' fp omode flags fM + handle' <- SPI.fdToHandle fd + pure (fd, handle') + streamlyCopy (fH, tH) = + S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH + +foreign import capi unsafe "fcntl.h open" + c_open :: CString -> CInt -> Posix.CMode -> IO CInt + + +open_ :: CString + -> Posix.OpenMode + -> [FD.Flags] + -> Maybe Posix.FileMode + -> IO Posix.Fd +open_ str how optional_flags maybe_mode = do + fd <- c_open str all_flags mode_w + return (Posix.Fd fd) + where + all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat + + + (creat, mode_w) = case maybe_mode of + Nothing -> ([],0) + Just x -> ([FD.oCreat], x) + + open_mode = case how of + Posix.ReadOnly -> FD.oRdonly + Posix.WriteOnly -> FD.oWronly + Posix.ReadWrite -> FD.oRdwr + + +-- |Open and optionally create this file. See 'System.Posix.Files' +-- for information on how to use the 'FileMode' type. +-- +-- Note that passing @Just x@ as the 4th argument triggers the +-- `oCreat` status flag, which must be set when you pass in `oExcl` +-- to the status flags. Also see the manpage for @open(2)@. +openFd' :: FilePath + -> Posix.OpenMode + -> [FD.Flags] -- ^ status flags of @open(2)@ + -> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist. + -> IO Posix.Fd +openFd' name how optional_flags maybe_mode = + withFilePath name $ \str -> + throwErrnoPathIfMinus1Retry "openFd" name $ + open_ str how optional_flags maybe_mode + + +-- |Deletes the given file. Raises `eISDIR` +-- if run on a directory. Does not follow symbolic links. +-- +-- Throws: +-- +-- - `InappropriateType` for wrong file type (directory) +-- - `NoSuchThing` if the file does not exist +-- - `PermissionDenied` if the directory cannot be read +-- +-- Notes: calls `unlink` +deleteFile :: FilePath -> IO () +deleteFile = removeLink + + +-- |Recreate a symlink. +-- +-- In `Overwrite` copy mode only files and empty directories are deleted. +-- +-- Safety/reliability concerns: +-- +-- * `Overwrite` mode is inherently non-atomic +-- +-- Throws: +-- +-- - `InvalidArgument` if source file is wrong type (not a symlink) +-- - `PermissionDenied` if output directory cannot be written to +-- - `PermissionDenied` if source directory cannot be opened +-- - `SameFile` if source and destination are the same file +-- (`HPathIOException`) +-- +-- +-- Throws in `Strict` mode only: +-- +-- - `AlreadyExists` if destination already exists +-- +-- Throws in `Overwrite` mode only: +-- +-- - `UnsatisfiedConstraints` if destination file is non-empty directory +-- +-- Notes: +-- +-- - calls `symlink` +recreateSymlink :: FilePath -- ^ the old symlink file + -> FilePath -- ^ destination file + -> Bool -- ^ fail if destination file exists + -> IO () +recreateSymlink symsource newsym fail' = do + sympoint <- readSymbolicLink symsource + case fail' of + True -> pure () + False -> + handleIO (\e -> if doesNotExistErrorType == ioeGetErrorType e then pure () else liftIO . ioError $ e) $ deleteFile newsym + createSymbolicLink sympoint newsym + + +-- copys files, recreates symlinks, fails on all other types +install :: FilePath -> FilePath -> Bool -> IO () +install from to fail' = do + fs <- PF.getSymbolicLinkStatus from + decide fs + where + decide fs | PF.isRegularFile fs = copyFile from to fail' + | PF.isSymbolicLink fs = recreateSymlink from to fail' + | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from) + +moveFile :: FilePath -> FilePath -> IO () +moveFile = rename + + +moveFilePortable :: FilePath -> FilePath -> IO () +moveFilePortable from to = do + catchErrno [eXDEV] (moveFile from to) $ do + copyFile from to True + removeFile from + + +catchErrno :: [Errno] -- ^ errno to catch + -> IO a -- ^ action to try, which can raise an IOException + -> IO a -- ^ action to carry out in case of an IOException and + -- if errno matches + -> IO a +catchErrno en a1 a2 = + catchIOError a1 $ \e -> do + errno <- getErrno + if errno `elem` en + then a2 + else ioError e + +removeEmptyDirectory :: FilePath -> IO () +removeEmptyDirectory = PD.removeDirectory + + +-- | Create an 'Unfold' of directory contents. +unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) +unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) + where + {-# INLINE [0] step #-} + step dirstream = do + (typ, e) <- liftIO $ readDirEnt dirstream + return $ if + | null e -> D.Stop + | "." == e -> D.Skip dirstream + | ".." == e -> D.Skip dirstream + | otherwise -> D.Yield (typ, e) dirstream + + +getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveDFSUnsafe fp = go "" + where + go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> + if | t == FD.dtDir -> go (cd f) + | otherwise -> pure (cd f) + + +getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath +getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) + where + {-# INLINE [0] step #-} + step (_, Nothing, []) = return D.Stop + + step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do + (dt, f) <- liftIO $ readDirEnt dirstream + if | FD.dtUnknown == dt -> do + runIOFinalizer finalizer + return $ D.Skip (topdir, Nothing, dirs) + | f == "." || f == ".." + -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) + | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) + | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) + + step (topdir, Nothing, dir:dirs) = do + (s, f) <- acquire (topdir dir) + return $ D.Skip (topdir, Just (dir, s, f), dirs) + + acquire dir = + withRunInIO $ \run -> mask_ $ run $ do + dirstream <- liftIO $ openDirStream dir + ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) + return (dirstream, ref) + +getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) + => FilePath + -> S.SerialT m FilePath +getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold + + diff --git a/lib/GHCup/Utils/File/Posix/Foreign.hsc b/lib/GHCup/Prelude/File/Posix/Foreign.hsc similarity index 97% rename from lib/GHCup/Utils/File/Posix/Foreign.hsc rename to lib/GHCup/Prelude/File/Posix/Foreign.hsc index 445b311..ed3f696 100644 --- a/lib/GHCup/Utils/File/Posix/Foreign.hsc +++ b/lib/GHCup/Prelude/File/Posix/Foreign.hsc @@ -1,6 +1,6 @@ {-# LANGUAGE PatternSynonyms #-} -module GHCup.Utils.File.Posix.Foreign where +module GHCup.Prelude.File.Posix.Foreign where import Data.Bits import Data.List (foldl') diff --git a/lib/GHCup/Utils/File/Posix/Traversals.hs b/lib/GHCup/Prelude/File/Posix/Traversals.hs similarity index 96% rename from lib/GHCup/Utils/File/Posix/Traversals.hs rename to lib/GHCup/Prelude/File/Posix/Traversals.hs index 1c1a241..f3a0490 100644 --- a/lib/GHCup/Utils/File/Posix/Traversals.hs +++ b/lib/GHCup/Prelude/File/Posix/Traversals.hs @@ -7,7 +7,7 @@ {-# OPTIONS_GHC -Wall #-} -module GHCup.Utils.File.Posix.Traversals ( +module GHCup.Prelude.File.Posix.Traversals ( -- lower-level stuff readDirEnt , unpackDirStream @@ -17,7 +17,7 @@ module GHCup.Utils.File.Posix.Traversals ( #if __GLASGOW_HASKELL__ < 710 import Control.Applicative ((<$>)) #endif -import GHCup.Utils.File.Posix.Foreign +import GHCup.Prelude.File.Posix.Foreign import Unsafe.Coerce (unsafeCoerce) import Foreign.C.Error diff --git a/lib/GHCup/Utils/File/Common.hs b/lib/GHCup/Prelude/File/Search.hs similarity index 86% rename from lib/GHCup/Utils/File/Common.hs rename to lib/GHCup/Prelude/File/Search.hs index 3a923e6..6a667c5 100644 --- a/lib/GHCup/Utils/File/Common.hs +++ b/lib/GHCup/Prelude/File/Search.hs @@ -2,13 +2,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE FlexibleContexts #-} -module GHCup.Utils.File.Common ( - module GHCup.Utils.File.Common +module GHCup.Prelude.File.Search ( + module GHCup.Prelude.File.Search , ProcessError(..) , CapturedProcess(..) ) where -import GHCup.Utils.Prelude import GHCup.Types(ProcessError(..), CapturedProcess(..)) import Control.Monad.Reader @@ -27,6 +26,8 @@ import Text.Regex.Posix import qualified Data.Text as T import qualified Text.Megaparsec as MP +import Control.Exception.Safe (handleIO) +import System.Directory.Internal.Prelude (ioeGetErrorType) @@ -38,7 +39,7 @@ searchPath paths needle = go paths where go [] = pure Nothing go (x : xs) = - hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs) + handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e) $ do contents <- listDirectory x findM (isMatch x) contents >>= \case @@ -52,6 +53,12 @@ searchPath paths needle = go paths isExecutable :: FilePath -> IO Bool isExecutable file = executable <$> getPermissions file + -- TODO: inlined from GHCup.Prelude + findM ~p = foldr (\x -> ifM (p x) (pure $ Just x)) (pure Nothing) + ifM ~b ~t ~f = do + b' <- b + if b' then t else f + -- | Check wether a binary is shadowed by another one that comes before -- it in PATH. Returns the path to said binary, if any. @@ -106,7 +113,3 @@ findFiles' path parser = do pure $ filter (\fp -> either (const False) (const True) $ MP.parse parser "" (T.pack fp)) contents -checkFileAlreadyExists :: (MonadIO m) => FilePath -> m Bool -checkFileAlreadyExists fp = liftIO $ doesFileExist fp - - diff --git a/lib/GHCup/Utils/File/Windows.hs b/lib/GHCup/Prelude/File/Windows.hs similarity index 52% rename from lib/GHCup/Utils/File/Windows.hs rename to lib/GHCup/Prelude/File/Windows.hs index 84d979b..acfca8b 100644 --- a/lib/GHCup/Utils/File/Windows.hs +++ b/lib/GHCup/Prelude/File/Windows.hs @@ -4,48 +4,28 @@ {-| Module : GHCup.Utils.File.Windows -Description : File and windows APIs +Description : File and directory handling for windows Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : Windows - -This module handles file and executable handling. -Some of these functions use sophisticated logging. -} -module GHCup.Utils.File.Windows where +module GHCup.Prelude.File.Windows where -import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink ) import GHCup.Utils.Dirs -import GHCup.Utils.File.Common -import GHCup.Utils.Logger -import GHCup.Types -import GHCup.Types.Optics +import GHCup.Prelude.Internal -import Control.Concurrent -import Control.DeepSeq import Control.Exception.Safe import Control.Monad import Control.Monad.Reader import Data.List -import Foreign.C.Error -import GHC.IO.Exception -import GHC.IO.Handle import qualified GHC.Unicode as U -import System.Environment import System.FilePath -import System.IO import qualified System.IO.Error as IOE -import System.Process import qualified System.Win32.Info as WS import qualified System.Win32.File as WS -import qualified Control.Exception as EX -import qualified Data.ByteString as BS -import qualified Data.ByteString.Lazy as BL -import qualified Data.Map.Strict as Map -import qualified Data.Text as T import qualified Streamly.Internal.Data.Stream.StreamD.Type as D @@ -58,188 +38,23 @@ import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFin -toProcessError :: FilePath - -> [FilePath] - -> ExitCode - -> Either ProcessError () -toProcessError exe args exitcode = case exitcode of - (ExitFailure xi) -> Left $ NonZeroExit xi exe args - ExitSuccess -> Right () - - --- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it --- lets you pass 'CreateProcess' giving better flexibility. +-- | On unix, we can use symlinks, so we just get the +-- symbolic link target. -- --- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess --- record will be ignored. --- --- @since 1.2.3.0 -readCreateProcessWithExitCodeBS - :: CreateProcess - -> BL.ByteString - -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr -readCreateProcessWithExitCodeBS cp input = do - let cp_opts = cp { - std_in = CreatePipe, - std_out = CreatePipe, - std_err = CreatePipe - } - withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $ - \mb_inh mb_outh mb_errh ph -> - case (mb_inh, mb_outh, mb_errh) of - (Just inh, Just outh, Just errh) -> do - - out <- BS.hGetContents outh - err <- BS.hGetContents errh - - -- fork off threads to start consuming stdout & stderr - withForkWait (EX.evaluate $ rnf out) $ \waitOut -> - withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do - - -- now write any input - unless (BL.null input) $ - ignoreSigPipe $ BL.hPut inh input - -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE - ignoreSigPipe $ hClose inh - - -- wait on the output - waitOut - waitErr - - hClose outh - hClose errh - - -- wait on the process - ex <- waitForProcess ph - return (ex, BL.fromStrict out, BL.fromStrict err) - - (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle." - (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle." - (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle." - where - ignoreSigPipe :: IO () -> IO () - ignoreSigPipe = EX.handle $ \e -> case e of - IOError { ioe_type = ResourceVanished - , ioe_errno = Just ioe } - | Errno ioe == ePIPE -> return () - _ -> throwIO e - -- wrapper so we can get exceptions with the appropriate function name. - withCreateProcess_ - :: String - -> CreateProcess - -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) - -> IO a - withCreateProcess_ fun c action = - EX.bracketOnError (createProcess_ fun c) cleanupProcess - (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) - --- | Fork a thread while doing something else, but kill it if there's an --- exception. --- --- This is important in the cases above because we want to kill the thread --- that is holding the Handle lock, because when we clean up the process we --- try to close that handle, which could otherwise deadlock. --- -withForkWait :: IO () -> (IO () -> IO a) -> IO a -withForkWait async' body = do - waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) - mask $ \restore -> do - tid <- forkIO $ try (restore async') >>= putMVar waitVar - let wait' = takeMVar waitVar >>= either throwIO return - restore (body wait') `EX.onException` killThread tid +-- On windows, we have to emulate symlinks via shims, +-- see 'createLink'. +getLinkTarget :: FilePath -> IO FilePath +getLinkTarget fp = do + content <- readFile (dropExtension fp <.> "shim") + [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content + pure $ stripNewline $ dropPrefix "path = " p --- | Execute the given command and collect the stdout, stderr and the exit code. --- The command is run in a subprocess. -executeOut :: MonadIO m - => FilePath -- ^ command as filename, e.g. 'ls' - -> [String] -- ^ arguments to the command - -> Maybe FilePath -- ^ chdir to this path - -> m CapturedProcess -executeOut path args chdir = do - cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir }) - (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" - pure $ CapturedProcess exit out err +-- | Checks whether the path is a link. +pathIsLink :: FilePath -> IO Bool +pathIsLink fp = doesPathExist (dropExtension fp <.> "shim") -execLogged :: ( MonadReader env m - , HasDirs env - , HasLog env - , HasSettings env - , MonadIO m - , MonadThrow m) - => FilePath -- ^ thing to execute - -> [String] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> FilePath -- ^ log filename (opened in append mode) - -> Maybe [(String, String)] -- ^ optional environment - -> m (Either ProcessError ()) -execLogged exe args chdir lfile env = do - Dirs {..} <- getDirs - logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args - let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" - stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" - cp <- createProcessWithMingwPath ((proc exe args) - { cwd = chdir - , env = env - , std_in = CreatePipe - , std_out = CreatePipe - , std_err = CreatePipe - }) - fmap (toProcessError exe args) - $ liftIO - $ withCreateProcess cp - $ \_ mout merr ph -> - case (mout, merr) of - (Just cStdout, Just cStderr) -> do - withForkWait (tee stdoutLogfile cStdout) $ \waitOut -> - withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do - waitOut - waitErr - waitForProcess ph - _ -> fail "Could not acquire out/err handle" - - where - tee :: FilePath -> Handle -> IO () - tee logFile handle' = go - where - go = do - some <- BS.hGetSome handle' 512 - if BS.null some - then pure () - else do - void $ BS.appendFile logFile some - -- subprocess stdout also goes to stderr for logging - void $ BS.hPut stderr some - go - - --- | Thin wrapper around `executeFile`. -exec :: MonadIO m - => FilePath -- ^ thing to execute - -> [FilePath] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> Maybe [(String, String)] -- ^ optional environment - -> m (Either ProcessError ()) -exec exe args chdir env = do - cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) - exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p - pure $ toProcessError exe args exit_code - - --- | Thin wrapper around `executeFile`. -execShell :: MonadIO m - => FilePath -- ^ thing to execute - -> [FilePath] -- ^ args for the thing - -> Maybe FilePath -- ^ optionally chdir into this - -> Maybe [(String, String)] -- ^ optional environment - -> m (Either ProcessError ()) -execShell exe args chdir env = do - let cmd = exe <> " " <> concatMap (' ':) args - cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env }) - exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p - pure $ toProcessError cmd [] exit_code - chmod_755 :: MonadIO m => FilePath -> m () chmod_755 fp = @@ -247,30 +62,6 @@ chmod_755 fp = in liftIO $ setPermissions fp perm -createProcessWithMingwPath :: MonadIO m - => CreateProcess - -> m CreateProcess -createProcessWithMingwPath cp = do - msys2Dir <- liftIO ghcupMsys2Dir - cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp) - let mingWPaths = [msys2Dir "usr" "bin" - ,msys2Dir "mingw64" "bin"] - paths = ["PATH", "Path"] - curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths - newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) - envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths - envWithNewPath = Map.insert "Path" newPath envWithoutPath - liftIO $ setEnv "Path" newPath - pure $ cp { env = Just $ Map.toList envWithNewPath } - -ghcupMsys2Dir :: IO FilePath -ghcupMsys2Dir = - lookupEnv "GHCUP_MSYS2" >>= \case - Just fp -> pure fp - Nothing -> do - baseDir <- liftIO ghcupBaseDir - pure (fromGHCupPath baseDir "msys64") - -- | Checks whether the binary is a broken link. isBrokenSymlink :: FilePath -> IO Bool isBrokenSymlink fp = do diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Prelude/Internal.hs similarity index 80% rename from lib/GHCup/Utils/Prelude.hs rename to lib/GHCup/Prelude/Internal.hs index d39d5d0..093f3e1 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Prelude/Internal.hs @@ -7,7 +7,7 @@ {-# LANGUAGE TypeOperators #-} {-| -Module : GHCup.Utils.Prelude +Module : GHCup.Prelude.Internal Description : MegaParsec utilities Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -15,28 +15,11 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -GHCup specific prelude. Lots of Excepts functionality. +Stuff that doesn't need GHCup modules, so we can avoid +recursive imports. -} -module GHCup.Utils.Prelude - (module GHCup.Utils.Prelude, -#if defined(IS_WINDOWS) - module GHCup.Utils.Prelude.Windows -#else - module GHCup.Utils.Prelude.Posix -#endif - ) -where +module GHCup.Prelude.Internal where -import {-# SOURCE #-} GHCup.Utils.Dirs (GHCupPath, fromGHCupPath, createTempGHCupDirectory, appendGHCupPath, removePathForcibly, removeDirectory) -import GHCup.Types -import GHCup.Errors -import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.Logger (logWarn) -#if defined(IS_WINDOWS) -import GHCup.Utils.Prelude.Windows -#else -import GHCup.Utils.Prelude.Posix -#endif import Control.Applicative import Control.Exception.Safe @@ -45,23 +28,15 @@ import Control.Monad.IO.Class import Control.Monad.Reader import Data.Bifunctor import Data.ByteString ( ByteString ) -import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse ) +import Data.List ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd ) import Data.Maybe -import Data.List.NonEmpty ( NonEmpty( (:|) )) import Data.String import Data.Text ( Text ) import Data.Versions import Data.Word8 hiding ( isDigit ) import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts -import Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty ) import System.IO.Error -import System.Directory hiding ( removeDirectory - , removeDirectoryRecursive - , removePathForcibly - , copyFile - ) -import System.FilePath import Control.Retry import GHC.IO.Exception @@ -70,7 +45,6 @@ import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L import qualified Data.Strict.Maybe as S import qualified Data.List.Split as Split -import qualified Data.List.NonEmpty as NE import qualified Data.Text as T import qualified Data.Text.Encoding as E import qualified Data.Text.Encoding.Error as E @@ -184,13 +158,6 @@ lEM' :: forall e' e es a m -> Excepts es m a lEM' f em = lift em >>= lE . first f --- for some obscure reason... this won't type-check if we move it to a different module -catchWarn :: forall es m env . ( Pretty (V es) - , MonadReader env m - , HasLog env - , MonadIO m - , Monad m) => Excepts es m () -> Excepts '[] m () -catchWarn = catchAllE @_ @es (\v -> lift $ logWarn (T.pack . prettyShow $ v)) fromEither :: Either a b -> VEither '[a] b fromEither = either (VLeft . V) VRight @@ -311,56 +278,6 @@ intToText :: Integral a => a -> T.Text intToText = TL.toStrict . B.toLazyText . B.decimal -pvpToVersion :: MonadThrow m => PVP -> Text -> m Version -pvpToVersion pvp_ rest = - either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . version . (<> rest) . prettyPVP $ pvp_ - --- | Convert a version to a PVP and unparsable rest. --- --- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v -versionToPVP :: MonadThrow m => Version -> m (PVP, Text) -versionToPVP (Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch" -versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . pvp . prettyVer $ v - where - alternative :: MonadThrow m => Version -> m PVP - alternative v' = case NE.takeWhile isDigit (_vChunks v') of - [] -> throwM $ ParseError "Couldn't convert Version to PVP" - xs -> pure $ pvpFromList (unsafeDigit <$> xs) - - rest :: Version -> Text - rest (Version _ cs pr me) = - let chunks = NE.dropWhile isDigit cs - ver = intersperse (T.pack ".") . chunksAsT $ chunks - me' = maybe [] (\m -> [T.pack "+",m]) me - pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr) - prefix = case (ver, pr', me') of - (_:_, _, _) -> T.pack "." - _ -> T.pack "" - in prefix <> mconcat (ver <> pr' <> me') - where - chunksAsT :: Functor t => t VChunk -> t Text - chunksAsT = fmap (foldMap f) - where - f :: VUnit -> Text - f (Digits i) = T.pack $ show i - f (Str s) = s - - foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b - foldable d g f | null f = d - | otherwise = g f - - - - isDigit :: VChunk -> Bool - isDigit (Digits _ :| []) = True - isDigit _ = False - - unsafeDigit :: VChunk -> Int - unsafeDigit (Digits x :| []) = fromIntegral x - unsafeDigit _ = error "unsafeDigit: wrong input" - -pvpFromList :: [Int] -> PVP -pvpFromList = PVP . NE.fromList . fmap fromIntegral -- | Safe 'decodeUtf8With'. Replaces an invalid input byte with -- the Unicode replacement character U+FFFD. diff --git a/lib/GHCup/Prelude/Logger.hs b/lib/GHCup/Prelude/Logger.hs new file mode 100644 index 0000000..b256cf9 --- /dev/null +++ b/lib/GHCup/Prelude/Logger.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Utils.Logger +Description : logger definition +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable + +Here we define our main logger. +-} +module GHCup.Prelude.Logger + ( module GHCup.Prelude.Logger + , module GHCup.Prelude.Logger.Internal + ) +where + +import GHCup.Prelude.Logger.Internal +import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils.Dirs (fromGHCupPath) +import GHCup.Prelude.Internal +import GHCup.Prelude.File.Search (findFiles) +import GHCup.Prelude.File (recycleFile) +import GHCup.Prelude.String.QQ + +import Control.Exception.Safe +import Control.Monad +import Control.Monad.IO.Class +import Control.Monad.Reader +import Prelude hiding ( appendFile ) +import System.FilePath +import System.IO.Error +import Text.Regex.Posix + +import qualified Data.ByteString as B + + + +initGHCupFileLogging :: ( MonadReader env m + , HasDirs env + , MonadIO m + , MonadMask m + ) => m FilePath +initGHCupFileLogging = do + Dirs { logsDir } <- getDirs + let logfile = fromGHCupPath logsDir "ghcup.log" + logFiles <- liftIO $ findFiles + (fromGHCupPath logsDir) + (makeRegexOpts compExtended + execBlank + ([s|^.*\.log$|] :: B.ByteString) + ) + forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) + + liftIO $ writeFile logfile "" + pure logfile diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Prelude/Logger/Internal.hs similarity index 70% rename from lib/GHCup/Utils/Logger.hs rename to lib/GHCup/Prelude/Logger/Internal.hs index 2d003b5..446f10e 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Prelude/Logger/Internal.hs @@ -3,7 +3,7 @@ {-# LANGUAGE OverloadedStrings #-} {-| -Module : GHCup.Utils.Logger +Module : GHCup.Utils.Logger.Internal Description : logger definition Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 @@ -11,18 +11,13 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -Here we define our main logger. +Breaking import cycles. -} -module GHCup.Utils.Logger where +module GHCup.Prelude.Logger.Internal where import GHCup.Types import GHCup.Types.Optics -import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath) -import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles) -import {-# SOURCE #-} GHCup.Utils.File (recycleFile) -import GHCup.Utils.String.QQ -import Control.Exception.Safe import Control.Monad import Control.Monad.IO.Class import Control.Monad.Reader @@ -30,12 +25,7 @@ import Data.Text ( Text ) import Optics import Prelude hiding ( appendFile ) import System.Console.Pretty -import System.FilePath -import System.IO.Error -import Text.Regex.Posix -import qualified Data.ByteString as B -import GHCup.Utils.Prelude import qualified Data.Text as T logInfo :: ( MonadReader env m @@ -93,7 +83,7 @@ logInternal logLevel msg = do let strs = T.split (== '\n') msg let out = case strs of [] -> T.empty - (x:xs) -> + (x:xs) -> foldr (\a b -> a <> "\n" <> b) mempty . ((l <> " " <> x) :) . fmap (\line' -> style' "[ ... ] " <> line' ) @@ -111,22 +101,3 @@ logInternal logLevel msg = do let outr = lr <> " " <> msg <> "\n" liftIO $ fileOutter outr - -initGHCupFileLogging :: ( MonadReader env m - , HasDirs env - , MonadIO m - , MonadMask m - ) => m FilePath -initGHCupFileLogging = do - Dirs { logsDir } <- getDirs - let logfile = fromGHCupPath logsDir "ghcup.log" - logFiles <- liftIO $ findFiles - (fromGHCupPath logsDir) - (makeRegexOpts compExtended - execBlank - ([s|^.*\.log$|] :: B.ByteString) - ) - forM_ logFiles $ hideError doesNotExistErrorType . recycleFile . (fromGHCupPath logsDir ) - - liftIO $ writeFile logfile "" - pure logfile diff --git a/lib/GHCup/Utils/MegaParsec.hs b/lib/GHCup/Prelude/MegaParsec.hs similarity index 98% rename from lib/GHCup/Utils/MegaParsec.hs rename to lib/GHCup/Prelude/MegaParsec.hs index b622eb8..2f8d06b 100644 --- a/lib/GHCup/Utils/MegaParsec.hs +++ b/lib/GHCup/Prelude/MegaParsec.hs @@ -10,7 +10,7 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} -module GHCup.Utils.MegaParsec where +module GHCup.Prelude.MegaParsec where import GHCup.Types diff --git a/lib/GHCup/Utils/Posix.hs b/lib/GHCup/Prelude/Posix.hs similarity index 78% rename from lib/GHCup/Utils/Posix.hs rename to lib/GHCup/Prelude/Posix.hs index 4b2dcee..c7c13de 100644 --- a/lib/GHCup/Utils/Posix.hs +++ b/lib/GHCup/Prelude/Posix.hs @@ -1,4 +1,4 @@ -module GHCup.Utils.Posix where +module GHCup.Prelude.Posix where -- | Enables ANSI support on windows, does nothing on unix. @@ -12,3 +12,8 @@ module GHCup.Utils.Posix where enableAnsiSupport :: IO (Either String Bool) enableAnsiSupport = pure (Right True) +isWindows, isNotWindows :: Bool +isWindows = False +isNotWindows = not isWindows + + diff --git a/lib/GHCup/Prelude/Process.hs b/lib/GHCup/Prelude/Process.hs new file mode 100644 index 0000000..ed38b4e --- /dev/null +++ b/lib/GHCup/Prelude/Process.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE CPP #-} + +{-| +Module : GHCup.Utils.Process +Description : Process handling +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Prelude.Process ( + executeOut, + execLogged, + exec, + toProcessError, +) where + + +#if IS_WINDOWS +import GHCup.Prelude.Process.Windows +#else +import GHCup.Prelude.Process.Posix +#endif + diff --git a/lib/GHCup/Utils/File/Posix.hs b/lib/GHCup/Prelude/Process/Posix.hs similarity index 54% rename from lib/GHCup/Utils/File/Posix.hs rename to lib/GHCup/Prelude/Process/Posix.hs index 1ff0f2f..4e9670b 100644 --- a/lib/GHCup/Utils/File/Posix.hs +++ b/lib/GHCup/Prelude/Process/Posix.hs @@ -6,25 +6,22 @@ {-| Module : GHCup.Utils.File.Posix -Description : File and unix APIs +Description : Process handling for unix Copyright : (c) Julian Ospald, 2020 License : LGPL-3.0 Maintainer : hasufell@hasufell.de Stability : experimental Portability : POSIX - -This module handles file and executable handling. -Some of these functions use sophisticated logging. -} -module GHCup.Utils.File.Posix where +module GHCup.Prelude.Process.Posix where import GHCup.Utils.Dirs -import GHCup.Utils.File.Common -import GHCup.Utils.Prelude -import GHCup.Utils.Logger +import GHCup.Prelude.File +import GHCup.Prelude.File.Posix +import GHCup.Prelude +import GHCup.Prelude.Logger import GHCup.Types import GHCup.Types.Optics -import GHCup.Utils.File.Posix.Traversals import Control.Concurrent import Control.Concurrent.Async @@ -39,17 +36,11 @@ import Data.IORef import Data.Sequence ( Seq, (|>) ) import Data.List import Data.Word8 -import Foreign.C.String -import Foreign.C.Error -import Foreign.C.Types import GHC.IO.Exception -import System.IO ( stderr, hClose, hSetBinaryMode ) +import System.IO ( stderr ) import System.IO.Error hiding ( catchIOError ) import System.FilePath import System.Posix.Directory -import System.Posix.Error ( throwErrnoPathIfMinus1Retry ) -import System.Posix.Internals ( withFilePath ) -import System.Posix.Files import System.Posix.IO import System.Posix.Process ( ProcessStatus(..) ) import System.Posix.Types @@ -59,27 +50,12 @@ import qualified Control.Exception as EX import qualified Data.Sequence as Sq import qualified Data.Text as T import qualified Data.Text.Encoding as E -import qualified System.Posix.Directory as PD -import qualified System.Posix.Files as PF import qualified System.Posix.Process as SPP -import qualified System.Posix.IO as SPI import qualified System.Console.Terminal.Size as TP -import qualified System.Posix as Posix import qualified Data.ByteString as BS import qualified Data.ByteString.Lazy as BL import qualified "unix-bytestring" System.Posix.IO.ByteString as SPIB -import qualified Streamly.FileSystem.Handle as FH -import qualified Streamly.Internal.FileSystem.Handle - as IFH -import qualified Streamly.Prelude as S -import qualified GHCup.Utils.File.Posix.Foreign as FD -import qualified Streamly.Internal.Data.Stream.StreamD.Type - as D -import Streamly.Internal.Data.Unfold.Type -import qualified Streamly.Internal.Data.Unfold as U -import Streamly.Internal.Control.Concurrent ( withRunInIO ) -import Streamly.Internal.Data.IOFinalizer ( newIOFinalizer, runIOFinalizer ) @@ -384,262 +360,3 @@ toProcessError exe args mps = case mps of -chmod_755 :: (MonadReader env m, HasLog env, MonadIO m) => FilePath -> m () -chmod_755 fp = do - let exe_mode = - nullFileMode - `unionFileModes` ownerExecuteMode - `unionFileModes` ownerReadMode - `unionFileModes` ownerWriteMode - `unionFileModes` groupExecuteMode - `unionFileModes` groupReadMode - `unionFileModes` otherExecuteMode - `unionFileModes` otherReadMode - logDebug ("chmod 755 " <> T.pack fp) - liftIO $ setFileMode fp exe_mode - - --- |Default permissions for a new file. -newFilePerms :: FileMode -newFilePerms = - ownerWriteMode - `unionFileModes` ownerReadMode - `unionFileModes` groupWriteMode - `unionFileModes` groupReadMode - `unionFileModes` otherWriteMode - `unionFileModes` otherReadMode - - --- | Checks whether the binary is a broken link. -isBrokenSymlink :: FilePath -> IO Bool -isBrokenSymlink fp = do - try (pathIsSymbolicLink fp) >>= \case - Right True -> do - let symDir = takeDirectory fp - tfp <- getSymbolicLinkTarget fp - not <$> doesPathExist - -- this drops 'symDir' if 'tfp' is absolute - (symDir tfp) - Right b -> pure b - Left e | isDoesNotExistError e -> pure False - | otherwise -> throwIO e - -copyFile :: FilePath -- ^ source file - -> FilePath -- ^ destination file - -> Bool -- ^ fail if file exists - -> IO () -copyFile from to fail' = do - bracket - (openFdHandle from SPI.ReadOnly [FD.oNofollow] Nothing) - (hClose . snd) - $ \(fromFd, fH) -> do - sourceFileMode <- fileMode <$> getFdStatus fromFd - let dflags = [ FD.oNofollow - , if fail' then FD.oExcl else FD.oTrunc - ] - bracket - (openFdHandle to SPI.WriteOnly dflags $ Just sourceFileMode) - (hClose . snd) - $ \(_, tH) -> do - hSetBinaryMode fH True - hSetBinaryMode tH True - streamlyCopy (fH, tH) - where - openFdHandle fp omode flags fM = do - fd <- openFd' fp omode flags fM - handle' <- SPI.fdToHandle fd - pure (fd, handle') - streamlyCopy (fH, tH) = - S.fold (FH.writeChunks tH) $ IFH.toChunksWithBufferOf (256 * 1024) fH - -foreign import capi unsafe "fcntl.h open" - c_open :: CString -> CInt -> Posix.CMode -> IO CInt - - -open_ :: CString - -> Posix.OpenMode - -> [FD.Flags] - -> Maybe Posix.FileMode - -> IO Posix.Fd -open_ str how optional_flags maybe_mode = do - fd <- c_open str all_flags mode_w - return (Posix.Fd fd) - where - all_flags = FD.unionFlags $ optional_flags ++ [open_mode] ++ creat - - - (creat, mode_w) = case maybe_mode of - Nothing -> ([],0) - Just x -> ([FD.oCreat], x) - - open_mode = case how of - Posix.ReadOnly -> FD.oRdonly - Posix.WriteOnly -> FD.oWronly - Posix.ReadWrite -> FD.oRdwr - - --- |Open and optionally create this file. See 'System.Posix.Files' --- for information on how to use the 'FileMode' type. --- --- Note that passing @Just x@ as the 4th argument triggers the --- `oCreat` status flag, which must be set when you pass in `oExcl` --- to the status flags. Also see the manpage for @open(2)@. -openFd' :: FilePath - -> Posix.OpenMode - -> [FD.Flags] -- ^ status flags of @open(2)@ - -> Maybe Posix.FileMode -- ^ @Just x@ => creates the file with the given modes, Nothing => the file must exist. - -> IO Posix.Fd -openFd' name how optional_flags maybe_mode = - withFilePath name $ \str -> - throwErrnoPathIfMinus1Retry "openFd" name $ - open_ str how optional_flags maybe_mode - - --- |Deletes the given file. Raises `eISDIR` --- if run on a directory. Does not follow symbolic links. --- --- Throws: --- --- - `InappropriateType` for wrong file type (directory) --- - `NoSuchThing` if the file does not exist --- - `PermissionDenied` if the directory cannot be read --- --- Notes: calls `unlink` -deleteFile :: FilePath -> IO () -deleteFile = removeLink - - --- |Recreate a symlink. --- --- In `Overwrite` copy mode only files and empty directories are deleted. --- --- Safety/reliability concerns: --- --- * `Overwrite` mode is inherently non-atomic --- --- Throws: --- --- - `InvalidArgument` if source file is wrong type (not a symlink) --- - `PermissionDenied` if output directory cannot be written to --- - `PermissionDenied` if source directory cannot be opened --- - `SameFile` if source and destination are the same file --- (`HPathIOException`) --- --- --- Throws in `Strict` mode only: --- --- - `AlreadyExists` if destination already exists --- --- Throws in `Overwrite` mode only: --- --- - `UnsatisfiedConstraints` if destination file is non-empty directory --- --- Notes: --- --- - calls `symlink` -recreateSymlink :: FilePath -- ^ the old symlink file - -> FilePath -- ^ destination file - -> Bool -- ^ fail if destination file exists - -> IO () -recreateSymlink symsource newsym fail' = do - sympoint <- readSymbolicLink symsource - case fail' of - True -> pure () - False -> - hideError doesNotExistErrorType $ deleteFile newsym - createSymbolicLink sympoint newsym - - --- copys files, recreates symlinks, fails on all other types -install :: FilePath -> FilePath -> Bool -> IO () -install from to fail' = do - fs <- PF.getSymbolicLinkStatus from - decide fs - where - decide fs | PF.isRegularFile fs = copyFile from to fail' - | PF.isSymbolicLink fs = recreateSymlink from to fail' - | otherwise = ioError $ mkIOError illegalOperationErrorType "install: not a regular file or symlink" Nothing (Just from) - -moveFile :: FilePath -> FilePath -> IO () -moveFile = rename - - -moveFilePortable :: FilePath -> FilePath -> IO () -moveFilePortable from to = do - catchErrno [eXDEV] (moveFile from to) $ do - copyFile from to True - removeFile from - - -catchErrno :: [Errno] -- ^ errno to catch - -> IO a -- ^ action to try, which can raise an IOException - -> IO a -- ^ action to carry out in case of an IOException and - -- if errno matches - -> IO a -catchErrno en a1 a2 = - catchIOError a1 $ \e -> do - errno <- getErrno - if errno `elem` en - then a2 - else ioError e - -removeEmptyDirectory :: FilePath -> IO () -removeEmptyDirectory = PD.removeDirectory - - --- | Create an 'Unfold' of directory contents. -unfoldDirContents :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath (FD.DirType, FilePath) -unfoldDirContents = U.bracket (liftIO . openDirStream) (liftIO . closeDirStream) (Unfold step return) - where - {-# INLINE [0] step #-} - step dirstream = do - (typ, e) <- liftIO $ readDirEnt dirstream - return $ if - | null e -> D.Stop - | "." == e -> D.Skip dirstream - | ".." == e -> D.Skip dirstream - | otherwise -> D.Yield (typ, e) dirstream - - -getDirectoryContentsRecursiveDFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveDFSUnsafe fp = go "" - where - go cd = flip S.concatMap (S.unfold unfoldDirContents (fp cd)) $ \(t, f) -> - if | t == FD.dtDir -> go (cd f) - | otherwise -> pure (cd f) - - -getDirectoryContentsRecursiveUnfold :: (MonadMask m, MonadIO m, S.MonadAsync m) => Unfold m FilePath FilePath -getDirectoryContentsRecursiveUnfold = Unfold step (\s -> return (s, Nothing, [""])) - where - {-# INLINE [0] step #-} - step (_, Nothing, []) = return D.Stop - - step (topdir, Just (cdir, dirstream, finalizer), dirs) = flip onException (runIOFinalizer finalizer) $ do - (dt, f) <- liftIO $ readDirEnt dirstream - if | FD.dtUnknown == dt -> do - runIOFinalizer finalizer - return $ D.Skip (topdir, Nothing, dirs) - | f == "." || f == ".." - -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), dirs) - | FD.dtDir == dt -> return $ D.Skip (topdir, Just (cdir, dirstream, finalizer), (cdir f):dirs) - | otherwise -> return $ D.Yield (cdir f) (topdir, Just (cdir, dirstream, finalizer), dirs) - - step (topdir, Nothing, dir:dirs) = do - (s, f) <- acquire (topdir dir) - return $ D.Skip (topdir, Just (dir, s, f), dirs) - - acquire dir = - withRunInIO $ \run -> mask_ $ run $ do - dirstream <- liftIO $ openDirStream dir - ref <- newIOFinalizer (liftIO $ closeDirStream dirstream) - return (dirstream, ref) - -getDirectoryContentsRecursiveBFSUnsafe :: (MonadMask m, MonadIO m, S.MonadAsync m) - => FilePath - -> S.SerialT m FilePath -getDirectoryContentsRecursiveBFSUnsafe = S.unfold getDirectoryContentsRecursiveUnfold - - diff --git a/lib/GHCup/Prelude/Process/Windows.hs b/lib/GHCup/Prelude/Process/Windows.hs new file mode 100644 index 0000000..17c75ac --- /dev/null +++ b/lib/GHCup/Prelude/Process/Windows.hs @@ -0,0 +1,251 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} + +{-| +Module : GHCup.Utils.Process.Windows +Description : Process handling for windows +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : Windows +-} +module GHCup.Prelude.Process.Windows where + +import GHCup.Utils.Dirs +import GHCup.Prelude.File.Search +import GHCup.Prelude.Logger.Internal +import GHCup.Types +import GHCup.Types.Optics + +import Control.Concurrent +import Control.DeepSeq +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Reader +import Data.List +import Foreign.C.Error +import GHC.IO.Exception +import GHC.IO.Handle +import System.Environment +import System.FilePath +import System.IO +import System.Process + +import qualified Control.Exception as EX +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BL +import qualified Data.Map.Strict as Map +import qualified Data.Text as T + + + + +toProcessError :: FilePath + -> [FilePath] + -> ExitCode + -> Either ProcessError () +toProcessError exe args exitcode = case exitcode of + (ExitFailure xi) -> Left $ NonZeroExit xi exe args + ExitSuccess -> Right () + + +-- | @readCreateProcessWithExitCode@ works exactly like 'readProcessWithExitCode' except that it +-- lets you pass 'CreateProcess' giving better flexibility. +-- +-- Note that @Handle@s provided for @std_in@, @std_out@, or @std_err@ via the CreateProcess +-- record will be ignored. +-- +-- @since 1.2.3.0 +readCreateProcessWithExitCodeBS + :: CreateProcess + -> BL.ByteString + -> IO (ExitCode, BL.ByteString, BL.ByteString) -- ^ exitcode, stdout, stderr +readCreateProcessWithExitCodeBS cp input = do + let cp_opts = cp { + std_in = CreatePipe, + std_out = CreatePipe, + std_err = CreatePipe + } + withCreateProcess_ "readCreateProcessWithExitCodeBS" cp_opts $ + \mb_inh mb_outh mb_errh ph -> + case (mb_inh, mb_outh, mb_errh) of + (Just inh, Just outh, Just errh) -> do + + out <- BS.hGetContents outh + err <- BS.hGetContents errh + + -- fork off threads to start consuming stdout & stderr + withForkWait (EX.evaluate $ rnf out) $ \waitOut -> + withForkWait (EX.evaluate $ rnf err) $ \waitErr -> do + + -- now write any input + unless (BL.null input) $ + ignoreSigPipe $ BL.hPut inh input + -- hClose performs implicit hFlush, and thus may trigger a SIGPIPE + ignoreSigPipe $ hClose inh + + -- wait on the output + waitOut + waitErr + + hClose outh + hClose errh + + -- wait on the process + ex <- waitForProcess ph + return (ex, BL.fromStrict out, BL.fromStrict err) + + (Nothing,_,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdin handle." + (_,Nothing,_) -> error "readCreateProcessWithExitCodeBS: Failed to get a stdout handle." + (_,_,Nothing) -> error "readCreateProcessWithExitCodeBS: Failed to get a stderr handle." + where + ignoreSigPipe :: IO () -> IO () + ignoreSigPipe = EX.handle $ \e -> case e of + IOError { ioe_type = ResourceVanished + , ioe_errno = Just ioe } + | Errno ioe == ePIPE -> return () + _ -> throwIO e + -- wrapper so we can get exceptions with the appropriate function name. + withCreateProcess_ + :: String + -> CreateProcess + -> (Maybe Handle -> Maybe Handle -> Maybe Handle -> ProcessHandle -> IO a) + -> IO a + withCreateProcess_ fun c action = + EX.bracketOnError (createProcess_ fun c) cleanupProcess + (\(m_in, m_out, m_err, ph) -> action m_in m_out m_err ph) + +-- | Fork a thread while doing something else, but kill it if there's an +-- exception. +-- +-- This is important in the cases above because we want to kill the thread +-- that is holding the Handle lock, because when we clean up the process we +-- try to close that handle, which could otherwise deadlock. +-- +withForkWait :: IO () -> (IO () -> IO a) -> IO a +withForkWait async' body = do + waitVar <- newEmptyMVar :: IO (MVar (Either SomeException ())) + mask $ \restore -> do + tid <- forkIO $ try (restore async') >>= putMVar waitVar + let wait' = takeMVar waitVar >>= either throwIO return + restore (body wait') `EX.onException` killThread tid + + +-- | Execute the given command and collect the stdout, stderr and the exit code. +-- The command is run in a subprocess. +executeOut :: MonadIO m + => FilePath -- ^ command as filename, e.g. 'ls' + -> [String] -- ^ arguments to the command + -> Maybe FilePath -- ^ chdir to this path + -> m CapturedProcess +executeOut path args chdir = do + cp <- createProcessWithMingwPath ((proc path args){ cwd = chdir }) + (exit, out, err) <- liftIO $ readCreateProcessWithExitCodeBS cp "" + pure $ CapturedProcess exit out err + + +execLogged :: ( MonadReader env m + , HasDirs env + , HasLog env + , HasSettings env + , MonadIO m + , MonadThrow m) + => FilePath -- ^ thing to execute + -> [String] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> FilePath -- ^ log filename (opened in append mode) + -> Maybe [(String, String)] -- ^ optional environment + -> m (Either ProcessError ()) +execLogged exe args chdir lfile env = do + Dirs {..} <- getDirs + logDebug $ T.pack $ "Running " <> exe <> " with arguments " <> show args + let stdoutLogfile = fromGHCupPath logsDir lfile <> ".stdout.log" + stderrLogfile = fromGHCupPath logsDir lfile <> ".stderr.log" + cp <- createProcessWithMingwPath ((proc exe args) + { cwd = chdir + , env = env + , std_in = CreatePipe + , std_out = CreatePipe + , std_err = CreatePipe + }) + fmap (toProcessError exe args) + $ liftIO + $ withCreateProcess cp + $ \_ mout merr ph -> + case (mout, merr) of + (Just cStdout, Just cStderr) -> do + withForkWait (tee stdoutLogfile cStdout) $ \waitOut -> + withForkWait (tee stderrLogfile cStderr) $ \waitErr -> do + waitOut + waitErr + waitForProcess ph + _ -> fail "Could not acquire out/err handle" + + where + tee :: FilePath -> Handle -> IO () + tee logFile handle' = go + where + go = do + some <- BS.hGetSome handle' 512 + if BS.null some + then pure () + else do + void $ BS.appendFile logFile some + -- subprocess stdout also goes to stderr for logging + void $ BS.hPut stderr some + go + + +-- | Thin wrapper around `executeFile`. +exec :: MonadIO m + => FilePath -- ^ thing to execute + -> [FilePath] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> Maybe [(String, String)] -- ^ optional environment + -> m (Either ProcessError ()) +exec exe args chdir env = do + cp <- createProcessWithMingwPath ((proc exe args) { cwd = chdir, env = env }) + exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p + pure $ toProcessError exe args exit_code + + +-- | Thin wrapper around `executeFile`. +execShell :: MonadIO m + => FilePath -- ^ thing to execute + -> [FilePath] -- ^ args for the thing + -> Maybe FilePath -- ^ optionally chdir into this + -> Maybe [(String, String)] -- ^ optional environment + -> m (Either ProcessError ()) +execShell exe args chdir env = do + let cmd = exe <> " " <> concatMap (' ':) args + cp <- createProcessWithMingwPath ((shell cmd) { cwd = chdir, env = env }) + exit_code <- liftIO $ withCreateProcess cp $ \_ _ _ p -> waitForProcess p + pure $ toProcessError cmd [] exit_code + + +createProcessWithMingwPath :: MonadIO m + => CreateProcess + -> m CreateProcess +createProcessWithMingwPath cp = do + msys2Dir <- liftIO ghcupMsys2Dir + cEnv <- Map.fromList <$> maybe (liftIO getEnvironment) pure (env cp) + let mingWPaths = [msys2Dir "usr" "bin" + ,msys2Dir "mingw64" "bin"] + paths = ["PATH", "Path"] + curPaths = (\x -> maybe [] splitSearchPath (Map.lookup x cEnv)) =<< paths + newPath = intercalate [searchPathSeparator] (mingWPaths ++ curPaths) + envWithoutPath = foldr (\x y -> Map.delete x y) cEnv paths + envWithNewPath = Map.insert "Path" newPath envWithoutPath + liftIO $ setEnv "Path" newPath + pure $ cp { env = Just $ Map.toList envWithNewPath } + +ghcupMsys2Dir :: IO FilePath +ghcupMsys2Dir = + lookupEnv "GHCUP_MSYS2" >>= \case + Just fp -> pure fp + Nothing -> do + baseDir <- liftIO ghcupBaseDir + pure (fromGHCupPath baseDir "msys64") + diff --git a/lib/GHCup/Utils/String/QQ.hs b/lib/GHCup/Prelude/String/QQ.hs similarity index 97% rename from lib/GHCup/Utils/String/QQ.hs rename to lib/GHCup/Prelude/String/QQ.hs index ec249de..822a34e 100644 --- a/lib/GHCup/Utils/String/QQ.hs +++ b/lib/GHCup/Prelude/String/QQ.hs @@ -30,7 +30,7 @@ Any instance of the IsString type is permitted. (For GHC versions 6, write "[$s||]" instead of "[s||]".) -} -module GHCup.Utils.String.QQ +module GHCup.Prelude.String.QQ ( s ) where diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Prelude/Version/QQ.hs similarity index 98% rename from lib/GHCup/Utils/Version/QQ.hs rename to lib/GHCup/Prelude/Version/QQ.hs index fe87237..d3d03c6 100644 --- a/lib/GHCup/Utils/Version/QQ.hs +++ b/lib/GHCup/Prelude/Version/QQ.hs @@ -16,7 +16,7 @@ Maintainer : hasufell@hasufell.de Stability : experimental Portability : portable -} -module GHCup.Utils.Version.QQ where +module GHCup.Prelude.Version.QQ where import Data.Data import Data.Text ( Text ) diff --git a/lib/GHCup/Utils/Windows.hs b/lib/GHCup/Prelude/Windows.hs similarity index 93% rename from lib/GHCup/Utils/Windows.hs rename to lib/GHCup/Prelude/Windows.hs index 14ffbd8..25b8731 100644 --- a/lib/GHCup/Utils/Windows.hs +++ b/lib/GHCup/Prelude/Windows.hs @@ -3,7 +3,7 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE OverloadedStrings #-} -module GHCup.Utils.Windows where +module GHCup.Prelude.Windows where import Control.Exception.Safe @@ -46,3 +46,8 @@ enableAnsiSupport = handleIO (pure . Left . displayException) $ do >> pure (Right False) else pure (Right True) + +isWindows, isNotWindows :: Bool +isWindows = True +isNotWindows = not isWindows + diff --git a/lib/GHCup/Stack.hs b/lib/GHCup/Stack.hs new file mode 100644 index 0000000..cfc7587 --- /dev/null +++ b/lib/GHCup/Stack.hs @@ -0,0 +1,278 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} + +{-| +Module : GHCup.Stack +Description : GHCup installation functions for Stack +Copyright : (c) Julian Ospald, 2020 +License : LGPL-3.0 +Maintainer : hasufell@hasufell.de +Stability : experimental +Portability : portable +-} +module GHCup.Stack where + +import GHCup.Download +import GHCup.Errors +import GHCup.Types +import GHCup.Types.JSON ( ) +import GHCup.Types.Optics +import GHCup.Utils +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger + +import Codec.Archive ( ArchiveResult ) +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +#if !MIN_VERSION_base(4,13,0) +import Control.Monad.Fail ( MonadFail ) +#endif +import Control.Monad.Reader +import Control.Monad.Trans.Resource + hiding ( throwM ) +import Data.Either +import Data.List +import Data.Maybe +import Data.Versions hiding ( patch ) +import Haskus.Utils.Variant.Excepts +import Optics +import Prelude hiding ( abs + , writeFile + ) +import Safe hiding ( at ) +import System.FilePath +import System.IO.Error + +import qualified Data.Text as T + + + + -------------------- + --[ Installation ]-- + -------------------- + + +-- | Installs stack into @~\/.ghcup\/bin/stack-\@ and +-- creates a default @stack -> stack-x.y.z.q@ symlink for +-- the latest installed version. +installStackBin :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasDirs env + , HasSettings env + , HasPlatformReq env + , HasGHCupInfo env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installStackBin ver installDir forceInstall = do + dlinfo <- liftE $ getDownloadInfo Stack ver + installStackBindist dlinfo ver installDir forceInstall + + +-- | Like 'installStackBin', except takes the 'DownloadInfo' as +-- argument instead of looking it up from 'GHCupDownloads'. +installStackBindist :: ( MonadMask m + , MonadCatch m + , MonadReader env m + , HasPlatformReq env + , HasDirs env + , HasSettings env + , HasLog env + , MonadResource m + , MonadIO m + , MonadUnliftIO m + , MonadFail m + ) + => DownloadInfo + -> Version + -> InstallDir + -> Bool -- ^ Force install + -> Excepts + '[ AlreadyInstalled + , CopyError + , DigestError + , GPGError + , DownloadFailed + , NoDownload + , NotInstalled + , UnknownArchive + , TarDirDoesNotExist + , ArchiveResult + , FileAlreadyExistsError + ] + m + () +installStackBindist dlinfo ver installDir forceInstall = do + lift $ logDebug $ "Requested to install stack version " <> prettyVer ver + + PlatformRequest {..} <- lift getPlatformReq + Dirs {..} <- lift getDirs + + regularStackInstalled <- lift $ stackInstalled ver + + if + | not forceInstall + , regularStackInstalled + , GHCupInternal <- installDir -> do + throwE $ AlreadyInstalled Stack ver + + | forceInstall + , regularStackInstalled + , GHCupInternal <- installDir -> do + lift $ logInfo "Removing the currently installed version of Stack first!" + liftE $ rmStackVer ver + + | otherwise -> pure () + + -- download (or use cached version) + dl <- liftE $ downloadCached dlinfo Nothing + + -- unpack + tmpUnpack <- lift withGHCupTmpDir + liftE $ cleanUpOnError tmpUnpack (unpackToDir (fromGHCupPath tmpUnpack) dl) + liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform (fromGHCupPath tmpUnpack) + + -- the subdir of the archive where we do the work + workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo) + + case installDir of + IsolateDir isoDir -> do -- isolated install + lift $ logInfo $ "isolated installing Stack to " <> T.pack isoDir + liftE $ installStackUnpacked workdir (IsolateDirResolved isoDir) ver forceInstall + GHCupInternal -> do -- regular install + liftE $ installStackUnpacked workdir (GHCupBinDir binDir) ver forceInstall + + +-- | Install an unpacked stack distribution. +installStackUnpacked :: (MonadReader env m, HasLog env, MonadCatch m, MonadIO m) + => GHCupPath -- ^ Path to the unpacked stack bindist (where the executable resides) + -> InstallDirResolved + -> Version + -> Bool -- ^ Force install + -> Excepts '[CopyError, FileAlreadyExistsError] m () +installStackUnpacked path installDir ver forceInstall = do + lift $ logInfo "Installing stack" + let stackFile = "stack" + liftIO $ createDirRecursive' (fromInstallDir installDir) + let destFileName = stackFile + <> (case installDir of + IsolateDirResolved _ -> "" + _ -> ("-" <>) . T.unpack . prettyVer $ ver + ) + <> exeExt + destPath = fromInstallDir installDir destFileName + + copyFileE + (fromGHCupPath path stackFile <> exeExt) + destPath + (not forceInstall) + lift $ chmod_755 destPath + + + + ----------------- + --[ Set stack ]-- + ----------------- + + +-- | Set the @~\/.ghcup\/bin\/stack@ symlink. +setStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadFail m + , MonadIO m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +setStack ver = do + let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt + + -- symlink destination + Dirs {..} <- lift getDirs + + whenM (liftIO $ not <$> doesFileExist (binDir targetFile)) + $ throwE + $ NotInstalled Stack (GHCTargetVersion Nothing ver) + + let stackbin = binDir "stack" <> exeExt + + lift $ createLink targetFile stackbin + + pure () + + +unsetStack :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadIO m) + => m () +unsetStack = do + Dirs {..} <- getDirs + let stackbin = binDir "stack" <> exeExt + hideError doesNotExistErrorType $ rmLink stackbin + + + ---------------- + --[ Rm stack ]-- + ---------------- + +-- | Delete a stack version. Will try to fix the @stack@ symlink +-- after removal (e.g. setting it to an older version). +rmStackVer :: ( MonadMask m + , MonadReader env m + , HasDirs env + , MonadThrow m + , HasLog env + , MonadIO m + , MonadFail m + , MonadCatch m + , MonadUnliftIO m + ) + => Version + -> Excepts '[NotInstalled] m () +rmStackVer ver = do + whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver)) + + sSet <- lift stackSet + + Dirs {..} <- lift getDirs + + let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt + lift $ hideError doesNotExistErrorType $ recycleFile (binDir stackFile) + + when (Just ver == sSet) $ do + sVers <- lift $ fmap rights getInstalledStacks + case headMay . reverse . sort $ sVers of + Just latestver -> setStack latestver + Nothing -> lift $ rmLink (binDir "stack" <> exeExt) diff --git a/lib/GHCup/Types.hs b/lib/GHCup/Types.hs index 3918de7..63761d2 100644 --- a/lib/GHCup/Types.hs +++ b/lib/GHCup/Types.hs @@ -26,8 +26,7 @@ module GHCup.Types ) where -import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath ) -import {-# SOURCE #-} GHCup.Utils.Dirs ( GHCupPath ) +import {-# SOURCE #-} GHCup.Utils.Dirs ( fromGHCupPath, GHCupPath ) import Control.DeepSeq ( NFData, rnf ) import Data.Map.Strict ( Map ) diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 8d7cd3b..35d8b83 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -23,7 +23,7 @@ module GHCup.Types.JSON where import GHCup.Types import GHCup.Types.JSON.Utils -import GHCup.Utils.MegaParsec +import GHCup.Prelude.MegaParsec import Control.Applicative ( (<|>) ) import Data.Aeson hiding (Key) diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 6a161a2..e46bf69 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -23,18 +23,18 @@ module GHCup.Utils ( module GHCup.Utils.Dirs , module GHCup.Utils #if defined(IS_WINDOWS) - , module GHCup.Utils.Windows + , module GHCup.Prelude.Windows #else - , module GHCup.Utils.Posix + , module GHCup.Prelude.Posix #endif ) where #if defined(IS_WINDOWS) -import GHCup.Utils.Windows +import GHCup.Prelude.Windows #else -import GHCup.Utils.Posix +import GHCup.Prelude.Posix #endif import GHCup.Download import GHCup.Errors @@ -42,11 +42,13 @@ import GHCup.Types import GHCup.Types.Optics import GHCup.Types.JSON ( ) import GHCup.Utils.Dirs -import GHCup.Utils.File -import GHCup.Utils.Logger -import GHCup.Utils.MegaParsec -import GHCup.Utils.Prelude -import GHCup.Utils.String.QQ +import GHCup.Version +import GHCup.Prelude +import GHCup.Prelude.File +import GHCup.Prelude.Logger.Internal +import GHCup.Prelude.MegaParsec +import GHCup.Prelude.Process +import GHCup.Prelude.String.QQ import Codec.Archive hiding ( Directory ) import Control.Applicative @@ -75,6 +77,7 @@ import Safe import System.FilePath import System.IO.Error import Text.Regex.Posix +import Text.PrettyPrint.HughesPJClass (prettyShow) import URI.ByteString import qualified Codec.Compression.BZip as BZip @@ -99,14 +102,14 @@ import GHC.IO (evaluate) -- >>> import System.Directory -- >>> import URI.ByteString -- >>> import qualified Data.Text as T --- >>> import GHCup.Utils.Prelude +-- >>> import GHCup.Prelude -- >>> import GHCup.Download -- >>> import GHCup.Version -- >>> import GHCup.Errors -- >>> import GHCup.Types -- >>> import GHCup.Types.Optics -- >>> import Optics --- >>> import GHCup.Utils.Version.QQ +-- >>> import GHCup.Prelude.Version.QQ -- >>> import qualified Data.Text.Encoding as E -- >>> import Control.Monad.Reader -- >>> import Haskus.Utils.Variant.Excepts @@ -1019,6 +1022,28 @@ applyPatch patch ddir = do !? PatchFailed +applyAnyPatch :: ( MonadReader env m + , HasDirs env + , HasLog env + , HasSettings env + , MonadUnliftIO m + , MonadCatch m + , MonadResource m + , MonadThrow m + , MonadMask m + , MonadIO m) + => Maybe (Either FilePath [URI]) + -> FilePath + -> Excepts '[PatchFailed, DownloadFailed, DigestError, GPGError] m () +applyAnyPatch Nothing _ = pure () +applyAnyPatch (Just (Left pdir)) workdir = liftE $ applyPatches pdir workdir +applyAnyPatch (Just (Right uris)) workdir = do + tmpUnpack <- fromGHCupPath <$> lift withGHCupTmpDir + forM_ uris $ \uri -> do + patch <- liftE $ download uri Nothing Nothing tmpUnpack Nothing False + liftE $ applyPatch patch workdir + + -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353 darwinNotarization :: (MonadReader env m, HasDirs env, MonadIO m) => Platform @@ -1134,97 +1159,6 @@ getVersionInfo v' tool = ) --- | The file extension for executables. -exeExt :: String -exeExt - | isWindows = ".exe" - | otherwise = "" - --- | The file extension for executables. -exeExt' :: ByteString -exeExt' - | isWindows = ".exe" - | otherwise = "" - - - - --- | On unix, we can use symlinks, so we just get the --- symbolic link target. --- --- On windows, we have to emulate symlinks via shims, --- see 'createLink'. -getLinkTarget :: FilePath -> IO FilePath -getLinkTarget fp - | isWindows = do - content <- readFile (dropExtension fp <.> "shim") - [p] <- pure . filter ("path = " `isPrefixOf`) . lines $ content - pure $ stripNewline $ dropPrefix "path = " p - | otherwise = getSymbolicLinkTarget fp - - --- | Checks whether the path is a link. -pathIsLink :: FilePath -> IO Bool -pathIsLink fp - | isWindows = doesPathExist (dropExtension fp <.> "shim") - | otherwise = pathIsSymbolicLink fp - - -rmLink :: (MonadReader env m, HasDirs env, MonadIO m, MonadMask m) => FilePath -> m () -rmLink fp - | isWindows = do - hideError doesNotExistErrorType . recycleFile $ fp - hideError doesNotExistErrorType . recycleFile $ (dropExtension fp <.> "shim") - | otherwise = hideError doesNotExistErrorType . recycleFile $ fp - - --- | Creates a symbolic link on unix and a fake symlink on windows for --- executables, which: --- 1. is a shim exe --- 2. has a corresponding .shim file in the same directory that --- contains the target --- --- This overwrites previously existing files. --- --- On windows, this requires that 'ensureGlobalTools' was run beforehand. -createLink :: ( MonadMask m - , MonadThrow m - , HasLog env - , MonadIO m - , MonadReader env m - , HasDirs env - , MonadUnliftIO m - , MonadFail m - ) - => FilePath -- ^ path to the target executable - -> FilePath -- ^ path to be created - -> m () -createLink link exe - | isWindows = do - dirs <- getDirs - let shimGen = fromGHCupPath (cacheDir dirs) "gs.exe" - - let shim = dropExtension exe <.> "shim" - -- For hardlinks, link needs to be absolute. - -- If link is relative, it's relative to the target exe. - -- Note that () drops lhs when rhs is absolute. - fullLink = takeDirectory exe link - shimContents = "path = " <> fullLink - - logDebug $ "rm -f " <> T.pack exe - rmLink exe - - logDebug $ "ln -s " <> T.pack fullLink <> " " <> T.pack exe - liftIO $ copyFile shimGen exe False - liftIO $ writeFile shim shimContents - | otherwise = do - logDebug $ "rm -f " <> T.pack exe - hideError doesNotExistErrorType $ recycleFile exe - - logDebug $ "ln -s " <> T.pack link <> " " <> T.pack exe - liftIO $ createFileLink link exe - - ensureGlobalTools :: ( MonadMask m , MonadThrow m , HasLog env @@ -1316,3 +1250,28 @@ getInstalledFiles t v' = hideErrorDef [doesNotExistErrorType] Nothing $ do pure (Just $ lines c) +-- | Warn if the installed and set HLS is not compatible with the installed and +-- set GHC version. +warnAboutHlsCompatibility :: ( MonadReader env m + , HasDirs env + , HasLog env + , MonadThrow m + , MonadCatch m + , MonadIO m + ) + => m () +warnAboutHlsCompatibility = do + supportedGHC <- hlsGHCVersions + currentGHC <- fmap _tvVersion <$> ghcSet Nothing + currentHLS <- hlsSet + + case (currentGHC, currentHLS) of + (Just gv, Just hv) | gv `notElem` supportedGHC -> do + logWarn $ + "GHC " <> T.pack (prettyShow gv) <> " is not compatible with " <> + "Haskell Language Server " <> T.pack (prettyShow hv) <> "." <> "\n" <> + "Haskell IDE support may not work until this is fixed." <> "\n" <> + "Install a different HLS version, or install and set one of the following GHCs:" <> "\n" <> + T.pack (prettyShow supportedGHC) + + _ -> return () diff --git a/lib/GHCup/Utils.hs-boot b/lib/GHCup/Utils.hs-boot deleted file mode 100644 index e534e82..0000000 --- a/lib/GHCup/Utils.hs-boot +++ /dev/null @@ -1,4 +0,0 @@ -module GHCup.Utils where - -getLinkTarget :: FilePath -> IO FilePath -pathIsLink :: FilePath -> IO Bool diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs index 817d2ac..c2c026a 100644 --- a/lib/GHCup/Utils/Dirs.hs +++ b/lib/GHCup/Utils/Dirs.hs @@ -99,9 +99,6 @@ module GHCup.Utils.Dirs , setAccessTime , setModificationTime , isSymbolicLink - - -- uhm - , rmPathForcibly ) where @@ -110,11 +107,15 @@ import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) import GHCup.Types.Optics -import GHCup.Utils.MegaParsec -import GHCup.Utils.Logger -import GHCup.Utils.Prelude -import GHCup.Utils.File.Common -import GHCup.Utils.String.QQ +import GHCup.Prelude.MegaParsec +import GHCup.Prelude.File.Search +import GHCup.Prelude.String.QQ +import GHCup.Prelude.Logger.Internal (logWarn, logDebug) +#if defined(IS_WINDOWS) +import GHCup.Prelude.Windows ( isWindows ) +#else +import GHCup.Prelude.Posix ( isWindows ) +#endif import Control.DeepSeq (NFData, rnf) import Control.Exception.Safe @@ -147,6 +148,7 @@ import qualified Data.ByteString as BS import qualified Data.Text as T import qualified Data.Yaml.Aeson as Y import qualified Text.Megaparsec as MP +import System.IO.Error (ioeGetErrorType) @@ -371,10 +373,15 @@ ghcupConfigFile :: (MonadIO m) => Excepts '[JSONError] m UserSettings ghcupConfigFile = do filepath <- getConfigFilePath - contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath + contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath case contents of Nothing -> pure defaultUserSettings - Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents' + Just contents' -> liftE + . veitherToExcepts @_ @'[JSONError] + . either (VLeft . V) VRight + . first (JSONDecodeError . displayException) + . Y.decodeEither' + $ contents' ------------------------- @@ -411,6 +418,12 @@ parseGHCupHLSDir :: MonadThrow m => FilePath -> m Version parseGHCupHLSDir (T.pack -> fp) = throwEither $ MP.parse version' "" fp +-- TODO: inlined from GHCup.Prelude +throwEither :: (Exception a, MonadThrow m) => Either a b -> m b +throwEither a = case a of + Left e -> throwM e + Right r -> pure r + -- | ~/.ghcup/hls by default, for new-style installs. ghcupHLSBaseDir :: (MonadReader env m, HasDirs env) => m GHCupPath ghcupHLSBaseDir = do @@ -459,7 +472,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> (\fp -> handleIO (\e -> run $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e))) - . rmPathForcibly + . removePathForcibly $ fp)) @@ -522,13 +535,5 @@ removePathForcibly :: GHCupPath -> IO () removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp -rmPathForcibly :: ( MonadIO m - , MonadMask m - ) - => GHCupPath - -> m () -rmPathForcibly fp - | isWindows = recover (liftIO $ removePathForcibly fp) - | otherwise = liftIO $ removePathForcibly fp diff --git a/lib/GHCup/Utils/File.hs-boot b/lib/GHCup/Utils/File.hs-boot deleted file mode 100644 index 2da9c00..0000000 --- a/lib/GHCup/Utils/File.hs-boot +++ /dev/null @@ -1,14 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} - -module GHCup.Utils.File ( - recycleFile -) where - -import Control.Monad.IO.Class (MonadIO) -import Control.Monad.Catch (MonadMask) -import Control.Monad.Reader (MonadReader) -import GHCup.Types.Optics (HasDirs) - - -recycleFile :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env) => FilePath -> m () - diff --git a/lib/GHCup/Utils/File/Common.hs-boot b/lib/GHCup/Utils/File/Common.hs-boot deleted file mode 100644 index 5933883..0000000 --- a/lib/GHCup/Utils/File/Common.hs-boot +++ /dev/null @@ -1,5 +0,0 @@ -module GHCup.Utils.File.Common where - -import Text.Regex.Posix - -findFiles :: FilePath -> Regex -> IO [FilePath] diff --git a/lib/GHCup/Utils/Logger.hs-boot b/lib/GHCup/Utils/Logger.hs-boot deleted file mode 100644 index 9e3b1b9..0000000 --- a/lib/GHCup/Utils/Logger.hs-boot +++ /dev/null @@ -1,19 +0,0 @@ -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE DataKinds #-} - -module GHCup.Utils.Logger where - -import GHCup.Types - -import Control.Monad.IO.Class -import Control.Monad.Reader -import Data.Text ( Text ) -import Optics - -logWarn :: ( MonadReader env m - , LabelOptic' "loggerConfig" A_Lens env LoggerConfig - , MonadIO m - ) - => Text - -> m () - diff --git a/lib/GHCup/Utils/Prelude/Posix.hs b/lib/GHCup/Utils/Prelude/Posix.hs deleted file mode 100644 index 3945423..0000000 --- a/lib/GHCup/Utils/Prelude/Posix.hs +++ /dev/null @@ -1,8 +0,0 @@ -module GHCup.Utils.Prelude.Posix where - - -isWindows, isNotWindows :: Bool -isWindows = False -isNotWindows = not isWindows - - diff --git a/lib/GHCup/Utils/Prelude/Windows.hs b/lib/GHCup/Utils/Prelude/Windows.hs deleted file mode 100644 index bcdeb41..0000000 --- a/lib/GHCup/Utils/Prelude/Windows.hs +++ /dev/null @@ -1,6 +0,0 @@ -module GHCup.Utils.Prelude.Windows where - -isWindows, isNotWindows :: Bool -isWindows = True -isNotWindows = not isWindows - diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs index 37926cb..065a49b 100644 --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -16,12 +16,18 @@ import GHCup.Types import Paths_ghcup (version) import Data.Version (Version(versionBranch)) -import Data.Versions hiding (version) import URI.ByteString import URI.ByteString.QQ import qualified Data.List.NonEmpty as NE import qualified Data.Text as T +import qualified Data.Versions as V +import Control.Exception.Safe (MonadThrow) +import Data.Text (Text) +import Data.List.NonEmpty (NonEmpty((:|))) +import Data.List (intersperse) +import Control.Monad.Catch (throwM) +import GHCup.Errors (ParseError(..)) -- | This reflects the API version of the YAML. -- @@ -31,22 +37,72 @@ ghcupURL :: URI ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|] -- | The current ghcup version. -ghcUpVer :: PVP -ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version +ghcUpVer :: V.PVP +ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version -- | ghcup version as numeric string. numericVer :: String -numericVer = T.unpack . prettyPVP $ ghcUpVer +numericVer = T.unpack . V.prettyPVP $ ghcUpVer -versionCmp :: Versioning -> VersionCmp -> Bool +versionCmp :: V.Versioning -> VersionCmp -> Bool versionCmp ver1 (VR_gt ver2) = ver1 > ver2 versionCmp ver1 (VR_gteq ver2) = ver1 >= ver2 versionCmp ver1 (VR_lt ver2) = ver1 < ver2 versionCmp ver1 (VR_lteq ver2) = ver1 <= ver2 versionCmp ver1 (VR_eq ver2) = ver1 == ver2 -versionRange :: Versioning -> VersionRange -> Bool +versionRange :: V.Versioning -> VersionRange -> Bool versionRange ver' (SimpleRange cmps) = and $ fmap (versionCmp ver') cmps versionRange ver' (OrRange cmps range) = versionRange ver' (SimpleRange cmps) || versionRange ver' range +pvpToVersion :: MonadThrow m => V.PVP -> Text -> m V.Version +pvpToVersion pvp_ rest = + either (\_ -> throwM $ ParseError "Couldn't convert PVP to Version") pure . V.version . (<> rest) . V.prettyPVP $ pvp_ + +-- | Convert a version to a PVP and unparsable rest. +-- +-- -- prop> \v -> let (Just (pvp', r)) = versionToPVP v in pvpToVersion pvp' r === Just v +versionToPVP :: MonadThrow m => V.Version -> m (V.PVP, Text) +versionToPVP (V.Version (Just _) _ _ _) = throwM $ ParseError "Unexpected epoch" +versionToPVP v = either (\_ -> (, rest v) <$> alternative v) (pure . (, mempty)) . V.pvp . V.prettyVer $ v + where + alternative :: MonadThrow m => V.Version -> m V.PVP + alternative v' = case NE.takeWhile isDigit (V._vChunks v') of + [] -> throwM $ ParseError "Couldn't convert Version to PVP" + xs -> pure $ pvpFromList (unsafeDigit <$> xs) + + rest :: V.Version -> Text + rest (V.Version _ cs pr me) = + let chunks = NE.dropWhile isDigit cs + ver = intersperse (T.pack ".") . chunksAsT $ chunks + me' = maybe [] (\m -> [T.pack "+",m]) me + pr' = foldable [] (T.pack "-" :) $ intersperse (T.pack ".") (chunksAsT pr) + prefix = case (ver, pr', me') of + (_:_, _, _) -> T.pack "." + _ -> T.pack "" + in prefix <> mconcat (ver <> pr' <> me') + where + chunksAsT :: Functor t => t V.VChunk -> t Text + chunksAsT = fmap (foldMap f) + where + f :: V.VUnit -> Text + f (V.Digits i) = T.pack $ show i + f (V.Str s) = s + + foldable :: Foldable f => f b -> (f a -> f b) -> f a -> f b + foldable d g f | null f = d + | otherwise = g f + + + + isDigit :: V.VChunk -> Bool + isDigit (V.Digits _ :| []) = True + isDigit _ = False + + unsafeDigit :: V.VChunk -> Int + unsafeDigit (V.Digits x :| []) = fromIntegral x + unsafeDigit _ = error "unsafeDigit: wrong input" + +pvpFromList :: [Int] -> V.PVP +pvpFromList = V.PVP . NE.fromList . fmap fromIntegral diff --git a/test/GHCup/Utils/FileSpec.hs b/test/GHCup/Utils/FileSpec.hs index 8bcc53c..aac4e3d 100644 --- a/test/GHCup/Utils/FileSpec.hs +++ b/test/GHCup/Utils/FileSpec.hs @@ -1,6 +1,6 @@ module GHCup.Utils.FileSpec where -import GHCup.Utils.File +import GHCup.Prelude.File import Data.List import System.Directory