Fix recursive deletion in ghcup nuke

.gitlab-ci.yml

@@ -206,7 +206,7 @@ variables:
     # otherwise we seem to get intel binaries
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
     # update and install packages
-    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils
+    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake
     # extract cabal cache
     - ./.gitlab/script/ci.sh extract_cabal_cache
   script: |
@@ -574,7 +574,7 @@ release:darwin:aarch64:
     # otherwise we seem to get intel binaries
     - export HOMEBREW_CHANGE_ARCH_TO_ARM=1
     # update and install packages
-    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake coreutils
+    - /bin/bash ./.gitlab/script/brew.sh llvm autoconf automake
   script: |
     export PATH="$CI_PROJECT_DIR/.brew/opt/llvm/bin:$CI_PROJECT_DIR/.brew/bin:$CI_PROJECT_DIR/.brew/sbin:$PATH"
     export CC=$CI_PROJECT_DIR/.brew/opt/llvm/bin/clang

.gitlab/script/ghcup_version.sh

@@ -216,7 +216,7 @@ eghcup rm $(ghc --numeric-version)
 # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
 if [ "${OS}" = "LINUX" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
-		eghcup install cabal -u https://downloads.haskell.org/~ghcup/unofficial-bindists/cabal/3.7.0.0-pre20220407/cabal-install-3.7-x86_64-linux-alpine.tar.xz 3.4.0.0-rc4
+		eghcup install cabal -u https://oleg.fi/cabal-install-3.4.0.0-rc4/cabal-install-3.4.0.0-x86_64-ubuntu-16.04.tar.xz 3.4.0.0-rc4
 		eghcup rm cabal 3.4.0.0-rc4
 	fi
 fi
@@ -289,20 +289,7 @@ fi
 eghcup upgrade
 eghcup upgrade -f
 
-# test that doing fishy symlinks into GHCup dir doesn't cause weird stuff on 'ghcup nuke'
-mkdir no_nuke/
-mkdir no_nuke/bar
-echo 'foo' > no_nuke/file
-echo 'bar' > no_nuke/bar/file
-ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/cache/no_nuke
-ln -s "$CI_PROJECT_DIR"/no_nuke/ "${GHCUP_DIR}"/logs/no_nuke
 
 # nuke
 eghcup nuke
 [ ! -e "${GHCUP_DIR}" ]
-
-# make sure nuke doesn't resolve symlinks
-[ -e "$CI_PROJECT_DIR"/no_nuke/file ]
-[ -e "$CI_PROJECT_DIR"/no_nuke/bar/file ]
-
-

CHANGELOG.md

@@ -1,13 +1,5 @@
 # Revision history for ghcup
 
-## 0.1.17.10 -- 2022-05-12
-
-* windows hotfix (hackage-only release)
-
-## 0.1.17.9 -- 2022-05-12
-
-* broken sdist (hackage-only release)
-
 ## 0.1.17.8 -- 2022-05-11
 
 * Fix a serious (but hard to trigger) bug when combining `--isolate <DIR>` with `--force`, please make sure to upgrade or avoid `--force`

app/ghcup/BrickMain.hs

@@ -13,10 +13,9 @@ import           GHCup.Errors
 import           GHCup.Types.Optics ( getDirs )
 import           GHCup.Types         hiding ( LeanAppState(..) )
 import           GHCup.Utils
-import           GHCup.Prelude ( decUTF8Safe )
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.Process
+import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude ( decUTF8Safe )
+import           GHCup.Utils.File
 
 import           Brick
 import           Brick.Widgets.Border
@@ -437,9 +436,8 @@ install' _ (_, ListResult {..}) = do
               , TarDirDoesNotExist
               , FileAlreadyExistsError
               , ProcessError
-              , ToolShadowed
+              , GHCupShadowed
               , UninstallFailed
-              , MergeFileTreeError
               ]
 
   run (do

app/ghcup/GHCup/OptParse/ChangeLog.hs

@@ -12,11 +12,9 @@ module GHCup.OptParse.ChangeLog where
 
 
 import           GHCup.Types
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
-import           GHCup.Prelude
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
-import           GHCup.Prelude.Process (exec)
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -36,6 +34,8 @@ 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)
 
 

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.Prelude
-import           GHCup.Prelude.Process
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.MegaParsec
+import           GHCup.Utils.File
+import           GHCup.Utils.Logger
+import           GHCup.Utils.MegaParsec
+import           GHCup.Utils.Prelude
 
 import           Control.DeepSeq
 import           Control.Concurrent
@@ -226,7 +226,7 @@ absolutePathParser f = case isValid f && isAbsolute f of
               False -> Left "Please enter a valid absolute filepath."
 
 isolateParser :: FilePath -> Either String FilePath
-isolateParser f = case isValid f && isAbsolute f of
+isolateParser f = case isValid f of
               True -> Right $ normalise f
               False -> Left "Please enter a valid filepath for isolate dir."
 

app/ghcup/GHCup/OptParse/Compile.hs

@@ -13,12 +13,13 @@ 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.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -388,7 +389,6 @@ type GHCEffects = '[ AlreadyInstalled
                   , CopyError
                   , BuildFailed
                   , UninstallFailed
-                  , MergeFileTreeError
                   ]
 type HLSEffects = '[ AlreadyInstalled
                   , BuildFailed
@@ -408,7 +408,6 @@ type HLSEffects = '[ AlreadyInstalled
                   , DirNotEmpty
                   , ArchiveResult
                   , UninstallFailed
-                  , MergeFileTreeError
                   ]
 
 

app/ghcup/GHCup/OptParse/Config.hs

@@ -7,6 +7,7 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE RankNTypes #-}
+{-# LANGUAGE ExplicitForAll #-}
 
 module GHCup.OptParse.Config where
 
@@ -14,9 +15,9 @@ module GHCup.OptParse.Config where
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Prelude
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 import           GHCup.OptParse.Common
 
 #if !MIN_VERSION_base(4,13,0)

app/ghcup/GHCup/OptParse/DInfo.hs

@@ -17,10 +17,9 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Version
 import           GHCup.Types
+import           GHCup.Utils.Prelude
 import           GHCup.Utils.Dirs
-import           GHCup.Prelude
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.Process
+import           GHCup.Utils.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -37,6 +36,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
+import GHCup.Utils.File
 import Language.Haskell.TH
 
 

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.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -56,26 +56,26 @@ data GCOptions = GCOptions
     --[ Parsers ]--
     ---------------
 
-
+          
 gcP :: Parser GCOptions
 gcP =
   GCOptions
-  <$>
+  <$> 
     switch
       (short 'o' <> long "ghc-old" <> help "Remove GHC versions marked as 'old'")
-  <*>
+  <*> 
     switch
       (short 'p' <> long "profiling-libs" <> help "Remove profiling libs of GHC versions")
-  <*>
+  <*> 
     switch
       (short 's' <> long "share-dir" <> help "Remove GHC share directories (documentation)")
-  <*>
+  <*> 
     switch
       (short 'h' <> long "hls-no-ghc" <> help "Remove HLS versions that don't have a corresponding installed GHC version")
-  <*>
+  <*> 
     switch
       (short 'c' <> long "cache" <> help "GC the GHCup cache")
-  <*>
+  <*> 
     switch
       (short 't' <> long "tmpdirs" <> help "Remove tmpdir leftovers")
 

app/ghcup/GHCup/OptParse/Install.hs

@@ -19,8 +19,8 @@ import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils.Dirs
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 import           Codec.Archive
 #if !MIN_VERSION_base(4,13,0)
@@ -259,7 +259,6 @@ type InstallEffects = '[ AlreadyInstalled
                        , FileAlreadyExistsError
                        , ProcessError
                        , UninstallFailed
-                       , MergeFileTreeError
 
                        , (AlreadyInstalled, ())
                        , (UnknownArchive, ())
@@ -268,7 +267,6 @@ type InstallEffects = '[ AlreadyInstalled
                        , (CopyError, ())
                        , (NotInstalled, ())
                        , (UninstallFailed, ())
-                       , (MergeFileTreeError, ())
                        , (DirNotEmpty, ())
                        , (NoDownload, ())
                        , (BuildFailed, ())
@@ -292,7 +290,6 @@ type InstallEffects = '[ AlreadyInstalled
                        , (NoDownload, NotInstalled)
                        , (NotInstalled, NotInstalled)
                        , (UninstallFailed, NotInstalled)
-                       , (MergeFileTreeError, NotInstalled)
                        , (BuildFailed, NotInstalled)
                        , (TagNotFound, NotInstalled)
                        , (DigestError, NotInstalled)
@@ -326,7 +323,6 @@ type InstallGHCEffects = '[ TagNotFound
                           , DirNotEmpty
                           , AlreadyInstalled
                           , UninstallFailed
-                          , MergeFileTreeError
 
                           , (AlreadyInstalled, NotInstalled)
                           , (UnknownArchive, NotInstalled)
@@ -337,7 +333,6 @@ type InstallGHCEffects = '[ TagNotFound
                           , (DirNotEmpty, NotInstalled)
                           , (NoDownload, NotInstalled)
                           , (UninstallFailed, NotInstalled)
-                          , (MergeFileTreeError, NotInstalled)
                           , (BuildFailed, NotInstalled)
                           , (TagNotFound, NotInstalled)
                           , (DigestError, NotInstalled)
@@ -358,7 +353,6 @@ type InstallGHCEffects = '[ TagNotFound
                           , (DirNotEmpty, ())
                           , (NoDownload, ())
                           , (UninstallFailed, ())
-                          , (MergeFileTreeError, ())
                           , (BuildFailed, ())
                           , (TagNotFound, ())
                           , (DigestError, ())

app/ghcup/GHCup/OptParse/List.hs

@@ -11,7 +11,7 @@ module GHCup.OptParse.List where
 
 
 import           GHCup
-import           GHCup.Prelude
+import           GHCup.Utils.Prelude
 import           GHCup.Types
 import           GHCup.OptParse.Common
 

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.Prelude.Logger
+import           GHCup.Utils.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Prefetch.hs

@@ -14,10 +14,9 @@ module GHCup.OptParse.Prefetch where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -34,6 +33,7 @@ import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 
 import qualified Data.Text                     as T
 import Control.Exception.Safe (MonadMask)
+import GHCup.Utils.Prelude
 import GHCup.Download (getDownloadsF)
 
 

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.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
 import           GHCup.OptParse.Common
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Run.hs

@@ -10,17 +10,14 @@ 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.Prelude
-import           GHCup.Prelude.File
-#ifdef IS_WINDOWS
-import           GHCup.Prelude.Process
-#endif
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 import           Control.Exception.Safe         ( MonadMask, MonadCatch )
 #if !MIN_VERSION_base(4,13,0)
@@ -179,7 +176,6 @@ type RunEffects = '[ AlreadyInstalled
                    , FileAlreadyExistsError
                    , ProcessError
                    , UninstallFailed
-                   , MergeFileTreeError
                    ]
 
 runLeanRUN :: (MonadUnliftIO m, MonadIO m)
