Better logging WIP

.gitlab/before_script/darwin/install_deps.sh

@@ -10,8 +10,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-apple-darwin-ghcup > ./gh
 chmod +x ghcup-bin
 
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 
 exit 0

.gitlab/before_script/freebsd/install_deps.sh

@@ -12,8 +12,8 @@ curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > .
 chmod +x ghcup-bin
 
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 
 exit 0

.gitlab/before_script/linux/alpine/install_deps.sh

@@ -28,8 +28,8 @@ else
 fi
 chmod +x ghcup-bin
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 
 # utils
 apk add --no-cache \
@@ -41,9 +41,6 @@ apk add --no-cache \
 	zlib \
 	zlib-dev \
 	zlib-static \
-	bzip2 \
-	bzip2-dev \
-	bzip2-static \
 	gmp \
 	gmp-dev \
 	openssl-dev \

.gitlab/before_script/linux/install_deps.sh

@@ -7,13 +7,13 @@ set -eux
 mkdir -p "${TMPDIR}"
 
 sudo apt-get update -y
-sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget
+sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget
 
 curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-linux-ghcup > ./ghcup-bin
 chmod +x ghcup-bin
 
 ./ghcup-bin upgrade -i -f
-./ghcup-bin install ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install ${GHC_VERSION}
-./ghcup-bin set ${GHC_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml set ${GHC_VERSION}
-./ghcup-bin install-cabal ${CABAL_VERSION}
+./ghcup-bin -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml install-cabal ${CABAL_VERSION}
 

.gitlab/before_script/linux/install_deps_manual.sh

@@ -19,7 +19,7 @@ ednf() {
 }
 
 ednf update
-ednf install gcc gcc-c++ gmp gmp-devel make ncurses ncurses-devel xz xz-devel perl zlib zlib-devel openssl-devel openssl-libs openssl libffi libffi-devel lbzip2 lbzip2-utils bzip2-devel
+ednf install gcc gcc-c++ gmp gmp-devel make ncurses ncurses-devel xz xz-devel perl zlib zlib-devel openssl-devel openssl-libs openssl libffi libffi-devel lbzip2 lbzip2-utils
 if [ "${ARCH}" = "ARM64" ] ; then
 	ednf install numactl numactl-libs numactl-devel
 fi

.gitlab/before_script/linux/install_deps_minimal.sh

@@ -7,4 +7,4 @@ set -eux
 mkdir -p "${TMPDIR}"
 
 sudo apt-get update -y
-sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev libbz2-dev git wget
+sudo apt-get install -y libnuma-dev zlib1g-dev libgmp-dev libgmp10 libssl-dev liblzma-dev git wget

.gitlab/script/ghcup_version.sh

@@ -7,11 +7,11 @@ set -eux
 mkdir -p "$CI_PROJECT_DIR"/.local/bin
 
 ecabal() {
-	cabal --store-dir="$CI_PROJECT_DIR"/.store "$@"
+	cabal --store-dir="$(pwd)"/.store "$@"
 }
 
 eghcup() {
-	ghcup -v -c -s file://$CI_PROJECT_DIR/ghcup-${JSON_VERSION}.yaml "$@"
+	ghcup -v -c -s file://$(pwd)/ghcup-${JSON_VERSION}.yaml "$@"
 }
 
 git describe --always
@@ -96,19 +96,14 @@ eghcup set ${GHC_VERSION}
 eghcup rm 8.10.3
 [ "$(ghc --numeric-version)" = "${ghc_ver}" ]
 
+# install hls
 if [ "${OS}" = "DARWIN" ] ; then
 	eghcup install hls
 	haskell-language-server-wrapper --version
-
-	eghcup install stack
-	stack --version
 elif [ "${OS}" = "LINUX" ] ; then
 	if [ "${ARCH}" = "64" ] ; then
 		eghcup install hls
 		haskell-language-server-wrapper --version
-
-		eghcup install stack
-		stack --version
 	fi
 fi
 
@@ -116,12 +111,8 @@ fi
 eghcup rm $(ghc --numeric-version)
 
 # https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/116
-if [ "${OS}" = "LINUX" ] ; then
+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
-	if [ "${ARCH}" = "64" ] ; then
+eghcup rm cabal 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
 
 eghcup upgrade
 eghcup upgrade -f

CHANGELOG.md

@@ -5,11 +5,6 @@
 * Add date to GHC bindist names created by ghcup
 * Warn when /tmp doesn't have 5GB or more of disk space
 * Allow to compile GHC from git repo wrt [#126](https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/126)
-* Add stack support
-
-## 0.1.14.2 -- 2021-05-12
-
-* Remove dead dependency on ascii-string
 
 ## 0.1.14.1 -- 2021-04-11
 

HACKING.md

@@ -6,6 +6,10 @@
 
 This is an open variant, similar to [plucky](https://hackage.haskell.org/package/plucky) or [oops](https://github.com/i-am-tom/oops) and allows us to combine different error types. Maybe it is too much and it's a little bit [unergonomic](https://github.com/haskus/packages/issues/32) at times. If it really hurts maintenance, it will be removed. It was more of an experiment.
 
+### No use of filepath or directory
+
+Filepath and directory have two fundamental problems: 1. they use String as filepath (see [AFPP](https://gitlab.haskell.org/ghc/ghc/-/wikis/proposal/abstract-file-path) as to why this is wrong) and 2. they try very hard to be cross-platform at the expense of low-level correctness. Instead, we use the [hpath](https://github.com/hasufell/hpath) libraries for file and filepath related stuff, which also gives us stronger filepath types.
+
 ### No use of haskell-TLS
 
 I consider haskell-TLS an interesting experiment, but not a battle-tested and peer-reviewed crypto implementation. There is little to no research about what the intricacies of using haskell for low-level crypto are and how vulnerable such binaries are. Instead, we use either curl the binary (for FreeBSD and mac) or http-io-streams, which works with OpenSSL bindings.

README.md

@@ -4,6 +4,8 @@ It follows the unix UNIX philosophy of [do one thing and do it well](https://en.
 
 Similar in scope to [rustup](https://github.com/rust-lang-nursery/rustup.rs), [pyenv](https://github.com/pyenv/pyenv) and [jenv](http://www.jenv.be).
 
+*Ubuntu users may prefer [hvr's ppa](https://launchpad.net/~hvr/+archive/ubuntu/ghc).*
+
 ## Table of Contents
 
    * [Installation](#installation)
@@ -77,7 +79,7 @@ ghcup install cabal
 ghcup upgrade
 ```
 
-GHCup works very well with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
+Generally this is meant to be used with [`cabal-install`](https://hackage.haskell.org/package/cabal-install), which
 handles your haskell packages and can demand that [a specific version](https://cabal.readthedocs.io/en/latest/nix-local-build.html#cfg-flag---with-compiler)  of `ghc` is available, which `ghcup` can do.
 
 ### Configuration
@@ -234,8 +236,8 @@ ghcup is not a reimplementation of stack. The only common part is automatic inst
 
 2. Why not support windows?
 
-We do.
+Consider using [Chocolatey](https://chocolatey.org/search?q=ghc) or [ghcups](https://github.com/kakkun61/ghcups).
 
 3. Why the haskell reimplementation?
 
-:-)
+Why not?

app/ghcup-gen/Validate.hs

@@ -37,11 +37,12 @@ import           Data.IORef
 import           Data.List
 import           Data.String.Interpolate
 import           Data.Versions
+import           HPath                          ( toFilePath, rel )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
-import           System.FilePath
 import           System.Exit
 import           System.IO
+import           System.Posix.FilePath
 import           Text.ParserCombinators.ReadP
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
@@ -105,10 +106,6 @@ validate dls = do
       addError
     when ((notElem FreeBSD pspecs) && arch == A_64) $ lift $ $(logWarn)
       [i|FreeBSD missing for #{t} #{v'} #{arch'}|]
-    when (notElem Windows pspecs && arch == A_64) $ do
-      lift $ $(logError)
-        [i|Windows missing for for #{t} #{v'} #{arch'}|]
-      addError
 
     -- alpine needs to be set explicitly, because
     -- we cannot assume that "Linux UnknownLinux" runs on Alpine
@@ -241,7 +238,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
       $ do
         case tool of
           Just GHCup -> do
-            let fn = "ghcup"
+            let fn = [rel|ghcup|]
             dir <- liftIO ghcupCacheDir
             p <- liftE $ download dli dir (Just fn)
             liftE $ checkDigest dli p
@@ -255,7 +252,7 @@ validateTarballs (TarballFilter tool versionRegex) dls = do
     case r of
       VRight (Just basePath) -> do
         case _dlSubdir dli of
-          Just (RealDir prel) -> do
+          Just (RealDir (toFilePath -> prel)) -> do
             lift $ $(logInfo)
               [i|verifying subdir: #{prel}|]
             when (basePath /= prel) $ do

app/ghcup/BrickMain.hs

@@ -14,7 +14,6 @@ import           GHCup.Download
 import           GHCup.Errors
 import           GHCup.Types
 import           GHCup.Utils
-import           GHCup.Utils.Prelude ( decUTF8Safe )
 import           GHCup.Utils.File
 import           GHCup.Utils.Logger
 
@@ -67,8 +66,7 @@ data BrickData = BrickData
   deriving Show
 
 data BrickSettings = BrickSettings
-  { showAllVersions :: Bool
+  { showAll :: Bool
-  , showAllTools    :: Bool
   }
   deriving Show
 
@@ -99,22 +97,17 @@ keyHandlers KeyBindings {..} =
   , (bUninstall, const "Uninstall", withIOAction del')
   , (bSet, const "Set"      , withIOAction set')
   , (bChangelog, const "ChangeLog", withIOAction changelog')
-  , ( bShowAllVersions
+  , ( bShowAll
     , \BrickSettings {..} ->
-       if showAllVersions then "Don't show all versions" else "Show all versions"
+       if showAll then "Hide old versions" else "Show all versions"
-    , hideShowHandler (not . showAllVersions) showAllTools
+    , hideShowHandler
-    )
-  , ( bShowAllTools
-    , \BrickSettings {..} ->
-       if showAllTools then "Don't show all tools" else "Show all tools"
-    , hideShowHandler showAllVersions (not . showAllTools)
     )
   , (bUp, const "Up", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Up, .. })
   , (bDown, const "Down", \BrickState {..} -> continue BrickState{ appState = moveCursor 1 appState Down, .. })
   ]
  where
-  hideShowHandler f p BrickState{..} =
+  hideShowHandler BrickState{..} =
-    let newAppSettings   = appSettings { showAllVersions = f appSettings , showAllTools = p appSettings }
+    let newAppSettings   = appSettings { showAll = not . showAll $ appSettings }
         newInternalState = constructList appData newAppSettings (Just appState)
     in  continue (BrickState appData newAppSettings newInternalState appKeys)
 
@@ -149,12 +142,7 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
       <+> minHSize 15 (str "Version")
       <+> padLeft (Pad 1) (minHSize 25 $ str "Tags")
       <+> padLeft (Pad 5) (str "Notes")
-  renderList' = withDefAttr listAttr . drawListElements renderItem True . filterStack
+  renderList' = withDefAttr listAttr . drawListElements renderItem True
-  filterStack appState'
-    | showAllTools as = appState'
-    | let v = clr appState'
-          nv = V.filter (\ListResult{..} -> lTool /= Stack) v
-    , otherwise = BrickInternalState { clr = nv, ix = ix appState' }
   renderItem _ b listResult@ListResult{..} =
     let marks = if
           | lSet       -> (withAttr "set" $ str "✔✔")
@@ -206,7 +194,6 @@ ui dimAttrs BrickState{ appSettings = as@BrickSettings{}, ..}
   printTool GHC = str "GHC"
   printTool GHCup = str "GHCup"
   printTool HLS = str "HLS"
-  printTool Stack = str "Stack"
 
   printNotes ListResult {..} =
     (if hlsPowered then [withAttr "hls-powered" $ str "hls-powered"] else mempty
@@ -364,7 +351,7 @@ constructList :: BrickData
               -> Maybe BrickInternalState
               -> BrickInternalState
 constructList appD appSettings =
-  replaceLR (filterVisible (showAllVersions appSettings)) (lr appD)
+  replaceLR (filterVisible (showAll appSettings)) (lr appD)
 
 listSelectedElement' :: BrickInternalState -> Maybe (Int, ListResult)
 listSelectedElement' BrickInternalState{..} = fmap (ix, ) $ clr !? ix
@@ -398,9 +385,9 @@ replaceLR filterF lr s =
 
 
 filterVisible :: Bool -> ListResult -> Bool
-filterVisible showAllVersions e | lInstalled e = True
+filterVisible showAll e | lInstalled e = True
-                                | showAllVersions = True
+                        | showAll      = True
-                                | otherwise    = not (elem Old (lTag e))
+                        | otherwise    = not (elem Old (lTag e))
 
 
 install' :: BrickState -> (Int, ListResult) -> IO (Either String ())
@@ -445,9 +432,6 @@ install' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
         HLS   -> do
           let vi = getVersionInfo lVer HLS dls
           liftE $ installHLSBin dls lVer pfreq $> vi
-        Stack -> do
-          let vi = getVersionInfo lVer Stack dls
-          liftE $ installStackBin dls lVer pfreq $> vi
     )
     >>= \case
           VRight vi                         -> do
@@ -476,7 +460,6 @@ set' _ (_, ListResult {..}) = do
         GHC   -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
         Cabal -> liftE $ setCabal lVer $> ()
         HLS   -> liftE $ setHLS lVer $> ()
-        Stack -> liftE $ setStack lVer $> ()
         GHCup -> pure ()
     )
     >>= \case
@@ -498,7 +481,6 @@ del' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
         GHC   -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> vi
         Cabal -> liftE $ rmCabalVer lVer $> vi
         HLS   -> liftE $ rmHLSVer lVer $> vi
-        Stack -> liftE $ rmStackVer lVer $> vi
         GHCup -> pure Nothing
     )
     >>= \case
@@ -519,8 +501,7 @@ changelog' BrickState { appData = BrickData {..} } (_, ListResult {..}) = do
             Darwin  -> "open"
             Linux _ -> "xdg-open"
             FreeBSD -> "xdg-open"
-            Windows -> "start"
+      exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
-      exec cmd [T.unpack $ decUTF8Safe $ serializeURIRef' uri] Nothing Nothing >>= \case
         Right _ -> pure $ Right ()
         Left  e -> pure $ Left $ prettyShow e
 
@@ -583,7 +564,7 @@ brickMain s l av pfreq' = do
 
 
 defaultAppSettings :: BrickSettings
-defaultAppSettings = BrickSettings { showAllVersions = False, showAllTools = False }
+defaultAppSettings = BrickSettings { showAll = False }
 
 
 getDownloads' :: IO (Either String GHCupDownloads)

app/ghcup/Main.hs

@@ -53,6 +53,8 @@ import           Data.Versions           hiding ( str )
 import           Data.Void
 import           GHC.IO.Encoding
 import           Haskus.Utils.Variant.Excepts
+import           HPath
+import           HPath.IO
 import           Language.Haskell.TH
 import           Options.Applicative     hiding ( style )
 import           Options.Applicative.Help.Pretty ( text )
@@ -62,7 +64,6 @@ import           System.Console.Pretty   hiding ( color )
 import qualified System.Console.Pretty         as Pretty
 import           System.Environment
 import           System.Exit
-import           System.FilePath
 import           System.IO               hiding ( appendFile )
 import           Text.Read               hiding ( lift )
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
@@ -125,7 +126,6 @@ toSetToolVer Nothing = SetRecommended
 data InstallCommand = InstallGHC InstallOptions
                     | InstallCabal InstallOptions
                     | InstallHLS InstallOptions
-                    | InstallStack InstallOptions
 
 data InstallOptions = InstallOptions
   { instVer      :: Maybe ToolVersion
@@ -137,7 +137,6 @@ data InstallOptions = InstallOptions
 data SetCommand = SetGHC SetOptions
                 | SetCabal SetOptions
                 | SetHLS SetOptions
-                | SetStack SetOptions
 
 -- a superset of ToolVersion
 data SetToolVersion = SetToolVersion GHCTargetVersion
@@ -158,7 +157,6 @@ data ListOptions = ListOptions
 data RmCommand = RmGHC RmOptions
                | RmCabal Version
                | RmHLS Version
-               | RmStack Version
 
 data RmOptions = RmOptions
   { ghcVer :: GHCTargetVersion
@@ -169,17 +167,17 @@ data CompileCommand = CompileGHC GHCCompileOptions
 
 data GHCCompileOptions = GHCCompileOptions
   { targetGhc    :: Either Version GitBranch
-  , bootstrapGhc :: Either Version FilePath
+  , bootstrapGhc :: Either Version (Path Abs)
   , jobs         :: Maybe Int
-  , buildConfig  :: Maybe FilePath
+  , buildConfig  :: Maybe (Path Abs)
-  , patchDir     :: Maybe FilePath
+  , patchDir     :: Maybe (Path Abs)
   , crossTarget  :: Maybe Text
   , addConfArgs  :: [Text]
   , setCompile   :: Bool
   }
 
 data UpgradeOpts = UpgradeInplace
-                 | UpgradeAt FilePath
+                 | UpgradeAt (Path Abs)
                  | UpgradeGHCupDir
                  deriving Show
 
@@ -434,15 +432,6 @@ installParser =
                  <> footerDoc (Just $ text installHLSFooter)
                  )
            )
-      <> command
-           "stack"
-           (   InstallStack
-           <$> info
-                 (installOpts (Just Stack) <**> helper)
-                 (  progDesc "Install stack"
-                 <> footerDoc (Just $ text installStackFooter)
-                 )
-           )
       )
     )
     <|> (Right <$> installOpts Nothing)
@@ -453,17 +442,9 @@ installParser =
   into "~/.ghcup/bin"
 
 Examples:
-  # install recommended HLS
+  # install recommended GHC
   ghcup install hls|]
 
-  installStackFooter :: String
-  installStackFooter = [s|Discussion:
-  Installs stack binaries into "~/.ghcup/bin"
-
-Examples:
-  # install recommended Stack
-  ghcup install stack|]
-
   installGHCFooter :: String
   installGHCFooter = [s|Discussion:
   Installs the specified GHC version (or a recommended default one) into
@@ -547,15 +528,6 @@ setParser =
                  <> footerDoc (Just $ text setHLSFooter)
                  )
            )
-      <> command
-           "stack"
-           (   SetStack
-           <$> info
-                 (setOpts (Just Stack) <**> helper)
-                 (  progDesc "Set stack version"
-                 <> footerDoc (Just $ text setStackFooter)
-                 )
-           )
       )
     )
     <|> (Right <$> setOpts Nothing)
@@ -570,10 +542,6 @@ setParser =
   setCabalFooter = [s|Discussion:
     Sets the the current Cabal version.|]
 
-  setStackFooter :: String
-  setStackFooter = [s|Discussion:
-    Sets the the current Stack version.|]
-
   setHLSFooter :: String
   setHLSFooter = [s|Discussion:
     Sets the the current haskell-language-server version.|]
@@ -626,12 +594,6 @@ rmParser =
            <$> info (versionParser' (Just ListInstalled) (Just HLS) <**> helper)
                     (progDesc "Remove haskell-language-server version")
            )
-      <> command
-           "stack"
-           (   RmStack
-           <$> info (versionParser' (Just ListInstalled) (Just Stack) <**> helper)
-                    (progDesc "Remove stack version")
-           )
       )
     )
     <|> (Right <$> rmOpts Nothing)
@@ -653,7 +615,6 @@ changelogP =
                 "ghc"   -> Right GHC
                 "cabal" -> Right Cabal
                 "ghcup" -> Right GHCup
-                "stack" -> Right Stack
                 e       -> Left e
               )
             )
@@ -720,7 +681,8 @@ ghcCompileOpts =
     <*> option
           (eitherReader
             (\x ->
-              (bimap (const "Not a valid version") Left . version . T.pack $ x) <|> (if isPathSeparator (head x) then pure $ Right x else Left "Not an absolute Path")
+              (bimap (const "Not a valid version") Left . version . T.pack $ x)
+                <|> (bimap show Right . parseAbs . E.encodeUtf8 . T.pack $ x)
             )
           )
           (  short 'b'
@@ -738,14 +700,26 @@ ghcCompileOpts =
           )
     <*> optional
           (option
-            str
+            (eitherReader
+              (\x ->
+                first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
+                    String
+                    (Path Abs)
+              )
+            )
             (short 'c' <> long "config" <> metavar "CONFIG" <> help
               "Absolute path to build config file"
             )
           )
     <*> optional
           (option
-            str
+            (eitherReader
+              (\x ->
+                first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
+                    String
+                    (Path Abs)
+              )
+            )
             (short 'p' <> long "patchdir" <> metavar "PATCH_DIR" <> help
               "Absolute path to patch directory (applied in order, uses -p1)"
             )
@@ -1012,8 +986,7 @@ toSettings options = do
          , bUninstall = fromMaybe bUninstall kUninstall
          , bSet = fromMaybe bSet kSet
          , bChangelog = fromMaybe bChangelog kChangelog
-         , bShowAllVersions = fromMaybe bShowAllVersions kShowAll
+         , bShowAll = fromMaybe bShowAll kShowAll
-         , bShowAllTools = fromMaybe bShowAllTools kShowAllTools
          }
 
 
@@ -1026,7 +999,13 @@ upgradeOptsP =
       )
     <|> (   UpgradeAt
         <$> option
-              str
+              (eitherReader
+                (\x ->
+                  first show . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
+                      String
+                      (Path Abs)
+                )
+              )
               (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
                 "Absolute filepath to write ghcup into"
               )
@@ -1038,9 +1017,9 @@ upgradeOptsP =
 describe_result :: String
 describe_result = $( LitE . StringL <$>
                      runIO (do
-                             CapturedProcess{..} <- executeOut "git" ["describe"] Nothing
+                             CapturedProcess{..} <- executeOut [rel|git|] ["describe"] Nothing
                              case _exitCode of
-                               ExitSuccess   -> pure . T.unpack . decUTF8Safe' $ _stdOut
+                               ExitSuccess   -> pure . T.unpack . decUTF8Safe $ _stdOut
                                ExitFailure _ -> pure numericVer
                      )
                    )
@@ -1094,7 +1073,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let loggerConfig = LoggerConfig
                 { lcPrintDebug = verbose settings
                 , colorOutter  = B.hPut stderr
-                , rawOutter    = B.appendFile logfile
+                , rawOutter    = appendFile logfile
                 }
           let runLogger = myLoggerT loggerConfig
 
@@ -1346,36 +1325,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                             $(logError) [i|Also check the logs in #{logsDir}|]
                           pure $ ExitFailure 4
 
-          let installStack InstallOptions{..} =
-                (case instBindist of
-                   Nothing -> runInstTool $ do
-                     (v, vi) <- liftE $ fromVersion dls instVer Stack
-                     liftE $ installStackBin dls (_tvVersion v) (fromMaybe pfreq instPlatform)
-                     pure vi
-                   Just uri -> runInstTool' appstate{ settings = settings { noVerify = True}} $ do
-                     (v, vi) <- liftE $ fromVersion dls instVer Stack
-                     liftE $ installStackBindist
-                         (DownloadInfo uri Nothing "")
-                         (_tvVersion v)
-                         (fromMaybe pfreq instPlatform)
-                     pure vi
-                  )
-                  >>= \case
-                        VRight vi -> do
-                          runLogger $ $(logInfo) "Stack installation successful"
-                          forM_ (_viPostInstall =<< vi) $ \msg ->
-                            runLogger $ $(logInfo) msg
-                          pure ExitSuccess
-                        VLeft (V (AlreadyInstalled _ v)) -> do
-                          runLogger $ $(logWarn)
-                            [i|Stack ver #{prettyVer v} already installed; if you really want to reinstall it, you may want to run 'ghcup rm stack #{prettyVer v}' first|]
-                          pure ExitSuccess
-                        VLeft e -> do
-                          runLogger $ do
-                            $(logError) $ T.pack $ prettyShow e
-                            $(logError) [i|Also check the logs in #{logsDir}|]
-                          pure $ ExitFailure 4
-
 
           let setGHC' SetOptions{..} =
                 runSetGHC (do
@@ -1424,22 +1373,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 14
 
-          let setStack' SetOptions{..} =
-                runSetCabal (do
-                    v <- liftE $ fst <$> fromVersion' dls sToolVer Stack
-                    liftE $ setStack (_tvVersion v)
-                    pure v
-                  )
-                  >>= \case
-                        VRight GHCTargetVersion{..} -> do
-                          runLogger
-                            $ $(logInfo)
-                                [i|Stack #{prettyVer _tvVersion} successfully set as default version|]
-                          pure ExitSuccess
-                        VLeft  e -> do
-                          runLogger $ $(logError) $ T.pack $ prettyShow e
-                          pure $ ExitFailure 14
-
           let rmGHC' RmOptions{..} =
                 runRm (do
                     liftE $
@@ -1485,20 +1418,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                           runLogger $ $(logError) $ T.pack $ prettyShow e
                           pure $ ExitFailure 15
 
-          let rmStack' tv =
-                runRm (do
-                    liftE $
-                      rmStackVer tv
-                    pure (getVersionInfo tv Stack dls)
-                  )
-                  >>= \case
-                        VRight vi -> do
-                          forM_ (_viPostRemove =<< vi) $ \msg ->
-                            runLogger $ $(logInfo) msg
-                          pure ExitSuccess
-                        VLeft  e -> do
-                          runLogger $ $(logError) $ T.pack $ prettyShow e
-                          pure $ ExitFailure 15
 
           res <- case optCommand of
 #if defined(BRICK)
@@ -1510,7 +1429,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             Install (Left (InstallGHC iopts)) -> installGHC iopts
             Install (Left (InstallCabal iopts)) -> installCabal iopts
             Install (Left (InstallHLS iopts)) -> installHLS iopts
-            Install (Left (InstallStack iopts)) -> installStack iopts
             InstallCabalLegacy iopts -> do
               runLogger ($(logWarn) [i|This is an old-style command for installing cabal. Use 'ghcup install cabal' instead.|])
               installCabal iopts
@@ -1521,7 +1439,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             Set (Left (SetGHC sopts)) -> setGHC' sopts
             Set (Left (SetCabal sopts)) -> setCabal' sopts
             Set (Left (SetHLS sopts)) -> setHLS' sopts
-            Set (Left (SetStack sopts)) -> setStack' sopts
 
             List ListOptions {..} ->
               runListGHC (do
@@ -1536,7 +1453,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
             Rm (Left (RmGHC rmopts)) -> rmGHC' rmopts
             Rm (Left (RmCabal rmopts)) -> rmCabal' rmopts
             Rm (Left (RmHLS rmopts)) -> rmHLS' rmopts
-            Rm (Left (RmStack rmopts)) -> rmStack' rmopts
 
             DInfo ->
               do runDebugInfo $ liftE getDebugInfo
@@ -1596,9 +1512,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
             Upgrade uOpts force -> do
               target <- case uOpts of
-                UpgradeInplace  -> Just <$> liftIO getExecutablePath
+                UpgradeInplace -> do
+                  efp <- liftIO getExecutablePath
+                  p   <- parseAbs . E.encodeUtf8 . T.pack $ efp
+                  pure $ Just p
                 (UpgradeAt p)   -> pure $ Just p
-                UpgradeGHCupDir -> pure (Just (binDir </> "ghcup"))
+                UpgradeGHCupDir -> pure (Just (binDir </> [rel|ghcup|]))
 
               runUpgrade (liftE $ upgradeGHCup dls target force pfreq) >>= \case
                 VRight v' -> do
@@ -1654,12 +1573,12 @@ Make sure to clean up #{tmpdir} afterwards.|])
                               Darwin  -> "open"
                               Linux _ -> "xdg-open"
                               FreeBSD -> "xdg-open"
-                              Windows -> "start"
 
                   if clOpen
                     then
                       exec cmd
-                           [T.unpack $ decUTF8Safe $ serializeURIRef' uri]
+                           True
+                           [serializeURIRef' uri]
                            Nothing
                            Nothing
                         >>= \case
@@ -1735,16 +1654,6 @@ fromVersion' av SetNext tool = do
         . cycle
         . sort
         $ hlses) ?? NoToolVersionSet tool
-    Stack -> do
-      set <- stackSet !? NoToolVersionSet tool
-      stacks <- rights <$> lift getInstalledStacks
-      (fmap (GHCTargetVersion Nothing)
-        . headMay
-        . tail
-        . dropWhile (/= set)
-        . cycle
-        . sort
-        $ stacks) ?? NoToolVersionSet tool
     GHCup -> fail "GHCup cannot be set"
   let vi = getVersionInfo (_tvVersion next) tool av
   pure (next, vi)
@@ -1943,21 +1852,14 @@ checkForUpdates dls pfreq = do
         $ $(logWarn)
             [i|New HLS version available: #{prettyVer l}. To upgrade, run 'ghcup install hls #{prettyVer l}'|]
 
-  forM_ (getLatest dls Stack) $ \(l, _) -> do
-    let mstack_ver = latestInstalled Stack
-    forM mstack_ver $ \stack_ver ->
-      when (l > stack_ver)
-        $ $(logWarn)
-            [i|New Stack version available: #{prettyVer l}. To upgrade, run 'ghcup install stack #{prettyVer l}'|]
-
 
 prettyDebugInfo :: DebugInfo -> String
 prettyDebugInfo DebugInfo {..} = [i|Debug Info
 ==========
-GHCup base dir: #{diBaseDir}
+GHCup base dir: #{toFilePath diBaseDir}
-GHCup bin dir: #{diBinDir}
+GHCup bin dir: #{toFilePath diBinDir}
-GHCup GHC directory: #{diGHCDir}
+GHCup GHC directory: #{toFilePath diGHCDir}
-GHCup cache directory: #{diCacheDir}
+GHCup cache directory: #{toFilePath diCacheDir}
 Architecture: #{prettyShow diArch}
 Platform: #{prettyShow diPlatform}
 Version: #{describe_result}|]

cabal.project

@@ -10,11 +10,6 @@ package ghcup
     tests: True
     flags: +tui
 
-source-repository-package
-    type: git
-    location: https://github.com/Bodigrim/tar
-    tag: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
-
 constraints: http-io-streams -brotli
 
 package libarchive

config.yaml

@@ -29,8 +29,6 @@ key-bindings:
     KChar: 'c'
   show-all:
     KChar: 'a'
-  show-all-tools:
-    KChar: 't'
 
 # Where to get GHC/cabal/hls download info/versions from. For more detailed explanation
 # check the 'URLSource' type in the code.

ghcup-0.0.4.yaml

@@ -170,11 +170,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-portbld-freebsd.tar.bz2
               dlSubdir: ghc-7.10.3
               dlHash: 2aa396edd2bb651f4bc7eef7a396913ea24923de5aafdc76df6295333e487e48
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/7.10.3/ghc-7.10.3-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-7.10.3
-              dlHash: 63e1689fc9e2809ae4d7f422b4dc810052e54c9aa2afd08746e234180e711dde
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-7103-32-deb8
@@ -241,11 +236,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.0.2
               dlHash: b36a20e5cae24d70bbb6116ae486f21811e9384f15d3892d260f02fba3e3bb8c
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.0.2
-              dlHash: 8c42c1f4af995205b9816a1e97e2752fe758544c1f5fe77958cdcd319c9c2d53
         A_32:
           Linux_Debian:
             '( >= 7 && < 8 )':
@@ -310,11 +300,6 @@ ghcupDownloads:
               dlSubdir: ghc-8.2.2
               dlHash: cd351c704b92b9af23994024df07de8ca7090ea7675d5c8b14b2be857a46d804
             unknown_versioning: *ghc-822-64-fbsd11
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.2.2/ghc-8.2.2-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.2.2
-              dlHash: 1e033df2092aa546e763e7be63167720b32df64f76673ea1ce7ae7c9f564b223
         A_32:
           Linux_Debian:
             '( >= 7 && < 8 )':
@@ -374,11 +359,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-portbld11-freebsd.tar.xz
               dlSubdir: ghc-8.4.1
               dlHash: e748daec098445c6190090fe32bb2817a1140553be5acd2188e1af05ad24e5aa
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.4.1/ghc-8.4.1-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.4.1
-              dlHash: 328b013fc651d34e075019107e58bb6c8a578f0155cf3ad4557e6f2661b03131
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-841-32-deb8
@@ -434,11 +414,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.4.2
               dlHash: e9ed417fdf94c2ff2c6e344ed16f332bf6b591511f6442c0d9ea94854882b66c
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.4.2/ghc-8.4.2-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.4.2
-              dlHash: 797634aa9812fc6b2084a24ddb4fde44fa83a2f59daea82e0af81ca3dd323fde
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-842-32-deb8
@@ -489,11 +464,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-apple-darwin.tar.xz
               dlSubdir: ghc-8.4.3
               dlHash: af0b455f6c46b9802b4b48dad996619cfa27cc6e2bf2ce5532387b4a8c00aa64
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.4.3/ghc-8.4.3-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.4.3
-              dlHash: 8a83cfbf9ae84de0443c39c93b931693bdf2a6d4bf163ffb41855f80f4bf883e
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-843-32-deb8
@@ -562,11 +532,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-portbld-freebsd11.tar.xz
               dlSubdir: ghc-8.4.4
               dlHash: 44fbd142d1c355d6110595c59c760e2c73866ff9259ec85ebf814edb244d1940
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.4.4
-              dlHash: da29dbb0f1199611c7d5bb7b0dd6a7426ca98f67dfd6da1526b033cd3830dc05
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-844-32-deb8
@@ -627,11 +592,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.6.1
               dlHash: 51403b054a3a649039ac988e1d1112561f96750bfced63df864091a3fab36f08
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.6.1/ghc-8.6.1-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.6.1
-              dlHash: 7316d9cb5e486460476754f872c7bac30ee2082e42f46da4342f872d10b88099
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-861-32-deb8
@@ -678,11 +638,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-apple-darwin.tar.xz
               dlSubdir: ghc-8.6.2
               dlHash: 8ec46a25872226dd7e5cf7271e3f3450c05f32144b96e6b9cb44cc4079db50dc
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.6.2/ghc-8.6.2-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.6.2
-              dlHash: 9a398e133cab09ff2610834337355d4e26c35e0665403fb9ff8db79315f74d3d
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-862-32-deb8
@@ -747,11 +702,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.6.3
               dlHash: bc2419fa180f8a7808c49775987866435995df9bdd9ce08bcd38352d63ba6031
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.6.3/ghc-8.6.3-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.6.3
-              dlHash: 2fec383904e5fa79413e9afd328faf9bc700006c8c3d4bcdd8d4f2ccf0f7fa2a
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-863-32-deb8
@@ -802,11 +752,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-apple-darwin.tar.xz
               dlSubdir: ghc-8.6.4
               dlHash: cccb58f142fe41b601d73690809f6089f7715b6a50a09aa3d0104176ab4db09e
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.6.4/ghc-8.6.4-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.6.4
-              dlHash: e8d021b7a90772fc559862079da20538498d991956d7557b468ca19ddda22a08
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-864-32-deb9
@@ -875,11 +820,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.6.5/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.6.5
               dlHash: 83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.6.5
-              dlHash: 457024c6ea43bdce340af428d86319931f267089398b859b00efdfe2fd4ce93f
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-865-32-deb9
@@ -950,11 +890,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-x86_64-apple-darwin.tar.xz
               dlSubdir: ghc-8.8.1
               dlHash: 38c8917b47c31bedf58c9305dfca3abe198d8d35570366f0773c4e2948bd8abe
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.8.1/ghc-8.8.1-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.8.1
-              dlHash: 29e56e6af38017a5a76b2b6995a39d3988fa58131e4b55b62dd317ba7186ac9b
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-881-32-deb9
@@ -1014,11 +949,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-x86_64-apple-darwin.tar.xz
               dlSubdir: ghc-8.8.2
               dlHash: 25c5c1a70036abf3f22b2b19c10d26adfdb08e8f8574f89d4b2042de5947f990
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.8.2/ghc-8.8.2-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.8.2
-              dlHash: e25d9b16ee62cafc7387af2cd021eea676a99cd2c32b83533b016162c63065d9
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-882-32-deb9
@@ -1083,11 +1013,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.8.3/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.8.3
               dlHash: 569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.8.3/ghc-8.8.3-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.8.3
-              dlHash: e22586762af0911c06e8140f1792e3ca381a3a482a20d67b9054883038b3a422
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-883-32-deb9
@@ -1162,11 +1087,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.8.4/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.8.4
               dlHash: 8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.8.4
-              dlHash: d185055d2c8dc3bfe5b88afd59d6877eb1e722b672d1c9649f18296e148ed71f
         A_32:
           Linux_Debian:
             unknown_versioning: &ghc-884-32-deb9
@@ -1244,11 +1164,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.10.1
               dlHash: e8646ec9b60fd40aa9505ee055f22f04601290ab7a1342c2cf37c34de9d3f142
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.10.1
-              dlHash: 38a3166ea50cccd5bae7e1680eae3aae2b4ae31b61f82a1d8168fb821f43bd67
         A_32:
           Linux_Debian:
             '( >= 9 && < 10 )': &ghc-8101-32-deb9
@@ -1339,11 +1254,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-unknown-freebsd.tar.xz
               dlSubdir: ghc-8.10.2
               dlHash: 9e5957f3497f4b58ecd3699568d9caaa11a47a6d7e902032c261e450fa0f6686
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.10.2/ghc-8.10.2-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.10.2
-              dlHash: dcae4c173b9896e07ff048de5509aa0a4537233150e06e5ce8848303dfadc176
         A_32:
           Linux_Debian:
             '( >= 9 && < 10 )': &ghc-8102-32-deb9
@@ -1433,11 +1343,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.10.3/ghc-8.10.3-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.10.3
               dlHash: 749007e995104db05cf6e3ad5bc36238cab8afac8055145661e5730e8f8af040
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.10.3/ghc-8.10.3-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.10.3
-              dlHash: 927a6c699533a115cd49772ef2c753d9af2c13bf9f0b2d3bd13645cc6a144ee3
         A_32:
           Linux_Debian:
             '( >= 9 && < 10 )': &ghc-8103-32-deb9
@@ -1529,11 +1434,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-8.10.4
               dlHash: c9776a2ccf9629b03e967206a507fcdcb6c5189800a626e9461ababf6733c357
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/8.10.4/ghc-8.10.4-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-8.10.4
-              dlHash: e9175a276504c3390a5e0084954e6997d56078737dbe7158049518892cf6bfb2
         A_32:
           Linux_Debian:
             '( >= 9 && < 10 )': &ghc-8104-32-deb9
@@ -1624,11 +1524,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/9.0.1/ghc-9.0.1-x86_64-portbld-freebsd.tar.xz
               dlSubdir: ghc-9.0.1
               dlHash: 9dbc06d8832cae5c9f86dd7b2db729b3748a47beb4fd4b1e62bb66119817c3c1
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/9.0.1/ghc-9.0.1-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-9.0.1-x86_64-unknown-mingw32
-              dlHash: 4f4ab118df01cbc7e7c510096deca0cb25025339a97730de0466416296202493
         A_32:
           Linux_Debian:
             '( >= 9 && < 10 )': &ghc-901-32-deb9
@@ -1719,11 +1614,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~ghc/9.2.1-alpha2/ghc-9.2.0.20210422-x86_64-apple-darwin.tar.xz
               dlSubdir: ghc-9.2.0.20210422
               dlHash: 8884c059f2b76e4c4309ff6bd7a7dde37663f751fd26220e9a2bcabb4d69a401
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~ghc/9.2.1-alpha2/ghc-9.2.0.20210422-x86_64-unknown-mingw32.tar.xz
-              dlSubdir: ghc-9.0.1-x86_64-unknown-mingw32
-              dlHash: 33f173b754d18f26bb27f52bb77a92fd22a48675daa2b43a1879bf01dddd7e8f
         A_32:
           Linux_Debian:
             '( >= 9 && < 10 )': &ghc-921-alpha2-32-deb9
@@ -1776,11 +1666,6 @@ ghcupDownloads:
               dlUri: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-portbld-freebsd.tar.xz
               dlSubdir:
               dlHash: 33b7d37ea0688c93436eac9ec139d9967687875aa1fa13f2bb73bf05a9a59a1d
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~cabal/cabal-install-2.4.1.0/cabal-install-2.4.1.0-x86_64-unknown-mingw32.zip
-              dlSubdir:
-              dlHash: 95f233efedb1ebf0e6db015fa2f55c1ed00b9938d207ec63c066f706fb4b6373
         A_32:
           Linux_UnknownLinux:
             unknown_versioning:
@@ -1809,11 +1694,6 @@ ghcupDownloads:
             unknown_versioning:
               dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-portbld-freebsd.tar.xz
               dlHash: 2240842ab2ae7b955feb8b526aba1c7991248c803383107adf39990441294d2a
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-mingw32.zip
-              dlSubdir:
-              dlHash: 8889963ebef5e829d86329fdb59832c107efd117cf7862a605f2fe2d2360de1f
         A_32:
           Linux_Alpine:
             unknown_versioning:
@@ -1845,11 +1725,6 @@ ghcupDownloads:
             unknown_versioning:
               dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz
               dlHash: f1e35151cca91541b0fb4bdb3ed18f3c348038eab751845ad19c11307d66c273
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.2.0.0/cabal-install-3.2.0.0-x86_64-unknown-mingw32.zip
-              dlSubdir:
-              dlHash: 17778c3ade0482bc37f451eec326f8fce8fbe1f12b1d6aacb2e2b9e34786c054
         A_32:
           Linux_Alpine:
             unknown_versioning:
@@ -1884,11 +1759,6 @@ ghcupDownloads:
             unknown_versioning:
               dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-x86_64-freebsd-12.1-release.tar.xz
               dlHash: a1e2db664ec00e42a1e071a4181f6476f6e0bad321f1ddc0cf27831119f4c6d4
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/~cabal/cabal-install-3.4.0.0/cabal-install-3.4.0.0-x86_64-windows.zip
-              dlSubdir:
-              dlHash: 860fff2d39a82d1dc0ca924a77164d0988af49c2c5f45e15d615144122beb647
         A_32:
           Linux_UnknownLinux:
             unknown_versioning: &cabal-3400-32
@@ -1927,10 +1797,6 @@ ghcupDownloads:
             unknown_versioning:
               dlUri: https://downloads.haskell.org/~ghcup/0.1.14.1/x86_64-portbld-freebsd-ghcup-0.1.14.1
               dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
-          Windows:
-            unknown_versioning:
-              dlUri: https://TODO
-              dlHash: 89a70980d77888dae8b9fd0f05e7a7920f421bc3bb5192da8e73fd4e7b4cb86f
           Linux_Alpine:
             unknown_versioning: *ghcup-64
         A_32:
@@ -1967,63 +1833,5 @@ ghcupDownloads:
             unknown_versioning:
               dlUri: https://github.com/haskell/haskell-language-server/releases/download/1.1.0/haskell-language-server-macOS-1.1.0.tar.gz
               dlHash: 4e89b192e2f49637d772e974f2c17b16da067ecd5912575eaa542551de97681b
-          Windows:
-            unknown_versioning:
-              dlUri: https://downloads.haskell.org/ghcup/unofficial-bindists/hls/1.1.0/haskell-language-server-Windows-1.1.0.tar.gz
-              dlHash: a1d3f451e64a041aa527a25da29e4716a2de6ae347cef4ef9312fc7611e168cc
           Linux_Alpine:
             unknown_versioning: *hls-64
-  Stack:
-    2.5.1:
-      viTags: []
-      viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v251
-      viArch:
-        A_64:
-          Linux_UnknownLinux:
-            unknown_versioning: &stack-251-64
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-linux-x86_64.tar.gz
-              dlHash: c83b6c93d6541c0bce2175085a04062020f4160a86116e20f3b343b562f2d1e8
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Darwin:
-            unknown_versioning:
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-osx-x86_64.tar.gz
-              dlHash: f4aedfa8fbe371f77286ee97ec5c3c553842e7ae15b2952a8b8442dccba04bf0
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Windows:
-            unknown_versioning:
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.5.1/stack-2.5.1-windows-x86_64.tar.gz
-              dlHash: 57150b422cfd42249f5e629d0eb678df6d95dabe486ced57e8298d300b940d41
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Linux_Alpine:
-            unknown_versioning: *stack-251-64
-    2.7.1:
-      viTags:
-        - Recommended
-        - Latest
-      viChangeLog: https://github.com/commercialhaskell/stack/blob/master/ChangeLog.md#v271
-      viArch:
-        A_64:
-          Linux_UnknownLinux:
-            unknown_versioning: &stack-64
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-linux-x86_64.tar.gz
-              dlHash: 2bc47749ee4be5eccb52a2d4a6a00b0f3b28b92517742b40c675836d7db2777d
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Darwin:
-            unknown_versioning:
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-osx-x86_64.tar.gz
-              dlHash: 4248c6fbc87e8a2c06f39e867eb5ef28eae0d99470137cb415356c631c0dcbf2
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Windows:
-            unknown_versioning:
-              dlUri: https://github.com/commercialhaskell/stack/releases/download/v2.7.1/stack-2.7.1-windows-x86_64.tar.gz
-              dlHash: 8452f5fc9235620a84863f2f68e5f681c72d0d181cde50482f178a966ee0ceb9
-              dlSubdir:
-                RegexDir: "stack-.*"
-          Linux_Alpine:
-            unknown_versioning: *stack-64
-

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:   3.0
 name:            ghcup
-version:         0.1.14.2
+version:         0.1.14.1
 license:         LGPL-3.0-only
 license-file:    LICENSE
 copyright:       Julian Ospald 2020
@@ -28,23 +28,19 @@ source-repository head
   location: https://gitlab.haskell.org/haskell/ghcup-hs.git
 
 flag tui
-  description:
+  description: Build the brick powered tui (ghcup tui)
-    Build the brick powered tui (ghcup tui). This is disabled on windows.
-
   default:     False
   manual:      True
 
 flag internal-downloader
   description:
-    Compile the internal downloader, which links against OpenSSL. This is disabled on windows.
+    Compile the internal downloader, which links against OpenSSL
 
   default:     False
   manual:      True
 
 flag tar
-  description:
+  description: Use tar-bytestring instead of libarchive
-    Use tar-bytestring instead of libarchive. This is always enabled on windows.
-
   default:     False
   manual:      True
 
@@ -62,7 +58,6 @@ library
     GHCup.Utils
     GHCup.Utils.Dirs
     GHCup.Utils.File
-    GHCup.Utils.File.Common
     GHCup.Utils.Logger
     GHCup.Utils.MegaParsec
     GHCup.Utils.Prelude
@@ -90,24 +85,27 @@ library
 
   build-depends:
     , aeson                 >=1.4        && <1.6
+    , ascii-string          ^>=1.0
     , async                 >=0.8        && <2.3
     , base                  >=4.13       && <5
     , base16-bytestring     >=0.1.1.6    && <1.1
     , binary                ^>=0.8.6.0
     , bytestring            ^>=0.10
+    , bz2                   >=0.5.0.5    && <1.1
     , case-insensitive      ^>=1.2.1.0
     , casing                ^>=0.1.4.1
     , concurrent-output     ^>=1.10.11
     , containers            ^>=0.6
     , cryptohash-sha256     ^>=0.11.101.0
-    , deepseq               ^>=1.4.4.0
-    , directory             ^>=1.3.6.0
     , disk-free-space       ^>=0.1.0.1
-    , extra                 ^>=1.7.9
-    , filepath              ^>=1.4.2.1
     , generics-sop          ^>=0.5
     , haskus-utils-types    ^>=1.5
     , haskus-utils-variant  >=3.0        && <3.2
+    , hpath                 >=0.11       && <0.13
+    , hpath-directory       ^>=0.14.1
+    , hpath-filepath        ^>=0.10.3
+    , hpath-io              ^>=0.14.1
+    , hpath-posix           ^>=0.13.2
     , lzma-static           ^>=5.2.5.2
     , megaparsec            >=8.0.0      && <9.1
     , monad-logger          ^>=0.3.31
@@ -118,7 +116,6 @@ library
     , parsec                ^>=3.1
     , pretty                ^>=1.1.3.1
     , pretty-terminal       ^>=0.1.0.0
-    , process               ^>=1.6.9.0
     , regex-posix           ^>=0.96
     , resourcet             ^>=1.2.2
     , safe                  ^>=0.3.18
@@ -126,25 +123,27 @@ library
     , split                 ^>=0.2.3.4
     , streamly              ^>=0.7.3
     , streamly-bytestring   ^>=0.1.2
+    , streamly-posix        ^>=0.1.0.0
     , strict-base           ^>=0.4
     , string-interpolate    >=0.2.0.0    && <0.4
     , template-haskell      >=2.7        && <2.17
-    , temporary             ^>=1.3
     , text                  ^>=1.2.4.0
     , time                  ^>=1.9.3
     , transformers          ^>=0.5
+    , unix                  ^>=2.7
+    , unix-bytestring       ^>=0.3
     , unliftio-core         ^>=0.2.0.1
     , unordered-containers  ^>=0.2.10.0
     , uri-bytestring        ^>=0.3.2.2
     , utf8-string           ^>=1.0
     , vector                ^>=0.12
     , versions              ^>=4.0.1
+    , vty                   >=5.28.2     && <5.34
     , word8                 ^>=0.1.3
     , yaml                  ^>=0.11.4.0
-    , zip                   ^>=1.7.0
     , zlib                  ^>=0.6.2.2
 
-  if (flag(internal-downloader) && !os(windows))
+  if flag(internal-downloader)
     exposed-modules: GHCup.Download.IOStreams
     cpp-options:     -DINTERNAL_DOWNLOADER
     build-depends:
@@ -153,31 +152,13 @@ library
       , io-streams             >=1.5
       , terminal-progress-bar  >=0.4.1
 
-  if (flag(tar) || os(windows))
+  if flag(tar)
     cpp-options:   -DTAR
-    build-depends: tar
+    build-depends: tar-bytestring ^>=0.6.3.1
 
   else
     build-depends: libarchive ^>=3.0.0.0
 
-  if os(windows)
-    cpp-options:   -DIS_WINDOWS
-    other-modules: GHCup.Utils.File.Windows
-    build-depends: bzlib
-
-  else
-    other-modules: GHCup.Utils.File.Posix
-    build-depends:
-        bz2              >=0.5.0.5 && <1.1
-      , hpath-posix      ^>=0.13.3
-      , streamly-posix   ^>=0.1.0.0
-      , unix             ^>=2.7
-      , unix-bytestring  ^>=0.3.7.3
-
-  if (flag(tui) && !os(windows))
-    cpp-options:   -DBRICK
-    build-depends: vty >=5.28.2 && <5.34
-
 executable ghcup
   main-is:            Main.hs
   hs-source-dirs:     app/ghcup
@@ -201,9 +182,10 @@ executable ghcup
     , base                  >=4.13     && <5
     , bytestring            ^>=0.10
     , containers            ^>=0.6
-    , filepath              ^>=1.4.2.1
     , ghcup
     , haskus-utils-variant  >=3.0      && <3.2
+    , hpath                 >=0.11     && <0.13
+    , hpath-io              ^>=0.14.1
     , megaparsec            >=8.0.0    && <9.1
     , monad-logger          ^>=0.3.31
     , mtl                   ^>=2.2
@@ -223,7 +205,7 @@ executable ghcup
   if flag(internal-downloader)
     cpp-options: -DINTERNAL_DOWNLOADER
 
-  if (flag(tui) && !os(windows))
+  if flag(tui)
     cpp-options:   -DBRICK
     other-modules: BrickMain
     build-depends:
@@ -231,7 +213,7 @@ executable ghcup
       , vector  ^>=0.12
       , vty     >=5.28.2 && <5.34
 
-  if (flag(tar) || os(windows))
+  if flag(tar)
     cpp-options: -DTAR
 
   else
@@ -260,9 +242,10 @@ executable ghcup-gen
     , base                  >=4.13     && <5
     , bytestring            ^>=0.10
     , containers            ^>=0.6
-    , filepath              ^>=1.4.2.1
     , ghcup
     , haskus-utils-variant  >=3.0      && <3.2
+    , hpath                 >=0.11     && <0.13
+    , hpath-filepath        ^>=0.10.3
     , monad-logger          ^>=0.3.31
     , mtl                   ^>=2.2
     , optics                >=0.2      && <0.5
@@ -280,9 +263,9 @@ executable ghcup-gen
     , versions              ^>=4.0.1
     , yaml                  ^>=0.11.4.0
 
-  if (flag(tar) || os(windows))
+  if flag(tar)
     cpp-options:   -DTAR
-    build-depends: tar
+    build-depends: tar-bytestring ^>=0.6.3.1
 
   else
     build-depends: libarchive ^>=3.0.0.0
@@ -315,8 +298,9 @@ test-suite ghcup-test
     , containers                ^>=0.6
     , generic-arbitrary         ^>=0.1.0
     , ghcup
-    , hspec                     ^>=2.7.10
+    , hpath                     >=0.11    && <0.13
-    , hspec-golden-aeson        >=0.9 && <0.10
+    , hspec                     ^>=2.7.4
+    , hspec-golden-aeson        >=0.7     && <0.10
     , QuickCheck                ^>=2.14.1
     , quickcheck-arbitrary-adt  ^>=0.3.1.0
     , text                      ^>=1.2.4.0

lib/GHCup.hs

@@ -18,7 +18,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 
 This module contains the main functions that correspond
 to the command line interface, like installation, listing versions
@@ -58,7 +58,6 @@ import           Control.Monad.Trans.Resource
 import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.List
-import           Data.List.Extra
 import           Data.Maybe
 import           Data.String                    ( fromString )
 import           Data.String.Interpolate
@@ -66,7 +65,10 @@ import           Data.Text                      ( Text )
 import           Data.Time.Clock
 import           Data.Time.Format.ISO8601
 import           Data.Versions
+import           Data.Word8
 import           GHC.IO.Exception
+import           HPath
+import           HPath.IO                hiding ( hideError )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
 import           Prelude                 hiding ( abs
@@ -74,10 +76,10 @@ import           Prelude                 hiding ( abs
                                                 , writeFile
                                                 )
 import           Safe                    hiding ( at )
-import           System.Directory        hiding ( findFiles )
-import           System.Environment
-import           System.FilePath
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment, getEnv )
+import           System.Posix.FilePath          ( getSearchPath, takeExtension )
+import           System.Posix.Files.ByteString
 import           Text.PrettyPrint.HughesPJClass ( prettyShow )
 import           Text.Regex.Posix
 
@@ -147,7 +149,7 @@ installGHCBindist dlinfo ver pfreq = do
 
  where
   toolchainSanityChecks = do
-    r <- forM ["CC", "LD"] (liftIO . lookupEnv)
+    r <- forM ["CC", "LD"] (liftIO . getEnv)
     case catMaybes r of
       [] -> pure ()
       _ -> do
@@ -166,9 +168,9 @@ installPackedGHC :: ( MonadMask m
                     , MonadIO m
                     , MonadUnliftIO m
                     )
-                 => FilePath          -- ^ Path to the packed GHC bindist
+                 => Path Abs          -- ^ Path to the packed GHC bindist
                  -> Maybe TarDir      -- ^ Subdir of the archive
-                 -> FilePath          -- ^ Path to install to
+                 -> Path Abs          -- ^ Path to install to
                  -> Version           -- ^ The GHC version
                  -> PlatformRequest
                  -> Excepts
@@ -201,27 +203,22 @@ installUnpackedGHC :: ( MonadReader AppState m
                       , MonadThrow m
                       , MonadLogger m
                       , MonadIO m
+                      , MonadMask m
                       )
-                   => FilePath      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
+                   => Path Abs      -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-                   -> FilePath      -- ^ Path to install to
+                   -> Path Abs      -- ^ Path to install to
                    -> Version       -- ^ The GHC version
                    -> PlatformRequest
                    -> Excepts '[ProcessError] m ()
-#if defined(IS_WINDOWS)
-installUnpackedGHC path inst _ _ = do
-  lift $ $(logInfo) "Installing GHC (this may take a while)"
-  -- windows bindists are relocatable and don't need
-  -- to run configure
-  liftIO $ copyDirectoryRecursive path inst
-#else
 installUnpackedGHC path inst ver PlatformRequest{..} = do
   lift $ $(logInfo) "Installing GHC (this may take a while)"
-  lEM $ execLogged "sh"
+  lEM $ withConsoleRegions $ execLogged "./configure"
-                   ("./configure" : ("--prefix=" <> inst) : alpineArgs)
+                   False
+                   (("--prefix=" <> toFilePath inst) : alpineArgs)
+                   [rel|ghc-configure|]
                    (Just path)
-                   "ghc-configure"
                    Nothing
-  lEM $ make ["install"] (Just path)
+  lEM $ withConsoleRegions $ make ["install"] (Just path)
   pure ()
  where
   alpineArgs
@@ -229,7 +226,6 @@ installUnpackedGHC path inst ver PlatformRequest{..} = do
     = ["--disable-ld-override"]
     | otherwise
     = []
-#endif
 
 
 -- | Installs GHC into @~\/.ghcup\/ghc/\<ver\>@ and places the
@@ -306,9 +302,9 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
   whenM
       (lift (cabalInstalled ver) >>= \a -> liftIO $
         handleIO (\_ -> pure False)
-          $ fmap (\x -> a && x)
+          $ fmap (\x -> a && isSymbolicLink x)
           -- ignore when the installation is a legacy cabal (binary, not symlink)
-          $ pathIsSymbolicLink (binDir </> "cabal" <> exeExt)
+          $ getSymbolicLinkStatus (toFilePath (binDir </> [rel|cabal|]))
       )
       (throwE $ AlreadyInstalled Cabal ver)
 
@@ -333,18 +329,19 @@ installCabalBindist dlinfo ver PlatformRequest {..} = do
  where
   -- | Install an unpacked cabal distribution.
   installCabal' :: (MonadLogger m, MonadCatch m, MonadIO m)
-                => FilePath      -- ^ Path to the unpacked cabal bindist (where the executable resides)
+                => Path Abs      -- ^ Path to the unpacked cabal bindist (where the executable resides)
-                -> FilePath      -- ^ Path to install to
+                -> Path Abs      -- ^ Path to install to
                 -> Excepts '[CopyError] m ()
   installCabal' path inst = do
     lift $ $(logInfo) "Installing cabal"
-    let cabalFile = "cabal"
+    let cabalFile = [rel|cabal|]
     liftIO $ createDirRecursive' inst
-    let destFileName = cabalFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
+    destFileName <- lift $ parseRel (toFilePath cabalFile <> "-" <> verToBS ver)
     let destPath = inst </> destFileName
     handleIO (throwE . CopyError . show) $ liftIO $ copyFile
-      (path </> cabalFile <> exeExt)
+      (path </> cabalFile)
       destPath
+      Overwrite
     lift $ chmod_755 destPath
 
 
@@ -441,8 +438,8 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
  where
   -- | Install an unpacked hls distribution.
   installHLS' :: (MonadFail m, MonadLogger m, MonadCatch m, MonadIO m)
-                => FilePath      -- ^ Path to the unpacked hls bindist (where the executable resides)
+                => Path Abs      -- ^ Path to the unpacked hls bindist (where the executable resides)
-                -> FilePath      -- ^ Path to install to
+                -> Path Abs      -- ^ Path to install to
                 -> Excepts '[CopyError] m ()
   installHLS' path inst = do
     lift $ $(logInfo) "Installing HLS"
@@ -456,19 +453,20 @@ installHLSBindist dlinfo ver PlatformRequest{..} = do
                      ([s|^haskell-language-server-[0-9].*$|] :: ByteString)
       )
     forM_ bins $ \f -> do
-      let toF = dropSuffix exeExt f
+      toF <- parseRel (toFilePath f <> "~" <> verToBS ver)
-                <> "~" <> T.unpack (prettyVer ver) <> exeExt
       handleIO (throwE . CopyError . show) $ liftIO $ copyFile
         (path </> f)
         (inst </> toF)
+        Overwrite
       lift $ chmod_755 (inst </> toF)
 
     -- install haskell-language-server-wrapper
-    let wrapper = "haskell-language-server-wrapper"
+    let wrapper = [rel|haskell-language-server-wrapper|]
-        toF = wrapper <> "-" <> T.unpack (prettyVer ver) <> exeExt
+    toF <- parseRel (toFilePath wrapper <> "-" <> verToBS ver)
     handleIO (throwE . CopyError . show) $ liftIO $ copyFile
-      (path </> wrapper <> exeExt)
+      (path </> wrapper)
       (inst </> toF)
+      Overwrite
     lift $ chmod_755 (inst </> toF)
 
 
@@ -506,114 +504,6 @@ installHLSBin bDls ver pfreq = do
   installHLSBindist dlinfo ver pfreq
 
 
--- | 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 AppState m
-                   , MonadLogger m
-                   , MonadResource m
-                   , MonadIO m
-                   , MonadUnliftIO m
-                   , MonadFail m
-                   )
-                => GHCupDownloads
-                -> Version
-                -> PlatformRequest
-                -> Excepts
-                     '[ AlreadyInstalled
-                      , CopyError
-                      , DigestError
-                      , DownloadFailed
-                      , NoDownload
-                      , NotInstalled
-                      , UnknownArchive
-                      , TarDirDoesNotExist
-#if !defined(TAR)
-                      , ArchiveResult
-#endif
-                      ]
-                     m
-                     ()
-installStackBin bDls ver pfreq = do
-  dlinfo <- lE $ getDownloadInfo Stack ver pfreq bDls
-  installStackBindist dlinfo ver pfreq
-
-
--- | Like 'installStackBin', except takes the 'DownloadInfo' as
--- argument instead of looking it up from 'GHCupDownloads'.
-installStackBindist :: ( MonadMask m
-                       , MonadCatch m
-                       , MonadReader AppState m
-                       , MonadLogger m
-                       , MonadResource m
-                       , MonadIO m
-                       , MonadUnliftIO m
-                       , MonadFail m
-                       )
-                    => DownloadInfo
-                    -> Version
-                    -> PlatformRequest
-                    -> Excepts
-                         '[ AlreadyInstalled
-                          , CopyError
-                          , DigestError
-                          , DownloadFailed
-                          , NoDownload
-                          , NotInstalled
-                          , UnknownArchive
-                          , TarDirDoesNotExist
-#if !defined(TAR)
-                          , ArchiveResult
-#endif
-                          ]
-                         m
-                         ()
-installStackBindist dlinfo ver PlatformRequest {..} = do
-  lift $ $(logDebug) [i|Requested to install stack version #{ver}|]
-
-  AppState {dirs = Dirs {..}} <- lift ask
-
-  whenM (lift (hlsInstalled ver))
-    (throwE $ AlreadyInstalled Stack ver)
-
-  -- download (or use cached version)
-  dl                           <- liftE $ downloadCached dlinfo Nothing
-
-  -- unpack
-  tmpUnpack                    <- lift withGHCupTmpDir
-  liftE $ unpackToDir tmpUnpack dl
-  void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
-
-  -- the subdir of the archive where we do the work
-  workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
-
-  liftE $ installStack' workdir binDir
-
-  -- create symlink if this is the latest version
-  sVers <- lift $ fmap rights getInstalledStacks
-  let lInstStack = headMay . reverse . sort $ sVers
-  when (maybe True (ver >=) lInstStack) $ liftE $ setStack ver
-
- where
-  -- | Install an unpacked stack distribution.
-  installStack' :: (MonadLogger m, MonadCatch m, MonadIO m)
-                => FilePath      -- ^ Path to the unpacked stack bindist (where the executable resides)
-                -> FilePath      -- ^ Path to install to
-                -> Excepts '[CopyError] m ()
-  installStack' path inst = do
-    lift $ $(logInfo) "Installing stack"
-    let stackFile = "stack"
-    liftIO $ createDirRecursive' inst
-    let destFileName = stackFile <> "-" <> T.unpack (prettyVer ver) <> exeExt
-    let destPath = inst </> destFileName
-    handleIO (throwE . CopyError . show) $ liftIO $ copyFile
-      (path </> stackFile <> exeExt)
-      destPath
-    lift $ chmod_755 destPath
-
-
 
 
     ---------------------
@@ -642,7 +532,7 @@ setGHC :: ( MonadReader AppState m
        -> SetGHC
        -> Excepts '[NotInstalled] m GHCTargetVersion
 setGHC ver sghc = do
-  let verS = T.unpack $ prettyVer (_tvVersion ver)
+  let verBS = verToBS (_tvVersion ver)
   ghcdir                        <- lift $ ghcupGHCDir ver
 
   whenM (lift $ not <$> ghcInstalled ver) (throwE (NotInstalled GHC ver))
@@ -664,50 +554,49 @@ setGHC ver sghc = do
     mTargetFile <- case sghc of
       SetGHCOnly -> pure $ Just file
       SetGHC_XY  -> do
-        handle
+        v' <-
+          handle
             (\(e :: ParseError) -> lift $ $(logWarn) [i|#{e}|] >> pure Nothing)
-          $ do 
+          $ fmap Just
-            (mj, mi) <- getMajorMinorV (_tvVersion ver)
+          $ getMajorMinorV (_tvVersion ver)
-            let major' = intToText mj <> "." <> intToText mi
+        forM v' $ \(mj, mi) ->
-            pure $ Just (file <> "-" <> T.unpack major')
+          let major' = E.encodeUtf8 $ intToText mj <> "." <> intToText mi
+          in  parseRel (toFilePath file <> B.singleton _hyphen <> major')
       SetGHC_XYZ ->
-        pure $ Just (file <> "-" <> verS)
+        fmap Just $ parseRel (toFilePath file <> B.singleton _hyphen <> verBS)
 
     -- create symlink
     forM mTargetFile $ \targetFile -> do
-      let fullF = binDir </> targetFile  <> exeExt
+      let fullF = binDir </> targetFile
-          fileWithExt = file <> exeExt
+      destL <- lift $ ghcLinkDestination (toFilePath file) ver
-      destL <- lift $ ghcLinkDestination fileWithExt ver
+      lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath fullF}|]
-      lift $ $(logDebug) [i|rm -f #{fullF}|]
+      liftIO $ createSymlink fullF destL
-      liftIO $ hideError doesNotExistErrorType $ removeFile fullF
-      lift $ $(logDebug) [i|ln -s #{destL} #{fullF}|]
-      liftIO $ createFileLink destL fullF
 
   -- create symlink for share dir
-  when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verS
+  when (isNothing . _tvTarget $ ver) $ lift $ symlinkShareDir ghcdir verBS
 
   pure ver
 
  where
 
   symlinkShareDir :: (MonadReader AppState m, MonadIO m, MonadLogger m)
-                  => FilePath
+                  => Path Abs
-                  -> String
+                  -> ByteString
                   -> m ()
-  symlinkShareDir ghcdir ver' = do
+  symlinkShareDir ghcdir verBS = do
     AppState { dirs = Dirs {..} } <- ask
     let destdir = baseDir
     case sghc of
       SetGHCOnly -> do
-        let sharedir     = "share"
+        let sharedir     = [rel|share|]
         let fullsharedir = ghcdir </> sharedir
         whenM (liftIO $ doesDirectoryExist fullsharedir) $ do
           let fullF   = destdir </> sharedir
-          let targetF = "." </> "ghc" </> ver' </> sharedir
+          let targetF = "./ghc/" <> verBS <> "/" <> toFilePath sharedir
           $(logDebug) [i|rm -f #{fullF}|]
-          liftIO $ hideError doesNotExistErrorType $ removeFile fullF
+          liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
           $(logDebug) [i|ln -s #{targetF} #{fullF}|]
-          liftIO $ createDirectoryLink targetF fullF
+          liftIO $ createSymlink fullF targetF
       _ -> pure ()
 
 
@@ -717,7 +606,8 @@ setCabal :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, M
          => Version
          -> Excepts '[NotInstalled] m ()
 setCabal ver = do
-  let targetFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
+  let verBS = verToBS ver
+  targetFile <- parseRel ("cabal-" <> verBS)
 
   -- symlink destination
   AppState {dirs = Dirs {..}} <- lift ask
@@ -727,17 +617,17 @@ setCabal ver = do
     $ throwE
     $ NotInstalled Cabal (GHCTargetVersion Nothing ver)
 
-  let cabalbin = binDir </> "cabal" <> exeExt
+  let cabalbin = binDir </> [rel|cabal|]
 
   -- delete old file (may be binary or symlink)
-  lift $ $(logDebug) [i|rm -f #{cabalbin}|]
+  lift $ $(logDebug) [i|rm -f #{toFilePath cabalbin}|]
-  liftIO $ hideError doesNotExistErrorType $ removeFile
+  liftIO $ hideError doesNotExistErrorType $ deleteFile
     cabalbin
 
   -- create symlink
-  let destL = targetFile
+  let destL = toFilePath targetFile
-  lift $ $(logDebug) [i|ln -s #{destL} #{cabalbin}|]
+  lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath cabalbin}|]
-  liftIO $ createFileLink destL cabalbin
+  liftIO $ createSymlink cabalbin destL
 
   pure ()
 
@@ -762,63 +652,36 @@ setHLS ver = do
   -- selected version, so we could end up with stray or incorrect symlinks.
   oldSyms <- lift hlsSymlinks
   forM_ oldSyms $ \f -> do
-    lift $ $(logDebug) [i|rm #{binDir </> f}|]
+    lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
-    liftIO $ removeFile (binDir </> f)
+    liftIO $ deleteFile (binDir </> f)
 
   -- set haskell-language-server-<ghcver> symlinks
   bins <- lift $ hlsServerBinaries ver
   when (null bins) $ throwE $ NotInstalled HLS (GHCTargetVersion Nothing ver)
 
   forM_ bins $ \f -> do
-    let destL = f
+    let destL = toFilePath f
-    let target = (<> exeExt) . head . splitOn "~" $ f
+    target <- parseRel . head . B.split _tilde . toFilePath $ f
 
-    lift $ $(logDebug) [i|rm -f #{binDir </> target}|]
+    lift $ $(logDebug) [i|rm -f #{toFilePath (binDir </> target)}|]
-    liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> target)
+    liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> target)
 
-    lift $ $(logDebug) [i|ln -s #{destL} #{binDir </> target}|]
+    lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath (binDir </> target)}|]
-    liftIO $ createFileLink destL (binDir </> target)
+    liftIO $ createSymlink (binDir </> target) destL
 
   -- set haskell-language-server-wrapper symlink
-  let destL = "haskell-language-server-wrapper-" <> T.unpack (prettyVer ver) <> exeExt
+  let destL = "haskell-language-server-wrapper-" <> verToBS ver
-  let wrapper = binDir </> "haskell-language-server-wrapper" <> exeExt
+  let wrapper = binDir </> [rel|haskell-language-server-wrapper|]
 
-  lift $ $(logDebug) [i|rm -f #{wrapper}|]
+  lift $ $(logDebug) [i|rm -f #{toFilePath wrapper}|]
-  liftIO $ hideError doesNotExistErrorType $ removeFile wrapper
+  liftIO $ hideError doesNotExistErrorType $ deleteFile wrapper
 
-  lift $ $(logDebug) [i|ln -s #{destL} #{wrapper}|]
+  lift $ $(logDebug) [i|ln -s #{destL} #{toFilePath wrapper}|]
-  liftIO $ createFileLink destL wrapper
+  liftIO $ createSymlink wrapper destL
 
   pure ()
 
 
--- | Set the @~\/.ghcup\/bin\/stack@ symlink.
-setStack :: (MonadReader AppState m, MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
-         => Version
-         -> Excepts '[NotInstalled] m ()
-setStack ver = do
-  let targetFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-
-  -- symlink destination
-  AppState {dirs = Dirs {..}} <- lift ask
-  liftIO $ createDirRecursive' binDir
-
-  whenM (liftIO $ not <$> doesFileExist (binDir </> targetFile))
-    $ throwE
-    $ NotInstalled Stack (GHCTargetVersion Nothing ver)
-
-  let stackbin = binDir </> "stack" <> exeExt
-
-  -- delete old file (may be binary or symlink)
-  lift $ $(logDebug) [i|rm -f #{stackbin}|]
-  liftIO $ hideError doesNotExistErrorType $ removeFile
-    stackbin
-
-  -- create symlink
-  lift $ $(logDebug) [i|ln -s #{targetFile} #{stackbin}|]
-  liftIO $ createFileLink targetFile stackbin
-
-  pure ()
 
 
 
@@ -876,17 +739,15 @@ listVersions av lt' criteria pfreq = do
   cabals <- getInstalledCabals' cSet
   hlsSet' <- hlsSet
   hlses <- getInstalledHLSs
-  sSet <- stackSet
-  stacks <- getInstalledStacks
 
-  go lt' cSet cabals hlsSet' hlses sSet stacks
+  go lt' cSet cabals hlsSet' hlses
  where
-  go lt cSet cabals hlsSet' hlses sSet stacks = do
+  go lt cSet cabals hlsSet' hlses = do
     case lt of
       Just t -> do
         -- get versions from GHCupDownloads
         let avTools = availableToolVersions av t
-        lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses sSet stacks)
+        lr <- filter' <$> forM (Map.toList avTools) (toListResult t cSet cabals hlsSet' hlses)
 
         case t of
           GHC -> do
@@ -898,17 +759,13 @@ listVersions av lt' criteria pfreq = do
           HLS -> do
             slr <- strayHLS avTools
             pure (sort (slr ++ lr))
-          Stack -> do
-            slr <- strayStacks avTools
-            pure (sort (slr ++ lr))
           GHCup -> pure lr
       Nothing -> do
-        ghcvers   <- go (Just GHC) cSet cabals hlsSet' hlses sSet stacks
+        ghcvers   <- go (Just GHC) cSet cabals hlsSet' hlses
-        cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses sSet stacks
+        cabalvers <- go (Just Cabal) cSet cabals hlsSet' hlses
-        hlsvers   <- go (Just HLS) cSet cabals hlsSet' hlses sSet stacks
+        hlsvers   <- go (Just HLS) cSet cabals hlsSet' hlses
-        ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses sSet stacks
+        ghcupvers <- go (Just GHCup) cSet cabals hlsSet' hlses
-        stackvers <- go (Just Stack) cSet cabals hlsSet' hlses sSet stacks
+        pure (ghcvers <> cabalvers <> hlsvers <> ghcupvers)
-        pure (ghcvers <> cabalvers <> hlsvers <> stackvers <> ghcupvers)
   strayGHCs :: (MonadCatch m, MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m)
             => Map.Map Version [Tag]
             -> m [ListResult]
@@ -948,13 +805,13 @@ listVersions av lt' criteria pfreq = do
           }
       Left e -> do
         $(logWarn)
-          [i|Could not parse version of stray directory #{e}|]
+          [i|Could not parse version of stray directory #{toFilePath e}|]
         pure Nothing
 
   strayCabals :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
             => Map.Map Version [Tag]
             -> Maybe Version
-            -> [Either FilePath Version]
+            -> [Either (Path Rel) Version]
             -> m [ListResult]
   strayCabals avTools cSet cabals = do
     fmap catMaybes $ forM cabals $ \case
@@ -977,7 +834,7 @@ listVersions av lt' criteria pfreq = do
               }
       Left e -> do
         $(logWarn)
-          [i|Could not parse version of stray directory #{e}|]
+          [i|Could not parse version of stray directory #{toFilePath e}|]
         pure Nothing
 
   strayHLS :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
@@ -1005,49 +862,19 @@ listVersions av lt' criteria pfreq = do
               }
       Left e -> do
         $(logWarn)
-          [i|Could not parse version of stray directory #{e}|]
+          [i|Could not parse version of stray directory #{toFilePath e}|]
-        pure Nothing
-
-  strayStacks :: (MonadReader AppState m, MonadCatch m, MonadThrow m, MonadLogger m, MonadIO m)
-              => Map.Map Version [Tag]
-              -> m [ListResult]
-  strayStacks avTools = do
-    stacks <- getInstalledStacks
-    fmap catMaybes $ forM stacks $ \case
-      Right ver ->
-        case Map.lookup ver avTools of
-          Just _  -> pure Nothing
-          Nothing -> do
-            lSet    <- fmap (== Just ver) hlsSet
-            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)
-          [i|Could not parse version of stray directory #{e}|]
         pure Nothing
 
   -- NOTE: this are not cross ones, because no bindists
   toListResult :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
                => Tool
                -> Maybe Version
-               -> [Either FilePath Version]
+               -> [Either (Path Rel) Version]
                -> Maybe Version
-               -> [Either FilePath Version]
+               -> [Either (Path Rel) Version]
-               -> Maybe Version
-               -> [Either FilePath Version]
                -> (Version, [Tag])
                -> m ListResult
-  toListResult t cSet cabals hlsSet' hlses stackSet' stacks (v, tags) = case t of
+  toListResult t cSet cabals hlsSet' hlses (v, tags) = case t of
     GHC -> do
       let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
       let tver = mkTVer v
@@ -1095,19 +922,6 @@ listVersions av lt' criteria pfreq = do
                       , hlsPowered = False
                       , ..
                       }
-    Stack -> do
-      let lNoBindist = isLeft $ getDownloadInfo Stack v pfreq av
-      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]
@@ -1156,8 +970,8 @@ rmGHCVer ver = do
   handle (\(_ :: ParseError) -> pure ()) $ liftE $ rmMajorSymlinks ver
   -- then fix them (e.g. with an earlier version)
 
-  lift $ $(logInfo) [i|Removing directory recursively: #{dir}|]
+  lift $ $(logInfo) [i|Removing directory recursively: #{toFilePath dir}|]
-  liftIO $ removeDirectoryRecursive dir
+  liftIO $ deleteDirRecursive dir
 
   v' <-
     handle
@@ -1171,7 +985,7 @@ rmGHCVer ver = do
 
   liftIO
     $ hideError doesNotExistErrorType
-    $ removeFile (baseDir </> "share")
+    $ deleteFile (baseDir </> [rel|share|])
 
 
 -- | Delete a cabal version. Will try to fix the @cabal@ symlink
@@ -1186,15 +1000,15 @@ rmCabalVer ver = do
 
   AppState {dirs = Dirs {..}} <- lift ask
 
-  let cabalFile = "cabal-" <> T.unpack (prettyVer ver) <> exeExt
+  cabalFile <- lift $ parseRel ("cabal-" <> verToBS ver)
-  liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> cabalFile)
+  liftIO $ hideError doesNotExistErrorType $ deleteFile (binDir </> cabalFile)
 
   when (Just ver == cSet) $ do
     cVers <- lift $ fmap rights getInstalledCabals
     case headMay . reverse . sort $ cVers of
       Just latestver -> setCabal latestver
-      Nothing        -> liftIO $ hideError doesNotExistErrorType $ removeFile
+      Nothing        -> liftIO $ hideError doesNotExistErrorType $ deleteFile
-        (binDir </> "cabal" <> exeExt)
+        (binDir </> [rel|cabal|])
 
 
 -- | Delete a hls version. Will try to fix the hls symlinks
@@ -1210,15 +1024,14 @@ rmHLSVer ver = do
   AppState {dirs = Dirs {..}} <- lift ask
 
   bins <- lift $ hlsAllBinaries ver
-  forM_ bins $ \f -> liftIO $ removeFile (binDir </> f)
+  forM_ bins $ \f -> liftIO $ deleteFile (binDir </> f)
 
   when (Just ver == isHlsSet) $ do
     -- delete all set symlinks
     oldSyms <- lift hlsSymlinks
     forM_ oldSyms $ \f -> do
-      let fullF = binDir </> f <> exeExt
+      lift $ $(logDebug) [i|rm #{toFilePath (binDir </> f)}|]
-      lift $ $(logDebug) [i|rm #{fullF}|]
+      liftIO $ deleteFile (binDir </> f)
-      liftIO $ removeFile fullF
     -- set latest hls
     hlsVers <- lift $ fmap rights getInstalledHLSs
     case headMay . reverse . sort $ hlsVers of
@@ -1226,28 +1039,6 @@ rmHLSVer ver = do
       Nothing        -> pure ()
 
 
--- | Delete a stack version. Will try to fix the @stack@ symlink
--- after removal (e.g. setting it to an older version).
-rmStackVer :: (MonadReader AppState m, MonadThrow m, MonadLogger m, MonadIO m, MonadFail m, MonadCatch m)
-           => Version
-           -> Excepts '[NotInstalled] m ()
-rmStackVer ver = do
-  whenM (lift $ fmap not $ stackInstalled ver) $ throwE (NotInstalled Stack (GHCTargetVersion Nothing ver))
-
-  sSet      <- lift stackSet
-
-  AppState {dirs = Dirs {..}} <- lift ask
-
-  let stackFile = "stack-" <> T.unpack (prettyVer ver) <> exeExt
-  liftIO $ hideError doesNotExistErrorType $ removeFile (binDir </> stackFile)
-
-  when (Just ver == sSet) $ do
-    sVers <- lift $ fmap rights getInstalledStacks
-    case headMay . reverse . sort $ sVers of
-      Just latestver -> setStack latestver
-      Nothing        -> liftIO $ hideError doesNotExistErrorType $ removeFile
-        (binDir </> "stack" <> exeExt)
-
 
 
     ------------------
@@ -1291,10 +1082,10 @@ compileGHC :: ( MonadMask m
               )
            => GHCupDownloads
            -> Either GHCTargetVersion GitBranch          -- ^ version to install
-           -> Either Version FilePath  -- ^ version to bootstrap with
+           -> Either Version (Path Abs)  -- ^ version to bootstrap with
            -> Maybe Int                  -- ^ jobs
-           -> Maybe FilePath           -- ^ build config
+           -> Maybe (Path Abs)           -- ^ build config
-           -> Maybe FilePath           -- ^ patch directory
+           -> Maybe (Path Abs)           -- ^ patch directory
            -> [Text]                     -- ^ additional args to ./configure
            -> PlatformRequest
            -> Excepts
@@ -1340,9 +1131,10 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
         pure (workdir, tmpUnpack, tver)
 
       -- clone from git
-      Right GitBranch{..} -> do
+      Right GitBranch{..} -> withConsoleRegions $ \pState rs -> do
         tmpUnpack <- lift mkGhcupTmpDir
-        let git args = execLogged "git" ("--no-pager":args) (Just tmpUnpack) "git" Nothing
+        let git args = execLogged [s|git|] True ("--no-pager":args) [rel|git|] (Just tmpUnpack) Nothing pState rs
+            git_fetch = execLogged [s|sh|] True ["-c", [i|git --no-pager fetch --depth 1 origin #{ref} 2>&1 | cat|]] [rel|git|] (Just tmpUnpack) Nothing pState rs
         tver <- reThrowAll @_ @'[ProcessError] DownloadFailed $ do
           let rep = fromMaybe "https://gitlab.haskell.org/ghc/ghc.git" repo
           lift $ $(logInfo) [i|Fetching git repo #{rep} at ref #{ref} (this may take a while)|]
@@ -1352,24 +1144,17 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
                     , "origin"
                     , fromString rep ]
 
-          let fetch_args = 
+          lEM $ git_fetch
-                    [ "fetch"
-                    , "--depth"
-                    , "1"
-                    , "--quiet"
-                    , "origin"
-                    , fromString ref ]
-          lEM $ git fetch_args
 
           lEM $ git [ "checkout", "FETCH_HEAD" ]
           lEM $ git [ "submodule", "update", "--init", "--depth", "1" ]
-          lEM $ execLogged "sh" ["./boot"] (Just tmpUnpack) "ghc-bootstrap" Nothing
+          lEM $ execLogged "./boot" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs
-          lEM $ execLogged "sh" ["./configure"] (Just tmpUnpack) "ghc-bootstrap" Nothing
+          lEM $ execLogged "./configure" False [] [rel|ghc-bootstrap|] (Just tmpUnpack) Nothing pState rs
           CapturedProcess {..} <- liftIO $ makeOut
             ["show!", "--quiet", "VALUE=ProjectVersion" ] (Just tmpUnpack)
           case _exitCode of
-            ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
+            ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe $ _stdOut
-            ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
+            ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe _stdErr))
 
         void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
         lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
@@ -1388,14 +1173,14 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
 
     bghc <- case bstrap of
       Right g    -> pure $ Right g
-      Left  bver -> pure $ Left ("ghc-" <> (T.unpack . prettyVer $ bver))
+      Left  bver -> Left <$> parseRel ("ghc-" <> verToBS bver)
 
     (bindist, bmk) <- liftE $ runBuildAction
       tmpUnpack
       Nothing
       (do
         b <- compileBindist bghc tver workdir
-        bmk <- liftIO $ B.readFile (build_mk workdir)
+        bmk <- liftIO $ readFileStrict (build_mk workdir)
         pure (b, bmk)
       )
 
@@ -1408,7 +1193,7 @@ compileGHC dls targetGhc bstrap jobs mbuildConfig patchdir aargs pfreq@PlatformR
                              (tver ^. tvVersion)
                              pfreq
 
-    liftIO $ B.writeFile (ghcdir </> ghcUpSrcBuiltFile) bmk
+    liftIO $ writeFile (ghcdir </> ghcUpSrcBuiltFile) (Just newFilePerms) bmk
 
     reThrowAll GHCupSetError $ postGHCInstall tver
 
@@ -1439,15 +1224,16 @@ HADDOCK_DOCS = YES|]
                     , MonadLogger m
                     , MonadIO m
                     , MonadFail m
+                    , MonadMask m
                     )
-                 => Either FilePath FilePath
+                 => Either (Path Rel) (Path Abs)
                  -> GHCTargetVersion
-                 -> FilePath
+                 -> Path Abs
                  -> Excepts
                       '[FileDoesNotExistError, InvalidBuildConfig, PatchFailed, ProcessError, NotFoundInPATH, CopyError]
                       m
-                      FilePath  -- ^ output path of bindist
+                      (Path Abs)  -- ^ output path of bindist
-  compileBindist bghc tver workdir = do
+  compileBindist bghc tver workdir = withConsoleRegions $ \pState rs -> do
     lift $ $(logInfo) [i|configuring build|]
     liftE checkBuildConfig
 
@@ -1461,52 +1247,58 @@ HADDOCK_DOCS = YES|]
           bghcPath <- case bghc of
             Right ghc' -> pure ghc'
             Left  bver -> do
-              spaths <- liftIO getSearchPath
+              spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
               liftIO (searchPath spaths bver) !? NotFoundInPATH bver
           lEM $ execLogged
-            "sh"
+            "./configure"
-            ("./configure" :  maybe mempty
+            False
-                      (\x -> ["--target=" <> T.unpack x])
+            (  maybe mempty
+                      (\x -> ["--target=" <> E.encodeUtf8 x])
                       (_tvTarget tver)
-            ++ fmap T.unpack aargs
+            ++ fmap E.encodeUtf8 aargs
             )
+            [rel|ghc-conf|]
             (Just workdir)
-            "ghc-conf"
+            (Just (("GHC", toFilePath bghcPath) : cEnv))
-            (Just (("GHC", bghcPath) : cEnv))
+            pState
+            rs
        | otherwise -> do
         lEM $ execLogged
-          "sh"
+          "./configure"
-          (  [ "./configure", "--with-ghc=" <> either id id bghc
+          False
+          (  [ "--with-ghc=" <> either toFilePath toFilePath bghc
              ]
           ++ maybe mempty
-                   (\x -> ["--target=" <> T.unpack x])
+                   (\x -> ["--target=" <> E.encodeUtf8 x])
                    (_tvTarget tver)
-          ++ fmap T.unpack aargs
+          ++ fmap E.encodeUtf8 aargs
           )
+          [rel|ghc-conf|]
           (Just workdir)
-          "ghc-conf"
           (Just cEnv)
+          pState
+          rs
 
     case mbuildConfig of
       Just bc -> liftIOException
         doesNotExistErrorType
-        (FileDoesNotExistError bc)
+        (FileDoesNotExistError $ toFilePath bc)
-        (liftIO $ copyFile bc (build_mk workdir))
+        (liftIO $ copyFile bc (build_mk workdir) Overwrite)
       Nothing ->
-        liftIO $ B.writeFile (build_mk workdir) defaultConf
+        liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
 
     lift $ $(logInfo) [i|Building (this may take a while)...|]
-    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir)
+    lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs) (Just workdir) pState rs
 
     lift $ $(logInfo) [i|Creating bindist...|]
-    lEM $ make ["binary-dist"] (Just workdir)
+    lEM $ make ["binary-dist"] (Just workdir) pState rs
     [tar] <- liftIO $ findFiles
       workdir
       (makeRegexOpts compExtended
                      execBlank
                      ([s|^ghc-.*\.tar\..*$|] :: ByteString)
       )
-    c       <- liftIO $ BL.readFile (workdir </> tar)
+    c       <- liftIO $ readFile (workdir </> tar)
     cDigest <-
       fmap (T.take 8)
       . lift
@@ -1516,14 +1308,17 @@ HADDOCK_DOCS = YES|]
       . SHA256.hashlazy
       $ c
     cTime <- liftIO getCurrentTime
-    let tarName = [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension tar}|]
+    tarName <-
+      parseRel
+        [i|ghc-#{tVerToText tver}-#{pfReqToString pfreq}-#{iso8601Show cTime}-#{cDigest}.tar#{takeExtension (toFilePath tar)}|]
     let tarPath = cacheDir </> tarName
     handleIO (throwE . CopyError . show) $ liftIO $ copyFile (workdir </> tar)
                                                              tarPath
+                                                             Strict
     lift $ $(logInfo) [i|Copied bindist to #{tarPath}|]
     pure tarPath
 
-  build_mk workdir = workdir </> "mk" </> "build.mk"
+  build_mk workdir = workdir </> [rel|mk/build.mk|]
 
   checkBuildConfig :: (MonadCatch m, MonadIO m)
                    => Excepts
@@ -1533,10 +1328,10 @@ HADDOCK_DOCS = YES|]
   checkBuildConfig = do
     c <- case mbuildConfig of
       Just bc -> do
-        liftIOException
+        BL.toStrict <$> liftIOException
           doesNotExistErrorType
-          (FileDoesNotExistError bc)
+          (FileDoesNotExistError $ toFilePath bc)
-          (liftIO $ B.readFile bc)
+          (liftIO $ readFile bc)
       Nothing -> pure defaultConf
     let lines' = fmap T.strip . T.lines $ decUTF8Safe c
 
@@ -1568,7 +1363,7 @@ upgradeGHCup :: ( MonadMask m
                 , MonadUnliftIO m
                 )
              => GHCupDownloads
-             -> Maybe FilePath    -- ^ full file destination to write ghcup into
+             -> Maybe (Path Abs)  -- ^ full file destination to write ghcup into
              -> Bool              -- ^ whether to force update regardless
                                   --   of currently installed version
              -> PlatformRequest
@@ -1588,24 +1383,25 @@ upgradeGHCup dls mtarget force pfreq = do
   when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
   dli   <- lE $ getDownloadInfo GHCup latestVer pfreq dls
   tmp   <- lift withGHCupTmpDir
-  let fn = "ghcup" <> exeExt
+  let fn = [rel|ghcup|]
   p <- liftE $ download dli tmp (Just fn)
-  let destDir = takeDirectory destFile
+  let destDir = dirname destFile
       destFile = fromMaybe (binDir </> fn) mtarget
-  lift $ $(logDebug) [i|mkdir -p #{destDir}|]
+  lift $ $(logDebug) [i|mkdir -p #{toFilePath destDir}|]
   liftIO $ createDirRecursive' destDir
-  lift $ $(logDebug) [i|rm -f #{destFile}|]
+  lift $ $(logDebug) [i|rm -f #{toFilePath destFile}|]
-  liftIO $ hideError NoSuchThing $ removeFile destFile
+  liftIO $ hideError NoSuchThing $ deleteFile destFile
-  lift $ $(logDebug) [i|cp #{p} #{destFile}|]
+  lift $ $(logDebug) [i|cp #{toFilePath p} #{toFilePath destFile}|]
   handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
                                                            destFile
+                                                           Overwrite
   lift $ chmod_755 destFile
 
   liftIO (isInPath destFile) >>= \b -> unless b $
-    lift $ $(logWarn) [i|"#{takeFileName destFile}" is not in PATH! You have to add it in order to use ghcup.|]
+    lift $ $(logWarn) [i|"#{toFilePath (dirname destFile)}" is not in PATH! You have to add it in order to use ghcup.|]
   liftIO (isShadowed destFile) >>= \case
     Nothing -> pure ()
-    Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{pa}". The upgrade will not be in effect, unless you remove "#{pa}" or make sure "#{destDir}" comes before "#{takeFileName pa}" in PATH.|]
+    Just pa -> lift $ $(logWarn) [i|ghcup is shadowed by "#{toFilePath pa}". The upgrade will not be in effect, unless you remove "#{toFilePath pa}" or make sure "#{toFilePath destDir}" comes before "#{toFilePath (dirname pa)}" in PATH.|]
 
   pure latestVer
 

lib/GHCup/Download.hs

@@ -16,7 +16,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 
 Module for handling all download related functions.
 
@@ -53,11 +53,11 @@ import           Control.Monad.Trans.Resource
                                          hiding ( throwM )
 import           Data.Aeson
 import           Data.Bifunctor
-#if defined(INTERNAL_DOWNLOADER)
 import           Data.ByteString                ( ByteString )
+#if defined(INTERNAL_DOWNLOADER)
 import           Data.CaseInsensitive           ( CI )
 #endif
-import           Data.List.Extra
+import           Data.List                      ( find )
 import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Time.Clock
@@ -66,29 +66,34 @@ import           Data.Time.Clock.POSIX
 import           Data.Time.Format
 #endif
 import           Data.Versions
+import           Data.Word8
 import           GHC.IO.Exception
+import           HPath
+import           HPath.IO                     as HIO hiding ( hideError )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
 import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
-import           System.Directory
-import           System.Environment
-import           System.FilePath
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnv )
 import           URI.ByteString
 
 import qualified Crypto.Hash.SHA256            as SHA256
+import qualified Data.ByteString               as BS
 import qualified Data.ByteString.Base16        as B16
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Map.Strict               as M
 #if defined(INTERNAL_DOWNLOADER)
 import qualified Data.CaseInsensitive          as CI
-#endif
 import qualified Data.Text                     as T
+#endif
 import qualified Data.Text.Encoding            as E
 import qualified Data.Yaml                     as Y
+import qualified System.Posix.Files.ByteString as PF
+import qualified System.Posix.RawFilePath.Directory
+                                               as RD
 
 
 
@@ -153,12 +158,12 @@ readFromCache = do
   lift $ $(logWarn)
     [i|Could not get download info, trying cached version (this may not be recent!)|]
   let path = view pathL' ghcupURL
-  let yaml_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
+  yaml_file <- (cacheDir </>) <$> urlBaseName path
   bs        <-
     handleIO' NoSuchThing
-              (\_ -> throwE $ FileDoesNotExistError yaml_file)
+              (\_ -> throwE $ FileDoesNotExistError (toFilePath yaml_file))
     $ liftIO
-    $ L.readFile yaml_file
+    $ readFile yaml_file
   lE' JSONDecodeError $ first show $ Y.decodeEither' (L.toStrict bs)
 
 
@@ -202,27 +207,29 @@ getBase =
   smartDl uri' = do
     AppState {dirs = Dirs {..}} <- lift ask
     let path = view pathL' uri'
-    let json_file = cacheDir </> (T.unpack . decUTF8Safe . urlBaseName $ path)
+    json_file <- (cacheDir </>) <$> urlBaseName path
     e         <- liftIO $ doesFileExist json_file
     if e
       then do
-        accessTime <- liftIO $ getAccessTime json_file
+        accessTime <-
-        currentTime <- liftIO getCurrentTime
+          PF.accessTimeHiRes
+            <$> liftIO (PF.getFileStatus (toFilePath json_file))
+        currentTime <- liftIO getPOSIXTime
 
         -- access time won't work on most linuxes, but we can try regardless
-        if (utcTimeToPOSIXSeconds currentTime - utcTimeToPOSIXSeconds accessTime) > 300
+        if (currentTime - accessTime) > 300
           then do -- no access in last 5 minutes, re-check upstream mod time
             getModTime >>= \case
               Just modTime -> do
                 fileMod <- liftIO $ getModificationTime json_file
                 if modTime > fileMod
                   then dlWithMod modTime json_file
-                  else liftIO $ L.readFile json_file
+                  else liftIO $ readFile json_file
               Nothing -> do
                 lift $ $(logDebug) [i|Unable to get/parse Last-Modified header|]
                 dlWithoutMod json_file
           else -- access in less than 5 minutes, re-use file
-               liftIO $ L.readFile json_file
+               liftIO $ readFile json_file
       else do
         liftIO $ createDirRecursive' cacheDir
         getModTime >>= \case
@@ -240,9 +247,9 @@ getBase =
       pure bs
     dlWithoutMod json_file = do
       bs <- liftE $ downloadBS uri'
-      liftIO $ hideError doesNotExistErrorType $ removeFile json_file
+      liftIO $ hideError doesNotExistErrorType $ deleteFile json_file
-      liftIO $ L.writeFile json_file bs
+      liftIO $ writeFileL json_file (Just newFilePerms) bs
-      liftIO $ setModificationTime json_file (posixSecondsToUTCTime (fromIntegral @Int 0))
+      liftIO $ setModificationTime json_file (fromIntegral @Int 0)
       pure bs
 
 
@@ -271,10 +278,11 @@ getBase =
 
 #endif
 
-  writeFileWithModTime :: UTCTime -> FilePath -> L.ByteString -> IO ()
+  writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
   writeFileWithModTime utctime path content = do
-    L.writeFile path content
+    let mod_time = utcTimeToPOSIXSeconds utctime
-    setModificationTime path utctime
+    writeFileL path (Just newFilePerms) content
+    setModificationTimeHiRes path mod_time
 
 
 getDownloadInfo :: Tool
@@ -326,9 +334,9 @@ download :: ( MonadMask m
             , MonadIO m
             )
          => DownloadInfo
-         -> FilePath          -- ^ destination dir
+         -> Path Abs          -- ^ destination dir
-         -> Maybe FilePath    -- ^ optional filename
+         -> Maybe (Path Rel)  -- ^ optional filename
-         -> Excepts '[DigestError , DownloadFailed] m FilePath
+         -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
 download dli dest mfn
   | scheme == "https" = dl
   | scheme == "http"  = dl
@@ -340,9 +348,9 @@ download dli dest mfn
   cp     = do
     -- destination dir must exist
     liftIO $ createDirRecursive' dest
-    let destFile = getDestFile
+    destFile <- getDestFile
-    let fromFile = T.unpack . decUTF8Safe $ path
+    fromFile <- parseAbs path
-    liftIO $ copyFile fromFile destFile
+    liftIO $ copyFile fromFile destFile Strict
     pure destFile
   dl = do
     let uri' = decUTF8Safe (serializeURIRef' (view dlUri dli))
@@ -350,25 +358,25 @@ download dli dest mfn
 
     -- destination dir must exist
     liftIO $ createDirRecursive' dest
-    let destFile = getDestFile
+    destFile <- getDestFile
 
     -- download
     flip onException
-         (liftIO $ hideError doesNotExistErrorType $ removeFile destFile)
+         (liftIO $ hideError doesNotExistErrorType $ deleteFile destFile)
      $ catchAllE @_ @'[ProcessError, DownloadFailed, UnsupportedScheme]
           (\e ->
-            liftIO (hideError doesNotExistErrorType $ removeFile destFile)
+            liftIO (hideError doesNotExistErrorType $ deleteFile destFile)
               >> (throwE . DownloadFailed $ e)
           ) $ do
               lift getDownloader >>= \case
                 Curl -> do
                   o' <- liftIO getCurlOpts
-                  liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" 
+                  liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "curl" True
-                    (o' ++ ["-fL", "-o", destFile, (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
+                    (o' ++ ["-fL", "-o", toFilePath destFile, serializeURIRef' $ view dlUri dli]) Nothing Nothing
                 Wget -> do
                   o' <- liftIO getWgetOpts
-                  liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" 
+                  liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
-                    (o' ++ ["-O", destFile , (T.unpack . decUTF8Safe) $ serializeURIRef' $ view dlUri dli]) Nothing Nothing
+                    (o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
 #if defined(INTERNAL_DOWNLOADER)
                 Internal -> do
                   (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
@@ -379,8 +387,8 @@ download dli dest mfn
     pure destFile
 
   -- Manage to find a file we can write the body into.
-  getDestFile :: FilePath
+  getDestFile :: MonadThrow m => m (Path Abs)
-  getDestFile = maybe (dest </> T.unpack (decUTF8Safe (urlBaseName path))) (dest </>) mfn
+  getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
 
   path        = view (dlUri % pathL') dli
 
@@ -396,14 +404,14 @@ downloadCached :: ( MonadMask m
                   , MonadReader AppState m
                   )
                => DownloadInfo
-               -> Maybe FilePath  -- ^ optional filename
+               -> Maybe (Path Rel)  -- ^ optional filename
-               -> Excepts '[DigestError , DownloadFailed] m FilePath
+               -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
 downloadCached dli mfn = do
   cache <- lift getCache
   case cache of
     True -> do
       AppState {dirs = Dirs {..}} <- lift ask
-      let fn = fromMaybe ((T.unpack . decUTF8Safe) $ urlBaseName $ view (dlUri % pathL') dli) mfn
+      fn       <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
       let cachfile = cacheDir </> fn
       fileExists <- liftIO $ doesFileExist cachfile
       if
@@ -445,8 +453,8 @@ downloadBS uri'
   | scheme == "http"
   = dl False
   | scheme == "file"
-  = liftIOException doesNotExistErrorType (FileDoesNotExistError $ T.unpack $ decUTF8Safe path)
+  = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
-    (liftIO $ L.readFile (T.unpack $ decUTF8Safe path))
+    (liftIO $ RD.readFile path)
   | otherwise
   = throwE UnsupportedScheme
 
@@ -462,20 +470,20 @@ downloadBS uri'
     lift getDownloader >>= \case
       Curl -> do
         o' <- liftIO getCurlOpts
-        let exe = "curl"
+        let exe = [rel|curl|]
-            args = o' ++ ["-sSfL", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
+            args = o' ++ ["-sSfL", serializeURIRef' uri']
         liftIO (executeOut exe args Nothing) >>= \case
           CapturedProcess ExitSuccess stdout _ -> do
-            pure stdout
+            pure $ L.fromStrict stdout
-          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
+          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
       Wget -> do
         o' <- liftIO getWgetOpts
-        let exe = "wget"
+        let exe = [rel|wget|]
-            args = o' ++ ["-qO-", T.unpack $ decUTF8Safe $ serializeURIRef' uri']
+            args = o' ++ ["-qO-", serializeURIRef' uri']
         liftIO (executeOut exe args Nothing) >>= \case
           CapturedProcess ExitSuccess stdout _ -> do
-            pure stdout
+            pure $ L.fromStrict stdout
-          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' exe args
+          CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
 #if defined(INTERNAL_DOWNLOADER)
       Internal -> do
         (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
@@ -485,31 +493,31 @@ downloadBS uri'
 
 checkDigest :: (MonadIO m, MonadThrow m, MonadLogger m, MonadReader AppState m)
             => DownloadInfo
-            -> FilePath
+            -> Path Abs
             -> Excepts '[DigestError] m ()
 checkDigest dli file = do
   verify <- lift ask <&> (not . noVerify . settings)
   when verify $ do
-    let p' = takeFileName file
+    p' <- toFilePath <$> basename file
     lift $ $(logInfo) [i|verifying digest of: #{p'}|]
-    c <- liftIO $ L.readFile file
+    c <- liftIO $ readFile file
     cDigest <- throwEither . E.decodeUtf8' . B16.encode . SHA256.hashlazy $ c
     let eDigest = view dlHash dli
     when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)
 
 
 -- | Get additional curl args from env. This is an undocumented option.
-getCurlOpts :: IO [String]
+getCurlOpts :: IO [ByteString]
 getCurlOpts =
-  lookupEnv "GHCUP_CURL_OPTS" >>= \case
+  getEnv "GHCUP_CURL_OPTS" >>= \case
-    Just r  -> pure $ splitOn " " r
+    Just r  -> pure $ BS.split _space r
     Nothing -> pure []
 
 
 -- | Get additional wget args from env. This is an undocumented option.
-getWgetOpts :: IO [String]
+getWgetOpts :: IO [ByteString]
 getWgetOpts =
-  lookupEnv "GHCUP_WGET_OPTS" >>= \case
+  getEnv "GHCUP_WGET_OPTS" >>= \case
-    Just r  -> pure $ splitOn " " r
+    Just r  -> pure $ BS.split _space r
     Nothing -> pure []
 

lib/GHCup/Download/IOStreams.hs

@@ -24,6 +24,8 @@ import           Data.CaseInsensitive           ( CI )
 import           Data.IORef
 import           Data.Maybe
 import           Data.Text.Read
+import           HPath
+import           HPath.IO                      as HIO
 import           Haskus.Utils.Variant.Excepts
 import           Network.Http.Client     hiding ( URL )
 import           Optics
@@ -31,8 +33,11 @@ import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( fdWrite )
+import "unix-bytestring" System.Posix.IO.ByteString
+                                                ( fdWrite )
 import           System.ProgressBar
-import           System.IO
 import           URI.ByteString
 
 import qualified Data.ByteString               as BS
@@ -76,12 +81,12 @@ downloadToFile :: (MonadMask m, MonadIO m)
                -> ByteString       -- ^ host (e.g. "www.example.com")
                -> ByteString       -- ^ path (e.g. "/my/file") including query
                -> Maybe Int        -- ^ optional port (e.g. 3000)
-               -> FilePath         -- ^ destination file to create and write to
+               -> Path Abs         -- ^ destination file to create and write to
                -> Excepts '[DownloadFailed] m ()
 downloadToFile https host fullPath port destFile = do
-  fd <- liftIO $ openFile destFile WriteMode
+  fd <- liftIO $ createRegularFileFd newFilePerms destFile
-  let stepper = BS.hPut fd
+  let stepper = fdWrite fd
-  flip finally (liftIO $ hClose fd)
+  flip finally (liftIO $ closeFd fd)
     $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
 
 

lib/GHCup/Errors.hs

@@ -15,11 +15,12 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Errors where
 
 import           GHCup.Types
+import           GHCup.Utils.Prelude
 
 #if !defined(TAR)
 import           Codec.Archive
@@ -27,9 +28,11 @@ import           Codec.Archive
 import qualified Codec.Archive.Tar             as Tar
 #endif
 import           Control.Exception.Safe
+import           Data.ByteString                ( ByteString )
 import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
+import           HPath
 import           Haskus.Utils.Variant
 import           Text.PrettyPrint
 import           Text.PrettyPrint.HughesPJClass
@@ -83,12 +86,12 @@ instance Pretty DistroNotFound where
     text "Unable to figure out the distribution of the host."
 
 -- | The archive format is unknown. We don't know how to extract it.
-data UnknownArchive = UnknownArchive FilePath
+data UnknownArchive = UnknownArchive ByteString
   deriving Show
 
 instance Pretty UnknownArchive where
   pPrint (UnknownArchive file) =
-    text [i|The archive format is unknown. We don't know how to extract the file "#{file}"|]
+    text [i|The archive format is unknown. We don't know how to extract the file "#{decUTF8Safe file}"|]
 
 -- | The scheme is not supported (such as ftp).
 data UnsupportedScheme = UnsupportedScheme
@@ -140,12 +143,12 @@ instance Pretty NotInstalled where
     text [i|The version "#{prettyShow ver}" of the tool "#{tool}" is not installed.|]
 
 -- | An executable was expected to be in PATH, but was not found.
-data NotFoundInPATH = NotFoundInPATH FilePath
+data NotFoundInPATH = NotFoundInPATH (Path Rel)
   deriving Show
 
 instance Pretty NotFoundInPATH where
   pPrint (NotFoundInPATH exe) =
-    text [i|The exe "#{exe}" was not found in PATH.|]
+    text [i|The exe "#{decUTF8Safe . toFilePath $ exe}" was not found in PATH.|]
 
 -- | JSON decoding failed.
 data JSONError = JSONDecodeError String
@@ -157,12 +160,12 @@ instance Pretty JSONError where
 
 -- | A file that is supposed to exist does not exist
 -- (e.g. when we use file scheme to "download" something).
-data FileDoesNotExistError = FileDoesNotExistError FilePath
+data FileDoesNotExistError = FileDoesNotExistError ByteString
   deriving Show
 
 instance Pretty FileDoesNotExistError where
   pPrint (FileDoesNotExistError file) =
-    text [i|File "#{file}" does not exist.|]
+    text [i|File "#{decUTF8Safe file}" does not exist.|]
 
 data TarDirDoesNotExist = TarDirDoesNotExist TarDir
   deriving Show
@@ -249,11 +252,11 @@ deriving instance Show DownloadFailed
 
 
 -- | A build failed.
-data BuildFailed = forall es . Show (V es) => BuildFailed FilePath (V es)
+data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
 
 instance Pretty BuildFailed where
   pPrint (BuildFailed path reason) =
-    text [i|BuildFailed failed in dir "#{path}": #{reason}|]
+    text [i|BuildFailed failed in dir "#{decUTF8Safe . toFilePath $ path}": #{reason}|]
 
 deriving instance Show BuildFailed
 

lib/GHCup/Platform.hs

@@ -13,7 +13,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Platform where
 
@@ -36,20 +36,18 @@ import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
+import           HPath
+import           HPath.IO
 import           Haskus.Utils.Variant.Excepts
 import           Prelude                 hiding ( abs
                                                 , readFile
                                                 , writeFile
                                                 )
 import           System.Info
-import           System.Directory
 import           System.OsRelease
 import           Text.Regex.Posix
 
 import qualified Data.Text                     as T
-import qualified Data.Text.IO                  as T
-
-
 
     --------------------------
     --[ Platform detection ]--
@@ -98,23 +96,22 @@ getPlatform = do
           . versioning
           -- TODO: maybe do this somewhere else
           . getMajorVersion
-          . decUTF8Safe'
+          . decUTF8Safe
         <$> getDarwinVersion
       pure $ PlatformResult { _platform = Darwin, _distroVersion = ver }
     "freebsd" -> do
       ver <-
-        either (const Nothing) Just . versioning . decUTF8Safe'
+        either (const Nothing) Just . versioning . decUTF8Safe
           <$> getFreeBSDVersion
       pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
-    "mingw32" -> pure PlatformResult { _platform = Windows, _distroVersion = Nothing }
     what -> throwE $ NoCompatiblePlatform what
   lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
   pure pfr
  where
   getMajorVersion = T.intercalate "." . take 2 . T.split (== '.')
   getFreeBSDVersion =
-    liftIO $ fmap _stdOut $ executeOut "freebsd-version" [] Nothing
+    liftIO $ fmap _stdOut $ executeOut [rel|freebsd-version|] [] Nothing
-  getDarwinVersion = liftIO $ fmap _stdOut $ executeOut "sw_vers"
+  getDarwinVersion = liftIO $ fmap _stdOut $ executeOut [rel|sw_vers|]
                                                         ["-productVersion"]
                                                         Nothing
 
@@ -150,12 +147,12 @@ getLinuxDistro = do
    where
     regex x = makeRegexOpts compIgnoreCase execBlank ([s|\<|] ++ x ++ [s|\>|])
 
-  lsb_release_cmd :: FilePath
+  lsb_release_cmd :: Path Rel
-  lsb_release_cmd = "lsb-release"
+  lsb_release_cmd = [rel|lsb-release|]
-  redhat_release :: FilePath
+  redhat_release :: Path Abs
-  redhat_release = "/etc/redhat-release"
+  redhat_release = [abs|/etc/redhat-release|]
-  debian_version :: FilePath
+  debian_version :: Path Abs
-  debian_version = "/etc/debian_version"
+  debian_version = [abs|/etc/debian_version|]
 
   try_os_release :: IO (Text, Maybe Text)
   try_os_release = do
@@ -168,11 +165,11 @@ getLinuxDistro = do
     (Just _) <- findExecutable lsb_release_cmd
     name     <- fmap _stdOut $ executeOut lsb_release_cmd ["-si"] Nothing
     ver      <- fmap _stdOut $ executeOut lsb_release_cmd ["-sr"] Nothing
-    pure (decUTF8Safe' name, Just $ decUTF8Safe' ver)
+    pure (decUTF8Safe name, Just $ decUTF8Safe ver)
 
   try_redhat_release :: IO (Text, Maybe Text)
   try_redhat_release = do
-    t <- T.readFile redhat_release
+    t <- fmap decUTF8Safe' $ readFile redhat_release
     let nameRegex n =
           makeRegexOpts compIgnoreCase
                         execBlank
@@ -194,5 +191,5 @@ getLinuxDistro = do
 
   try_debian_version :: IO (Text, Maybe Text)
   try_debian_version = do
-    ver <- T.readFile debian_version
+    ver <- readFile debian_version
-    pure (T.pack "debian", Just ver)
+    pure (T.pack "debian", Just . decUTF8Safe' $ ver)

lib/GHCup/Requirements.hs

@@ -7,7 +7,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Requirements where
 

lib/GHCup/Types.hs

@@ -2,6 +2,10 @@
 {-# LANGUAGE CPP               #-}
 {-# LANGUAGE DeriveGeneric     #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE FlexibleInstances           #-}
+{-# LANGUAGE MultiParamTypeClasses           #-}
+{-# LANGUAGE UndecidableInstances           #-}
 
 {-|
 Module      : GHCup.Types
@@ -10,39 +14,28 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
-module GHCup.Types
+module GHCup.Types where
-  ( module GHCup.Types
-#if defined(BRICK)
-  , Key(..)
-#endif
-  )
-  where
 
 import           Data.Map.Strict                ( Map )
 import           Data.List.NonEmpty             ( NonEmpty (..) )
+import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
+import           HPath
 import           Text.PrettyPrint.HughesPJClass (Pretty, pPrint, text)
 import           URI.ByteString
-#if defined(BRICK)
-import           Graphics.Vty                   ( Key(..) )
-#endif
 
 import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified Data.Text.Encoding.Error      as E
 import qualified GHC.Generics                  as GHC
+import qualified Graphics.Vty                  as Vty
+import Haskus.Utils.Variant.Excepts
+import Control.Monad.Reader
 
 
-#if !defined(BRICK)
-data Key = KEsc  | KChar Char | KBS | KEnter
-         | KLeft | KRight | KUp | KDown
-         | KUpLeft | KUpRight | KDownLeft | KDownRight | KCenter
-         | KFun Int | KBackTab | KPrtScr | KPause | KIns
-         | KHome | KPageUp | KDel | KEnd | KPageDown | KBegin | KMenu
-    deriving (Eq,Show,Read,Ord,GHC.Generic)
-#endif
-
 
     --------------------
     --[ GHCInfo Tree ]--
@@ -97,7 +90,6 @@ data Tool = GHC
           | Cabal
           | GHCup
           | HLS
-          | Stack
   deriving (Eq, GHC.Generic, Ord, Show, Enum, Bounded)
 
 
@@ -169,15 +161,12 @@ data Platform = Linux LinuxDistro
               | Darwin
               -- ^ must exit
               | FreeBSD
-              | Windows
-              -- ^ must exit
   deriving (Eq, GHC.Generic, Ord, Show)
 
 platformToString :: Platform -> String
 platformToString (Linux distro) = "linux-" ++ distroToString distro
 platformToString Darwin = "darwin"
 platformToString FreeBSD = "freebsd"
-platformToString Windows = "windows"
 
 instance Pretty Platform where
   pPrint = text . platformToString
@@ -233,12 +222,12 @@ data DownloadInfo = DownloadInfo
 
 
 -- | How to descend into a tar archive.
-data TarDir = RealDir FilePath
+data TarDir = RealDir (Path Rel)
             | RegexDir String     -- ^ will be compiled to regex, the first match will "win"
             deriving (Eq, Ord, GHC.Generic, Show)
 
 instance Pretty TarDir where
-  pPrint (RealDir path) = text path
+  pPrint (RealDir path) = text [i|#{E.decodeUtf8With E.lenientDecode . toFilePath $ path}|]
   pPrint (RegexDir regex) = text regex
 
 
@@ -265,42 +254,39 @@ defaultUserSettings :: UserSettings
 defaultUserSettings = UserSettings Nothing Nothing Nothing Nothing Nothing Nothing Nothing
 
 data UserKeyBindings = UserKeyBindings
-  { kUp        :: Maybe Key
+  { kUp        :: Maybe Vty.Key
-  , kDown      :: Maybe Key
+  , kDown      :: Maybe Vty.Key
-  , kQuit      :: Maybe Key
+  , kQuit      :: Maybe Vty.Key
-  , kInstall   :: Maybe Key
+  , kInstall   :: Maybe Vty.Key
-  , kUninstall :: Maybe Key
+  , kUninstall :: Maybe Vty.Key
-  , kSet       :: Maybe Key
+  , kSet       :: Maybe Vty.Key
-  , kChangelog :: Maybe Key
+  , kChangelog :: Maybe Vty.Key
-  , kShowAll   :: Maybe Key
+  , kShowAll   :: Maybe Vty.Key
-  , kShowAllTools :: Maybe Key
   }
   deriving (Show, GHC.Generic)
 
 data KeyBindings = KeyBindings
-  { bUp        :: Key
+  { bUp        :: Vty.Key
-  , bDown      :: Key
+  , bDown      :: Vty.Key
-  , bQuit      :: Key
+  , bQuit      :: Vty.Key
-  , bInstall   :: Key
+  , bInstall   :: Vty.Key
-  , bUninstall :: Key
+  , bUninstall :: Vty.Key
-  , bSet       :: Key
+  , bSet       :: Vty.Key
-  , bChangelog :: Key
+  , bChangelog :: Vty.Key
-  , bShowAllVersions :: Key
+  , bShowAll   :: Vty.Key
-  , bShowAllTools :: Key
   }
   deriving (Show, GHC.Generic)
 
 defaultKeyBindings :: KeyBindings
 defaultKeyBindings = KeyBindings
-  { bUp = KUp
+  { bUp = Vty.KUp
-  , bDown = KDown
+  , bDown = Vty.KDown
-  , bQuit = KChar 'q'
+  , bQuit = Vty.KChar 'q'
-  , bInstall = KChar 'i'
+  , bInstall = Vty.KChar 'i'
-  , bUninstall = KChar 'u'
+  , bUninstall = Vty.KChar 'u'
-  , bSet = KChar 's'
+  , bSet = Vty.KChar 's'
-  , bChangelog = KChar 'c'
+  , bChangelog = Vty.KChar 'c'
-  , bShowAllVersions = KChar 'a'
+  , bShowAll = Vty.KChar 'a'
-  , bShowAllTools = KChar 't'
   }
 
 data AppState = AppState
@@ -320,11 +306,11 @@ data Settings = Settings
   deriving (Show, GHC.Generic)
 
 data Dirs = Dirs
-  { baseDir  :: FilePath
+  { baseDir  :: Path Abs
-  , binDir   :: FilePath
+  , binDir   :: Path Abs
-  , cacheDir :: FilePath
+  , cacheDir :: Path Abs
-  , logsDir  :: FilePath
+  , logsDir  :: Path Abs
-  , confDir  :: FilePath
+  , confDir  :: Path Abs
   }
   deriving Show
 
@@ -341,10 +327,10 @@ data Downloader = Curl
   deriving (Eq, Show, Ord)
 
 data DebugInfo = DebugInfo
-  { diBaseDir  :: FilePath
+  { diBaseDir  :: Path Abs
-  , diBinDir   :: FilePath
+  , diBinDir   :: Path Abs
-  , diGHCDir   :: FilePath
+  , diGHCDir   :: Path Abs
-  , diCacheDir :: FilePath
+  , diCacheDir :: Path Abs
   , diArch     :: Architecture
   , diPlatform :: PlatformResult
   }
@@ -437,3 +423,13 @@ instance Pretty Versioning where
 
 instance Pretty Version where
   pPrint = text . T.unpack . prettyVer
+
+
+    -----------------
+    --[ Instances ]--
+    -----------------
+
+instance MonadReader r' m => MonadReader r' (Excepts es m) where
+    ask   = lift ask
+    local = mapExcepts . local
+    reader = lift . reader

lib/GHCup/Types/JSON.hs

@@ -17,7 +17,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Types.JSON where
 
@@ -33,11 +33,15 @@ import           Data.List.NonEmpty             ( NonEmpty(..) )
 import           Data.Text.Encoding            as E
 import           Data.Versions
 import           Data.Void
+import           Data.Word8
+import           HPath
 import           URI.ByteString
 import           Text.Casing
 
+import qualified Data.ByteString               as BS
 import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
+import qualified Graphics.Vty                  as Vty
 import qualified Text.Megaparsec               as MP
 import qualified Text.Megaparsec.Char          as MPC
 
@@ -60,7 +64,7 @@ deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Downlo
 deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''URLSource
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "u-") . T.pack . kebab $ str' } ''UserSettings
 deriveJSON defaultOptions { fieldLabelModifier = \str' -> maybe str' T.unpack . T.stripPrefix (T.pack "k-") . T.pack . kebab $ str' } ''UserKeyBindings
-deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Key
+deriveJSON defaultOptions { sumEncoding = ObjectWithSingleField } ''Vty.Key
 
 instance ToJSON Tag where
   toJSON Latest             = String "Latest"
@@ -124,13 +128,11 @@ instance ToJSONKey Platform where
     Darwin  -> T.pack "Darwin"
     FreeBSD -> T.pack "FreeBSD"
     Linux d -> T.pack ("Linux_" <> show d)
-    Windows -> T.pack "Windows"
 
 instance FromJSONKey Platform where
   fromJSONKey = FromJSONKeyTextParser $ \t -> if
     | T.pack "Darwin" == t -> pure Darwin
     | T.pack "FreeBSD" == t -> pure FreeBSD
-    | T.pack "Windows" == t -> pure Windows
     | T.pack "Linux_" `T.isPrefixOf` t -> case
         T.stripPrefix (T.pack "Linux_") t
       of
@@ -197,6 +199,20 @@ instance ToJSONKey Tool where
 instance FromJSONKey Tool where
   fromJSONKey = genericFromJSONKey defaultJSONKeyOptions
 
+instance ToJSON (Path Rel) where
+  toJSON p = case and . fmap isAscii . BS.unpack $ fp of
+    True  -> toJSON . decUTF8Safe $ fp
+    False -> String "/not/a/valid/path"
+    where fp = toFilePath p
+
+instance FromJSON (Path Rel) where
+  parseJSON = withText "HPath Rel" $ \t -> do
+    let d = encodeUtf8 t
+    case parseRel d of
+      Right x -> pure x
+      Left  e -> fail $ "Failure in HPath Rel (FromJSON)" <> show e
+
+
 instance ToJSON TarDir where
   toJSON (RealDir  p) = toJSON p
   toJSON (RegexDir r) = object ["RegexDir" .= r]

lib/GHCup/Types/Optics.hs

@@ -7,7 +7,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Types.Optics where
 

lib/GHCup/Utils.hs

@@ -14,7 +14,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 
 This module contains GHCup helpers specific to
 installation and introspection of files/versions etc.
@@ -39,7 +39,6 @@ import           GHCup.Utils.String.QQ
 #if !defined(TAR)
 import           Codec.Archive           hiding ( Directory )
 #endif
-import           Codec.Archive.Zip
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
@@ -52,21 +51,28 @@ import           Data.ByteString                ( ByteString )
 import           Data.Either
 import           Data.Foldable
 import           Data.List
-import           Data.List.Extra
 import           Data.List.NonEmpty             ( NonEmpty( (:|) ))
+import           Data.List.Split
 import           Data.Maybe
 import           Data.String.Interpolate
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Data.Word8
 import           GHC.IO.Exception
+import           HPath
+import           HPath.IO                hiding ( hideError )
 import           Haskus.Utils.Variant.Excepts
 import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
 import           Safe
-import           System.Directory      hiding   ( findFiles )
-import           System.FilePath
 import           System.IO.Error
-import           System.IO.Unsafe               ( unsafeInterleaveIO )
+import           System.Posix.FilePath          ( getSearchPath
+                                                , takeFileName
+                                                )
+import           System.Posix.Files.ByteString  ( readSymbolicLink )
 import           Text.Regex.Posix
 import           URI.ByteString
 
@@ -79,9 +85,15 @@ import qualified Codec.Compression.Lzma        as Lzma
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as BL
 import qualified Data.Map.Strict               as Map
+#if !defined(TAR)
 import qualified Data.Text                     as T
+#endif
 import qualified Data.Text.Encoding            as E
 import qualified Text.Megaparsec               as MP
+import System.Console.Regions
+import Data.Sequence (Seq)
+import qualified Data.Sequence as Sq
+import Control.Concurrent
 
 
 
@@ -94,13 +106,14 @@ import qualified Text.Megaparsec               as MP
 
 -- | The symlink destination of a ghc tool.
 ghcLinkDestination :: (MonadReader AppState m, MonadThrow m, MonadIO m)
-                   => FilePath -- ^ the tool, such as 'ghc', 'haddock' etc.
+                   => ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
                    -> GHCTargetVersion
-                   -> m FilePath
+                   -> m ByteString
 ghcLinkDestination tool ver = do
   AppState { dirs = Dirs {..} } <- ask
+  t <- parseRel tool
   ghcd <- ghcupGHCDir ver
-  pure (relativeSymlink binDir (ghcd </> "bin" </> tool))
+  pure (relativeSymlink binDir (ghcd </> [rel|bin|] </> t))
 
 
 -- | Removes the minor GHC symlinks, e.g. ghc-8.6.5.
@@ -118,10 +131,10 @@ rmMinorSymlinks tv@GHCTargetVersion{..} = do
 
   files                         <- liftE $ ghcToolFiles tv
   forM_ files $ \f -> do
-    let f_xyz = f <> "-" <> T.unpack (prettyVer _tvVersion) <> exeExt
+    f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> verToBS _tvVersion)
     let fullF = binDir </> f_xyz
-    lift $ $(logDebug) [i|rm -f #{fullF}|]
+    lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ removeFile fullF
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
 
 
 -- | Removes the set ghc version for the given target, if any.
@@ -139,13 +152,13 @@ rmPlain target = do
   forM_ mtv $ \tv -> do
     files <- liftE $ ghcToolFiles tv
     forM_ files $ \f -> do
-      let fullF = binDir </> f <> exeExt
+      let fullF = binDir </> f
-      lift $ $(logDebug) [i|rm -f #{fullF}|]
+      lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
-      liftIO $ hideError doesNotExistErrorType $ removeFile fullF
+      liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
     -- old ghcup
-    let hdc_file = binDir </> "haddock-ghc" <> exeExt
+    let hdc_file = binDir </> [rel|haddock-ghc|]
-    lift $ $(logDebug) [i|rm -f #{hdc_file}|]
+    lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
-    liftIO $ hideError doesNotExistErrorType $ removeFile hdc_file
+    liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
 
 
 -- | Remove the major GHC symlink, e.g. ghc-8.6.
@@ -165,10 +178,10 @@ rmMajorSymlinks tv@GHCTargetVersion{..} = do
 
   files                         <- liftE $ ghcToolFiles tv
   forM_ files $ \f -> do
-    let f_xy = f <> "-" <> T.unpack v' <> exeExt
+    f_xyz <- liftIO $ parseRel (toFilePath f <> B.singleton _hyphen <> E.encodeUtf8 v')
-    let fullF = binDir </> f_xy
+    let fullF = binDir </> f_xyz
-    lift $ $(logDebug) [i|rm -f #{fullF}|]
+    lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
-    liftIO $ hideError doesNotExistErrorType $ removeFile fullF
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
 
 
 
@@ -199,40 +212,42 @@ ghcSet :: (MonadReader AppState m, MonadThrow m, MonadIO m)
        -> m (Maybe GHCTargetVersion)
 ghcSet mtarget = do
   AppState {dirs = Dirs {..}} <- ask
-  let ghc = maybe "ghc" (\t -> T.unpack t <> "-ghc") mtarget
+  ghc    <- parseRel $ E.encodeUtf8 (maybe "ghc" (<> "-ghc") mtarget)
-  let ghcBin = binDir </> ghc <> exeExt
+  let ghcBin = binDir </> ghc
 
   -- link destination is of the form ../ghc/<ver>/bin/ghc
   -- for old ghcup, it is ../ghc/<ver>/bin/ghc-<ver>
   liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-    link <- liftIO $ getSymbolicLinkTarget ghcBin
+    link <- readSymbolicLink $ toFilePath ghcBin
     Just <$> ghcLinkVersion link
 
-ghcLinkVersion :: MonadThrow m => FilePath -> m GHCTargetVersion
+ghcLinkVersion :: MonadThrow m => ByteString -> m GHCTargetVersion
-ghcLinkVersion (T.pack . dropSuffix exeExt -> t) = throwEither $ MP.parse parser "ghcLinkVersion" t
+ghcLinkVersion bs = do
+  t <- throwEither $ E.decodeUtf8' bs
+  throwEither $ MP.parse parser "ghcLinkVersion" t
  where
   parser =
       (do
-         _    <- parseUntil1 ghcSubPath
+         _    <- parseUntil1 (MP.chunk "/ghc/")
-         _    <- ghcSubPath
+         _    <- MP.chunk "/ghc/"
-         r    <- parseUntil1 pathSep
+         r    <- parseUntil1 (MP.chunk "/")
          rest <- MP.getInput
          MP.setInput r
          x <- ghcTargetVerP
          MP.setInput rest
          pure x
        )
-      <* pathSep
+      <* MP.chunk "/"
       <* MP.takeRest
       <* MP.eof
-  ghcSubPath = pathSep <* MP.chunk "ghc" *> pathSep
+
 
 -- | Get all installed GHCs by reading ~/.ghcup/ghc/<dir>.
 -- If a dir cannot be parsed, returns left.
-getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either FilePath GHCTargetVersion]
+getInstalledGHCs :: (MonadReader AppState m, MonadIO m) => m [Either (Path Rel) GHCTargetVersion]
 getInstalledGHCs = do
   ghcdir <- ghcupGHCBaseDir
-  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ listDirectory ghcdir
+  fs     <- liftIO $ hideErrorDef [NoSuchThing] [] $ getDirsFiles' ghcdir
   forM fs $ \f -> case parseGHCupGHCDir f of
     Right r -> pure $ Right r
     Left  _ -> pure $ Left f
@@ -240,7 +255,7 @@ getInstalledGHCs = do
 
 -- | Get all installed cabals, by matching on @~\/.ghcup\/bin/cabal-*@.
 getInstalledCabals :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
-                   => m [Either FilePath Version]
+                   => m [Either (Path Rel) Version]
 getInstalledCabals = do
   cs <- cabalSet -- for legacy cabal
   getInstalledCabals' cs
@@ -248,13 +263,13 @@ getInstalledCabals = do
 
 getInstalledCabals' :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadCatch m)
                    => Maybe Version
-                   -> m [Either FilePath Version]
+                   -> m [Either (Path Rel) Version]
 getInstalledCabals' cs = do
   AppState {dirs = Dirs {..}} <- ask
   bins   <- liftIO $ handleIO (\_ -> pure []) $ findFiles
     binDir
     (makeRegexOpts compExtended execBlank ([s|^cabal-.*$|] :: ByteString))
-  vs <- forM bins $ \f -> case fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "cabal-" $ f of
+  vs <- forM bins $ \f -> case fmap (version . decUTF8Safe) . B.stripPrefix "cabal-" . toFilePath $ f of
     Just (Right r) -> pure $ Right r
     Just (Left  _) -> pure $ Left f
     Nothing        -> pure $ Left f
@@ -272,20 +287,22 @@ cabalInstalled ver = do
 cabalSet :: (MonadLogger m, MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
 cabalSet = do
   AppState {dirs = Dirs {..}} <- ask
-  let cabalbin = binDir </> "cabal" <> exeExt
+  let cabalbin = binDir </> [rel|cabal|]
-  b        <- handleIO (\_ -> pure False) $ liftIO $ pathIsSymbolicLink cabalbin
+  b        <- handleIO (\_ -> pure False) $ fmap (== SymbolicLink) $ liftIO $ getFileType cabalbin
   if
     | b -> do
       handleIO' NoSuchThing (\_ -> pure Nothing) $ do
         broken <- liftIO $ isBrokenSymlink cabalbin
         if broken
-          then pure Nothing
+          then do
+            $(logWarn) [i|Symlink #{cabalbin} is broken.|]
+            pure Nothing
           else do
-            link <- liftIO $ getSymbolicLinkTarget cabalbin
+            link <- liftIO $ readSymbolicLink $ toFilePath cabalbin
             case linkVersion link of
               Right v -> pure $ Just v
               Left err -> do
-                $(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
+                $(logWarn) [i|Failed to parse cabal symlink target with: "#{err}". The symlink #{toFilePath cabalbin} needs to point to valid cabal binary, such as 'cabal-3.4.0.0'.|]
                 pure Nothing
     | otherwise -> do -- legacy behavior
       mc <- liftIO $ handleIO (\_ -> pure Nothing) $ fmap Just $ executeOut
@@ -293,8 +310,8 @@ cabalSet = do
         ["--numeric-version"]
         Nothing
       fmap join $ forM mc $ \c -> if
-        | not (BL.null (_stdOut c)), _exitCode c == ExitSuccess -> do
+        | not (B.null (_stdOut c)), _exitCode c == ExitSuccess -> do
-          let reportedVer = fst . B.spanEnd (== _lf) . BL.toStrict . _stdOut $ c
+          let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ c
           case version $ decUTF8Safe reportedVer of
             Left  e -> throwM e
             Right r -> pure $ Just r
@@ -303,8 +320,10 @@ cabalSet = do
   -- We try to be extra permissive with link destination parsing,
   -- because of:
   --   https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/119
-  linkVersion :: MonadThrow m => FilePath -> m Version
+  linkVersion :: MonadThrow m => ByteString -> m Version
-  linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
+  linkVersion bs = do
+    t <- throwEither $ E.decodeUtf8' bs
+    throwEither $ MP.parse parser "" t
 
   parser
     =   MP.try (stripAbsolutePath *> cabalParse)
@@ -314,10 +333,10 @@ cabalSet = do
   cabalParse = MP.chunk "cabal-" *> version'
   -- parses any path component ending with path separator,
   -- e.g. "foo/"
-  stripPathComponet = parseUntil1 pathSep *> pathSep
+  stripPathComponet = parseUntil1 "/" *> MP.chunk "/"
   -- parses an absolute path up until the last path separator,
   -- e.g. "/bar/baz/foo" -> "/bar/baz/", leaving "foo"
-  stripAbsolutePath = pathSep *> MP.many (MP.try stripPathComponet)
+  stripAbsolutePath = MP.chunk "/" *> MP.many (MP.try stripPathComponet)
   -- parses a relative path up until the last path separator,
   -- e.g. "bar/baz/foo" -> "bar/baz/", leaving "foo"
   stripRelativePath = MP.many (MP.try stripPathComponet)
@@ -327,7 +346,7 @@ cabalSet = do
 -- | Get all installed hls, by matching on
 -- @~\/.ghcup\/bin/haskell-language-server-wrapper-<\hlsver\>@.
 getInstalledHLSs :: (MonadReader AppState m, MonadIO m, MonadCatch m)
-                 => m [Either FilePath Version]
+                 => m [Either (Path Rel) Version]
 getInstalledHLSs = do
   AppState { dirs = Dirs {..} } <- ask
   bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -338,58 +357,12 @@ getInstalledHLSs = do
     )
   forM bins $ \f ->
     case
-          fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "haskell-language-server-wrapper-" $ f
+          fmap (version . decUTF8Safe) . B.stripPrefix "haskell-language-server-wrapper-" . toFilePath $ f
       of
         Just (Right r) -> pure $ Right r
         Just (Left  _) -> pure $ Left f
         Nothing        -> pure $ Left f
 
--- | Get all installed stacks, by matching on
--- @~\/.ghcup\/bin/stack-<\stackver\>@.
-getInstalledStacks :: (MonadReader AppState m, MonadIO m, MonadCatch m)
-                   => m [Either FilePath Version]
-getInstalledStacks = do
-  AppState { dirs = Dirs {..} } <- ask
-  bins                          <- liftIO $ handleIO (\_ -> pure []) $ findFiles
-    binDir
-    (makeRegexOpts compExtended
-                   execBlank
-                   ([s|^stack-.*$|] :: ByteString)
-    )
-  forM bins $ \f ->
-    case
-          fmap (version . T.pack . dropSuffix exeExt) . stripPrefix "stack-" $ f
-      of
-        Just (Right r) -> pure $ Right r
-        Just (Left  _) -> pure $ Left f
-        Nothing        -> pure $ Left f
-
--- Return the currently set stack version, if any.
--- TODO: there's a lot of code duplication here :>
-stackSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
-stackSet = do
-  AppState {dirs = Dirs {..}} <- ask
-  let stackBin = binDir </> "stack" <> exeExt
-
-  liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
-    broken <- isBrokenSymlink stackBin
-    if broken
-      then pure Nothing
-      else do
-        link <- liftIO $ getSymbolicLinkTarget stackBin
-        Just <$> linkVersion link
- where
-  linkVersion :: MonadThrow m => FilePath -> m Version
-  linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
-   where
-    parser =
-      MP.chunk "stack-" *> version'
-
--- | Whether the given Stack version is installed.
-stackInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
-stackInstalled ver = do
-  vers <- fmap rights getInstalledStacks
-  pure $ elem ver vers
 
 -- | Whether the given HLS version is installed.
 hlsInstalled :: (MonadIO m, MonadReader AppState m, MonadCatch m) => Version -> m Bool
@@ -403,18 +376,20 @@ hlsInstalled ver = do
 hlsSet :: (MonadReader AppState m, MonadIO m, MonadThrow m, MonadCatch m) => m (Maybe Version)
 hlsSet = do
   AppState {dirs = Dirs {..}} <- ask
-  let hlsBin = binDir </> "haskell-language-server-wrapper" <> exeExt
+  let hlsBin = binDir </> [rel|haskell-language-server-wrapper|]
 
   liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ do
     broken <- isBrokenSymlink hlsBin
     if broken
       then pure Nothing
       else do
-        link <- liftIO $ getSymbolicLinkTarget hlsBin
+        link <- readSymbolicLink $ toFilePath hlsBin
         Just <$> linkVersion link
  where
-  linkVersion :: MonadThrow m => FilePath -> m Version
+  linkVersion :: MonadThrow m => ByteString -> m Version
-  linkVersion = throwEither . MP.parse parser "" . T.pack . dropSuffix exeExt
+  linkVersion bs = do
+    t <- throwEither $ E.decodeUtf8' bs
+    throwEither $ MP.parse parser "" t
    where
     parser =
       MP.chunk "haskell-language-server-wrapper-" *> version'
@@ -433,12 +408,13 @@ hlsGHCVersions = do
     bins <- hlsServerBinaries h'
     pure $ fmap
       (version
-        . T.pack
+        . decUTF8Safe
         . fromJust
-        . stripPrefix "haskell-language-server-"
+        . B.stripPrefix "haskell-language-server-"
         . head
-        . splitOn "~"
+        . B.split _tilde
-        )
+        . toFilePath
+      )
       bins
   pure . rights . concat . maybeToList $ vers
 
@@ -446,7 +422,7 @@ hlsGHCVersions = do
 -- | Get all server binaries for an hls version, if any.
 hlsServerBinaries :: (MonadReader AppState m, MonadIO m)
                   => Version
-                  -> m [FilePath]
+                  -> m [Path Rel]
 hlsServerBinaries ver = do
   AppState { dirs = Dirs {..} } <- ask
   liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -454,7 +430,7 @@ hlsServerBinaries ver = do
     (makeRegexOpts
       compExtended
       execBlank
-      ([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
+      ([s|^haskell-language-server-.*~|] <> escapeVerRex ver <> [s|$|] :: ByteString
       )
     )
 
@@ -462,7 +438,7 @@ hlsServerBinaries ver = do
 -- | Get the wrapper binary for an hls version, if any.
 hlsWrapperBinary :: (MonadReader AppState m, MonadThrow m, MonadIO m)
                  => Version
-                 -> m (Maybe FilePath)
+                 -> m (Maybe (Path Rel))
 hlsWrapperBinary ver = do
   AppState { dirs = Dirs {..} } <- ask
   wrapper                       <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -470,7 +446,7 @@ hlsWrapperBinary ver = do
     (makeRegexOpts
       compExtended
       execBlank
-      ([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> E.encodeUtf8 (T.pack exeExt) <> [s|$|] :: ByteString
+      ([s|^haskell-language-server-wrapper-|] <> escapeVerRex ver <> [s|$|] :: ByteString
       )
     )
   case wrapper of
@@ -481,7 +457,7 @@ hlsWrapperBinary ver = do
 
 
 -- | Get all binaries for an hls version, if any.
-hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [FilePath]
+hlsAllBinaries :: (MonadReader AppState m, MonadIO m, MonadThrow m) => Version -> m [Path Rel]
 hlsAllBinaries ver = do
   hls     <- hlsServerBinaries ver
   wrapper <- hlsWrapperBinary ver
@@ -489,7 +465,7 @@ hlsAllBinaries ver = do
 
 
 -- | Get the active symlinks for hls.
-hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [FilePath]
+hlsSymlinks :: (MonadReader AppState m, MonadIO m, MonadCatch m) => m [Path Rel]
 hlsSymlinks = do
   AppState { dirs = Dirs {..} } <- ask
   oldSyms                       <- liftIO $ handleIO (\_ -> pure []) $ findFiles
@@ -499,8 +475,9 @@ hlsSymlinks = do
                    ([s|^haskell-language-server-.*$|] :: ByteString)
     )
   filterM
-    ( liftIO
+    ( fmap (== SymbolicLink)
-    . pathIsSymbolicLink
+    . liftIO
+    . getFileType
     . (binDir </>)
     )
     oldSyms
@@ -564,61 +541,61 @@ getLatestGHCFor major' minor' dls =
 
 -- | Unpack an archive to a temporary directory and return that path.
 unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
-            => FilePath       -- ^ destination dir
+            => Path Abs       -- ^ destination dir
-            -> FilePath       -- ^ archive path
+            -> Path Abs       -- ^ archive path
             -> Excepts '[UnknownArchive
 #if !defined(TAR)
                         , ArchiveResult
 #endif
                         ] m ()
-unpackToDir dfp av = do
+unpackToDir dest av = do
-  let fn = takeFileName av
+  fp <- decUTF8Safe . toFilePath <$> basename av
-  lift $ $(logInfo) [i|Unpacking: #{fn} to #{dfp}|]
+  let dfp = decUTF8Safe . toFilePath $ dest
+  lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
+  fn <- toFilePath <$> basename av
 
 #if defined(TAR)
   let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
-      untar = liftIO . Tar.unpack dfp . Tar.read
+      untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
 
-      rf :: MonadIO m => FilePath -> Excepts '[] m BL.ByteString
+      rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
-      rf = liftIO . BL.readFile
+      rf = liftIO . readFile
 #else
   let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
-      untar = lEM . liftIO . runArchiveM . unpackToDirLazy dfp
+      untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
 
-      rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
+      rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
-      rf = liftIO . BL.readFile
+      rf = liftIO . readFile
 #endif
 
   -- extract, depending on file extension
   if
-    | ".tar.gz" `isSuffixOf` fn -> liftE
+    | ".tar.gz" `B.isSuffixOf` fn -> liftE
       (untar . GZip.decompress =<< rf av)
-    | ".tar.xz" `isSuffixOf` fn -> do
+    | ".tar.xz" `B.isSuffixOf` fn -> do
       filecontents <- liftE $ rf av
       let decompressed = Lzma.decompress filecontents
       liftE $ untar decompressed
-    | ".tar.bz2" `isSuffixOf` fn ->
+    | ".tar.bz2" `B.isSuffixOf` fn ->
       liftE (untar . BZip.decompress =<< rf av)
-    | ".tar" `isSuffixOf` fn -> liftE (untar =<< rf av)
+    | ".tar" `B.isSuffixOf` fn -> liftE (untar =<< rf av)
-    | ".zip" `isSuffixOf` fn ->
-      withArchive av (unpackInto dfp)
     | otherwise -> throwE $ UnknownArchive fn
 
 
 getArchiveFiles :: (MonadLogger m, MonadIO m, MonadThrow m)
-                => FilePath       -- ^ archive path
+                => Path Abs       -- ^ archive path
                 -> Excepts '[UnknownArchive
 #if defined(TAR)
                             , Tar.FormatError
 #else
                             , ArchiveResult
 #endif
-                            ] m [FilePath]
+                            ] m [ByteString]
 getArchiveFiles av = do
-  let fn = takeFileName av
+  fn <- toFilePath <$> basename av
 
 #if defined(TAR)
-  let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [FilePath]
+  let entries :: Monad m => BL.ByteString -> Excepts '[Tar.FormatError] m [ByteString]
       entries =
           lE @Tar.FormatError
           . Tar.foldEntries
@@ -627,45 +604,41 @@ getArchiveFiles av = do
             (\e -> Left e)
           . Tar.read
 
-      rf :: MonadIO m => FilePath -> Excepts '[Tar.FormatError] m BL.ByteString
+      rf :: MonadIO m => Path Abs -> Excepts '[Tar.FormatError] m BL.ByteString
-      rf = liftIO . BL.readFile
+      rf = liftIO . readFile
 #else
-  let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [FilePath]
+  let entries :: Monad m => BL.ByteString -> Excepts '[ArchiveResult] m [ByteString]
-      entries = (fmap . fmap) filepath . lE . readArchiveBSL
+      entries = (fmap . fmap) (E.encodeUtf8 . T.pack . filepath) . lE . readArchiveBSL
 
-      rf :: MonadIO m => FilePath -> Excepts '[ArchiveResult] m BL.ByteString
+      rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
-      rf = liftIO . BL.readFile
+      rf = liftIO . readFile
 #endif
 
   -- extract, depending on file extension
   if
-    | ".tar.gz" `isSuffixOf` fn -> liftE
+    | ".tar.gz" `B.isSuffixOf` fn -> liftE
       (entries . GZip.decompress =<< rf av)
-    | ".tar.xz" `isSuffixOf` fn -> do
+    | ".tar.xz" `B.isSuffixOf` fn -> do
       filecontents <- liftE $ rf av
       let decompressed = Lzma.decompress filecontents
       liftE $ entries decompressed
-    | ".tar.bz2" `isSuffixOf` fn ->
+    | ".tar.bz2" `B.isSuffixOf` fn ->
       liftE (entries . BZip.decompress =<< rf av)
-    | ".tar" `isSuffixOf` fn -> liftE (entries =<< rf av)
+    | ".tar" `B.isSuffixOf` fn -> liftE (entries =<< rf av)
-    | ".zip" `isSuffixOf` fn ->
-      withArchive av $ do
-        entries' <- getEntries
-        pure $ fmap unEntrySelector $ Map.keys entries'
     | otherwise -> throwE $ UnknownArchive fn
 
 
 intoSubdir :: (MonadLogger m, MonadIO m, MonadThrow m, MonadCatch m)
-           => FilePath       -- ^ unpacked tar dir
+           => Path Abs       -- ^ unpacked tar dir
            -> TarDir         -- ^ how to descend
-           -> Excepts '[TarDirDoesNotExist] m FilePath
+           -> Excepts '[TarDirDoesNotExist] m (Path Abs)
 intoSubdir bdir tardir = case tardir of
   RealDir pr -> do
     whenM (fmap not . liftIO . doesDirectoryExist $ (bdir </> pr))
           (throwE $ TarDirDoesNotExist tardir)
     pure (bdir </> pr)
   RegexDir r -> do
-    let rs = split (`elem` pathSeparators) r
+    let rs = splitOn "/" r
     foldlM
       (\y x ->
         (handleIO (\_ -> pure []) . liftIO . findFiles y . regex $ x) >>= (\case
@@ -726,124 +699,119 @@ getDownloader = ask <&> downloader . settings
     -------------
 
 
-urlBaseName :: ByteString  -- ^ the url path (without scheme and host)
+urlBaseName :: MonadThrow m
-            -> ByteString
+            => ByteString  -- ^ the url path (without scheme and host)
-urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
+            -> m (Path Rel)
+urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
 
 
 -- | Get tool files from @~\/.ghcup\/bin\/ghc\/\<ver\>\/bin\/\*@
 -- while ignoring @*-\<ver\>@ symlinks and accounting for cross triple prefix.
 --
--- Returns unversioned relative files without extension, e.g.:
+-- Returns unversioned relative files, e.g.:
 --
 --   - @["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]@
 ghcToolFiles :: (MonadReader AppState m, MonadThrow m, MonadFail m, MonadIO m)
              => GHCTargetVersion
-             -> Excepts '[NotInstalled] m [FilePath]
+             -> Excepts '[NotInstalled] m [Path Rel]
 ghcToolFiles ver = do
   ghcdir <- lift $ ghcupGHCDir ver
-  let bindir = ghcdir </> "bin"
+  let bindir = ghcdir </> [rel|bin|]
 
   -- fail if ghc is not installed
   whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
         (throwE (NotInstalled GHC ver))
 
-  files    <- liftIO $ listDirectory bindir
+  files    <- liftIO $ getDirsFiles' bindir
   -- figure out the <ver> suffix, because this might not be `Version` for
   -- alpha/rc releases, but x.y.a.somedate.
 
-  ghcIsHadrian    <- liftIO $ isHadrian bindir
+  -- for cross, this won't be "ghc", but e.g.
-  onlyUnversioned <- case ghcIsHadrian of
+  -- "armv7-unknown-linux-gnueabihf-ghc"
-    Right () -> pure id
+  [ghcbin] <- liftIO $ findFiles
-    Left (fmap (dropSuffix exeExt) -> [ghc, ghc_ver])
+    bindir
-      | (Just symver) <- stripPrefix (ghc <> "-") ghc_ver
+    (makeRegexOpts compExtended
-      , not (null symver) -> pure $ filter (\x -> not $ symver `isInfixOf` x)
+                   execBlank
-    _ -> fail "Fatal: Could not find internal GHC version"
+                   ([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc$|] :: ByteString)
+    )
 
-  pure $ onlyUnversioned $ fmap (dropSuffix exeExt) files
+  let ghcbinPath = bindir </> ghcbin
+  ghcIsHadrian    <- liftIO $ isHadrian ghcbinPath
+  onlyUnversioned <- if ghcIsHadrian
+    then pure id
+    else do
+      (Just symver) <-
+        B.stripPrefix (toFilePath ghcbin <> "-") . takeFileName
+          <$> liftIO (readSymbolicLink $ toFilePath ghcbinPath)
+      when (B.null symver)
+           (throwIO $ userError "Fatal: ghc symlink target is broken")
+      pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x)
+
+  pure $ onlyUnversioned files
  where
-  isNotAnyInfix xs t = foldr (\a b -> not (a `isInfixOf` t) && b) True xs
     -- GHC is moving some builds to Hadrian for bindists,
     -- which doesn't create versioned binaries.
     -- https://gitlab.haskell.org/haskell/ghcup-hs/issues/31
-  isHadrian :: FilePath -- ^ ghcbin path
+  isHadrian :: Path Abs -- ^ ghcbin path
-            -> IO (Either [String] ()) -- ^ Right for Hadrian
+            -> IO Bool
-  isHadrian dir = do
+  isHadrian = fmap (/= SymbolicLink) . getFileType
-    -- Non-hadrian has e.g. ["ghc", "ghc-8.10.4"]
-    -- which also requires us to discover the internal version
-    -- to filter the correct tool files.
-    -- We can't use the symlink on windows, so we fall back to some
-    -- more complicated logic.
-    fs <- fmap
-         -- regex over-matches
-         (filter (isNotAnyInfix ["haddock", "ghc-pkg", "ghci"]))
-       $ liftIO $ findFiles
-      dir
-      (makeRegexOpts compExtended
-                     execBlank
-                     -- for cross, this won't be "ghc", but e.g.
-                     -- "armv7-unknown-linux-gnueabihf-ghc"
-                     ([s|^([a-zA-Z0-9_-]*[a-zA-Z0-9_]-)?ghc.*$|] :: ByteString)
-      )
-    if | length fs == 1 -> pure $ Right ()        -- hadrian
-       | length fs == 2 -> pure $ Left
-                              (sortOn length fs)  -- legacy make, result should
-                                                  -- be ["ghc", "ghc-8.10.4"]
-       | otherwise      -> fail "isHadrian failed!"
-
 
 
 -- | This file, when residing in @~\/.ghcup\/ghc\/\<ver\>\/@ signals that
 -- this GHC was built from source. It contains the build config.
-ghcUpSrcBuiltFile :: FilePath
+ghcUpSrcBuiltFile :: Path Rel
-ghcUpSrcBuiltFile = ".ghcup_src_built"
+ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
 
 
 -- | Calls gmake if it exists in PATH, otherwise make.
-make :: (MonadThrow m, MonadIO m, MonadReader AppState m)
+make :: (MonadThrow m, MonadIO m, MonadReader AppState m, MonadMask m)
-     => [String]
+     => [ByteString]
-     -> Maybe FilePath
+     -> Maybe (Path Abs)
+     -> MVar Bool
+     -> Seq ConsoleRegion
      -> m (Either ProcessError ())
-make args workdir = do
+make args workdir pState rs = do
-  spaths    <- liftIO getSearchPath
+  spaths    <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
-  has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
+  has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
   let mymake = if has_gmake then "gmake" else "make"
-  execLogged mymake args workdir "ghc-make" Nothing
+  execLogged mymake True args [rel|ghc-make|] workdir Nothing pState rs
 
-makeOut :: [String]
+makeOut :: [ByteString]
-        -> Maybe FilePath
+        -> Maybe (Path Abs)
         -> IO CapturedProcess
 makeOut args workdir = do
-  spaths    <- liftIO getSearchPath
+  spaths    <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
-  has_gmake <- isJust <$> liftIO (searchPath spaths "gmake")
+  has_gmake <- isJust <$> liftIO (searchPath spaths [rel|gmake|])
-  let mymake = if has_gmake then "gmake" else "make"
+  let mymake = if has_gmake then [rel|gmake|] else [rel|make|]
   liftIO $ executeOut mymake args workdir
 
 
 -- | Try to apply patches in order. Fails with 'PatchFailed'
 -- on first failure.
 applyPatches :: (MonadLogger m, MonadIO m)
-             => FilePath   -- ^ dir containing patches
+             => Path Abs   -- ^ dir containing patches
-             -> FilePath   -- ^ dir to apply patches in
+             -> Path Abs   -- ^ dir to apply patches in
              -> Excepts '[PatchFailed] m ()
 applyPatches pdir ddir = do
-  patches <- (fmap . fmap) (pdir </>) $ liftIO $ listDirectory pdir
+  patches <- liftIO $ getDirsFiles pdir
   forM_ (sort patches) $ \patch' -> do
     lift $ $(logInfo) [i|Applying patch #{patch'}|]
     fmap (either (const Nothing) Just)
          (liftIO $ exec
            "patch"
-           ["-p1", "-i", patch']
+           True
+           ["-p1", "-i", toFilePath patch']
            (Just ddir)
            Nothing)
       !? PatchFailed
 
 
 -- | https://gitlab.haskell.org/ghc/ghc/-/issues/17353
-darwinNotarization :: Platform -> FilePath -> IO (Either ProcessError ())
+darwinNotarization :: Platform -> Path Abs -> IO (Either ProcessError ())
 darwinNotarization Darwin path = exec
   "xattr"
-  ["-r", "-d", "com.apple.quarantine", path]
+  True
+  ["-r", "-d", "com.apple.quarantine", toFilePath path]
   Nothing
   Nothing
 darwinNotarization _ _ = pure $ Right ()
@@ -861,19 +829,19 @@ getChangeLog dls tool (Right tag) =
 --   1. the build directory, depending on the KeepDirs setting
 --   2. the install destination, depending on whether the build failed
 runBuildAction :: (Show (V e), MonadReader AppState m, MonadIO m, MonadMask m)
-               => FilePath          -- ^ build directory (cleaned up depending on Settings)
+               => Path Abs          -- ^ build directory (cleaned up depending on Settings)
-               -> Maybe FilePath  -- ^ dir to *always* clean up on exception
+               -> Maybe (Path Abs)  -- ^ dir to *always* clean up on exception
                -> Excepts e m a
                -> Excepts '[BuildFailed] m a
 runBuildAction bdir instdir action = do
   AppState { settings = Settings {..} } <- lift ask
   let exAction = do
         forM_ instdir $ \dir ->
-          liftIO $ hideError doesNotExistErrorType $ removeDirectoryRecursive dir
+          liftIO $ hideError doesNotExistErrorType $ deleteDirRecursive dir
         when (keepDirs == Never)
           $ liftIO
           $ hideError doesNotExistErrorType
-          $ removeDirectoryRecursive bdir
+          $ deleteDirRecursive bdir
   v <-
     flip onException exAction
     $ catchAllE
@@ -882,90 +850,32 @@ runBuildAction bdir instdir action = do
           throwE (BuildFailed bdir es)
         ) action
 
-  when (keepDirs == Never || keepDirs == Errors) $ liftIO $ removeDirectoryRecursive
+  when (keepDirs == Never || keepDirs == Errors) $ liftIO $ deleteDirRecursive
     bdir
   pure v
 
 
 -- | More permissive version of 'createDirRecursive'. This doesn't
 -- error when the destination is a symlink to a directory.
-createDirRecursive' :: FilePath -> IO ()
+createDirRecursive' :: Path b -> IO ()
 createDirRecursive' p =
   handleIO (\e -> if isAlreadyExistsError e then isSymlinkDir e else throwIO e)
-    . createDirectoryIfMissing True
+    . createDirRecursive newDirPerms
     $ p
 
  where
   isSymlinkDir e = do
-    ft <- pathIsSymbolicLink p
+    ft <- getFileType p
     case ft of
-      True -> do
+      SymbolicLink -> do
         rp <- canonicalizePath p
-        rft <- doesDirectoryExist rp
+        rft <- getFileType rp
         case rft of
-          True -> pure ()
+          Directory -> pure ()
           _ -> throwIO e
       _ -> throwIO e
 
 
--- | Recursively copy the contents of one directory to another path.
---
--- This is a rip-off of Cabal library.
-copyDirectoryRecursive :: FilePath -> FilePath -> IO ()
-copyDirectoryRecursive srcDir destDir = do
-  srcFiles <- getDirectoryContentsRecursive srcDir
-  copyFilesWith copyFile destDir [ (srcDir, f)
-                                   | f <- srcFiles ]
-  where
-    -- | Common implementation of 'copyFiles', 'installOrdinaryFiles',
-    -- 'installExecutableFiles' and 'installMaybeExecutableFiles'.
-    copyFilesWith :: (FilePath -> FilePath -> IO ())
-                  -> FilePath -> [(FilePath, FilePath)] -> IO ()
-    copyFilesWith doCopy targetDir srcFiles = do
-
-      -- Create parent directories for everything
-      let dirs = map (targetDir </>) . nub . map (takeDirectory . snd) $ srcFiles
-      traverse_ (createDirectoryIfMissing True) dirs
-
-      -- Copy all the files
-      sequence_ [ let src  = srcBase   </> srcFile
-                      dest = targetDir </> srcFile
-                   in doCopy src dest
-                | (srcBase, srcFile) <- srcFiles ]
-
-    -- | 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.
-    --
-    getDirectoryContentsRecursive :: FilePath -> IO [FilePath]
-    getDirectoryContentsRecursive topdir = recurseDirectories [""]
-      where
-        recurseDirectories :: [FilePath] -> IO [FilePath]
-        recurseDirectories []         = return []
-        recurseDirectories (dir:dirs) = unsafeInterleaveIO $ do
-          (files, dirs') <- collect [] [] =<< getDirectoryContents (topdir </> dir)
-          files' <- recurseDirectories (dirs' ++ dirs)
-          return (files ++ files')
-
-          where
-            collect files dirs' []              = return (reverse files
-                                                         ,reverse dirs')
-            collect files dirs' (entry:entries) | ignore entry
-                                                = collect files dirs' entries
-            collect files dirs' (entry:entries) = do
-              let dirEntry = dir </> entry
-              isDirectory <- doesDirectoryExist (topdir </> dirEntry)
-              if isDirectory
-                then collect files (dirEntry:dirs') entries
-                else collect (dirEntry:files) dirs' entries
-
-            ignore ['.']      = True
-            ignore ['.', '.'] = True
-            ignore _          = False
-
-
 getVersionInfo :: Version
                -> Tool
                -> GHCupDownloads
@@ -988,11 +898,25 @@ forFold :: (Foldable t, Applicative m, Monoid b) => t a -> (a -> m b) -> m b
 forFold = \t -> (`traverseFold` t)
 
 
--- | The file extension for executables.
+withConsoleRegions :: (MonadReader AppState m, MonadIO m, MonadMask m) => (MVar Bool -> Seq ConsoleRegion -> m a) -> m a
-exeExt :: String
+withConsoleRegions = withConsoleRegions' Linear 6
-#if defined(IS_WINDOWS)
-exeExt = ".exe"
-#else
-exeExt = ""
-#endif
 
+
+withConsoleRegions' :: (MonadReader AppState m, MonadIO m, MonadMask m) => RegionLayout -> Int -> (MVar Bool -> Seq ConsoleRegion -> m a) -> m a
+withConsoleRegions' ly size action = do
+  AppState { settings = Settings {..} } <- ask
+  pState <- liftIO newEmptyMVar
+  if (not verbose)
+  then displayConsoleRegions $
+          bracketIO
+                (fmap Sq.fromList . sequence . replicate size . openConsoleRegion $ ly)
+                (\rs -> uninterruptibleMask_ $ do
+                  ps <- takeMVar pState
+                  when ps (forM_ rs closeConsoleRegion))
+                (action pState)
+  else
+    action pState mempty
+  
+ where
+  bracketIO :: (MonadMask m, MonadIO m) => IO v -> (v -> IO b) -> (v -> m a) -> m a
+  bracketIO setup cleanup' = bracket (liftIO setup) (liftIO . cleanup')

lib/GHCup/Utils/Dirs.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP                   #-}
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE OverloadedStrings     #-}
 {-# LANGUAGE FlexibleContexts      #-}
@@ -13,7 +12,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Utils.Dirs
   ( getDirs
@@ -35,6 +34,7 @@ import           GHCup.Types.JSON               ( )
 import           GHCup.Utils.MegaParsec
 import           GHCup.Utils.Prelude
 
+import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Unlift
@@ -42,20 +42,32 @@ import           Control.Monad.Logger
 import           Control.Monad.Reader
 import           Control.Monad.Trans.Resource hiding (throwM)
 import           Data.Bifunctor
+import           Data.ByteString                ( ByteString )
 import           Data.Maybe
 import           Data.String.Interpolate
 import           GHC.IO.Exception               ( IOErrorType(NoSuchThing) )
 import           Haskus.Utils.Variant.Excepts
+import           HPath
+import           HPath.IO
 import           Optics
-import           System.Directory
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
 import           System.DiskSpace                                                
-import           System.Environment
+import           System.Posix.Env.ByteString    ( getEnv
-import           System.FilePath
+                                                , getEnvDefault
-import           System.IO.Temp
+                                                )
+import           System.Posix.FilePath   hiding ( (</>) )
+import           System.Posix.Temp.ByteString   ( mkdtemp )
 
-import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+import qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
 import qualified Data.Yaml                     as Y
+import qualified System.Posix.FilePath         as FP
+import qualified System.Posix.User             as PU
 import qualified Text.Megaparsec               as MP
 import Control.Concurrent (threadDelay)
 
@@ -70,96 +82,96 @@ import Control.Concurrent (threadDelay)
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_DATA_HOME/ghcup' as per xdg spec.
-ghcupBaseDir :: IO FilePath
+ghcupBaseDir :: IO (Path Abs)
 ghcupBaseDir = do
   xdg <- useXDG
   if xdg
     then do
-      bdir <- lookupEnv "XDG_DATA_HOME" >>= \case
+      bdir <- getEnv "XDG_DATA_HOME" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> do
           home <- liftIO getHomeDirectory
-          pure (home </> ".local" </> "share")
+          pure (home </> [rel|.local/share|])
-      pure (bdir </> "ghcup")
+      pure (bdir </> [rel|ghcup|])
     else do
-      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+      bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> liftIO getHomeDirectory
-      pure (bdir </> ".ghcup")
+      pure (bdir </> [rel|.ghcup|])
 
 
 -- | ~/.ghcup by default
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CONFIG_HOME/ghcup' as per xdg spec.
-ghcupConfigDir :: IO FilePath
+ghcupConfigDir :: IO (Path Abs)
 ghcupConfigDir = do
   xdg <- useXDG
   if xdg
     then do
-      bdir <- lookupEnv "XDG_CONFIG_HOME" >>= \case
+      bdir <- getEnv "XDG_CONFIG_HOME" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> do
           home <- liftIO getHomeDirectory
-          pure (home </> ".config")
+          pure (home </> [rel|.config|])
-      pure (bdir </> "ghcup")
+      pure (bdir </> [rel|ghcup|])
     else do
-      bdir <- lookupEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
+      bdir <- getEnv "GHCUP_INSTALL_BASE_PREFIX" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> liftIO getHomeDirectory
-      pure (bdir </> ".ghcup")
+      pure (bdir </> [rel|.ghcup|])
 
 
 -- | If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_BIN_HOME' env var or defaults to '~/.local/bin'
 -- (which, sadly is not strictly xdg spec).
-ghcupBinDir :: IO FilePath
+ghcupBinDir :: IO (Path Abs)
 ghcupBinDir = do
   xdg <- useXDG
   if xdg
     then do
-      lookupEnv "XDG_BIN_HOME" >>= \case
+      getEnv "XDG_BIN_HOME" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> do
           home <- liftIO getHomeDirectory
-          pure (home </> ".local" </> "bin")
+          pure (home </> [rel|.local/bin|])
-    else ghcupBaseDir <&> (</> "bin")
+    else ghcupBaseDir <&> (</> [rel|bin|])
 
 
 -- | Defaults to '~/.ghcup/cache'.
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup' as per xdg spec.
-ghcupCacheDir :: IO FilePath
+ghcupCacheDir :: IO (Path Abs)
 ghcupCacheDir = do
   xdg <- useXDG
   if xdg
     then do
-      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+      bdir <- getEnv "XDG_CACHE_HOME" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> do
           home <- liftIO getHomeDirectory
-          pure (home </> ".cache")
+          pure (home </> [rel|.cache|])
-      pure (bdir </> "ghcup")
+      pure (bdir </> [rel|ghcup|])
-    else ghcupBaseDir <&> (</> "cache")
+    else ghcupBaseDir <&> (</> [rel|cache|])
 
 
 -- | Defaults to '~/.ghcup/logs'.
 --
 -- If 'GHCUP_USE_XDG_DIRS' is set (to anything),
 -- then uses 'XDG_CACHE_HOME/ghcup/logs' as per xdg spec.
-ghcupLogsDir :: IO FilePath
+ghcupLogsDir :: IO (Path Abs)
 ghcupLogsDir = do
   xdg <- useXDG
   if xdg
     then do
-      bdir <- lookupEnv "XDG_CACHE_HOME" >>= \case
+      bdir <- getEnv "XDG_CACHE_HOME" >>= \case
-        Just r  -> pure r
+        Just r  -> parseAbs r
         Nothing -> do
           home <- liftIO getHomeDirectory
-          pure (home </> ".cache")
+          pure (home </> [rel|.cache|])
-      pure (bdir </> "ghcup" </> "logs")
+      pure (bdir </> [rel|ghcup/logs|])
-    else ghcupBaseDir <&> (</> "logs")
+    else ghcupBaseDir <&> (</> [rel|logs|])
 
 
 getDirs :: IO Dirs
@@ -182,11 +194,11 @@ ghcupConfigFile :: (MonadIO m)
                 => Excepts '[JSONError] m UserSettings
 ghcupConfigFile = do
   confDir <- liftIO ghcupConfigDir
-  let file = confDir </> "config.yaml"
+  let file = confDir </> [rel|config.yaml|]
-  contents <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> BS.readFile file
+  bs <- liftIO $ handleIO' NoSuchThing (\_ -> pure Nothing) $ Just <$> readFile file
-  case contents of
+  case bs of
       Nothing -> pure defaultUserSettings
-      Just contents' -> lE' JSONDecodeError . first show . Y.decodeEither' $ contents'
+      Just bs' -> lE' JSONDecodeError . first show . Y.decodeEither' . L.toStrict $ bs'
 
 
     -------------------------
@@ -195,10 +207,10 @@ ghcupConfigFile = do
 
 
 -- | ~/.ghcup/ghc by default.
-ghcupGHCBaseDir :: (MonadReader AppState m) => m FilePath
+ghcupGHCBaseDir :: (MonadReader AppState m) => m (Path Abs)
 ghcupGHCBaseDir = do
   AppState { dirs = Dirs {..} } <- ask
-  pure (baseDir </> "ghc")
+  pure (baseDir </> [rel|ghc|])
 
 
 -- | Gets '~/.ghcup/ghc/<ghcupGHCDir>'.
@@ -207,32 +219,35 @@ ghcupGHCBaseDir = do
 --   * 8.8.4
 ghcupGHCDir :: (MonadReader AppState m, MonadThrow m)
             => GHCTargetVersion
-            -> m FilePath
+            -> m (Path Abs)
 ghcupGHCDir ver = do
-  ghcbasedir <- ghcupGHCBaseDir
+  ghcbasedir    <- ghcupGHCBaseDir
-  let verdir = T.unpack $ tVerToText ver
+  verdir        <- parseRel $ E.encodeUtf8 (tVerToText ver)
   pure (ghcbasedir </> verdir)
 
 
 -- | See 'ghcupToolParser'.
-parseGHCupGHCDir :: MonadThrow m => FilePath -> m GHCTargetVersion
+parseGHCupGHCDir :: MonadThrow m => Path Rel -> m GHCTargetVersion
-parseGHCupGHCDir (T.pack -> fp) =
+parseGHCupGHCDir (toFilePath -> f) = do
+  fp <- throwEither $ E.decodeUtf8' f
   throwEither $ MP.parse ghcTargetVerP "" fp
 
 
-mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m FilePath
+mkGhcupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadThrow m, MonadIO m) => m (Path Abs)
 mkGhcupTmpDir = do
-  tmpdir <- liftIO getCanonicalTemporaryDirectory
+  tmpdir <- liftIO $ getEnvDefault "TMPDIR" "/tmp"
+  let fp = T.unpack $ decUTF8Safe tmpdir
 
   let minSpace = 5000 -- a rough guess, aight?
-  space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace tmpdir
+  space <- handleIO (\_ -> pure Nothing) $ fmap Just $ liftIO $ getAvailSpace fp
   when (maybe False (toBytes minSpace >) space) $ do
-    $(logWarn) [i|Possibly insufficient disk space on #{tmpdir}. At least #{minSpace} MB are recommended, but only #{toMB (fromJust space)} are free. Consider freeing up disk space or setting TMPDIR env variable.|]
+    $(logWarn) [i|Possibly insufficient disk space on #{fp}. At least #{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"
+  tmp <- liftIO $ mkdtemp (tmpdir FP.</> "ghcup-")
+  parseAbs tmp
  where
   toBytes mb = mb * 1024 * 1024
   toMB b = show (truncate' (fromIntegral b / (1024 * 1024) :: Double) 2)
@@ -241,8 +256,8 @@ mkGhcupTmpDir = do
       where t = 10^n
 
 
-withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m FilePath
+withGHCupTmpDir :: (MonadUnliftIO m, MonadLogger m, MonadCatch m, MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
-withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) removeDirectoryRecursive)
+withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir) deleteDirRecursive)
 
 
 
@@ -252,19 +267,29 @@ withGHCupTmpDir = snd <$> withRunInIO (\run -> run $ allocate (run mkGhcupTmpDir
     --------------
 
 
+getHomeDirectory :: IO (Path Abs)
+getHomeDirectory = do
+  e <- getEnv "HOME"
+  case e of
+    Just fp -> parseAbs fp
+    Nothing -> do
+      h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID)
+      parseAbs $ UTF8.fromString h -- this is a guess
+
+
 useXDG :: IO Bool
-useXDG = isJust <$> lookupEnv "GHCUP_USE_XDG_DIRS"
+useXDG = isJust <$> getEnv "GHCUP_USE_XDG_DIRS"
 
 
-relativeSymlink :: FilePath  -- ^ the path in which to create the symlink
+relativeSymlink :: Path Abs  -- ^ the path in which to create the symlink
-                -> FilePath  -- ^ the symlink destination
+                -> Path Abs  -- ^ the symlink destination
-                -> FilePath
+                -> ByteString
-relativeSymlink p1 p2 =
+relativeSymlink (toFilePath -> p1) (toFilePath -> p2) =
   let d1      = splitDirectories p1
       d2      = splitDirectories p2
       common  = takeWhile (\(x, y) -> x == y) $ zip d1 d2
       cPrefix = drop (length common) d1
   in  joinPath (replicate (length cPrefix) "..")
-        <> joinPath ([pathSeparator] : drop (length common) d2)
+        <> joinPath ("/" : drop (length common) d2)
 
 

lib/GHCup/Utils/File.hs

@@ -1,17 +1,482 @@
-{-# LANGUAGE CPP #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE FlexibleContexts  #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE ViewPatterns      #-}
 
-module GHCup.Utils.File (
+{-|
-  module GHCup.Utils.File.Common,
+Module      : GHCup.Utils.File
-#if IS_WINDOWS
+Description : File and unix APIs
-  module GHCup.Utils.File.Windows
+Copyright   : (c) Julian Ospald, 2020
-#else
+License     : LGPL-3.0
-  module GHCup.Utils.File.Posix
+Maintainer  : hasufell@hasufell.de
-#endif
+Stability   : experimental
-) where
+Portability : POSIX
 
-import GHCup.Utils.File.Common
+This module handles file and executable handling.
-#if IS_WINDOWS
+Some of these functions use sophisticated logging.
-import GHCup.Utils.File.Windows
+-}
-#else
+module GHCup.Utils.File where
-import GHCup.Utils.File.Posix
+
-#endif
+import           GHCup.Utils.Prelude
+import           GHCup.Types
+
+import           Control.Concurrent
+import           Control.Concurrent.Async
+import           Control.Exception              ( evaluate )
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.State.Strict
+import           Data.ByteString                ( ByteString )
+import           Data.Foldable
+import           Data.Functor
+import           Data.IORef
+import           Data.Maybe
+import           Data.Sequence                  ( Seq, (|>) )
+import           Data.String.Interpolate
+import           Data.Text                      ( Text )
+import           Data.Void
+import           Data.Word8
+import           GHC.IO.Exception
+import           HPath
+import           HPath.IO                hiding ( hideError )
+import           Optics                  hiding ((<|), (|>))
+import           System.Console.Pretty   hiding ( Pretty )
+import           System.Console.Regions
+import           System.IO.Error
+import           System.Posix.Directory.ByteString
+import           System.Posix.FD               as FD
+import           System.Posix.FilePath   hiding ( (</>) )
+import           System.Posix.Files.ByteString
+import           System.Posix.Foreign           ( oExcl, oAppend )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( openFd )
+import           System.Posix.Process           ( ProcessStatus(..) )
+import           System.Posix.Types
+import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
+import           Text.Regex.Posix
+
+
+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.Process.ByteString
+                                               as SPPB
+import           Streamly.External.Posix.DirStream
+import qualified Streamly.Prelude              as S
+import qualified Text.Megaparsec               as MP
+import qualified Data.ByteString               as BS
+import qualified "unix-bytestring" System.Posix.IO.ByteString
+                                               as SPIB
+
+
+
+data ProcessError = NonZeroExit Int ByteString [ByteString]
+                  | PTerminated ByteString [ByteString]
+                  | PStopped ByteString [ByteString]
+                  | NoSuchPid ByteString [ByteString]
+                  deriving Show
+
+instance Pretty ProcessError where
+  pPrint (NonZeroExit e exe args) =
+    text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} failed with exit code #{e}.|]
+  pPrint (PTerminated exe args) =
+    text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} terminated.|]
+  pPrint (PStopped exe args) =
+    text [i|Process "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args} stopped.|]
+  pPrint (NoSuchPid exe args) =
+    text [i|Could not find PID for process running "#{decUTF8Safe exe}" with arguments #{fmap decUTF8Safe args}.|]
+
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
+  , _stdOut   :: ByteString
+  , _stdErr   :: ByteString
+  }
+  deriving (Eq, Show)
+
+makeLenses ''CapturedProcess
+
+
+-- | Find the given executable by searching all *absolute* PATH components.
+-- Relative paths in PATH are ignored.
+--
+-- This shouldn't throw IO exceptions, unless getting the environment variable
+-- PATH does.
+findExecutable :: Path Rel -> IO (Maybe (Path Abs))
+findExecutable ex = do
+  sPaths <- fmap (catMaybes . fmap parseAbs) getSearchPath
+  -- We don't want exceptions to mess up our result. If we can't
+  -- figure out if a file exists, then treat it as a negative result.
+  asum $ fmap
+    (handleIO (\_ -> pure Nothing)
+      -- asum for short-circuiting behavior
+      . (\s' -> (isExecutable (s' </> ex) >>= guard) $> Just (s' </> ex))
+    )
+    sPaths
+
+
+-- | Execute the given command and collect the stdout, stderr and the exit code.
+-- The command is run in a subprocess.
+executeOut :: Path b            -- ^ command as filename, e.g. 'ls'
+           -> [ByteString]      -- ^ arguments to the command
+           -> Maybe (Path Abs)  -- ^ chdir to this path
+           -> IO CapturedProcess
+executeOut path args chdir = captureOutStreams $ do
+  maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+  SPPB.executeFile (toFilePath path) True args Nothing
+
+
+execLogged :: (MonadReader AppState m, MonadIO m, MonadThrow m)
+           => ByteString       -- ^ thing to execute
+           -> Bool             -- ^ whether to search PATH for the thing
+           -> [ByteString]     -- ^ args for the thing
+           -> Path Rel         -- ^ log filename (opened in append mode)
+           -> Maybe (Path Abs) -- ^ optionally chdir into this
+           -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+           -> MVar Bool
+           -> Seq ConsoleRegion
+           -> m (Either ProcessError ())
+execLogged exe spath args lfile chdir env pState rs = do
+  AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
+  logfile       <- (logsDir </>) <$> parseRel (toFilePath lfile <> ".log")
+  liftIO $ bracket (openFd (toFilePath logfile) WriteOnly [oAppend] (Just newFilePerms))
+                   closeFd
+                   (action verbose)
+ where
+  action verbose fd = do
+    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
+      -- start the thread that logs to stdout
+      void $ tryTakeMVar pState
+      done   <- newEmptyMVar
+      void
+        $ forkIO
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ EX.finally
+            (if verbose
+              then tee fd stdoutRead
+              else printToRegion fd stdoutRead 6
+            )
+            (putMVar done ())
+
+      -- fork the subprocess
+      pid <- SPPB.forkProcess $ do
+        void $ dupTo stdoutWrite stdOutput
+        void $ dupTo stdoutWrite stdError
+        closeFd stdoutRead
+        closeFd stdoutWrite
+
+        -- execute the action
+        maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+        void $ SPPB.executeFile exe spath args env
+
+      closeFd stdoutWrite
+
+      -- wait for the subprocess to finish
+      e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
+      putMVar pState (either (const False) (const True) e)
+
+      void $ race (takeMVar done) (threadDelay (1000000 * 3))
+      closeFd stdoutRead
+
+      pure e
+
+  tee :: Fd -> Fd -> IO ()
+  tee fileFd fdIn = readTilEOF lineAction fdIn
+
+   where
+    lineAction :: ByteString -> IO ()
+    lineAction bs' = do
+      void $ SPIB.fdWrite fileFd (bs' <> "\n")
+      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
+
+  -- Reads fdIn and logs the output in a continous scrolling area
+  -- of 'size' terminal lines. Also writes to a log file.
+  printToRegion :: Fd -> Fd -> Int -> IO ()
+  printToRegion fileFd fdIn size = do
+    void $
+      flip runStateT mempty $ readTilEOF (lineAction rs) fdIn
+
+   where
+    -- action to perform line by line
+    -- TODO: do this with vty for efficiency
+    lineAction :: (MonadMask m, MonadIO m)
+               => Seq ConsoleRegion
+               -> ByteString
+               -> StateT (Seq ByteString) m ()
+    lineAction rs' = \bs' -> do
+      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
+      modify (swapRegs bs')
+      regs <- get
+      liftIO $ forM_ (Sq.zip regs rs') $ \(bs, r) -> setConsoleRegion r $ do
+        w <- consoleWidth
+        return
+          . T.pack
+          . color Blue
+          . T.unpack
+          . decUTF8Safe
+          . trim w
+          . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
+          $ bs
+
+    swapRegs :: a -> Seq a -> Seq a
+    swapRegs bs = \regs -> if
+      | Sq.length regs < size -> regs |> bs
+      | otherwise             -> Sq.drop 1 regs |> bs
+
+    -- trim output line to terminal width
+    trim :: Int -> ByteString -> ByteString
+    trim w = \bs -> if
+      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
+      | otherwise                 -> bs
+
+  -- Consecutively read from Fd in 512 chunks until we hit
+  -- newline or EOF.
+  readLine :: MonadIO m
+           => Fd          -- ^ input file descriptor
+           -> ByteString  -- ^ rest buffer (read across newline)
+           -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
+  readLine fd = go
+   where
+    go inBs = do
+      -- if buffer is not empty, process it first
+      mbs <- if BS.length inBs == 0
+               -- otherwise attempt read
+               then liftIO
+                    $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
+                    $ fmap Just
+                    $ SPIB.fdRead fd 512
+               else pure $ Just inBs
+      case mbs of
+        Nothing -> pure ("", "", True)
+        Just bs -> do
+          -- split on newline
+          let (line, rest) = BS.span (/= _lf) bs
+          if
+            | BS.length rest /= 0 -> pure (line, BS.tail rest, False)
+            -- if rest is empty, then there was no newline, process further
+            | otherwise           -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
+
+  readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
+  readTilEOF ~action' fd' = go mempty
+   where
+    go bs' = do
+      (bs, rest, eof) <- readLine fd' bs'
+      if eof
+         then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
+         else void (action' bs) >> go rest
+
+
+-- | Capture the stdout and stderr of the given action, which
+-- is run in a subprocess. Stdin is closed. You might want to
+-- 'race' this to make sure it terminates.
+captureOutStreams :: IO a
+                     -- ^ the action to execute in a subprocess
+                  -> IO CapturedProcess
+captureOutStreams action = do
+  actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
+    actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
+      pid <- SPPB.forkProcess $ do
+        -- dup stdout
+        void $ dupTo childStdoutWrite stdOutput
+        closeFd childStdoutWrite
+        closeFd parentStdoutRead
+
+        -- dup stderr
+        void $ dupTo childStderrWrite stdError
+        closeFd childStderrWrite
+        closeFd parentStderrRead
+
+        -- execute the action
+        a <- action
+        void $ evaluate a
+
+      -- close everything we don't need
+      closeFd childStdoutWrite
+      closeFd childStderrWrite
+
+      -- start thread that writes the output
+      refOut <- newIORef BS.empty
+      refErr <- newIORef BS.empty
+      done   <- newEmptyMVar
+      _      <-
+        forkIO
+        $ EX.handle (\(_ :: IOException) -> pure ())
+        $ flip EX.finally (putMVar done ())
+        $ writeStds parentStdoutRead parentStderrRead refOut refErr
+
+      status <- SPPB.getProcessStatus True True pid
+      void $ race (takeMVar done) (threadDelay (1000000 * 3))
+
+      case status of
+        -- readFd will take care of closing the fd
+        Just (SPPB.Exited es) -> do
+          stdout' <- readIORef refOut
+          stderr' <- readIORef refErr
+          pure $ CapturedProcess { _exitCode = es
+                                 , _stdOut   = stdout'
+                                 , _stdErr   = stderr'
+                                 }
+
+        _ -> throwIO $ userError ("No such PID " ++ show pid)
+
+ where
+  writeStds pout perr rout rerr = do
+    doneOut <- newEmptyMVar
+    void
+      $ forkIO
+      $ hideError eofErrorType
+      $ flip EX.finally (putMVar doneOut ())
+      $ readTilEOF (\x -> modifyIORef' rout (<> x)) pout
+    doneErr <- newEmptyMVar
+    void
+      $ forkIO
+      $ hideError eofErrorType
+      $ flip EX.finally (putMVar doneErr ())
+      $ readTilEOF (\x -> modifyIORef' rerr (<> x)) perr
+    takeMVar doneOut
+    takeMVar doneErr
+
+  readTilEOF ~action' fd' = do
+    bs <- SPIB.fdRead fd' 512
+    void $ action' bs
+    readTilEOF action' fd'
+
+
+actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
+actionWithPipes a =
+  createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
+
+cleanup :: [Fd] -> IO ()
+cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
+
+
+
+-- | Create a new regular file in write-only mode. The file must not exist.
+createRegularFileFd :: FileMode -> Path b -> IO Fd
+createRegularFileFd fm dest =
+  FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
+
+
+-- | Thin wrapper around `executeFile`.
+exec :: ByteString       -- ^ thing to execute
+     -> Bool             -- ^ whether to search PATH for the thing
+     -> [ByteString]     -- ^ args for the thing
+     -> Maybe (Path Abs) -- ^ optionally chdir into this
+     -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+     -> IO (Either ProcessError ())
+exec exe spath args chdir env = do
+  pid <- SPPB.forkProcess $ do
+    maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+    SPPB.executeFile exe spath args env
+
+  fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
+
+
+toProcessError :: ByteString
+               -> [ByteString]
+               -> Maybe ProcessStatus
+               -> Either ProcessError ()
+toProcessError exe args mps = case mps of
+  Just (SPPB.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
+  Just (SPPB.Exited ExitSuccess    ) -> Right ()
+  Just (Terminated _ _             ) -> Left $ PTerminated exe args
+  Just (Stopped _                  ) -> Left $ PStopped exe args
+  Nothing                            -> Left $ NoSuchPid exe args
+
+
+-- | Search for a file in the search paths.
+--
+-- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
+searchPath :: [Path Abs] -> Path Rel -> IO (Maybe (Path Abs))
+searchPath paths needle = go paths
+ where
+  go [] = pure Nothing
+  go (x : xs) =
+    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
+      $ do
+          dirStream <- openDirStream (toFilePath x)
+          S.findM (\(_, p) -> isMatch x p) (dirContentsStream dirStream)
+            >>= \case
+                  Just _  -> pure $ Just (x </> needle)
+                  Nothing -> go xs
+  isMatch basedir p = do
+    if p == toFilePath needle
+      then isExecutable (basedir </> needle)
+      else pure False
+
+
+-- | Check wether a binary is shadowed by another one that comes before
+-- it in PATH. Returns the path to said binary, if any.
+isShadowed :: Path Abs -> IO (Maybe (Path Abs))
+isShadowed p = do
+  let dir = dirname p
+  fn <- basename p
+  spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+  if dir `elem` spaths
+  then do
+    let shadowPaths = takeWhile (/= dir) spaths
+    searchPath shadowPaths fn
+  else pure Nothing
+
+
+-- | Check whether the binary is in PATH. This returns only `True`
+-- if the directory containing the binary is part of PATH.
+isInPath :: Path Abs -> IO Bool
+isInPath p = do
+  let dir = dirname p
+  fn <- basename p
+  spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
+  if dir `elem` spaths
+  then isJust <$> searchPath [dir] fn
+  else pure False
+
+
+findFiles :: Path Abs -> Regex -> IO [Path Rel]
+findFiles path regex = do
+  dirStream <- openDirStream (toFilePath path)
+  f         <-
+    (fmap . fmap) snd
+    . S.toList
+    . S.filter (\(_, p) -> match regex p)
+    $ dirContentsStream dirStream
+  pure $ parseRel =<< f
+
+
+findFiles' :: Path Abs -> MP.Parsec Void Text () -> IO [Path Rel]
+findFiles' path parser = do
+  dirStream <- openDirStream (toFilePath path)
+  f         <-
+    (fmap . fmap) snd
+    . S.toList
+    . S.filter (\(_, p) -> case E.decodeUtf8' p of
+                             Left _ -> False
+                             Right p' -> isJust $ MP.parseMaybe parser p')
+    $ dirContentsStream dirStream
+  pure $ parseRel =<< f
+
+
+isBrokenSymlink :: Path Abs -> IO Bool
+isBrokenSymlink p =
+  handleIO
+      (\e -> if ioeGetErrorType e == NoSuchThing then pure True else throwIO e)
+    $ do
+        _ <- canonicalizePath p
+        pure False
+
+
+chmod_755 :: (MonadLogger m, MonadIO m) => Path a -> m ()
+chmod_755 (toFilePath -> fp) = do
+  let exe_mode =
+          nullFileMode
+            `unionFileModes` ownerExecuteMode
+            `unionFileModes` ownerReadMode
+            `unionFileModes` ownerWriteMode
+            `unionFileModes` groupExecuteMode
+            `unionFileModes` groupReadMode
+            `unionFileModes` otherExecuteMode
+            `unionFileModes` otherReadMode
+  $(logDebug) [i|chmod 755 #{fp}|]
+  liftIO $ setFileMode fp exe_mode

lib/GHCup/Utils/File/Common.hs

@@ -1,122 +0,0 @@
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE ViewPatterns      #-}
-
-module GHCup.Utils.File.Common where
-
-import           GHCup.Utils.Prelude
-
-import           Control.Exception
-import           Control.Monad.Extra
-import           Control.Monad.Reader
-import           Data.Maybe
-import           Data.String.Interpolate
-import           GHC.IO.Exception
-import           Optics                  hiding ((<|), (|>))
-import           System.Directory
-import           System.FilePath
-import           System.IO.Error
-import           Text.PrettyPrint.HughesPJClass hiding ( (<>) )
-import           Text.Regex.Posix
-
-import qualified Data.ByteString.Lazy          as BL
-
-
-
-data ProcessError = NonZeroExit Int FilePath [String]
-                  | PTerminated FilePath [String]
-                  | PStopped FilePath [String]
-                  | NoSuchPid FilePath [String]
-                  deriving Show
-
-instance Pretty ProcessError where
-  pPrint (NonZeroExit e exe args) =
-    text [i|Process "#{exe}" with arguments #{args} failed with exit code #{e}.|]
-  pPrint (PTerminated exe args) =
-    text [i|Process "#{exe}" with arguments #{args} terminated.|]
-  pPrint (PStopped exe args) =
-    text [i|Process "#{exe}" with arguments #{args} stopped.|]
-  pPrint (NoSuchPid exe args) =
-    text [i|Could not find PID for process running "#{exe}" with arguments #{args}.|]
-
-data CapturedProcess = CapturedProcess
-  { _exitCode :: ExitCode
-  , _stdOut   :: BL.ByteString
-  , _stdErr   :: BL.ByteString
-  }
-  deriving (Eq, Show)
-
-makeLenses ''CapturedProcess
-
-
-
--- | Search for a file in the search paths.
---
--- Catches `PermissionDenied` and `NoSuchThing` and returns `Nothing`.
-searchPath :: [FilePath] -> FilePath -> IO (Maybe FilePath)
-searchPath paths needle = go paths
- where
-  go [] = pure Nothing
-  go (x : xs) =
-    hideErrorDefM [InappropriateType, PermissionDenied, NoSuchThing] (go xs)
-      $ do
-          contents <- listDirectory x
-          findM (isMatch x) contents >>= \case
-            Just _ -> pure $ Just (x </> needle)
-            Nothing -> go xs
-  isMatch basedir p = do
-    if p == needle
-      then isExecutable (basedir </> needle)
-      else pure False
-
-  isExecutable :: FilePath -> IO Bool
-  isExecutable file = executable <$> getPermissions file
-
-
--- | Check wether a binary is shadowed by another one that comes before
--- it in PATH. Returns the path to said binary, if any.
-isShadowed :: FilePath -> IO (Maybe FilePath)
-isShadowed p = do
-  let dir = takeDirectory p
-  let fn = takeFileName p
-  spaths <- liftIO getSearchPath
-  if dir `elem` spaths
-  then do
-    let shadowPaths = takeWhile (/= dir) spaths
-    searchPath shadowPaths fn
-  else pure Nothing
-
-
--- | Check whether the binary is in PATH. This returns only `True`
--- if the directory containing the binary is part of PATH.
-isInPath :: FilePath -> IO Bool
-isInPath p = do
-  let dir = takeDirectory p
-  let fn = takeFileName p
-  spaths <- liftIO getSearchPath
-  if dir `elem` spaths
-  then isJust <$> searchPath [dir] fn
-  else pure False
-
-
-findFiles :: FilePath -> Regex -> IO [FilePath]
-findFiles path regex = do
-  contents <- listDirectory path
-  pure $ filter (match regex) contents
-
-
-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
-

lib/GHCup/Utils/File/Posix.hs

@@ -1,368 +0,0 @@
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE ViewPatterns      #-}
-
-{-|
-Module      : GHCup.Utils.File.Posix
-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.Utils.File.Posix where
-
-import           GHCup.Utils.File.Common
-import           GHCup.Utils.Prelude
-import           GHCup.Types
-
-import           Control.Concurrent
-import           Control.Concurrent.Async
-import           Control.Exception              ( evaluate )
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.Logger
-import           Control.Monad.Reader
-import           Control.Monad.Trans.State.Strict
-import           Data.ByteString                ( ByteString )
-import           Data.Foldable
-import           Data.IORef
-import           Data.Sequence                  ( Seq, (|>) )
-import           Data.String.Interpolate
-import           Data.List
-import           Data.Word8
-import           GHC.IO.Exception
-import           System.Console.Pretty   hiding ( Pretty )
-import           System.Console.Regions
-import           System.IO.Error
-import           System.FilePath
-import           System.Posix.Directory
-import           System.Posix.Files
-import           System.Posix.IO
-import           System.Posix.Process           ( ProcessStatus(..) )
-import           System.Posix.Types
-
-
-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.Process          as SPP
-import qualified Data.ByteString               as BS
-import qualified Data.ByteString.Lazy          as BL
-import qualified "unix-bytestring" System.Posix.IO.ByteString
-                                               as SPIB
-
-
-
--- | Execute the given command and collect the stdout, stderr and the exit code.
--- The command is run in a subprocess.
-executeOut :: FilePath          -- ^ command as filename, e.g. 'ls'
-           -> [String]          -- ^ arguments to the command
-           -> Maybe FilePath    -- ^ chdir to this path
-           -> IO CapturedProcess
-executeOut path args chdir = captureOutStreams $ do
-  maybe (pure ()) changeWorkingDirectory chdir
-  SPP.executeFile path True args Nothing
-
-
-execLogged :: (MonadReader AppState m, 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
-  AppState { settings = Settings {..}, dirs = Dirs {..} } <- ask
-  let logfile = logsDir </> lfile <> ".log"
-  liftIO $ bracket (openFd logfile WriteOnly (Just newFilePerms) defaultFileFlags{ append = True })
-                   closeFd
-                   (action verbose)
- where
-  action verbose fd = do
-    actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-      -- start the thread that logs to stdout
-      pState <- newEmptyMVar
-      done   <- newEmptyMVar
-      void
-        $ forkIO
-        $ EX.handle (\(_ :: IOException) -> pure ())
-        $ EX.finally
-            (if verbose
-              then tee fd stdoutRead
-              else printToRegion fd stdoutRead 6 pState
-            )
-            (putMVar done ())
-
-      -- fork the subprocess
-      pid <- SPP.forkProcess $ do
-        void $ dupTo stdoutWrite stdOutput
-        void $ dupTo stdoutWrite stdError
-        closeFd stdoutRead
-        closeFd stdoutWrite
-
-        -- execute the action
-        maybe (pure ()) changeWorkingDirectory chdir
-        void $ SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
-
-      closeFd stdoutWrite
-
-      -- wait for the subprocess to finish
-      e <- toProcessError exe args <$!> SPP.getProcessStatus True True pid
-      putMVar pState (either (const False) (const True) e)
-
-      void $ race (takeMVar done) (threadDelay (1000000 * 3))
-      closeFd stdoutRead
-
-      pure e
-
-  tee :: Fd -> Fd -> IO ()
-  tee fileFd fdIn = readTilEOF lineAction fdIn
-
-   where
-    lineAction :: ByteString -> IO ()
-    lineAction bs' = do
-      void $ SPIB.fdWrite fileFd (bs' <> "\n")
-      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-
-  -- Reads fdIn and logs the output in a continous scrolling area
-  -- of 'size' terminal lines. Also writes to a log file.
-  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
-  printToRegion fileFd fdIn size pState = do
-    void $ displayConsoleRegions $ do
-      rs <-
-        liftIO
-        . fmap Sq.fromList
-        . sequence
-        . replicate size
-        . openConsoleRegion
-        $ Linear
-      flip runStateT mempty
-        $ handle
-            (\(ex :: SomeException) -> do
-              ps <- liftIO $ takeMVar pState
-              when ps (forM_ rs (liftIO . closeConsoleRegion))
-              throw ex
-            )
-        $ readTilEOF (lineAction rs) fdIn
-
-   where
-    -- action to perform line by line
-    -- TODO: do this with vty for efficiency
-    lineAction :: (MonadMask m, MonadIO m)
-               => Seq ConsoleRegion
-               -> ByteString
-               -> StateT (Seq ByteString) m ()
-    lineAction rs = \bs' -> do
-      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
-      modify (swapRegs bs')
-      regs <- get
-      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
-        w <- consoleWidth
-        return
-          . T.pack
-          . color Blue
-          . T.unpack
-          . decUTF8Safe
-          . trim w
-          . (\b -> "[ " <> E.encodeUtf8 (T.pack lfile) <> " ] " <> b)
-          $ bs
-
-    swapRegs :: a -> Seq a -> Seq a
-    swapRegs bs = \regs -> if
-      | Sq.length regs < size -> regs |> bs
-      | otherwise             -> Sq.drop 1 regs |> bs
-
-    -- trim output line to terminal width
-    trim :: Int -> ByteString -> ByteString
-    trim w = \bs -> if
-      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
-      | otherwise                 -> bs
-
-  -- Consecutively read from Fd in 512 chunks until we hit
-  -- newline or EOF.
-  readLine :: MonadIO m
-           => Fd          -- ^ input file descriptor
-           -> ByteString  -- ^ rest buffer (read across newline)
-           -> m (ByteString, ByteString, Bool) -- ^ (full line, rest, eof)
-  readLine fd = go
-   where
-    go inBs = do
-      -- if buffer is not empty, process it first
-      mbs <- if BS.length inBs == 0
-               -- otherwise attempt read
-               then liftIO
-                    $ handleIO (\e -> if isEOFError e then pure Nothing else ioError e)
-                    $ fmap Just
-                    $ SPIB.fdRead fd 512
-               else pure $ Just inBs
-      case mbs of
-        Nothing -> pure ("", "", True)
-        Just bs -> do
-          -- split on newline
-          let (line, rest) = BS.span (/= _lf) bs
-          if
-            | BS.length rest /= 0 -> pure (line, BS.tail rest, False)
-            -- if rest is empty, then there was no newline, process further
-            | otherwise           -> (\(l, r, b) -> (line <> l, r, b)) <$!> go mempty
-
-  readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
-  readTilEOF ~action' fd' = go mempty
-   where
-    go bs' = do
-      (bs, rest, eof) <- readLine fd' bs'
-      if eof
-         then liftIO $ ioError (mkIOError eofErrorType "" Nothing Nothing)
-         else void (action' bs) >> go rest
-
-
--- | Capture the stdout and stderr of the given action, which
--- is run in a subprocess. Stdin is closed. You might want to
--- 'race' this to make sure it terminates.
-captureOutStreams :: IO a
-                     -- ^ the action to execute in a subprocess
-                  -> IO CapturedProcess
-captureOutStreams action = do
-  actionWithPipes $ \(parentStdoutRead, childStdoutWrite) ->
-    actionWithPipes $ \(parentStderrRead, childStderrWrite) -> do
-      pid <- SPP.forkProcess $ do
-        -- dup stdout
-        void $ dupTo childStdoutWrite stdOutput
-        closeFd childStdoutWrite
-        closeFd parentStdoutRead
-
-        -- dup stderr
-        void $ dupTo childStderrWrite stdError
-        closeFd childStderrWrite
-        closeFd parentStderrRead
-
-        -- execute the action
-        a <- action
-        void $ evaluate a
-
-      -- close everything we don't need
-      closeFd childStdoutWrite
-      closeFd childStderrWrite
-
-      -- start thread that writes the output
-      refOut <- newIORef BL.empty
-      refErr <- newIORef BL.empty
-      done   <- newEmptyMVar
-      _      <-
-        forkIO
-        $ EX.handle (\(_ :: IOException) -> pure ())
-        $ flip EX.finally (putMVar done ())
-        $ writeStds parentStdoutRead parentStderrRead refOut refErr
-
-      status <- SPP.getProcessStatus True True pid
-      void $ race (takeMVar done) (threadDelay (1000000 * 3))
-
-      case status of
-        -- readFd will take care of closing the fd
-        Just (SPP.Exited es) -> do
-          stdout' <- readIORef refOut
-          stderr' <- readIORef refErr
-          pure $ CapturedProcess { _exitCode = es
-                                 , _stdOut   = stdout'
-                                 , _stdErr   = stderr'
-                                 }
-
-        _ -> throwIO $ userError ("No such PID " ++ show pid)
-
- where
-  writeStds :: Fd -> Fd -> IORef BL.ByteString -> IORef BL.ByteString -> IO ()
-  writeStds pout perr rout rerr = do
-    doneOut <- newEmptyMVar
-    void
-      $ forkIO
-      $ hideError eofErrorType
-      $ flip EX.finally (putMVar doneOut ())
-      $ readTilEOF (\x -> modifyIORef' rout (<> BL.fromStrict x)) pout
-    doneErr <- newEmptyMVar
-    void
-      $ forkIO
-      $ hideError eofErrorType
-      $ flip EX.finally (putMVar doneErr ())
-      $ readTilEOF (\x -> modifyIORef' rerr (<> BL.fromStrict x)) perr
-    takeMVar doneOut
-    takeMVar doneErr
-
-  readTilEOF ~action' fd' = do
-    bs <- SPIB.fdRead fd' 512
-    void $ action' bs
-    readTilEOF action' fd'
-
-
-actionWithPipes :: ((Fd, Fd) -> IO b) -> IO b
-actionWithPipes a =
-  createPipe >>= \(p1, p2) -> flip finally (cleanup [p1, p2]) $ a (p1, p2)
-
-cleanup :: [Fd] -> IO ()
-cleanup fds = for_ fds $ \fd -> handleIO (\_ -> pure ()) $ closeFd fd
-
-
-
--- | Create a new regular file in write-only mode. The file must not exist.
-createRegularFileFd :: FileMode -> FilePath -> IO Fd
-createRegularFileFd fm dest =
-  openFd dest WriteOnly (Just fm) defaultFileFlags{ exclusive = True }
-
-
--- | Thin wrapper around `executeFile`.
-exec :: String           -- ^ thing to execute
-     -> [String]         -- ^ args for the thing
-     -> Maybe FilePath   -- ^ optionally chdir into this
-     -> Maybe [(String, String)] -- ^ optional environment
-     -> IO (Either ProcessError ())
-exec exe args chdir env = do
-  pid <- SPP.forkProcess $ do
-    maybe (pure ()) changeWorkingDirectory chdir
-    SPP.executeFile exe (not ("./" `isPrefixOf` exe)) args env
-
-  fmap (toProcessError exe args) $ SPP.getProcessStatus True True pid
-
-
-toProcessError :: FilePath
-               -> [String]
-               -> Maybe ProcessStatus
-               -> Either ProcessError ()
-toProcessError exe args mps = case mps of
-  Just (SPP.Exited (ExitFailure xi)) -> Left $ NonZeroExit xi exe args
-  Just (SPP.Exited ExitSuccess    ) -> Right ()
-  Just (Terminated _ _             ) -> Left $ PTerminated exe args
-  Just (Stopped _                  ) -> Left $ PStopped exe args
-  Nothing                            -> Left $ NoSuchPid exe args
-
-
-
-chmod_755 :: (MonadLogger m, 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) [i|chmod 755 #{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

lib/GHCup/Utils/File/Windows.hs

@@ -1,202 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
-
-{-|
-Module      : GHCup.Utils.File.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.Utils.File.Windows where
-
-import           GHCup.Utils.File.Common
-import           GHCup.Types
-
-import           Control.Concurrent
-import           Control.DeepSeq
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.Reader
-import           Foreign.C.Error
-import           GHC.IO.Exception
-import           GHC.IO.Handle
-import           System.Directory
-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
-
-
-
-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_ "readCreateProcessWithExitCode" 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 :: FilePath          -- ^ command as filename, e.g. 'ls'
-           -> [String]          -- ^ arguments to the command
-           -> Maybe FilePath    -- ^ chdir to this path
-           -> IO CapturedProcess
-executeOut path args chdir = do
-  (exit, out, err) <- readCreateProcessWithExitCodeBS (proc path args){ cwd = chdir } ""
-  pure $ CapturedProcess exit out err
-
-
-execLogged :: (MonadReader AppState m, 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
-  AppState { dirs = Dirs {..} } <- ask
-  let stdoutLogfile = logsDir </> lfile <> ".stdout.log"
-      stderrLogfile = logsDir </> lfile <> ".stderr.log"
-  fmap (toProcessError exe args)
-    $ liftIO
-    $ withCreateProcess
-        (proc exe args){ cwd = chdir
-                       , env = env
-                       , std_in = CreatePipe
-                       , std_out = CreatePipe
-                       , std_err = CreatePipe
-        }
-    $ \_ 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
-            void $ BS.hPut stdout some
-            go
-        
-
--- | Thin wrapper around `executeFile`.
-exec :: FilePath       -- ^ thing to execute
-     -> [FilePath]     -- ^ args for the thing
-     -> Maybe FilePath   -- ^ optionally chdir into this
-     -> Maybe [(String, String)] -- ^ optional environment
-     -> IO (Either ProcessError ())
-exec exe args chdir env = do
-  exit_code <- withCreateProcess
-                 (proc exe args) { cwd = chdir, env = env } $ \_ _ _ p ->
-                 waitForProcess p
-  pure $ toProcessError exe args exit_code
-
-
-chmod_755 :: MonadIO m => FilePath -> m ()
-chmod_755 fp =
-  let perm = setOwnerWritable True emptyPermissions
-  in liftIO $ setPermissions fp perm

lib/GHCup/Utils/Logger.hs

@@ -8,13 +8,14 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 
 Here we define our main logger.
 -}
 module GHCup.Utils.Logger where
 
 import           GHCup.Types
+import           GHCup.Utils
 import           GHCup.Utils.File
 import           GHCup.Utils.String.QQ
 
@@ -22,15 +23,14 @@ import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
 import           Control.Monad.Logger
+import           HPath
+import           HPath.IO
 import           Prelude                 hiding ( appendFile )
 import           System.Console.Pretty
-import           System.Directory        hiding ( findFiles )
-import           System.FilePath
 import           System.IO.Error
 import           Text.Regex.Posix
 
 import qualified Data.ByteString               as B
-import GHCup.Utils.Prelude
 
 
 data LoggerConfig = LoggerConfig
@@ -68,19 +68,20 @@ myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
     rawOutter outr
 
 
-initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m FilePath
+initGHCupFileLogging :: (MonadIO m, MonadReader AppState m) => m (Path Abs)
 initGHCupFileLogging = do
   AppState {dirs = Dirs {..}} <- ask
-  let logfile = logsDir </> "ghcup.log"
+  let logfile = logsDir </> [rel|ghcup.log|]
   liftIO $ do
-    createDirectoryIfMissing True logsDir
+    createDirRecursive' logsDir
     logFiles <- findFiles
       logsDir
       (makeRegexOpts compExtended
                      execBlank
                      ([s|^.*\.log$|] :: B.ByteString)
       )
-    forM_ logFiles $ hideError doesNotExistErrorType . removeFile . (logsDir </>)
+    forM_ logFiles $ hideError doesNotExistErrorType . deleteFile . (logsDir </>)
 
-    writeFile logfile ""
+    createRegularFile newFilePerms logfile
     pure logfile
+

lib/GHCup/Utils/MegaParsec.hs

@@ -8,7 +8,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Utils.MegaParsec where
 
@@ -23,7 +23,6 @@ import           Data.Maybe
 import           Data.Text                      ( Text )
 import           Data.Versions
 import           Data.Void
-import           System.FilePath
 
 import qualified Data.List.NonEmpty            as NE
 import qualified Data.Text                     as T
@@ -118,7 +117,3 @@ verP suffix = do
       v <- versioning'
       MP.setInput rest
       pure v
-
-
-pathSep :: MP.Parsec Void Text Char
-pathSep = MP.oneOf pathSeparators

lib/GHCup/Utils/Prelude.hs

@@ -12,7 +12,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 
 GHCup specific prelude. Lots of Excepts functionality.
 -}
@@ -32,6 +32,8 @@ import           Data.Word8
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment )
+
 import qualified Data.ByteString               as B
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
@@ -240,8 +242,6 @@ throwEither' e eth = case eth of
 verToBS :: Version -> ByteString
 verToBS = E.encodeUtf8 . prettyVer
 
-verToS :: Version -> String
-verToS = T.unpack . prettyVer
 
 intToText :: Integral a => a -> T.Text
 intToText = TL.toStrict . B.toLazyText . B.decimal
@@ -252,6 +252,14 @@ removeLensFieldLabel str' =
   maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str'
 
 
+addToCurrentEnv :: MonadIO m
+                => [(ByteString, ByteString)]
+                -> m [(ByteString, ByteString)]
+addToCurrentEnv adds = do
+  cEnv <- liftIO getEnvironment
+  pure (adds ++ cEnv)
+
+
 pvpToVersion :: PVP -> Version
 pvpToVersion =
   either (\_ -> error "Couldn't convert PVP to Version") id

lib/GHCup/Utils/String/QQ.hs

@@ -7,7 +7,7 @@ Copyright   : (c) Audrey Tang <audreyt@audreyt.org> 2019, Julian Ospald <hasufel
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 
 QuasiQuoter for non-interpolated strings, texts and bytestrings.
 

lib/GHCup/Utils/Version/QQ.hs

@@ -14,7 +14,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Utils.Version.QQ where
 

lib/GHCup/Version.hs

@@ -8,7 +8,7 @@ Copyright   : (c) Julian Ospald, 2020
 License     : LGPL-3.0
 Maintainer  : hasufell@hasufell.de
 Stability   : experimental
-Portability : portable
+Portability : POSIX
 -}
 module GHCup.Version where
 

stack.yaml

@@ -1,4 +1,4 @@
-resolver: lts-17.11
+resolver: lts-17.4
 
 packages:
   - .
@@ -7,9 +7,6 @@ extra-deps:
   - git: https://github.com/hasufell/text-conversions.git
     commit: 9abf0e5e5664a3178367597c32db19880477a53c
 
-  - git: https://github.com/Bodigrim/tar
-    commit: ac197ec7ea4838dc2b4e22b9b888b080cedf29cf
-
   - IfElse-0.85@sha256:6939b94acc6a55f545f63a168a349dd2fbe4b9a7cca73bf60282db5cc6aa47d2,445
   - ascii-string-1.0.1.4@sha256:fa34f1d9ba57e8e89c0d4c9cef5e01ba32cb2d4373d13f92dcc0b531a6c6749b,2582
   - brotli-0.0.0.0@sha256:2bf383a4cd308745740986be0b18381c5a0784393fe69b91456aacb2d603de46,2964
@@ -20,18 +17,16 @@ extra-deps:
   - haskus-utils-data-1.3@sha256:f62c4e49021b463185d043f7b69c727b63af641a71d7edd582d9f4f98e80e500,1466
   - haskus-utils-types-1.5.1@sha256:991c472f4e751e2f0d7aab6ad4220ef151d6160876dcf0511bbf876bbd432020,1298
   - haskus-utils-variant-3.0@sha256:8d51e45d3b664e61ccc25a58b37c0ccc4ee7537138b9fee21cd15c356906dd34,2159
-  - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
+  - hpath-0.11.0@sha256:12b8405bee13d0007d644a888ef8407069ce7bbbd76970f8746b801447124ade,1440
+  - hpath-directory-0.14.1@sha256:548ac1321222c34caa843a41a2379a77d961141082a4695bb37cc4731e91b2c7,5312
   - hpath-filepath-0.10.4@sha256:e9e44fb5fdbade7f30b5b5451257dbee15b6ef1aae4060034d73008bb3b5d878,1269
-  - hpath-posix-0.13.3@sha256:abe472cf16bccd3a8b8814865ed3551a728fde0f3a2baea2acc03023bec6c565,1615
+  - hpath-io-0.14.1@sha256:d91373cd81483eb370a1c683e4add6182250dccce32f9b682bb1104f7765c750,1522
-  - hspec-2.7.10@sha256:c9e82c90086acebac576552a06f3cabd249bba048edd1667c7fae0b1313d5bce,1712
+  - hpath-posix-0.13.2@sha256:eec4ff2b00dc86be847aca0f409fc8f6212ffd2170ec36a17dc9a52b46562392,1615
-  - hspec-core-2.7.10@sha256:2aba6ea126442b29e8183ab27f1c811706b19b1d83b02f193a896f6fc1589d13,4621
+  - http-io-streams-0.1.6.0@sha256:53f5bab177efb52cd65ec396fd04ed59b93e5f919fb3700cd7dacd6cfce6f06d,3582
-  - hspec-discover-2.7.10@sha256:d08bf5dd785629f589571477d9beb7cd91529471bd89f39517c1cb4b9b38160f,2184
-  - hspec-golden-aeson-0.9.0.0@sha256:aa17274114026661ba4dfc9c60c230673c8f408bd86482fd611d2d5cb6aff996,2179
   - lzma-static-5.2.5.2@sha256:ac38dcad9ab423342a72ba48415bd75f62234e9c9e11831495b75603b5a060f6,7184
   - libarchive-3.0.2.1@sha256:40ebf2a278e585802427bc58826867208bb33822f63d56107a1fcc3ca04d691d,10990
   - os-release-1.0.1@sha256:1281c62081f438fc3f0874d3bae6a4887d5964ac25261ba06e29d368ab173467,2716
   - primitive-0.7.0.1@sha256:a381571c36edc7dca28b77fe8159b43c14c640087ec5946adacf949feec64231,3433
-  - regex-posix-clib-2.7
   - streamly-0.7.3@sha256:ad2a488fe802692ed47cab9fd0416c2904aac9e51cf2d8aafd1c3a40064c42f5,27421
   - streamly-bytestring-0.1.2@sha256:cc828f41d1c714c711d38fb213b4ed186febabba598ab080e13255f69c20b13c,2469
   - streamly-posix-0.1.0.1@sha256:5d89b806281035d34020387ed99dde1ddab282c7ed66df3b7cd010b38fd3517b,2138
@@ -45,8 +40,13 @@ flags:
   libarchive:
     system-libarchive: false
 
-  regex-posix:
+  ghcup:
-    _regex-posix-clib: true
+    tui: true
+    internal-downloader: true
+
+system-ghc: true
+compiler: ghc-8.10.4
+compiler-check: match-exact
 
 ghc-options:
   "$locals": -O2

test/GHCup/ArbitraryTypes.hs

@@ -11,6 +11,7 @@ import           GHCup.Types
 import           Data.ByteString                ( ByteString )
 import           Data.Versions
 import           Data.List.NonEmpty
+import           HPath
 import           Test.QuickCheck
 import           Test.QuickCheck.Arbitrary.ADT  ( ToADTArbitrary )
 import           Test.QuickCheck.Arbitrary.Generic
@@ -163,6 +164,11 @@ instance Arbitrary VersionCmp where
   arbitrary = genericArbitrary
   shrink    = genericShrink
 
+instance Arbitrary (Path Rel) where
+  arbitrary =
+    either (error . show) id . parseRel . E.encodeUtf8 . T.pack
+      <$> listOf1 (elements ['a' .. 'z'])
+
 instance Arbitrary TarDir where
   arbitrary = genericArbitrary
   shrink    = genericShrink