@@ -344,7 +340,6 @@ run RunOptions{..} runAppState leanAppstate runLogger = do
                               , FileAlreadyExistsError
                               , CopyError
                               , UninstallFailed
-                              , MergeFileTreeError
                               ] (ResourceT (ReaderT AppState m)) ()
    installToolChainFull Toolchain{..} tmp = do
          forM_ [(GHC,) <$> ghcVer, (Cabal,) <$> cabalVer, (HLS,) <$> hlsVer, (Stack,) <$> stackVer] $ \mt -> do

app/ghcup/GHCup/OptParse/Set.hs

@@ -17,8 +17,8 @@ import           GHCup.OptParse.Common
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/ToolRequirements.hs

@@ -11,8 +11,8 @@ module GHCup.OptParse.ToolRequirements where
 
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.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.Prelude
+import GHCup.Utils.Prelude
 import GHCup.Requirements
 import System.IO
 

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.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

app/ghcup/GHCup/OptParse/Upgrade.hs

@@ -14,8 +14,7 @@ module GHCup.OptParse.Upgrade where
 import           GHCup
 import           GHCup.Errors
 import           GHCup.Types
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger
+import           GHCup.Utils.Logger
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -94,7 +93,7 @@ type UpgradeEffects = '[ DigestError
                        , FileDoesNotExistError
                        , CopyError
                        , DownloadFailed
-                       , ToolShadowed
+                       , GHCupShadowed
                        ]
 
 

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.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

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.Prelude
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 import           GHCup.Version
 
 import           Cabal.Plan ( findPlanJson, SearchPlanJson(..) )
@@ -155,6 +155,7 @@ main = do
   versions. It maintains a self-contained ~/.ghcup directory.
 
 ENV variables:
+  * TMPDIR: where ghcup does the work (unpacking, building, ...)
   * GHCUP_INSTALL_BASE_PREFIX: the base of ghcup (default: $HOME)
   * GHCUP_USE_XDG_DIRS: set to anything to use XDG style directories
 

docs/guide.md

@@ -76,6 +76,7 @@ Partial configuration is fine. Command line options always override the config f
 This is the complete list of env variables that change GHCup behavior:
 
 * `GHCUP_USE_XDG_DIRS`: see [XDG support](#xdg-support) above
+* `TMPDIR`: where ghcup does the work (unpacking, building, ...)
 * `GHCUP_INSTALL_BASE_PREFIX`: the base of ghcup (default: `$HOME`)
 * `GHCUP_CURL_OPTS`: additional options that can be passed to curl
 * `GHCUP_WGET_OPTS`: additional options that can be passed to wget
@@ -287,11 +288,10 @@ GHCup itself is also pre-installed on all platforms, but may use non-standard in
 GHCup supports verifying the GPG signature of the metadata file. The metadata file then contains SHA256 hashes of all downloads, so
 this is cryptographically secure.
 
-First, obtain the gpg keys:
+First, obtain the gpg key:
 
 ```sh
-gpg --batch --keyserver keys.openpgp.org     --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
-gpg --batch --keyserver keyserver.ubuntu.com --recv-keys FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01
+gpg --batch --keyserver keys.openpgp.org --recv-keys 7784930957807690A66EBDBE3786C5262ECB4A3F
 ```
 
 Then verify the gpg key in one of these ways:

docs/install.md

@@ -187,7 +187,7 @@ Lower availability of bindists. Stack and HLS binaries are experimental.
 Download the binary for your platform at [https://downloads.haskell.org/~ghcup/](https://downloads.haskell.org/~ghcup/)
 and place it into your `PATH` anywhere.
 
-If you want to GPG verify the binaries, import the following keys first: `7784930957807690A66EBDBE3786C5262ECB4A3F` and `FE5AB6C91FEA597C3B31180B73EDE9E8CFBAEF01`.
+If you want to GPG verify the binaries, import the following key first: `7784930957807690A66EBDBE3786C5262ECB4A3F`.
 
 Then adjust your `PATH` in `~/.bashrc` (or similar, depending on your shell) like so:
 

ghcup.cabal

@@ -44,39 +44,31 @@ 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
@@ -117,7 +109,6 @@ library
     , deepseq               ^>=1.4.4.0
     , directory             ^>=1.3.6.0
     , disk-free-space       ^>=0.1.0.1
-    , exceptions            ^>=0.10
     , filepath              ^>=1.4.2.1
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  ^>=3.2.1
@@ -163,9 +154,9 @@ library
   if os(windows)
     cpp-options:   -DIS_WINDOWS
     other-modules:
-      GHCup.Prelude.File.Windows
-      GHCup.Prelude.Process.Windows
-      GHCup.Prelude.Windows
+      GHCup.Utils.File.Windows
+      GHCup.Utils.Prelude.Windows
+      GHCup.Utils.Windows
 
     build-depends:
       , bzlib
@@ -174,11 +165,11 @@ library
 
   else
     other-modules:
-      GHCup.Prelude.File.Posix
-      GHCup.Prelude.File.Posix.Foreign
-      GHCup.Prelude.File.Posix.Traversals
-      GHCup.Prelude.Posix
-      GHCup.Prelude.Process.Posix
+      GHCup.Utils.File.Posix
+      GHCup.Utils.File.Posix.Foreign
+      GHCup.Utils.File.Posix.Traversals
+      GHCup.Utils.Posix
+      GHCup.Utils.Prelude.Posix
 
     c-sources:     cbits/dirutils.c
     build-depends:

lib/GHCup/Cabal.hs

@@ -1,284 +0,0 @@
-{-# 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
-import Text.PrettyPrint.HughesPJClass (prettyShow)
-
-
-
-    -------------------------
-    --[ 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-\<ver\>@ 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
-
-  liftIO (isShadowed cabalbin) >>= \case
-    Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa cabalbin ver)
-
-  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)

lib/GHCup/Download.hs

@@ -34,10 +34,9 @@ import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
-import           GHCup.Prelude
-import           GHCup.Prelude.File
-import           GHCup.Prelude.Logger.Internal
-import           GHCup.Prelude.Process
+import           GHCup.Utils.File
+import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude
 import           GHCup.Version
 
 import           Control.Applicative

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.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Applicative
 import           Control.Exception.Safe

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.Prelude
+import           GHCup.Utils.Prelude
 
 import           Control.Applicative
 import           Control.Monad

lib/GHCup/Errors.hs

@@ -105,15 +105,6 @@ instance Pretty CopyError where
   pPrint (CopyError reason) =
     text ("Unable to copy a file. Reason was: " ++ reason)
 
--- | Unable to merge file trees.
-data MergeFileTreeError = MergeFileTreeError IOException FilePath FilePath
-  deriving Show
-
-instance Pretty MergeFileTreeError where
-  pPrint (MergeFileTreeError e from to) =
-    text "Failed to merge file tree from" <+> text from <+> text "to" <+> text to <+> text "\nexception was:" <+> text (displayException e)
-     <+> text "\n...tried to clean up" <+> text to <+> text ". Make sure it's gone."
-
 -- | Unable to find a tag of a tool.
 data TagNotFound = TagNotFound Tag Tool
   deriving Show
@@ -308,21 +299,19 @@ instance Pretty HadrianNotFound where
   pPrint HadrianNotFound =
     text "Could not find Hadrian build files. Does this GHC version support Hadrian builds?"
 
-data ToolShadowed = ToolShadowed
-                       Tool
+data GHCupShadowed = GHCupShadowed
                        FilePath  -- shadow binary
                        FilePath  -- upgraded binary
                        Version   -- upgraded version
   deriving Show
 
-instance Pretty ToolShadowed where
-  pPrint (ToolShadowed tool sh up _) =
-    text (prettyShow tool
-         <> " is shadowed by "
+instance Pretty GHCupShadowed where
+  pPrint (GHCupShadowed sh up _) =
+    text ("ghcup is shadowed by "
          <> sh
-         <> ".\nThe upgrade will not be in effect, unless you remove "
+         <> ". The upgrade will not be in effect, unless you remove "
          <> sh
-         <> "\nor make sure "
+         <> " or make sure "
          <> takeDirectory up
          <> " comes before "
          <> takeDirectory sh

lib/GHCup/HLS.hs

@@ -1,625 +0,0 @@
-{-# 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
-import Text.PrettyPrint.HughesPJClass (prettyShow)
-
-
-
-    --------------------
-    --[ 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-<ghcver>
-  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-\<ghcver\>@
--- 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-<ghcver> 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
-
-      liftIO (isShadowed wrapper) >>= \case
-        Nothing -> pure ()
-        Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed HLS pa wrapper ver)
-
-
-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 ()

lib/GHCup/List.hs

@@ -1,410 +0,0 @@
-{-# 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
-

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.Prelude
-import           GHCup.Prelude.Logger
-import           GHCup.Prelude.Process
-import           GHCup.Prelude.String.QQ
+import           GHCup.Utils.File
+import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )

lib/GHCup/Prelude.hs

@@ -1,54 +0,0 @@
-{-# 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))
-

lib/GHCup/Prelude/File.hs

@@ -1,426 +0,0 @@
-{-# LANGUAGE CPP                 #-}
-{-# LANGUAGE BangPatterns        #-}
-{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE TypeFamilies        #-}
-{-# LANGUAGE TypeOperators       #-}
-
-module GHCup.Prelude.File (
-  mergeFileTree,
-  copyFileE,
-  findFilesDeep,
-  getDirectoryContentsRecursive,
-  getDirectoryContentsRecursiveBFS,
-  getDirectoryContentsRecursiveDFS,
-  getDirectoryContentsRecursiveUnsafe,
-  getDirectoryContentsRecursiveBFSUnsafe,
-  getDirectoryContentsRecursiveDFSUnsafe,
-  recordedInstallationFile,
-  module GHCup.Prelude.File.Search,
-
-  chmod_755,
-  isBrokenSymlink,
-  copyFile,
-  deleteFile,
-  install,
-  removeEmptyDirectory,
-  removeDirIfEmptyOrIsSymlink,
-  removeEmptyDirsRecursive,
-  rmFileForce,
-  createDirRecursive',
-  recyclePathForcibly,
-  rmDirectory,
-  recycleFile,
-  rmFile,
-  rmDirectoryLink,
-  moveFilePortable,
-  moveFile,
-  rmPathForcibly,
-
-  exeExt,
-  exeExt',
-  getLinkTarget,
-  pathIsLink,
-  rmLink,
-  createLink
-) where
-
-import GHCup.Utils.Dirs
-import GHCup.Prelude.Logger.Internal (logInfo, logDebug)
-import GHCup.Prelude.Internal
-import GHCup.Prelude.File.Search
-#if IS_WINDOWS
-import GHCup.Prelude.File.Windows
-import GHCup.Prelude.Windows
-#else
-import GHCup.Prelude.File.Posix
-import GHCup.Prelude.Posix
-#endif
-import           GHCup.Errors
-import           GHCup.Types
-import           GHCup.Types.Optics
-
-import           Text.Regex.Posix
-import           Control.Monad.IO.Unlift        ( MonadUnliftIO )
-import           Control.Exception.Safe
-import           Control.Monad.Reader
-import           Data.ByteString                ( ByteString )
-import           Haskus.Utils.Variant.Excepts
-import           System.FilePath
-import           Text.PrettyPrint.HughesPJClass (prettyShow)
-
-import qualified Data.Text                     as T
-import qualified Streamly.Prelude              as S
-import Control.DeepSeq (force)
-import Control.Exception (evaluate)
-import GHC.IO.Exception
-import System.IO.Error
-
-
--- | Merge one file tree to another given a copy operation.
---
--- Records every successfully installed file into the destination
--- returned by 'recordedInstallationFile'.
---
--- If any copy operation fails, the record file is deleted, as well
--- as the partially installed files.
-mergeFileTree :: ( MonadMask m
-                 , S.MonadAsync m
-                 , MonadReader env m
-                 , HasDirs env
-                 , HasLog env
-                 , MonadCatch m
-                 )
-              => GHCupPath                       -- ^ source base directory from which to install findFiles
-              -> InstallDirResolved              -- ^ destination base dir
-              -> Tool
-              -> GHCTargetVersion
-              -> (FilePath -> FilePath -> m ())  -- ^ file copy operation
-              -> Excepts '[MergeFileTreeError] m ()
-mergeFileTree _ (GHCupBinDir fp) _ _ _ =
-  throwIO $ userError ("mergeFileTree: internal error, called on " <> fp)
-mergeFileTree sourceBase destBase tool v' copyOp = do
-  lift $ logInfo $ "Merging file tree from \""
-       <> T.pack (fromGHCupPath sourceBase)
-       <> "\" to \""
-       <> T.pack (fromInstallDir destBase)
-       <> "\""
-  recFile <- recordedInstallationFile tool v'
-
-  wrapInExcepts $ do
-    -- These checks are not atomic, but we perform them to have
-    -- the opportunity to abort before copying has started.
-    --
-    -- The actual copying might still fail.
-    liftIO $ baseCheck (fromGHCupPath sourceBase)
-    liftIO $ destCheck (fromInstallDir destBase)
-
-    -- we only record for non-isolated installs
-    when (isSafeDir destBase) $ do
-      whenM (liftIO $ doesFileExist recFile)
-        $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
-      liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
-
-  -- we want the cleanup action to leak through in case of exception
-  onE_ (cleanupOnPartialInstall recFile) $ wrapInExcepts $ do
-    logDebug "Starting merge"
-    lift $ flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
-      copy f
-      logDebug $ T.pack "Recording installed file: " <> T.pack f
-      recordInstalledFile f recFile
-      pure f
-
- where
-  wrapInExcepts = handleIO (\e -> throwE $ MergeFileTreeError e (fromGHCupPath sourceBase) (fromInstallDir destBase))
-
-  cleanupOnPartialInstall recFile = when (isSafeDir destBase) $ do
-    (force -> !l) <- hideErrorDef [NoSuchThing] [] $ lines <$> liftIO
-      (readFile recFile >>= evaluate)
-    logDebug "Deleting recorded files due to partial install"
-    forM_ l $ \f -> do
-      let dest = fromInstallDir destBase </> dropDrive f
-      logDebug $ "rm -f " <> T.pack f
-      hideError NoSuchThing $ rmFile dest
-      pure ()
-    logDebug $ "rm -f " <> T.pack recFile
-    hideError NoSuchThing $ rmFile recFile
-    logDebug $ "rm -f " <> T.pack (fromInstallDir destBase)
-    hideError UnsatisfiedConstraints $ hideError NoSuchThing $
-      removeEmptyDirsRecursive (fromInstallDir destBase)
-
-
-  recordInstalledFile f recFile = when (isSafeDir destBase) $
-    liftIO $ appendFile recFile (f <> "\n")
-
-  copy source = do
-    let dest = fromInstallDir destBase </> source
-        src  = fromGHCupPath sourceBase </> source
-
-    when (isAbsolute source)
-      $ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
-
-    liftIO . createDirectoryIfMissing True . takeDirectory $ dest
-
-    copyOp src dest
-
-
-  baseCheck src = do
-      when (isRelative src)
-        $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")
-      whenM (not <$> doesDirectoryExist src)
-        $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")
-  destCheck dest = do
-      when (isRelative dest)
-        $ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")
-
-
-
-copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
-copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to
-
-
--- | List all the files in a directory and all subdirectories.
---
--- The order places files in sub-directories after all the files in their
--- parent directories. The list is generated lazily so is not well defined if
--- the source directory structure changes before the list is used.
---
--- depth first
-getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
-                                 => GHCupPath
-                                 -> S.SerialT m FilePath
-getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp
-
--- breadth first
-getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
-                                 => GHCupPath
-                                 -> S.SerialT m FilePath
-getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp
-
-
-getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
-                              => GHCupPath
-                              -> S.SerialT m FilePath
-getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS
-
-getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
-                                    => FilePath
-                                    -> S.SerialT m FilePath
-getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe
-
-findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
-findFilesDeep path regex =
-  S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path
-
-
-recordedInstallationFile :: ( MonadReader env m
-                            , HasDirs env
-                            )
-                         => Tool
-                         -> GHCTargetVersion
-                         -> m FilePath
-recordedInstallationFile t v' = do
-  Dirs {..}  <- getDirs
-  pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
-
-removeDirIfEmptyOrIsSymlink :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
-removeDirIfEmptyOrIsSymlink filepath =
-  hideError UnsatisfiedConstraints $
-  handleIO' InappropriateType
-        (handleIfSym filepath)
-        (liftIO $ removeEmptyDirectory filepath)
-  where
-    handleIfSym fp e = do
-      isSym <- liftIO $ pathIsSymbolicLink fp
-      if isSym
-      then rmFileForce fp
-      else liftIO $ ioError e
-
-removeEmptyDirsRecursive :: (MonadMask m, MonadIO m, MonadCatch m) => FilePath -> m ()
-removeEmptyDirsRecursive = go
- where
-  go fp = do
-    cs <- liftIO $ listDirectory fp >>= filterM doesDirectoryExist . fmap (fp </>)
-    forM_ cs go
-    liftIO $ removeEmptyDirectory fp
-
-rmFileForce :: (MonadMask m, MonadIO m) => FilePath -> m ()
-rmFileForce filepath = do
-  hideError doesNotExistErrorType
-    $ hideError InappropriateType $ rmFile filepath
-
--- | More permissive version of 'createDirRecursive'. This doesn't
--- error when the destination is a symlink to a directory.
-createDirRecursive' :: FilePath -> IO ()
-createDirRecursive' p =
-  handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
-    . createDirectoryIfMissing True
-    $ p
-
- where
-  isSymlinkDir e = do
-    ft <- pathIsSymbolicLink p
-    case ft of
-      True -> do
-        rp <- canonicalizePath p
-        rft <- doesDirectoryExist rp
-        case rft of
-          True -> pure ()
-          _ -> throwIO e
-      _ -> throwIO e
-
-
--- https://github.com/haskell/directory/issues/110
--- https://github.com/haskell/directory/issues/96
--- https://www.sqlite.org/src/info/89f1848d7f
-recyclePathForcibly :: ( MonadIO m
-                       , MonadReader env m
-                       , HasDirs env
-                       , MonadMask m
-                       )
-                    => GHCupPath
-                    -> m ()
-recyclePathForcibly fp
-  | isWindows = do
-      Dirs { recycleDir } <- getDirs
-      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
-      let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
-      liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
-          `catch`
-          (\e -> if | isDoesNotExistError e -> pure ()
-                    | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
-                    | otherwise -> throwIO e)
-          `finally`
-            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-  | otherwise = liftIO $ removePathForcibly fp
-
-
-
-rmDirectory :: (MonadIO m, MonadMask m)
-            => GHCupPath
-            -> m ()
-rmDirectory fp
-  | isWindows = recover (liftIO $ removeDirectory fp)
-  | otherwise = liftIO $ removeDirectory fp
-
-
--- https://www.sqlite.org/src/info/89f1848d7f
--- https://github.com/haskell/directory/issues/96
-recycleFile :: ( MonadIO m
-               , MonadMask m
-               , MonadReader env m
-               , HasDirs env
-               )
-            => FilePath
-            -> m ()
-recycleFile fp
-  | isWindows = do
-      Dirs { recycleDir } <- getDirs
-      liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
-      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
-      let dest = fromGHCupPath tmp </> takeFileName fp
-      liftIO (moveFile fp dest)
-        `catch`
-          (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
-        `finally`
-          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
-  | otherwise = liftIO $ removeFile fp
-
-
-rmFile :: ( MonadIO m
-          , MonadMask m
-          )
-      => FilePath
-      -> m ()
-rmFile fp
-  | isWindows = recover (liftIO $ removeFile fp)
-  | otherwise = liftIO $ removeFile fp
-
-
-rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
-                => FilePath
-                -> m ()
-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

lib/GHCup/Prelude/File/Posix.hs

@@ -1,324 +0,0 @@
-{-# 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
-
-

lib/GHCup/Prelude/Logger.hs

@@ -1,61 +0,0 @@
-{-# 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

lib/GHCup/Prelude/Process.hs

@@ -1,25 +0,0 @@
-{-# 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
-

lib/GHCup/Prelude/Process/Windows.hs

@@ -1,251 +0,0 @@
-{-# 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")
-

lib/GHCup/Stack.hs

@@ -1,283 +0,0 @@
-{-# 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
-import Text.PrettyPrint.HughesPJClass (prettyShow)
-
-
-
-    --------------------
-    --[ Installation ]--
-    --------------------
-
-
--- | Installs stack into @~\/.ghcup\/bin/stack-\<ver\>@ 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
-
-  liftIO (isShadowed stackbin) >>= \case
-    Nothing -> pure ()
-    Just pa -> lift $ logWarn $ T.pack $ prettyShow (ToolShadowed Cabal pa stackbin ver)
-
-  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)

lib/GHCup/Types.hs

@@ -26,7 +26,8 @@ module GHCup.Types
   )
   where
 
-import {-# SOURCE #-} GHCup.Utils.Dirs          ( fromGHCupPath, GHCupPath )
+import {-# SOURCE #-} GHCup.Utils.Dirs          ( fromGHCupPath )
+import {-# SOURCE #-} GHCup.Utils.Dirs          ( GHCupPath )
 
 import           Control.DeepSeq                ( NFData, rnf )
 import           Data.Map.Strict                ( Map )
@@ -440,14 +441,13 @@ defaultSettings = Settings False defaultMetaCache False Never Curl False GHCupUR
 instance NFData Settings
 
 data Dirs = Dirs
-  { baseDir    :: GHCupPath
-  , binDir     :: FilePath
-  , cacheDir   :: GHCupPath
-  , logsDir    :: GHCupPath
-  , confDir    :: GHCupPath
-  , dbDir      :: GHCupPath
+  { baseDir  :: GHCupPath
+  , binDir   :: FilePath
+  , cacheDir :: GHCupPath
+  , logsDir  :: GHCupPath
+  , confDir  :: GHCupPath
+  , dbDir    :: GHCupPath
   , recycleDir :: GHCupPath -- mainly used on windows
-  , tmpDir     :: GHCupPath
   }
   deriving (Show, GHC.Generic)
 
@@ -647,17 +647,3 @@ fromInstallDir :: InstallDirResolved -> FilePath
 fromInstallDir (IsolateDirResolved fp) = fp
 fromInstallDir (GHCupDir fp) = fromGHCupPath fp
 fromInstallDir (GHCupBinDir fp) = fp
-
-
-isSafeDir :: InstallDirResolved -> Bool
-isSafeDir (IsolateDirResolved _) = False
-isSafeDir (GHCupDir _)           = True
-isSafeDir (GHCupBinDir _)        = False
-
-
-
-
-
-
-
-

lib/GHCup/Types/JSON.hs

@@ -23,7 +23,7 @@ module GHCup.Types.JSON where
 
 import           GHCup.Types
 import           GHCup.Types.JSON.Utils
-import           GHCup.Prelude.MegaParsec
+import           GHCup.Utils.MegaParsec
 
 import           Control.Applicative            ( (<|>) )
 import           Data.Aeson              hiding (Key)

lib/GHCup/Utils.hs

@@ -23,18 +23,18 @@ module GHCup.Utils
   ( module GHCup.Utils.Dirs
   , module GHCup.Utils
 #if defined(IS_WINDOWS)
-  , module GHCup.Prelude.Windows
+  , module GHCup.Utils.Windows
 #else
-  , module GHCup.Prelude.Posix
+  , module GHCup.Utils.Posix
 #endif
   )
 where
 
 
 #if defined(IS_WINDOWS)
-import GHCup.Prelude.Windows
+import GHCup.Utils.Windows
 #else
-import GHCup.Prelude.Posix
+import GHCup.Utils.Posix
 #endif
 import           GHCup.Download
 import           GHCup.Errors
@@ -42,13 +42,11 @@ import           GHCup.Types
 import           GHCup.Types.Optics
 import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.Dirs
-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           GHCup.Utils.File
+import           GHCup.Utils.Logger
+import           GHCup.Utils.MegaParsec
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 import           Codec.Archive           hiding ( Directory )
 import           Control.Applicative
@@ -77,7 +75,6 @@ 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
@@ -102,14 +99,14 @@ import GHC.IO (evaluate)
 -- >>> import System.Directory
 -- >>> import URI.ByteString
 -- >>> import qualified Data.Text as T
--- >>> import GHCup.Prelude
+-- >>> import GHCup.Utils.Prelude
 -- >>> import GHCup.Download
 -- >>> import GHCup.Version
 -- >>> import GHCup.Errors
 -- >>> import GHCup.Types
 -- >>> import GHCup.Types.Optics
 -- >>> import Optics
--- >>> import GHCup.Prelude.Version.QQ
+-- >>> import GHCup.Utils.Version.QQ
 -- >>> import qualified Data.Text.Encoding as E
 -- >>> import Control.Monad.Reader
 -- >>> import Haskus.Utils.Variant.Excepts
@@ -1022,28 +1019,6 @@ 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
@@ -1159,6 +1134,97 @@ 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
@@ -1189,17 +1255,15 @@ ensureGlobalTools
 
 -- | Ensure ghcup directory structure exists.
 ensureDirectories :: Dirs -> IO ()
-ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir tmpDir) = do
+ensureDirectories (Dirs baseDir binDir cacheDir logsDir confDir trashDir dbDir) = do
   createDirRecursive' (fromGHCupPath baseDir)
   createDirRecursive' (fromGHCupPath baseDir </> "ghc")
-  createDirRecursive' (fromGHCupPath baseDir </> "hls")
   createDirRecursive' binDir
   createDirRecursive' (fromGHCupPath cacheDir)
   createDirRecursive' (fromGHCupPath logsDir)
   createDirRecursive' (fromGHCupPath confDir)
   createDirRecursive' (fromGHCupPath trashDir)
   createDirRecursive' (fromGHCupPath dbDir)
-  createDirRecursive' (fromGHCupPath tmpDir)
   pure ()
 
 
@@ -1250,28 +1314,3 @@ 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 ()

lib/GHCup/Utils.hs-boot

@@ -0,0 +1,4 @@
+module GHCup.Utils where
+
+getLinkTarget :: FilePath -> IO FilePath
+pathIsLink :: FilePath -> IO Bool

lib/GHCup/Utils/Dirs.hs

@@ -107,15 +107,11 @@ import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Types.JSON               ( )
 import           GHCup.Types.Optics
-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           GHCup.Utils.MegaParsec
+import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.File.Common
+import           GHCup.Utils.String.QQ
 
 import           Control.DeepSeq (NFData, rnf)
 import           Control.Exception.Safe
@@ -139,6 +135,7 @@ import           System.Directory hiding ( removeDirectory
                                          )
 import qualified System.Directory              as SD
 
+import           System.DiskSpace
 import           System.Environment
 import           System.FilePath
 import           System.IO.Temp
@@ -148,7 +145,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)
+import Control.Concurrent (threadDelay)
 
 
 
@@ -177,7 +174,7 @@ createTempGHCupDirectory (GHCupPath gp) d = GHCupPath <$> createTempDirectory gp
 
 getGHCupTmpDirs :: IO [GHCupPath]
 getGHCupTmpDirs = do
-  tmpdir <- fromGHCupPath <$> ghcupTMPDir
+  tmpdir <- getCanonicalTemporaryDirectory
   ghcup_dirs <- handleIO (\_ -> pure []) $ findFiles
     tmpdir
     (makeRegexOpts compExtended
@@ -326,25 +323,6 @@ ghcupRecycleDir :: IO GHCupPath
 ghcupRecycleDir = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "trash"))
 
 
--- | Defaults to '~/.ghcup/tmp.
---
--- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
--- then uses 'XDG_CACHE_HOME/ghcup/tmp as per xdg spec.
-ghcupTMPDir :: IO GHCupPath
-ghcupTMPDir
-  | isWindows = ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
-  | otherwise = do
-      xdg <- useXDG
-      if xdg
-        then do
-          bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
-            Just r  -> pure r
-            Nothing -> do
-              home <- liftIO getHomeDirectory
-              pure (home </> ".cache")
-          pure (GHCupPath (bdir </> "ghcup" </> "tmp"))
-        else ghcupBaseDir <&> (\(GHCupPath gp) -> GHCupPath (gp </> "tmp"))
-
 
 getAllDirs :: IO Dirs
 getAllDirs = do
@@ -354,7 +332,6 @@ getAllDirs = do
   logsDir    <- ghcupLogsDir
   confDir    <- ghcupConfigDir
   recycleDir <- ghcupRecycleDir
-  tmpDir     <- ghcupTMPDir
   dbDir      <- ghcupDbDir
   pure Dirs { .. }
 
@@ -373,15 +350,10 @@ ghcupConfigFile :: (MonadIO m)
                 => Excepts '[JSONError] m UserSettings
 ghcupConfigFile = do
   filepath <- getConfigFilePath
-  contents <- liftIO $ handleIO (\e -> if NoSuchThing == ioeGetErrorType e then pure Nothing else liftIO $ ioError e) $ Just <$> BS.readFile filepath
+  contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile filepath
   case contents of
       Nothing -> pure defaultUserSettings
-      Just contents' -> liftE
-        . veitherToExcepts @_ @'[JSONError]
-        . either (VLeft . V) VRight
-        . first (JSONDecodeError . displayException)
-        . Y.decodeEither'
-        $ contents'
+      Just contents' -> lE' JSONDecodeError . first displayException . Y.decodeEither' $ contents'
 
 
     -------------------------
@@ -418,12 +390,6 @@ 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
@@ -439,7 +405,6 @@ ghcupHLSDir ver = do
   let verdir = T.unpack $ prettyVer ver
   pure (basedir `appendGHCupPath` verdir)
 
-
 mkGhcupTmpDir :: ( MonadReader env m
                  , HasDirs env
                  , MonadUnliftIO m
@@ -450,8 +415,29 @@ mkGhcupTmpDir :: ( MonadReader env m
                  , MonadIO m)
               => m GHCupPath
 mkGhcupTmpDir = GHCupPath <$> do
-  Dirs { tmpDir } <- getDirs
-  liftIO $ createTempDirectory (fromGHCupPath tmpDir) "ghcup"
+  tmpdir <- liftIO getCanonicalTemporaryDirectory
+
+  let minSpace = 5000 -- a rough guess, aight?
+  space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
+  when (maybe False (toBytes minSpace >) space) $ do
+    logWarn ("Possibly insufficient disk space on "
+      <> T.pack tmpdir
+      <> ". At least "
+      <> T.pack (show minSpace)
+      <> " MB are recommended, but only "
+      <> toMB (fromJust space)
+      <> " are free. Consider freeing up disk space or setting TMPDIR env variable.")
+    logWarn
+      "...waiting for 10 seconds before continuing anyway, you can still abort..."
+    liftIO $ threadDelay 10000000 -- give the user a sec to intervene
+
+  liftIO $ createTempDirectory tmpdir "ghcup"
+ where
+  toBytes mb = mb * 1024 * 1024
+  toMB b = T.pack $ show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
+  truncate' :: Double -> Int -> Double
+  truncate' x n = fromIntegral (floor (x * t) :: Integer) / t
+      where t = 10^n
 
 
 withGHCupTmpDir :: ( MonadReader env m
@@ -472,7 +458,7 @@ withGHCupTmpDir = snd <$> withRunInIO (\run ->
         (\fp ->
             handleIO (\e -> run
                 $ logDebug ("Resource cleanup failed for " <> T.pack (fromGHCupPath fp) <> ", error was: " <> T.pack (displayException e)))
-            . removePathForcibly
+            . rmPathForcibly
             $ fp))
 
 
@@ -536,4 +522,3 @@ removePathForcibly (GHCupPath fp) = SD.removePathForcibly fp
 
 
 
-

lib/GHCup/Utils/File.hs

@@ -0,0 +1,160 @@
+{-# LANGUAGE CPP #-}
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module GHCup.Utils.File (
+  mergeFileTree,
+  copyFileE,
+  findFilesDeep,
+  getDirectoryContentsRecursive,
+  getDirectoryContentsRecursiveBFS,
+  getDirectoryContentsRecursiveDFS,
+  getDirectoryContentsRecursiveUnsafe,
+  getDirectoryContentsRecursiveBFSUnsafe,
+  getDirectoryContentsRecursiveDFSUnsafe,
+  recordedInstallationFile,
+  module GHCup.Utils.File.Common,
+
+  executeOut,
+  execLogged,
+  exec,
+  toProcessError,
+  chmod_755,
+  isBrokenSymlink,
+  copyFile,
+  deleteFile,
+  install,
+  removeEmptyDirectory,
+) where
+
+import GHCup.Utils.Dirs
+import GHCup.Utils.File.Common
+#if IS_WINDOWS
+import GHCup.Utils.File.Windows
+#else
+import GHCup.Utils.File.Posix
+#endif
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Types.Optics
+import           GHCup.Utils.Prelude
+
+import           Text.Regex.Posix
+import           Control.Exception.Safe
+import           Haskus.Utils.Variant.Excepts
+import           Control.Monad.Reader
+import           System.FilePath
+import           Text.PrettyPrint.HughesPJClass (prettyShow)
+
+import qualified Data.Text                     as T
+import qualified Streamly.Prelude              as S
+
+
+mergeFileTree :: (MonadMask m, S.MonadAsync m, MonadReader env m, HasDirs env)
+              => GHCupPath                       -- ^ source base directory from which to install findFiles
+              -> InstallDirResolved              -- ^ destination base dir
+              -> Tool
+              -> GHCTargetVersion
+              -> (FilePath -> FilePath -> m ())  -- ^ file copy operation
+              -> m ()
+mergeFileTree sourceBase destBase tool v' copyOp = do
+  -- These checks are not atomic, but we perform them to have
+  -- the opportunity to abort before copying has started.
+  --
+  -- The actual copying might still fail.
+  liftIO $ baseCheck (fromGHCupPath sourceBase)
+  liftIO $ destCheck (fromInstallDir destBase)
+
+  recFile <- recordedInstallationFile tool v'
+  case destBase of
+    IsolateDirResolved _ -> pure ()
+    _ -> do
+      whenM (liftIO $ doesFileExist recFile) $ throwIO $ userError ("mergeFileTree: DB file " <> recFile <> " already exists!")
+      liftIO $ createDirectoryIfMissing True (takeDirectory recFile)
+
+  flip S.mapM_ (getDirectoryContentsRecursive sourceBase) $ \f -> do
+    copy f
+    recordInstalledFile f recFile
+    pure f
+
+ where
+  recordInstalledFile f recFile = do
+    case destBase of
+      IsolateDirResolved _ -> pure ()
+      _ -> liftIO $ appendFile recFile (f <> "\n")
+
+  copy source = do
+    let dest = fromInstallDir destBase </> source
+        src  = fromGHCupPath sourceBase </> source
+
+    when (isAbsolute source)
+      $ throwIO $ userError ("mergeFileTree: source file " <> source <> " is not relative!")
+
+    liftIO . createDirectoryIfMissing True . takeDirectory $ dest
+
+    copyOp src dest
+
+
+  baseCheck src = do
+      when (isRelative src)
+        $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " is not absolute!")
+      whenM (not <$> doesDirectoryExist src)
+        $ throwIO $ userError ("mergeFileTree: source base directory " <> src <> " does not exist!")
+  destCheck dest = do
+      when (isRelative dest)
+        $ throwIO $ userError ("mergeFileTree: destination base directory " <> dest <> " is not absolute!")
+
+
+
+copyFileE :: (CopyError :< xs, MonadCatch m, MonadIO m) => FilePath -> FilePath -> Bool -> Excepts xs m ()
+copyFileE from to = handleIO (throwE . CopyError . show) . liftIO . copyFile from to
+
+
+-- | List all the files in a directory and all subdirectories.
+--
+-- The order places files in sub-directories after all the files in their
+-- parent directories. The list is generated lazily so is not well defined if
+-- the source directory structure changes before the list is used.
+--
+-- depth first
+getDirectoryContentsRecursiveDFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                                 => GHCupPath
+                                 -> S.SerialT m FilePath
+getDirectoryContentsRecursiveDFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveDFSUnsafe fp
+
+-- breadth first
+getDirectoryContentsRecursiveBFS :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                                 => GHCupPath
+                                 -> S.SerialT m FilePath
+getDirectoryContentsRecursiveBFS (fromGHCupPath -> fp) = getDirectoryContentsRecursiveBFSUnsafe fp
+
+
+getDirectoryContentsRecursive :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                              => GHCupPath
+                              -> S.SerialT m FilePath
+getDirectoryContentsRecursive = getDirectoryContentsRecursiveBFS
+
+getDirectoryContentsRecursiveUnsafe :: (MonadCatch m, S.MonadAsync m, MonadMask m)
+                                    => FilePath
+                                    -> S.SerialT m FilePath
+getDirectoryContentsRecursiveUnsafe = getDirectoryContentsRecursiveBFSUnsafe
+
+findFilesDeep :: GHCupPath -> Regex -> IO [FilePath]
+findFilesDeep path regex =
+  S.toList $ S.filter (match regex) $ getDirectoryContentsRecursive path
+
+
+recordedInstallationFile :: ( MonadReader env m
+                            , HasDirs env
+                            )
+                         => Tool
+                         -> GHCTargetVersion
+                         -> m FilePath
+recordedInstallationFile t v' = do
+  Dirs {..}  <- getDirs
+  pure (fromGHCupPath dbDir </> prettyShow t </> T.unpack (tVerToText v'))
+

lib/GHCup/Utils/File/Common.hs

@@ -2,12 +2,13 @@
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE FlexibleContexts  #-}
 
-module GHCup.Prelude.File.Search (
-  module GHCup.Prelude.File.Search
+module GHCup.Utils.File.Common (
+  module GHCup.Utils.File.Common
   , ProcessError(..)
   , CapturedProcess(..)
   ) where
 
+import           GHCup.Utils.Prelude
 import           GHCup.Types(ProcessError(..), CapturedProcess(..))
 
 import           Control.Monad.Reader
@@ -26,8 +27,6 @@ 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)
 
 
 
@@ -39,7 +38,7 @@ searchPath paths needle = go paths
  where
   go [] = pure Nothing
   go (x : xs) =
-    handleIO (\e -> if ioeGetErrorType e `elem` [InappropriateType, PermissionDenied, NoSuchThing] then go xs else ioError e)
+    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
       $ do
           contents <- listDirectory x
           findM (isMatch x) contents >>= \case
@@ -53,12 +52,6 @@ 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.
@@ -113,3 +106,7 @@ 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
+
+

lib/GHCup/Utils/File/Common.hs-boot

@@ -0,0 +1,5 @@
+module GHCup.Utils.File.Common where
+
+import           Text.Regex.Posix
+
+findFiles :: FilePath -> Regex -> IO [FilePath]

lib/GHCup/Utils/File/Posix.hs

@@ -2,26 +2,28 @@
 {-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE DataKinds  #-}
 {-# LANGUAGE MultiWayIf  #-}
-{-# LANGUAGE CApiFFI #-}
 
 {-|
 Module      : GHCup.Utils.File.Posix
-Description : Process handling for unix
+Description : File and unix APIs
 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.Prelude.Process.Posix where
+module GHCup.Utils.File.Posix where
 
 import           GHCup.Utils.Dirs
-import           GHCup.Prelude.File
-import           GHCup.Prelude.File.Posix
-import           GHCup.Prelude
-import           GHCup.Prelude.Logger
+import           GHCup.Utils.File.Common
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.Logger
 import           GHCup.Types
 import           GHCup.Types.Optics
+import           GHCup.Utils.File.Posix.Traversals
 
 import           Control.Concurrent
 import           Control.Concurrent.Async
@@ -36,11 +38,16 @@ import           Data.IORef
 import           Data.Sequence                  ( Seq, (|>) )
 import           Data.List
 import           Data.Word8
+import           Foreign.C.String
+import           Foreign.C.Types
 import           GHC.IO.Exception
-import           System.IO                      ( stderr )
-import           System.IO.Error      hiding    ( catchIOError )
+import           System.IO                      ( stderr, hClose, hSetBinaryMode )
+import           System.IO.Error
 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
@@ -50,12 +57,27 @@ 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 )
 
 
 
@@ -360,3 +382,240 @@ 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 ccall unsafe "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)
+
+
+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
+
+

lib/GHCup/Utils/File/Posix/Foreign.hsc

@@ -1,6 +1,6 @@
 {-# LANGUAGE PatternSynonyms #-}
 
-module GHCup.Prelude.File.Posix.Foreign where
+module GHCup.Utils.File.Posix.Foreign where
 
 import Data.Bits
 import Data.List (foldl')

lib/GHCup/Utils/File/Posix/Traversals.hs

@@ -7,7 +7,7 @@
 {-# OPTIONS_GHC -Wall #-}
 
 
-module GHCup.Prelude.File.Posix.Traversals (
+module GHCup.Utils.File.Posix.Traversals (
 -- lower-level stuff
   readDirEnt
 , unpackDirStream
@@ -17,7 +17,7 @@ module GHCup.Prelude.File.Posix.Traversals (
 #if __GLASGOW_HASKELL__ < 710
 import Control.Applicative ((<$>))
 #endif
-import GHCup.Prelude.File.Posix.Foreign
+import GHCup.Utils.File.Posix.Foreign
 
 import Unsafe.Coerce (unsafeCoerce)
 import Foreign.C.Error

lib/GHCup/Utils/File/Windows.hs

@@ -4,28 +4,48 @@
 
 {-|
 Module      : GHCup.Utils.File.Windows
-Description : File and directory handling for windows
+Description : File and windows APIs
 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.Prelude.File.Windows where
+module GHCup.Utils.File.Windows where
 
+import {-# SOURCE #-} GHCup.Utils ( getLinkTarget, pathIsLink )
 import           GHCup.Utils.Dirs
-import           GHCup.Prelude.Internal
+import           GHCup.Utils.File.Common
+import           GHCup.Utils.Logger
+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 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
@@ -38,23 +58,188 @@ import           Streamly.Internal.Data.IOFinalizer   ( newIOFinalizer, runIOFin
 
 
 
--- | On unix, we can use symlinks, so we just get the
--- symbolic link target.
+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 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
+-- 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
 
 
--- | Checks whether the path is a link.
-pathIsLink :: FilePath -> IO Bool
-pathIsLink fp = doesPathExist (dropExtension fp <.> "shim")
+-- | 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
+
 
 chmod_755 :: MonadIO m => FilePath -> m ()
 chmod_755 fp =
@@ -62,6 +247,30 @@ 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
@@ -84,19 +293,9 @@ copyFile = WS.copyFile
 deleteFile :: FilePath -> IO ()
 deleteFile = WS.deleteFile
 
-
 install :: FilePath -> FilePath -> Bool -> IO ()
 install = copyFile
 
-
-moveFile :: FilePath -> FilePath -> IO ()
-moveFile from to = WS.moveFileEx from (Just to) 0
-
-
-moveFilePortable :: FilePath -> FilePath -> IO ()
-moveFilePortable = WS.moveFile
-
-
 removeEmptyDirectory :: FilePath -> IO ()
 removeEmptyDirectory = WS.removeDirectory
 

lib/GHCup/Utils/Logger.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE OverloadedStrings   #-}
 
 {-|
-Module      : GHCup.Utils.Logger.Internal
+Module      : GHCup.Utils.Logger
 Description : logger definition
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -11,13 +11,17 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 
-Breaking import cycles.
+Here we define our main logger.
 -}
-module GHCup.Prelude.Logger.Internal where
+module GHCup.Utils.Logger where
 
 import           GHCup.Types
 import           GHCup.Types.Optics
+import {-# SOURCE #-} GHCup.Utils.Dirs (fromGHCupPath)
+import {-# SOURCE #-} GHCup.Utils.File.Common (findFiles)
+import           GHCup.Utils.String.QQ
 
+import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
@@ -25,7 +29,12 @@ 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
@@ -83,7 +92,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' )
@@ -101,3 +110,22 @@ 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

lib/GHCup/Utils/Logger.hs-boot

@@ -0,0 +1,19 @@
+{-# 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 ()
+

lib/GHCup/Utils/MegaParsec.hs

@@ -10,7 +10,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Prelude.MegaParsec where
+module GHCup.Utils.MegaParsec where
 
 import           GHCup.Types
 

lib/GHCup/Utils/Posix.hs

@@ -1,4 +1,4 @@
-module GHCup.Prelude.Posix where
+module GHCup.Utils.Posix where
 
 
 -- | Enables ANSI support on windows, does nothing on unix.
@@ -12,8 +12,3 @@ module GHCup.Prelude.Posix where
 enableAnsiSupport :: IO (Either String Bool)
 enableAnsiSupport = pure (Right True)
 
-isWindows, isNotWindows :: Bool
-isWindows = False
-isNotWindows = not isWindows
-
-

lib/GHCup/Utils/Prelude.hs

@@ -7,7 +7,7 @@
 {-# LANGUAGE TypeOperators       #-}
 
 {-|
-Module      : GHCup.Prelude.Internal
+Module      : GHCup.Utils.Prelude
 Description : MegaParsec utilities
 Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
@@ -15,11 +15,28 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 
-Stuff that doesn't need GHCup modules, so we can avoid
-recursive imports.
+GHCup specific prelude. Lots of Excepts functionality.
 -}
-module GHCup.Prelude.Internal where
+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
 
+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
@@ -28,15 +45,23 @@ import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
-import           Data.List                      ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd )
+import           Data.List                      ( intercalate, stripPrefix, isPrefixOf, dropWhileEnd, intersperse )
 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
@@ -45,6 +70,7 @@ 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
@@ -158,6 +184,13 @@ 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
@@ -278,6 +311,56 @@ 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.
@@ -296,6 +379,109 @@ escapeVerRex = B.pack . go . B.unpack . verToBS
   go (x : xs) | x == _period = [_backslash, _period] ++ go xs
               | otherwise    = x : go xs
 
+-- | More permissive version of 'createDirRecursive'. This doesn't
+-- error when the destination is a symlink to a directory.
+createDirRecursive' :: FilePath -> IO ()
+createDirRecursive' p =
+  handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
+    . createDirectoryIfMissing True
+    $ p
+
+ where
+  isSymlinkDir e = do
+    ft <- pathIsSymbolicLink p
+    case ft of
+      True -> do
+        rp <- canonicalizePath p
+        rft <- doesDirectoryExist rp
+        case rft of
+          True -> pure ()
+          _ -> throwIO e
+      _ -> throwIO e
+
+
+-- https://github.com/haskell/directory/issues/110
+-- https://github.com/haskell/directory/issues/96
+-- https://www.sqlite.org/src/info/89f1848d7f
+recyclePathForcibly :: ( MonadIO m
+                       , MonadReader env m
+                       , HasDirs env
+                       , MonadMask m
+                       )
+                    => GHCupPath
+                    -> m ()
+recyclePathForcibly fp
+  | isWindows = do
+      Dirs { recycleDir } <- getDirs
+      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recyclePathForcibly"
+      let dest = tmp `appendGHCupPath` takeFileName (fromGHCupPath fp)
+      liftIO (moveFile (fromGHCupPath fp) (fromGHCupPath dest))
+          `catch`
+          (\e -> if | isDoesNotExistError e -> pure ()
+                    | isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} -> recover (liftIO $ removePathForcibly fp)
+                    | otherwise -> throwIO e)
+          `finally`
+            liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+  | otherwise = liftIO $ removePathForcibly fp
+
+
+rmPathForcibly :: ( MonadIO m
+                  , MonadMask m
+                  )
+               => GHCupPath
+               -> m ()
+rmPathForcibly fp
+  | isWindows = recover (liftIO $ removePathForcibly fp)
+  | otherwise = liftIO $ removePathForcibly fp
+
+
+rmDirectory :: (MonadIO m, MonadMask m)
+            => GHCupPath
+            -> m ()
+rmDirectory fp
+  | isWindows = recover (liftIO $ removeDirectory fp)
+  | otherwise = liftIO $ removeDirectory fp
+
+
+-- https://www.sqlite.org/src/info/89f1848d7f
+-- https://github.com/haskell/directory/issues/96
+recycleFile :: ( MonadIO m
+               , MonadMask m
+               , MonadReader env m
+               , HasDirs env
+               )
+            => FilePath
+            -> m ()
+recycleFile fp
+  | isWindows = do
+      Dirs { recycleDir } <- getDirs
+      liftIO $ whenM (doesDirectoryExist fp) $ ioError (IOError Nothing InappropriateType "recycleFile" "" Nothing (Just fp))
+      tmp <- liftIO $ createTempGHCupDirectory recycleDir "recycleFile"
+      let dest = fromGHCupPath tmp </> takeFileName fp
+      liftIO (moveFile fp dest)
+        `catch`
+          (\e -> if isPermissionError e || ioeGetErrorType e == UnsupportedOperation {- EXDEV on windows -} then recover (liftIO $ rmFile fp) else throwIO e)
+        `finally`
+          liftIO (handleIO (\_ -> pure ()) $ removePathForcibly tmp)
+  | otherwise = liftIO $ removeFile fp
+
+
+rmFile :: ( MonadIO m
+          , MonadMask m
+          )
+      => FilePath
+      -> m ()
+rmFile fp
+  | isWindows = recover (liftIO $ removeFile fp)
+  | otherwise = liftIO $ removeFile fp
+
+
+rmDirectoryLink :: (MonadIO m, MonadMask m, MonadReader env m, HasDirs env)
+                => FilePath
+                -> m ()
+rmDirectoryLink fp
+  | isWindows = recover (liftIO $ removeDirectoryLink fp)
+  | otherwise = liftIO $ removeDirectoryLink fp
 
 
 recover :: (MonadIO m, MonadMask m) => m a -> m a

lib/GHCup/Utils/Prelude/Posix.hs

@@ -0,0 +1,24 @@
+module GHCup.Utils.Prelude.Posix where
+
+import           System.Directory hiding ( removeDirectory
+                                         , removeDirectoryRecursive
+                                         , removePathForcibly
+                                         , findFiles
+                                         )
+import System.Posix.Files
+
+
+isWindows, isNotWindows :: Bool
+isWindows = False
+isNotWindows = not isWindows
+
+
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile = rename
+
+
+moveFilePortable :: FilePath -> FilePath -> IO ()
+moveFilePortable from to = do
+  copyFile from to
+  removeFile from
+

lib/GHCup/Utils/Prelude/Windows.hs

@@ -0,0 +1,17 @@
+module GHCup.Utils.Prelude.Windows where
+
+import qualified System.Win32.File             as Win32
+
+
+isWindows, isNotWindows :: Bool
+isWindows = True
+isNotWindows = not isWindows
+
+
+moveFile :: FilePath -> FilePath -> IO ()
+moveFile from to = Win32.moveFileEx from (Just to) 0
+
+
+moveFilePortable :: FilePath -> FilePath -> IO ()
+moveFilePortable = Win32.moveFile
+

lib/GHCup/Utils/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.Prelude.String.QQ
+module GHCup.Utils.String.QQ
   ( s
   )
 where

lib/GHCup/Utils/Version/QQ.hs

@@ -16,7 +16,7 @@ Maintainer  : hasufell@hasufell.de
 Stability   : experimental
 Portability : portable
 -}
-module GHCup.Prelude.Version.QQ where
+module GHCup.Utils.Version.QQ where
 
 import           Data.Data
 import           Data.Text                      ( Text )

lib/GHCup/Utils/Windows.hs

@@ -3,7 +3,7 @@
 {-# LANGUAGE FlexibleContexts      #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
-module GHCup.Prelude.Windows where
+module GHCup.Utils.Windows where
 
 
 import           Control.Exception.Safe
@@ -46,8 +46,3 @@ enableAnsiSupport = handleIO (pure . Left . displayException) $ do
     >> pure (Right False)
   else pure (Right True)
 
-
-isWindows, isNotWindows :: Bool
-isWindows = True
-isNotWindows = not isWindows
-

lib/GHCup/Version.hs

@@ -16,18 +16,12 @@ 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.
 --
@@ -37,72 +31,22 @@ ghcupURL :: URI
 ghcupURL = [uri|https://raw.githubusercontent.com/haskell/ghcup-metadata/master/ghcup-0.0.7.yaml|]
 
 -- | The current ghcup version.
-ghcUpVer :: V.PVP
-ghcUpVer = V.PVP . NE.fromList . fmap fromIntegral $ versionBranch version
+ghcUpVer :: PVP
+ghcUpVer = PVP . NE.fromList . fmap fromIntegral $ versionBranch version
 
 -- | ghcup version as numeric string.
 numericVer :: String
-numericVer = T.unpack . V.prettyPVP $ ghcUpVer
+numericVer = T.unpack . prettyPVP $ ghcUpVer
 
-versionCmp :: V.Versioning -> VersionCmp -> Bool
+versionCmp :: 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 :: V.Versioning -> VersionRange -> Bool
+versionRange :: 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

scripts/bootstrap/bootstrap-haskell

@@ -763,7 +763,7 @@ if [ -z "${BOOTSTRAP_HASKELL_MINIMAL}" ] ; then
 
 	do_cabal_config_init $ask_cabal_config_init_answer
 
-	edo cabal update --ignore-project
+	edo cabal new-update --ignore-project
 else # don't install ghc and cabal
 	case "${plat}" in
 			MSYS*|MINGW*)

stack.yaml

@@ -57,9 +57,6 @@ flags:
   cabal-plan:
     exe: false
 
-  streamly:
-    use-unliftio: true
-
 ghc-options:
   "$locals": -O2
   streamly: -O2 -fspec-constr-recursive=16 -fmax-worker-args=16

test/GHCup/Utils/FileSpec.hs

@@ -1,6 +1,6 @@
 module GHCup.Utils.FileSpec where
 
-import           GHCup.Prelude.File
+import           GHCup.Utils.File
 
 import           Data.List
 import           System.Directory
@@ -16,14 +16,14 @@ spec :: Spec
 spec = do
   describe "GHCup.Utils.File" $ do
     it "getDirectoryContentsRecursiveBFS" $ do
-      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe "lib")
-      l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib"
+      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveBFSUnsafe ".")
+      l2 <- sort <$> getDirectoryContentsRecursiveLazy "."
       not (null l1) `shouldBe` True
       not (null l2) `shouldBe` True
       l1 `shouldBe` l2
     it "getDirectoryContentsRecursiveDFS" $ do
-      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe "lib")
-      l2 <- sort <$> getDirectoryContentsRecursiveLazy "lib"
+      l1 <- sort <$> S.toList (getDirectoryContentsRecursiveDFSUnsafe ".")
+      l2 <- sort <$> getDirectoryContentsRecursiveLazy "."
       not (null l1) `shouldBe` True
       not (null l2) `shouldBe` True
       l1 `shouldBe` l2