Yoo

README.md

@@ -1,28 +1,25 @@
 # ghcup
 
-A rewrite of ghcup in haskell. This can be used as a library
-and may be redistributed as a binary in the future.
+A rewrite of ghcup in haskell.
 
 ## Motivation
 
-ghcup has increasingly become difficult to maintain. A few reasons:
+Maintenance problems:
 
-* few maintainers
-* increasing LOC
 * platform incompatibilities regularly causing breaking bugs:
 	* [Mktemp not working properly on macOS](https://gitlab.haskell.org/haskell/ghcup/issues/130)
 	* [ln: illegal option -- T on macOS Catalina](https://gitlab.haskell.org/haskell/ghcup/issues/123)
 	* [Wrong tar flag on darwin](https://gitlab.haskell.org/haskell/ghcup/issues/119))
 * refactoring being difficult due to POSIX sh
 
-More benefits of a rewrite:
+Benefits of a rewrite:
 
 * Features such as installing [release candidates](https://gitlab.haskell.org/haskell/ghcup/issues/94) or [HEAD builds](https://gitlab.haskell.org/haskell/ghcup/issues/65) can be more conveniently implemented in a rewrite
 * Refactoring will be easier
 * Better tool support (such as linting the downloads file)
 * saner downloads file format (such as JSON)
 
-However, the downside will be:
+Downsides:
 
 * building static binaries for all platforms (and possibly causing SSL/DNS problems)
 * still bootstrapping those binaries via a POSIX sh script
@@ -31,4 +28,4 @@ However, the downside will be:
 
 * Correct low-level code
 * Good exception handling
-* Easier user interface (possibly interactive and non-interactive ones)
+* Cleaner user interface

TODO.md

@@ -1,37 +1,41 @@
 # TODOs and Remarks
 
-## New
+## Now
 
-* download progress
+* print-system-reqs
 
-* Downloads from URL
-* set                Set currently active GHC version
-* list               Show available GHCs and other tools
-* upgrade            Upgrade this script in-place
-* rm                 Remove an already installed GHC
-* debug-info         Print debug info (e.g. detected system/distro)
-* changelog          Show the changelog of a GHC release (online)
-* print-system-reqs  Print an approximation of system requirements
+## Cleanups
+
+* avoid alternative for IO
+* don't use Excepts?
+
+## Maybe
+
+* maybe: changelog          Show the changelog of a GHC release (online)
+* OS faking
+* sign the JSON? (Or check gpg keys?)
 
 * testing (especially distro detection -> unit tests)
 
+* hard cleanup command?
 
-## Old
+## Later
+
+* static builds and host ghcup
+* do bootstrap-haskell with new ghcup
+* add support for RC/alpha/HEAD versions
+* check for updates on start
+* use plucky or oops instead of Excepts
+
+## Questions
 
 * handling of SIGTERM and SIGUSR
-* add support for RC/alpha/HEAD versions
-* redo/rethink how tool tags works
-* mirror support
-* checksums
-* check for new version on start
-* tarball tags as well as version tags?
-
-* --copy-compiler-tools
-* installing multiple versions in parallel?
-* how to version and extend the format of the downloads file? Compatibility?
-* how to propagate updates? Automatically? Might solve the versioning problem
 * installing musl on demand?
+* redo/rethink how tool tags works
+  * tarball tags as well as version tags?
+* mirror support
+* check for new version on start
+  * how to propagate updates? Automatically? Might solve the versioning problem
+  * maybe add deprecation notice into JSON
 * interactive handling when distro doesn't exist and we know the tarball is incompatible?
 * ghcup-with wrapper to execute a command with a given ghc in PATH?
-
-* maybe add deprecation notice into JSON

app/Main.hs

@@ -1,177 +0,0 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-
-module Main where
-
-import           Control.Monad.Logger
-import           Control.Monad.Reader
-import           Control.Monad.IO.Class
-import           Data.Bifunctor
-import           Data.ByteString                ( ByteString )
-import           Data.Functor                   ( (<&>) )
-import           Data.Maybe
-import           Data.Semigroup                 ( (<>) )
-import           Data.String.QQ
-import           Data.Text                      ( Text )
-import qualified Data.Text                     as T
-import qualified Data.Text.Encoding            as E
-import           Data.Traversable
-import           Data.Versions
-import           GHCup
-import           GHCup.File
-import           GHCup.Prelude
-import           GHCup.Types
-import           Haskus.Utils.Variant.Excepts
-import           HPath
-import           Options.Applicative
-import           System.Console.Pretty
-import           System.Exit
-
-
-
-
-data Options = Options
-  { optVerbose :: Bool
-  , optCache   :: Bool
-  , optCommand :: Command
-  }
-
-data Command
-  = InstallGHC InstallGHCOptions
-  | InstallCabal InstallCabalOptions
-
-data InstallGHCOptions = InstallGHCOptions
-  { ghcVer :: Maybe Version
-  }
-
-data InstallCabalOptions = InstallCabalOptions
-  { cabalVer :: Maybe Version
-  }
-
-
-opts :: Parser Options
-opts =
-  Options
-    <$> switch
-          (short 'v' <> long "verbose" <> help "Whether to enable verbosity")
-    <*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
-    <*> com
-
-
-com :: Parser Command
-com = subparser
-  (  command
-      "install-ghc"
-      (   InstallGHC
-      <$> (info (installGHCOpts <**> helper)
-                (progDesc "Install a GHC version")
-          )
-      )
-  <> command
-       "install-cabal"
-       (   InstallCabal
-       <$> (info (installCabalOpts <**> helper)
-                 (progDesc "Install a cabal-install version")
-           )
-       )
-  )
-
-installGHCOpts :: Parser InstallGHCOptions
-installGHCOpts = InstallGHCOptions <$> optional
-  (option
-    (eitherReader
-      (\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
-    )
-    (short 'v' <> long "version" <> metavar "VERSION" <> help
-      "The GHC version to install"
-    )
-  )
-
-
-installCabalOpts :: Parser InstallCabalOptions
-installCabalOpts = InstallCabalOptions <$> optional
-  (option
-    (eitherReader
-      (\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
-    )
-    (short 'v' <> long "version" <> metavar "VERSION" <> help
-      "The Cabal version to install"
-    )
-  )
-
-
-toSettings :: Options -> Settings
-toSettings Options {..} = let cache = optCache in Settings { .. }
-
-
--- TODO: something better than Show instance for errors
-
-main :: IO ()
-main = do
-  -- logger interpreter
-  let runLogger = runStderrLoggingT
-
-  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
-    >>= \opt@Options {..} -> do
-          let settings = toSettings opt
-          -- wrapper to run effects with settings
-          let runInstTool =
-                runLogger
-                  . flip runReaderT settings
-                  . runE
-                    @'[ FileError
-                      , ArchiveError
-                      , ProcessError
-                      , URLException
-                      , PlatformResultError
-                      , NoDownload
-                      , NoCompatibleArch
-                      , DistroNotFound
-                      , TagNotFound
-                      , AlreadyInstalled
-                      , NotInstalled
-                      ]
-
-          case optCommand of
-            InstallGHC (InstallGHCOptions {..}) ->
-              void
-                $   (runInstTool $ do
-                      v <- maybe
-                        (  getRecommended availableDownloads GHC
-                        ?? TagNotFound Recommended GHC
-                        )
-                        pure
-                        ghcVer
-                      liftE $ installTool (ToolRequest GHC v)
-                                          Nothing
-                                          (OwnSpec availableDownloads)
-                    )
-                >>= \case
-                      VRight _ -> runLogger $ $(logInfo) ([s|GHC installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
-                        runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
-                      VLeft e -> die (color Red $ show e)
-            InstallCabal (InstallCabalOptions {..}) ->
-              void
-                $   (runInstTool $ do
-                      v <- maybe
-                        (  getRecommended availableDownloads Cabal
-                        ?? TagNotFound Recommended Cabal
-                        )
-                        pure
-                        cabalVer
-                      liftE $ installTool (ToolRequest Cabal v)
-                                          Nothing
-                                          (OwnSpec availableDownloads)
-                    )
-                >>= \case
-                      VRight _ -> runLogger $ $(logInfo) ([s|Cabal installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
-                        runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
-                      VLeft e -> die (color Red $ show e)
-  pure ()

app/ghcup-gen/Main.hs

@@ -0,0 +1,164 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module Main where
+
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Logger
+import           GHCupDownloads
+
+import           Data.Aeson                     ( eitherDecode )
+import           Data.Aeson.Encode.Pretty
+import           Data.Semigroup                 ( (<>) )
+import           Options.Applicative     hiding ( style )
+import           System.Console.Pretty
+import           System.Exit
+import           System.IO                      ( stdout )
+import           Validate
+
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.Lazy          as L
+
+
+data Options = Options
+  { optCommand :: Command
+  }
+
+data Command = GenJSON GenJSONOpts
+             | ValidateJSON ValidateJSONOpts
+             | ValidateTarballs ValidateJSONOpts
+
+data Output
+  = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdOutput
+
+fileOutput :: Parser Output
+fileOutput =
+  FileOutput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Output to a file"
+          )
+        )
+
+stdOutput :: Parser Output
+stdOutput = flag'
+  StdOutput
+  (short 'o' <> long "stdout" <> help "Print to stdout (default)")
+
+outputP :: Parser Output
+outputP = fileOutput <|> stdOutput
+
+
+data GenJSONOpts = GenJSONOpts
+  { output :: Maybe Output
+  }
+
+genJSONOpts :: Parser GenJSONOpts
+genJSONOpts = GenJSONOpts <$> optional outputP
+
+
+data Input
+  = FileInput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
+  | StdInput
+
+fileInput :: Parser Input
+fileInput =
+  FileInput
+    <$> (strOption
+          (long "file" <> short 'f' <> metavar "FILENAME" <> help
+            "Input file to validate"
+          )
+        )
+
+stdInput :: Parser Input
+stdInput = flag'
+  StdInput
+  (short 'i' <> long "stdin" <> help "Validate from stdin (default)")
+
+inputP :: Parser Input
+inputP = fileInput <|> stdInput
+
+data ValidateJSONOpts = ValidateJSONOpts
+  { input :: Maybe Input
+  }
+
+validateJSONOpts :: Parser ValidateJSONOpts
+validateJSONOpts = ValidateJSONOpts <$> optional inputP
+
+opts :: Parser Options
+opts = Options <$> com
+
+com :: Parser Command
+com = subparser
+  (  (command
+       "gen"
+       (   GenJSON
+       <$> (info (genJSONOpts <**> helper)
+                 (progDesc "Generate the json downloads file")
+           )
+       )
+     )
+  <> (command
+       "check"
+       (   ValidateJSON
+       <$> (info (validateJSONOpts <**> helper)
+                 (progDesc "Validate the JSON")
+           )
+       )
+     )
+  <> (command
+       "check-tarballs"
+       (   ValidateTarballs
+       <$> (info
+             (validateJSONOpts <**> helper)
+             (progDesc "Validate all tarballs (download and checksum)")
+           )
+       )
+     )
+  )
+
+
+
+main :: IO ()
+main = do
+  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+    >>= \Options {..} -> case optCommand of
+          GenJSON gopts -> do
+            let
+              bs = encodePretty' (defConfig { confIndent = Spaces 2 })
+                                 ghcupDownloads
+            case gopts of
+              GenJSONOpts { output = Nothing }        -> L.hPutStr stdout bs
+              GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
+              GenJSONOpts { output = Just (FileOutput file) } ->
+                L.writeFile file bs
+          ValidateJSON vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validate
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validate
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validate
+          ValidateTarballs vopts -> case vopts of
+            ValidateJSONOpts { input = Nothing } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just StdInput } ->
+              L.getContents >>= valAndExit validateTarballs
+            ValidateJSONOpts { input = Just (FileInput file) } ->
+              L.readFile file >>= valAndExit validateTarballs
+  pure ()
+
+ where
+  valAndExit f contents = do
+    av <- case eitherDecode contents of
+      Right r -> pure r
+      Left  e -> die (color Red $ show e)
+    myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
+      >>= exitWith
+

app/ghcup-gen/Validate.hs

@@ -0,0 +1,181 @@
+{-# LANGUAGE TemplateHaskell  #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE QuasiQuotes      #-}
+
+module Validate where
+
+import           GHCup
+import           GHCup.Download
+import           GHCup.Types
+import           GHCup.Utils.Logger
+
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.Logger
+import           Control.Monad.Reader.Class
+import           Control.Monad.Trans.Class      ( lift )
+import           Control.Monad.Trans.Reader     ( runReaderT )
+import           Control.Monad.Trans.Resource   ( runResourceT
+                                                , MonadUnliftIO
+                                                )
+import           Data.IORef
+import           Data.List
+import           Data.String.Interpolate
+import           Data.Versions
+import           Haskus.Utils.Variant.Excepts
+import           Optics
+import           System.Exit
+import           System.IO
+
+import qualified Data.ByteString               as B
+import qualified Data.Map.Strict               as M
+
+
+data ValidationError = InternalError String
+  deriving Show
+
+instance Exception ValidationError
+
+
+addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
+addError = do
+  ref <- ask
+  liftIO $ modifyIORef ref (+ 1)
+
+
+validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
+         => GHCupDownloads
+         -> m ExitCode
+validate dls = do
+  ref <- liftIO $ newIORef 0
+
+  -- * verify binary downloads * --
+  flip runReaderT ref $ do
+    -- unique tags
+    forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
+
+    -- required platforms
+    forM_ (M.toList dls) $ \(t, versions) ->
+      forM_ (M.toList versions) $ \(v, vi) ->
+        forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do
+          checkHasRequiredPlatforms t v arch (M.keys pspecs)
+
+    checkGHCisSemver
+    forM_ (M.toList dls) $ \(t, _) -> checkMandatoryTags t
+
+    -- exit
+    e <- liftIO $ readIORef ref
+    if e > 0
+      then pure $ ExitFailure e
+      else do
+        lift $ $(logInfo) [i|All good|]
+        pure ExitSuccess
+ where
+  checkHasRequiredPlatforms t v arch pspecs = do
+    let v' = prettyVer v
+    when (not $ any (== Linux UnknownLinux) pspecs) $ do
+      lift $ $(logError)
+        [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
+      addError
+    when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
+      lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
+      addError
+    when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn)
+      [i|FreeBSD missing for #{t} #{v'} #{arch}|]
+
+  checkUniqueTags tool = do
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
+    let nonUnique =
+          fmap fst
+            .   filter (\(_, b) -> not b)
+            <$> ( mapM
+                    (\case
+                      [] -> throwM $ InternalError "empty inner list"
+                      (t : ts) ->
+                        pure $ (t, ) $ if isUniqueTag t then ts == [] else True
+                    )
+                . group
+                . sort
+                $ allTags
+                )
+    case join nonUnique of
+      [] -> pure ()
+      xs -> do
+        lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|]
+        addError
+   where
+    isUniqueTag Latest      = True
+    isUniqueTag Recommended = True
+
+  checkGHCisSemver = do
+    let ghcVers = toListOf (ix GHC % to M.keys % folded) dls
+    forM_ ghcVers $ \v -> case semver (prettyVer v) of
+      Left _ -> do
+        lift $ $(logError) [i|GHC version #{v} is not valid semver|]
+        addError
+      Right _ -> pure ()
+
+  -- a tool must have at least one of each mandatory tags
+  checkMandatoryTags tool = do
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
+    forM_ [Latest, Recommended] $ \t -> case elem t allTags of
+      False -> do
+        lift $ $(logError) [i|Tag #{t} missing from #{tool}|]
+        addError
+      True -> pure ()
+
+
+validateTarballs :: ( Monad m
+                    , MonadLogger m
+                    , MonadThrow m
+                    , MonadIO m
+                    , MonadUnliftIO m
+                    , MonadMask m
+                    )
+                 => GHCupDownloads
+                 -> m ExitCode
+validateTarballs dls = do
+  ref <- liftIO $ newIORef 0
+
+  flip runReaderT ref $ do
+     -- download/verify all binary tarballs
+    let
+      dlbis = nub $ join $ (M.elems dls) <&> \versions ->
+        join $ (M.elems versions) <&> \vi ->
+          join $ (M.elems $ _viArch vi) <&> \pspecs ->
+            join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs)
+    forM_ dlbis $ downloadAll
+
+    let dlsrc = nub $ join $ (M.elems dls) <&> \versions ->
+          join $ (M.elems versions) <&> maybe [] (: []) . _viSourceDL
+    forM_ dlsrc $ downloadAll
+
+    -- exit
+    e <- liftIO $ readIORef ref
+    if e > 0
+      then pure $ ExitFailure e
+      else do
+        lift $ $(logInfo) [i|All good|]
+        pure ExitSuccess
+
+ where
+  downloadAll dli = do
+    let settings = Settings True GHCupURL False
+    let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
+                                           , colorOutter  = B.hPut stderr
+                                           , rawOutter    = (\_ -> pure ())
+                                           }
+
+    r <-
+      runLogger
+      . flip runReaderT settings
+      . runResourceT
+      . runE
+      $ downloadCached dli Nothing
+    case r of
+      VRight _ -> pure ()
+      VLeft  e -> do
+        lift $ $(logError)
+          [i|Could not download (or verify hash) of #{dli}, Error was: #{e}|]
+        addError

app/ghcup/Main.hs

@@ -0,0 +1,702 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
+{-# LANGUAGE QuasiQuotes       #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+
+
+module Main where
+
+import           GHCup
+import           GHCup.Download
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Utils
+import           GHCup.Utils.Logger
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+import           GHCup.Version
+
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Bifunctor
+import           Data.Char
+import           Data.List                      ( intercalate )
+import           Data.Semigroup                 ( (<>) )
+import           Data.String.Interpolate
+import           Data.Versions
+import           Haskus.Utils.Variant.Excepts
+import           HPath
+import           HPath.IO
+import           Options.Applicative     hiding ( style )
+import           Prelude                 hiding ( appendFile )
+import           System.Console.Pretty
+import           System.Environment
+import           System.Exit
+import           System.IO               hiding ( appendFile )
+import           Text.Read
+import           Text.Layout.Table
+import           URI.ByteString
+
+import qualified Data.ByteString               as B
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified Data.Text                     as T
+import qualified Data.Text.IO                  as T
+import qualified Data.Text.Encoding            as E
+
+
+
+
+
+data Options = Options
+  {
+  -- global options
+    optVerbose   :: Bool
+  , optCache     :: Bool
+  , optUrlSource :: Maybe URI
+  , optNoVerify  :: Bool
+  -- commands
+  , optCommand   :: Command
+  }
+
+data Command
+  = Install InstallCommand
+  | SetGHC SetGHCOptions
+  | List ListOptions
+  | Rm RmOptions
+  | DInfo
+  | Compile CompileCommand
+  | Upgrade UpgradeOpts
+  | NumericVersion
+
+data ToolVersion = ToolVersion Version
+                 | ToolTag Tag
+
+
+data InstallCommand = InstallGHC InstallOptions
+                    | InstallCabal InstallOptions
+
+data InstallOptions = InstallOptions
+  { instVer :: Maybe ToolVersion
+  }
+
+data SetGHCOptions = SetGHCOptions
+  { ghcVer :: Maybe ToolVersion
+  }
+
+data ListOptions = ListOptions
+  { lTool     :: Maybe Tool
+  , lCriteria :: Maybe ListCriteria
+  }
+
+data RmOptions = RmOptions
+  { ghcVer :: Version
+  }
+
+
+data CompileCommand = CompileGHC CompileOptions
+                    | CompileCabal CompileOptions
+
+
+data CompileOptions = CompileOptions
+  { targetVer    :: Version
+  , bootstrapVer :: Version
+  , jobs         :: Maybe Int
+  , buildConfig  :: Maybe (Path Abs)
+  }
+
+data UpgradeOpts = UpgradeInplace
+                 | UpgradeAt (Path Abs)
+                 | UpgradeGHCupDir
+                 deriving Show
+
+
+opts :: Parser Options
+opts =
+  Options
+    <$> switch
+          (short 'v' <> long "verbose" <> help
+            "Whether to enable verbosity (default: False)"
+          )
+    <*> switch
+          (short 'c' <> long "cache" <> help
+            "Whether to cache downloads (default: False)"
+          )
+    <*> (optional
+          (option
+            (eitherReader parseUri)
+            (short 's' <> long "url-source" <> metavar "URL" <> help
+              "Alternative ghcup download info url" <> internal
+            )
+          )
+        )
+    <*> switch
+          (short 'n' <> long "no-verify" <> help
+            "Skip tarball checksum verification (default: False)"
+          )
+    <*> com
+ where
+  parseUri s' =
+    bimap show id $ parseURI strictURIParserOptions (UTF8.fromString s')
+
+
+com :: Parser Command
+com =
+  subparser
+      (  command
+          "install"
+          (   Install
+          <$> (info (installP <**> helper)
+                    (progDesc "Install or update GHC/cabal")
+              )
+          )
+      <> command
+           "list"
+           (   List
+           <$> (info (listOpts <**> helper)
+                     (progDesc "Show available GHCs and other tools")
+               )
+           )
+      <> command
+           "upgrade"
+           (   Upgrade
+           <$> (info
+                 (upgradeOptsP <**> helper)
+                 (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")
+               )
+           )
+          <> command
+               "compile"
+               (   Compile
+               <$> (info (compileP <**> helper)
+                         (progDesc "Compile a tool from source")
+                   )
+               )
+      <> commandGroup "Main commands:"
+      )
+    <|> subparser
+          (  command
+              "set"
+              (   SetGHC
+              <$> (info (setGHCOpts <**> helper)
+                        (progDesc "Set the currently active GHC version")
+                  )
+              )
+          <> command
+               "rm"
+               (   Rm
+               <$> (info
+                     (rmOpts <**> helper)
+                     (progDesc "Remove a GHC version installed by ghcup")
+                   )
+               )
+          <> commandGroup "GHC commands:"
+          <> hidden
+          )
+    <|> subparser
+          (  command
+              "debug-info"
+              ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
+          <> command
+               "numeric-version"
+               (   (\_ -> NumericVersion)
+               <$> (info (helper) (progDesc "Show the numeric version"))
+               )
+          <> commandGroup "Other commands:"
+          <> hidden
+          )
+
+
+installP :: Parser InstallCommand
+installP = subparser
+  (  command
+      "ghc"
+      (   InstallGHC
+      <$> (info (installOpts <**> helper) (progDesc "Install a GHC version"))
+      )
+  <> command
+       "cabal"
+       (   InstallCabal
+       <$> (info (installOpts <**> helper)
+                 (progDesc "Install or update a Cabal version")
+           )
+       )
+  )
+
+installOpts :: Parser InstallOptions
+installOpts = InstallOptions <$> optional toolVersionParser
+
+setGHCOpts :: Parser SetGHCOptions
+setGHCOpts = SetGHCOptions <$> optional toolVersionParser
+
+listOpts :: Parser ListOptions
+listOpts =
+  ListOptions
+    <$> optional
+          (option
+            (eitherReader toolParser)
+            (short 't' <> long "tool" <> metavar "<ghc|cabal>" <> help
+              "Tool to list versions for. Default is all"
+            )
+          )
+    <*> (optional
+          (option
+            (eitherReader criteriaParser)
+            (  short 'c'
+            <> long "show-criteria"
+            <> metavar "<installed|set>"
+            <> help "Show only installed or set tool versions"
+            )
+          )
+        )
+
+rmOpts :: Parser RmOptions
+rmOpts = RmOptions <$> versionParser
+
+
+compileP :: Parser CompileCommand
+compileP = subparser
+  (  command
+      "ghc"
+      (   CompileGHC
+      <$> (info (compileOpts <**> helper) (progDesc "Compile GHC from source")
+          )
+      )
+  <> command
+       "cabal"
+       (   CompileCabal
+       <$> (info (compileOpts <**> helper)
+                 (progDesc "Compile Cabal from source")
+           )
+       )
+  )
+
+
+compileOpts :: Parser CompileOptions
+compileOpts =
+  CompileOptions
+    <$> (option
+          (eitherReader
+            (bimap (const "Not a valid version") id . version . T.pack)
+          )
+          (short 'v' <> long "version" <> metavar "VERSION" <> help
+            "The tool version to compile"
+          )
+        )
+    <*> (option
+          (eitherReader
+            (bimap (const "Not a valid version") id . version . T.pack)
+          )
+          (  short 'b'
+          <> long "bootstrap-version"
+          <> metavar "BOOTSTRAP_VERSION"
+          <> help "The GHC version to bootstrap with (must be installed)"
+          )
+        )
+    <*> optional
+          (option
+            (eitherReader (readEither @Int))
+            (short 'j' <> long "jobs" <> metavar "JOBS" <> help
+              "How many jobs to use for make"
+            )
+          )
+    <*> optional
+          (option
+            (eitherReader
+              (\x ->
+                bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
+                    String
+                    (Path Abs)
+              )
+            )
+            (short 'c' <> long "config" <> metavar "CONFIG" <> help
+              "Absolute path to build config file"
+            )
+          )
+
+
+versionParser :: Parser Version
+versionParser = option
+  (eitherReader (bimap (const "Not a valid version") id . version . T.pack))
+  (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
+  )
+
+
+toolVersionParser :: Parser ToolVersion
+toolVersionParser = verP <|> toolP
+ where
+  verP = ToolVersion <$> versionParser
+  toolP =
+    ToolTag
+      <$> (option
+            (eitherReader
+              (\s' -> case fmap toLower s' of
+                "recommended" -> Right Recommended
+                "latest"      -> Right Latest
+                other         -> Left ([i|Unknown tag #{other}|])
+              )
+            )
+            (short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
+          )
+
+
+toolParser :: String -> Either String Tool
+toolParser s' | t == T.pack "ghc"   = Right GHC
+              | t == T.pack "cabal" = Right Cabal
+              | otherwise           = Left ("Unknown tool: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+criteriaParser :: String -> Either String ListCriteria
+criteriaParser s' | t == T.pack "installed" = Right ListInstalled
+                  | t == T.pack "set"       = Right ListSet
+                  | otherwise               = Left ("Unknown criteria: " <> s')
+  where t = T.toLower (T.pack s')
+
+
+toSettings :: Options -> Settings
+toSettings Options {..} =
+  let cache     = optCache
+      urlSource = maybe GHCupURL OwnSource optUrlSource
+      noVerify  = optNoVerify
+  in  Settings { .. }
+
+
+upgradeOptsP :: Parser UpgradeOpts
+upgradeOptsP =
+  flag'
+      UpgradeInplace
+      (short 'i' <> long "inplace" <> help
+        "Upgrade ghcup in-place (wherever it's at)"
+      )
+    <|> (   UpgradeAt
+        <$> (option
+              (eitherReader
+                (\x ->
+                  bimap show id . parseAbs . E.encodeUtf8 . T.pack $ x :: Either
+                      String
+                      (Path Abs)
+                )
+              )
+              (short 't' <> long "target" <> metavar "TARGET_DIR" <> help
+                "Absolute filepath to write ghcup into"
+              )
+            )
+        )
+    <|> (pure UpgradeGHCupDir)
+
+
+
+
+main :: IO ()
+main = do
+
+  customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+    >>= \opt@Options {..} -> do
+          let settings = toSettings opt
+
+          -- logger interpreter
+          logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel)
+          let runLogger = myLoggerT LoggerConfig
+                { lcPrintDebug = optVerbose
+                , colorOutter  = B.hPut stderr
+                , rawOutter    = appendFile logfile
+                }
+
+          -- wrapper to run effects with settings
+          let runInstTool =
+                runLogger
+                  . flip runReaderT settings
+                  . runResourceT
+                  . runE
+                    @'[ AlreadyInstalled
+                      , UnknownArchive
+                      , DistroNotFound
+                      , FileDoesNotExistError
+                      , CopyError
+                      , JSONError
+                      , NoCompatibleArch
+                      , NoDownload
+                      , NotInstalled
+                      , NoCompatiblePlatform
+                      , BuildFailed
+                      , TagNotFound
+                      , DigestError
+                      , DownloadFailed
+                      ]
+
+          let runSetGHC =
+                runLogger
+                  . flip runReaderT settings
+                  . runE
+                    @'[ FileDoesNotExistError
+                      , NotInstalled
+                      , TagNotFound
+                      , JSONError
+                      , TagNotFound
+                      , DownloadFailed
+                      ]
+
+          let runListGHC =
+                runLogger
+                  . flip runReaderT settings
+                  . runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
+
+          let runRmGHC =
+                runLogger . flip runReaderT settings . runE @'[NotInstalled]
+
+          let runDebugInfo =
+                runLogger
+                  . flip runReaderT settings
+                  . runE
+                    @'[NoCompatiblePlatform , NoCompatibleArch , DistroNotFound]
+
+          let runCompileGHC =
+                runLogger
+                  . flip runReaderT settings
+                  . runResourceT
+                  . runE
+                    @'[ AlreadyInstalled
+                      , BuildFailed
+                      , DigestError
+                      , DownloadFailed
+                      , GHCupSetError
+                      , NoDownload
+                      , UnknownArchive
+                     --
+                      , JSONError
+                      ]
+
+          let runCompileCabal =
+                runLogger
+                  . flip runReaderT settings
+                  . runResourceT
+                  . runE
+                    @'[ JSONError
+                      , UnknownArchive
+                      , NoDownload
+                      , DigestError
+                      , DownloadFailed
+                      , BuildFailed
+                      ]
+
+          let runUpgrade =
+                runLogger
+                  . flip runReaderT settings
+                  . runResourceT
+                  . runE
+                    @'[ DigestError
+                      , DistroNotFound
+                      , NoCompatiblePlatform
+                      , NoCompatibleArch
+                      , NoDownload
+                      , FileDoesNotExistError
+                      , JSONError
+                      , DownloadFailed
+                      , CopyError
+                      ]
+
+
+          case optCommand of
+            Install (InstallGHC InstallOptions {..}) ->
+              void
+                $   (runInstTool $ do
+                      dls <- liftE getDownloads
+                      v   <- liftE $ fromVersion dls instVer GHC
+                      liftE $ installGHCBin dls v Nothing
+                    )
+                >>= \case
+                      VRight _ -> runLogger
+                        $ $(logInfo) ([s|GHC installation successful|])
+                      VLeft (V (AlreadyInstalled _ v)) ->
+                        runLogger $ $(logWarn)
+                          [i|GHC ver #{prettyVer v} already installed|]
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
+                      VLeft e -> do
+                        runLogger $ do
+                          $(logError) [i|#{e}|]
+                          $(logError) [i|Also check the logs in ~/.ghcup/logs|]
+                        exitFailure
+            Install (InstallCabal InstallOptions {..}) ->
+              void
+                $   (runInstTool $ do
+                      dls <- liftE getDownloads
+                      v   <- liftE $ fromVersion dls instVer Cabal
+                      liftE $ installCabalBin dls v Nothing
+                    )
+                >>= \case
+                      VRight _ -> runLogger
+                        $ $(logInfo) ([s|Cabal installation successful|])
+                      VLeft (V (AlreadyInstalled _ v)) ->
+                        runLogger $ $(logWarn)
+                          [i|Cabal ver #{prettyVer v} already installed|]
+                      VLeft e -> do
+                        runLogger $ do
+                          $(logError) [i|#{e}|]
+                          $(logError) [i|Also check the logs in ~/.ghcup/logs|]
+                        exitFailure
+
+            SetGHC (SetGHCOptions {..}) ->
+              void
+                $   (runSetGHC $ do
+                      dls <- liftE getDownloads
+                      v   <- liftE $ fromVersion dls ghcVer GHC
+                      liftE $ setGHC v SetGHCOnly
+                    )
+                >>= \case
+                      VRight _ ->
+                        runLogger $ $(logInfo) ([s|GHC successfully set|])
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            List (ListOptions {..}) ->
+              void
+                $   (runListGHC $ do
+                      dls <- liftE getDownloads
+                      liftIO $ listVersions dls lTool lCriteria
+                    )
+                >>= \case
+                      VRight r -> liftIO $ printListResult r
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            Rm (RmOptions {..}) ->
+              void
+                $   (runRmGHC $ do
+                      liftE $ rmGHCVer ghcVer
+                    )
+                >>= \case
+                      VRight _ -> pure ()
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            DInfo -> do
+              void
+                $   (runDebugInfo $ do
+                      liftE $ getDebugInfo
+                    )
+                >>= \case
+                      VRight dinfo -> putStrLn $ show dinfo
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            Compile (CompileGHC CompileOptions {..}) ->
+              void
+                $   (runCompileGHC $ do
+                      dls <- liftE getDownloads
+                      liftE
+                        $ compileGHC dls targetVer bootstrapVer jobs buildConfig
+                    )
+                >>= \case
+                      VRight _ ->
+                        runLogger $ $(logInfo)
+                          ([s|GHC successfully compiled and installed|])
+                      VLeft (V (AlreadyInstalled _ v)) ->
+                        runLogger $ $(logWarn)
+                          [i|GHC ver #{prettyVer v} already installed|]
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            Compile (CompileCabal CompileOptions {..}) ->
+              void
+                $   (runCompileCabal $ do
+                      dls <- liftE getDownloads
+                      liftE $ compileCabal dls
+                                           targetVer
+                                           bootstrapVer
+                                           jobs
+                    )
+                >>= \case
+                      VRight _ ->
+                        runLogger $ $(logInfo)
+                          ([s|Cabal successfully compiled and installed|])
+                      VLeft (V (BuildFailed tmpdir e)) ->
+                        runLogger
+                            ($(logError) [i|Build failed with #{e}
+Check the logs at ~/ghcup/logs and the build directory #{tmpdir} for more clues.|]
+                            )
+                          >> exitFailure
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            Upgrade (uOpts) -> do
+              target <- case uOpts of
+                UpgradeInplace -> do
+                  efp <- liftIO $ getExecutablePath
+                  p   <- parseAbs . E.encodeUtf8 . T.pack $ efp
+                  pure $ Just p
+                (UpgradeAt p)   -> pure $ Just p
+                UpgradeGHCupDir -> do
+                  bdir <- liftIO $ ghcupBinDir
+                  pure (Just (bdir </> ([rel|ghcup|] :: Path Rel)))
+
+              void
+                $   (runUpgrade $ do
+                      dls <- liftE getDownloads
+                      liftE $ upgradeGHCup dls target
+                    )
+                >>= \case
+                      VRight v' -> do
+                        let pretty_v = prettyVer v'
+                        runLogger
+                          $ $(logInfo)
+                              [i|Successfully upgraded GHCup to version #{pretty_v}|]
+                      VLeft e ->
+                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+
+            NumericVersion -> T.hPutStr stdout (prettyPVP ghcUpVer)
+  pure ()
+
+
+fromVersion :: Monad m
+            => GHCupDownloads
+            -> Maybe ToolVersion
+            -> Tool
+            -> Excepts '[TagNotFound] m Version
+fromVersion av Nothing tool =
+  getRecommended av tool ?? TagNotFound Recommended tool
+fromVersion _ (Just (ToolVersion v)) _ = pure v
+fromVersion av (Just (ToolTag Latest)) tool =
+  getLatest av tool ?? TagNotFound Latest tool
+fromVersion av (Just (ToolTag Recommended)) tool =
+  getRecommended av tool ?? TagNotFound Recommended tool
+
+
+printListResult :: [ListResult] -> IO ()
+printListResult lr = do
+  let
+    formatted =
+      gridString
+          [ column expand left def def
+          , column expand left def def
+          , column expand left def def
+          , column expand left def def
+          , column expand left def def
+          ]
+        $ fmap
+            (\ListResult {..} ->
+              [ if
+                | lSet       -> (color Green "✔✔")
+                | lInstalled -> (color Green "✓")
+                | otherwise  -> (color Red "✗")
+              , fmap toLower . show $ lTool
+              , T.unpack . prettyVer $ lVer
+              , intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
+              , if fromSrc then (color Blue "compiled") else mempty
+              ]
+            )
+            lr
+  putStrLn $ formatted

cabal.project

@@ -13,12 +13,3 @@ package ghcup
 package tar-bytestring
     ghc-options: -O2
 
-source-repository-package
-  type: git
-  location: https://github.com/composewell/streamly
-  tag: 4eb53e7f868bdc08afcc4b5210ab5916b9a4dfbc
-
-source-repository-package
-  type: git
-  location: https://github.com/hasufell/tar-bytestring
-  tag: 64707be1abb534e88007e3320090598a0a9490a7

cabal.project.freeze

@@ -1,5 +1,4 @@
 constraints: any.Cabal ==2.4.0.1,
-             any.HUnit ==1.6.0.0,
              any.HsOpenSSL ==0.11.4.17,
              HsOpenSSL -fast-bignum -homebrew-openssl -macports-openssl -old-locale,
              any.IfElse ==0.85,
@@ -10,81 +9,97 @@ constraints: any.Cabal ==2.4.0.1,
              abstract-deque -usecas,
              any.aeson ==1.4.6.0,
              aeson -bytestring-builder -cffi -developer -fast,
+             any.aeson-pretty ==0.8.8,
+             aeson-pretty -lib-only,
              any.ansi-terminal ==0.10.3,
              ansi-terminal -example,
+             any.ansi-wl-pprint ==0.6.9,
+             ansi-wl-pprint -example,
              any.array ==0.5.3.0,
              any.ascii-string ==1.0.1.4,
+             any.assoc ==1.0.1,
              any.async ==2.2.2,
              async -bench,
              any.atomic-primops ==0.8.3,
              atomic-primops -debug,
              any.attoparsec ==0.13.2.3,
              attoparsec -developer,
+             any.auto-update ==0.1.6,
              any.base ==4.12.0.0,
              any.base-compat ==0.11.1,
              any.base-orphans ==0.8.2,
              any.base-prelude ==1.3,
+             any.base16-bytestring ==0.1.1.6,
              any.base64-bytestring ==1.0.0.3,
-             any.basement ==0.0.11,
              any.bifunctors ==5.5.7,
              bifunctors +semigroups +tagged,
              any.binary ==0.8.6.0,
              any.blaze-builder ==0.4.1.0,
+             any.brotli ==0.0.0.0,
+             any.brotli-streams ==0.0.0.0,
              any.bytestring ==0.10.8.2,
              any.bytestring-builder ==0.10.8.2.0,
              bytestring-builder +bytestring_has_builder,
              any.bzlib ==0.5.0.5,
              any.cabal-doctest ==1.0.8,
-             any.call-stack ==0.2.0,
              any.case-insensitive ==1.2.1.0,
              any.cereal ==0.5.8.1,
              cereal -bytestring-builder,
              any.clock ==0.8,
              clock -llvm,
+             any.cmdargs ==0.10.20,
+             cmdargs +quotation -testprog,
              any.colour ==2.3.5,
              any.comonad ==5.0.6,
              comonad +containers +distributive +test-doctests,
+             any.conduit ==1.3.1.2,
+             any.conduit-extra ==1.3.4,
              any.containers ==0.6.0.1,
              any.contravariant ==1.5.2,
              contravariant +semigroups +statevar +tagged,
              any.data-default-class ==0.1.2.0,
+             any.data-default-instances-base ==0.1.0.1,
              any.deepseq ==1.4.4.0,
              any.deferred-folds ==0.9.10.1,
-             any.directory ==1.3.3.0,
+             any.directory ==1.3.3.0 || ==1.3.6.0,
              any.distributive ==0.6.1,
              distributive +semigroups +tagged,
              any.dlist ==0.8.0.7,
+             any.easy-file ==0.2.2,
+             any.errors ==2.3.0,
              any.exceptions ==0.10.4,
              exceptions +transformers-0-4,
+             any.extra ==1.7,
+             any.fast-logger ==3.0.1,
              any.filepath ==1.4.2.1,
              any.focus ==1.0.1.3,
              any.foldl ==1.4.6,
-             any.fusion-plugin ==0.1.1,
-             any.gauge ==0.2.5,
-             gauge +analysis,
+             any.free ==5.1.3,
+             any.fusion-plugin-types ==0.1.0,
              any.generics-sop ==0.5.0.0,
-             any.ghc ==8.6.5,
-             any.ghc-boot ==8.6.5,
              any.ghc-boot-th ==8.6.5,
-             any.ghc-heap ==8.6.5,
              any.ghc-prim ==0.5.3,
-             any.ghci ==8.6.5,
+             any.happy ==1.19.12,
+             happy +small_base,
              any.hashable ==1.3.0.0,
              hashable -examples +integer-gmp +sse2 -sse41,
+             any.haskell-src-exts ==1.23.0,
+             any.haskell-src-meta ==0.8.5,
+             any.haskus-utils-data ==1.2,
+             any.haskus-utils-types ==1.5,
+             any.haskus-utils-variant ==3.0,
              any.heaps ==0.3.6.1,
+             any.hopenssl ==2.2.4,
+             hopenssl -link-libz,
              any.hpath ==0.11.0,
              any.hpath-directory ==0.13.2,
              any.hpath-filepath ==0.10.4,
              any.hpath-io ==0.13.1,
              any.hpath-posix ==0.13.1,
-             any.hpc ==0.6.0.3,
              any.hsc2hs ==0.68.6,
              hsc2hs -in-ghc-tree,
-             any.hspec ==2.7.1,
-             any.hspec-core ==2.7.1,
-             any.hspec-discover ==2.7.1,
-             any.hspec-expectations ==0.8.2,
-             any.http-io-streams ==0.1.0.0,
+             any.http-io-streams ==0.1.2.0,
+             http-io-streams +brotli,
              any.indexed-profunctors ==0.1,
              any.integer-gmp ==1.0.2.0,
              any.integer-logarithms ==1.0.3,
@@ -92,6 +107,7 @@ constraints: any.Cabal ==2.4.0.1,
              any.io-streams ==1.5.1.0,
              io-streams -nointeractivetests,
              any.language-bash ==0.9.0,
+             any.lifted-base ==0.2.3.12,
              any.list-t ==1.0.4,
              any.lockfree-queue ==0.2.3.1,
              any.lzma ==0.0.0.3,
@@ -101,29 +117,42 @@ constraints: any.Cabal ==2.4.0.1,
              megaparsec -dev,
              any.mmorph ==1.1.3,
              any.monad-control ==1.0.2.3,
+             any.monad-logger ==0.3.32,
+             monad-logger +template_haskell,
+             any.monad-loops ==0.4.3,
+             monad-loops +base4,
+             any.mono-traversable ==1.0.15.1,
              any.mtl ==2.2.2,
              any.mwc-random ==0.14.0.0,
-             any.network ==3.0.1.1,
-             any.network-uri ==2.6.2.0,
+             any.network ==3.1.1.1,
+             any.network-uri ==2.6.3.0,
+             any.old-locale ==1.0.0.7,
+             any.old-time ==1.1.0.3,
              any.openssl-streams ==1.2.2.0,
              any.optics ==0.2,
              any.optics-core ==0.2,
              any.optics-extra ==0.2,
              any.optics-th ==0.2,
+             any.optics-vl ==0.2,
+             any.optparse-applicative ==0.15.1.0,
              any.parsec ==3.1.13.0,
              any.parser-combinators ==1.2.1,
              parser-combinators -dev,
              any.pretty ==1.1.3.6,
+             any.pretty-terminal ==0.1.0.0,
              any.prettyprinter ==1.6.1,
              prettyprinter -buildreadme,
-             any.primitive ==0.7.0.0,
+             any.primitive ==0.7.0.1,
              any.primitive-extras ==0.8,
              any.primitive-unlifted ==0.1.3.0,
-             any.process ==1.6.5.0,
+             any.process ==1.6.5.0 || ==1.6.8.0,
              any.profunctors ==5.5.2,
-             any.quickcheck-io ==0.2.0,
              any.random ==1.1,
+             any.recursion-schemes ==5.1.3,
+             recursion-schemes +template-haskell,
+             any.resourcet ==1.2.3,
              any.rts ==1.0,
+             any.safe ==0.3.18,
              any.safe-exceptions ==0.1.7.0,
              any.scientific ==0.3.6.2,
              scientific -bytestring-builder -integer-simple,
@@ -131,27 +160,42 @@ constraints: any.Cabal ==2.4.0.1,
              semigroupoids +comonad +containers +contravariant +distributive +doctests +tagged +unordered-containers,
              any.semigroups ==0.19.1,
              semigroups +binary +bytestring -bytestring-builder +containers +deepseq +hashable +tagged +template-haskell +text +transformers +unordered-containers,
-             any.setenv ==0.1.1.3,
              any.sop-core ==0.5.0.0,
-             any.splitmix ==0.0.3,
+             any.split ==0.2.3.4,
+             any.splitmix ==0.0.4,
              splitmix -optimised-mixer +random,
              any.stm ==2.5.0.0,
+             any.stm-chans ==3.0.0.4,
+             any.streaming-commons ==0.2.1.2,
+             streaming-commons -use-bytestring-builder,
+             any.streamly ==0.7.1,
              streamly -debug -dev -examples -examples-sdl -fusion-plugin -has-llvm -inspection -no-charts -no-fusion -streamk,
              any.streamly-bytestring ==0.1.2,
+             any.streamly-posix ==0.1.0.0,
              any.strict-base ==0.4.0.0,
+             any.string-interpolate ==0.2.0.0,
              any.syb ==0.7.1,
+             any.table-layout ==0.8.0.5,
              any.tagged ==0.8.6,
              tagged +deepseq +transformers,
-             any.tar-bytestring ==0.6.2.0,
+             any.tar-bytestring ==0.6.3.0,
              any.template-haskell ==2.14.0.0,
-             any.terminfo ==0.4.1.2,
+             any.terminal-progress-bar ==0.4.1,
+             any.terminal-size ==0.3.2.1,
              any.text ==1.2.3.1,
+             any.text-conversions ==0.3.0,
              any.text-icu ==0.7.0.1,
              any.text-short ==0.1.3,
              text-short -asserts,
-             any.tf-random ==0.5,
              any.th-abstraction ==0.3.2.0,
-             any.time ==1.8.0.2,
+             any.th-expand-syns ==0.4.5.0,
+             any.th-lift ==0.8.1,
+             any.th-lift-instances ==0.1.14,
+             any.th-orphans ==0.13.9,
+             any.th-reify-many ==0.1.9,
+             any.these ==1.0.1,
+             these +aeson +assoc +quickcheck +semigroupoids,
+             any.time ==1.8.0.2 || ==1.9.3,
              any.time-compat ==1.9.2.2,
              time-compat -old-locale,
              any.transformers ==0.5.6.2,
@@ -162,14 +206,20 @@ constraints: any.Cabal ==2.4.0.1,
              any.typed-process ==0.2.6.0,
              any.unix ==2.7.2.2,
              any.unix-bytestring ==0.3.7.3,
-             any.unliftio-core ==0.1.2.0,
+             any.unix-compat ==0.5.2,
+             unix-compat -old-time,
+             any.unix-time ==0.4.7,
+             any.unliftio-core ==0.2.0.1,
              any.unordered-containers ==0.2.10.0,
              unordered-containers -debug,
-             any.url ==2.1.3,
+             any.uri-bytestring ==0.3.2.2,
+             uri-bytestring -lib-werror,
              any.utf8-string ==1.0.1.1,
              any.uuid-types ==1.0.3,
              any.vector ==0.12.1.2,
              vector +boundschecks -internalchecks -unsafechecks -wall,
+             any.vector-algorithms ==0.8.0.3,
+             vector-algorithms +bench +boundschecks -internalchecks -llvm +properties -unsafechecks,
              any.vector-builder ==0.3.8,
              any.vector-th-unbox ==0.2.1.7,
              any.versions ==3.5.3,

ghcup.cabal

@@ -22,20 +22,26 @@ source-repository head
 
 common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
 common aeson { build-depends: aeson >= 1.4 }
+common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 }
 common ascii-string { build-depends: ascii-string >= 1.0 }
 common async { build-depends: async >= 0.8 }
+common attoparsec { build-depends: attoparsec >= 0.13 }
 common base { build-depends: base >= 4.12 && < 5 }
+common binary { build-depends: binary >= 0.8.6.0 }
 common bytestring { build-depends: bytestring >= 0.10 }
 common bzlib { build-depends: bzlib >= 0.5.0.5 }
+common case-insensitive { build-depends: case-insensitive >= 1.2.1.0 }
 common containers { build-depends: containers >= 0.6 }
 common generics-sop { build-depends: generics-sop >= 0.5 }
+common haskus-utils-types { build-depends: haskus-utils-types >= 1.5 }
 common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
+common hopenssl { build-depends: hopenssl >= 2.2.4 }
 common hpath { build-depends: hpath >= 0.11 }
 common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
 common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
 common hpath-io { build-depends: hpath-io >= 0.13.1 }
 common hpath-posix { build-depends: hpath-posix >= 0.11.1 }
-common http-io-streams { build-depends: http-io-streams >= 0.1 }
+common http-io-streams { build-depends: http-io-streams >= 0.1.2.0 }
 common io-streams { build-depends: io-streams >= 1.5 }
 common language-bash { build-depends: language-bash >= 0.9 }
 common lzma { build-depends: lzma >= 0.0.0.3 }
@@ -46,15 +52,21 @@ common optics-vl { build-depends: optics-vl >= 0.2 }
 common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
 common parsec { build-depends: parsec >= 3.1 }
 common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 }
+common resourcet { build-depends: resourcet >= 1.2.2 }
+common safe { build-depends: safe >= 0.3.18 }
 common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
-common streamly { build-depends: streamly >= 0.7 }
+common streamly { build-depends: streamly >= 0.7.1 }
+common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 }
 common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
 common strict-base { build-depends: strict-base >= 0.4 }
-common string-qq { build-depends: string-qq >= 0.0.4 }
-common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 }
+common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
+common table-layout { build-depends: table-layout >= 0.8 }
+common tar-bytestring { build-depends: tar-bytestring >= 0.6.3.0 }
 common template-haskell { build-depends: template-haskell >= 2.7 }
+common terminal-progress-bar { build-depends: terminal-progress-bar >= 0.4.1 }
 common text { build-depends: text >= 1.2 }
 common text-icu { build-depends: text-icu >= 0.7 }
+common time { build-depends: time >= 1.9.3 }
 common transformers { build-depends: transformers >= 0.5 }
 common unix { build-depends: unix >= 2.7 }
 common unix-bytestring { build-depends: unix-bytestring >= 0.3 }
@@ -87,11 +99,16 @@ library
                      , aeson
                      , ascii-string
                      , async
+                     , attoparsec
+                     , binary
                      , bytestring
                      , bzlib
+                     , case-insensitive
                      , containers
                      , generics-sop
+                     , haskus-utils-types
                      , haskus-utils-variant
+                     , hopenssl
                      , hpath
                      , hpath-directory
                      , hpath-filepath
@@ -106,15 +123,21 @@ library
                      , optics
                      , optics-vl
                      , parsec
+                     , pretty-terminal
+                     , resourcet
+                     , safe
                      , safe-exceptions
                      , streamly
+                     , streamly-posix
                      , streamly-bytestring
                      , strict-base
-                     , string-qq
+                     , string-interpolate
                      , tar-bytestring
                      , template-haskell
+                     , terminal-progress-bar
                      , text
                      , text-icu
+                     , time
                      , transformers
                      , unix
                      , unix-bytestring
@@ -125,12 +148,21 @@ library
                      , word8
                      , zlib
   exposed-modules:     GHCup
-                       GHCup.Bash
-                       GHCup.File
-                       GHCup.Prelude
+                       GHCup.Download
+                       GHCup.Errors
+                       GHCup.Platform
                        GHCup.Types
                        GHCup.Types.JSON
                        GHCup.Types.Optics
+                       GHCup.Utils
+                       GHCup.Utils.Bash
+                       GHCup.Utils.Dirs
+                       GHCup.Utils.File
+                       GHCup.Utils.Logger
+                       GHCup.Utils.Prelude
+                       GHCup.Utils.String.QQ
+                       GHCup.Utils.Version.QQ
+                       GHCup.Version
   -- other-modules:
   -- other-extensions:
   hs-source-dirs:      lib
@@ -138,7 +170,9 @@ library
 executable ghcup
   import:                config
                        , base
+                       --
                        , bytestring
+                       , containers
                        , haskus-utils-variant
                        , monad-logger
                        , mtl
@@ -146,13 +180,50 @@ executable ghcup
                        , text
                        , versions
                        , hpath
+                       , hpath-io
                        , pretty-terminal
-                       , string-qq
+                       , resourcet
+                       , string-interpolate
+                       , table-layout
+                       , uri-bytestring
+                       , utf8-string
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:
   build-depends:       ghcup
-  hs-source-dirs:      app
+  hs-source-dirs:      app/ghcup
+  default-language:    Haskell2010
+
+executable ghcup-gen
+  import:                config
+                       , base
+                       --
+                       , aeson
+                       , aeson-pretty
+                       , bytestring
+                       , containers
+                       , safe-exceptions
+                       , haskus-utils-variant
+                       , monad-logger
+                       , mtl
+                       , optics
+                       , optparse-applicative
+                       , text
+                       , versions
+                       , hpath
+                       , pretty-terminal
+                       , resourcet
+                       , string-interpolate
+                       , table-layout
+                       , transformers
+                       , uri-bytestring
+                       , utf8-string
+  main-is:             Main.hs
+  other-modules:       GHCupDownloads
+                       Validate
+  -- other-extensions:
+  build-depends:       ghcup
+  hs-source-dirs:      app/ghcup-gen
   default-language:    Haskell2010
 
 test-suite ghcup-test

lib/GHCup/Download.hs

@@ -0,0 +1,615 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+{-# LANGUAGE TypeApplications      #-}
+
+
+module GHCup.Download where
+
+
+import           GHCup.Errors
+import           GHCup.Platform
+import           GHCup.Types
+import           GHCup.Types.JSON               ( )
+import           GHCup.Types.Optics
+import           GHCup.Utils
+import           GHCup.Utils.File
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Fail             ( MonadFail )
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Class      ( lift )
+import           Control.Monad.Trans.Resource
+                                         hiding ( throwM )
+import           Data.Aeson
+import           Data.ByteString                ( ByteString )
+import           Data.ByteString.Builder
+import           Data.CaseInsensitive           ( CI )
+import           Data.IORef
+import           Data.Maybe
+import           Data.String.Interpolate
+import           Data.Text.Read
+import           Data.Time.Clock
+import           Data.Time.Clock.POSIX
+import           Data.Time.Format
+import           Data.Versions
+import           GHC.IO.Exception
+import           HPath
+import           HPath.IO
+import           Haskus.Utils.Variant.Excepts
+import           Network.Http.Client     hiding ( URL )
+import           OpenSSL.Digest
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           System.IO.Error
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( fdWrite )
+import "unix-bytestring" System.Posix.IO.ByteString
+                                                ( fdWrite )
+import           System.Posix.RawFilePath.Directory.Errors
+                                                ( hideError )
+import           System.ProgressBar
+import           URI.ByteString
+import           URI.ByteString.QQ
+
+import qualified Data.Binary.Builder           as B
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+import qualified Data.CaseInsensitive          as CI
+import qualified Data.Map.Strict               as M
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified System.IO.Streams             as Streams
+import qualified System.Posix.Files.ByteString as PF
+import qualified System.Posix.RawFilePath.Directory
+                                               as RD
+
+
+
+ghcupURL :: URI
+ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.1.json|]
+
+
+
+    ------------------
+    --[ High-level ]--
+    ------------------
+
+
+-- | Downloads the download information! But only if we need to ;P
+getDownloads :: ( FromJSONKey Tool
+                , FromJSONKey Version
+                , FromJSON VersionInfo
+                , MonadIO m
+                , MonadCatch m
+                , MonadReader Settings m
+                , MonadLogger m
+                , MonadThrow m
+                , MonadFail m
+                )
+             => Excepts '[JSONError , DownloadFailed] m GHCupDownloads
+getDownloads = do
+  urlSource <- lift getUrlSource
+  lift $ $(logDebug) [i|Receiving download info from: #{urlSource}|]
+  case urlSource of
+    GHCupURL -> do
+      bs <- reThrowAll DownloadFailed $ dl ghcupURL
+      lE' JSONDecodeError $ eitherDecode' bs
+    (OwnSource url) -> do
+      bs <- reThrowAll DownloadFailed $ dl url
+      lE' JSONDecodeError $ eitherDecode' bs
+    (OwnSpec av) -> pure $ av
+
+ where
+  -- First check if the json file is in the ~/.ghcup/cache dir
+  -- and check it's access time. If it has been accessed within the
+  -- last 5 minutes, just reuse it.
+  --
+  -- If not, then send a HEAD request and check for modification time.
+  -- Only download the file if the modification time is newer
+  -- than the local file.
+  --
+  -- Always save the local file with the mod time of the remote file.
+  dl :: forall m1
+      . (MonadCatch m1, MonadIO m1, MonadFail m1, MonadLogger m1)
+     => URI
+     -> Excepts
+          '[ FileDoesNotExistError
+           , HTTPStatusError
+           , URIParseError
+           , UnsupportedScheme
+           , NoLocationHeader
+           , TooManyRedirs
+           ]
+          m1
+          L.ByteString
+  dl uri' = do
+    let path = view pathL' uri'
+    json_file <- (liftIO $ ghcupCacheDir)
+      >>= \cacheDir -> (cacheDir </>) <$> urlBaseName path
+    e <- liftIO $ doesFileExist json_file
+    if e
+      then do
+        accessTime <-
+          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 (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 do
+                    bs <- liftE $ downloadBS uri'
+                    liftIO $ writeFileWithModTime modTime json_file bs
+                    pure bs
+                  else liftIO $ readFile json_file
+              Nothing -> do
+                lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
+                liftIO $ deleteFile json_file
+                liftE $ downloadBS uri'
+          else -- access in less than 5 minutes, re-use file
+               liftIO $ readFile json_file
+      else do
+        getModTime >>= \case
+          Just modTime -> do
+            bs <- liftE $ downloadBS uri'
+            liftIO $ writeFileWithModTime modTime json_file bs
+            pure bs
+          Nothing -> do
+            lift $ $(logWarn) [i|Unable to get/parse Last-Modified header|]
+            liftE $ downloadBS uri'
+
+   where
+    getModTime = do
+      headers <-
+        handleIO (\_ -> pure mempty)
+        $ liftE
+        $ ( catchAllE
+              (\_ ->
+                pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
+              )
+          $ getHead uri'
+          )
+      pure $ parseModifiedHeader headers
+
+
+  parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
+  parseModifiedHeader headers =
+    (M.lookup (CI.mk [s|Last-Modified|]) headers) >>= \h -> parseTimeM
+      True
+      defaultTimeLocale
+      "%a, %d %b %Y %H:%M:%S %Z"
+      (T.unpack . E.decodeUtf8 $ h)
+
+  writeFileWithModTime :: UTCTime -> Path Abs -> L.ByteString -> IO ()
+  writeFileWithModTime utctime path content = do
+    let mod_time = utcTimeToPOSIXSeconds utctime
+    writeFileL path (Just newFilePerms) content
+    setModificationTimeHiRes path mod_time
+
+
+
+getDownloadInfo :: ( MonadLogger m
+                   , MonadCatch m
+                   , MonadIO m
+                   , MonadReader Settings m
+                   )
+                => GHCupDownloads
+                -> Tool
+                -> Version
+                -> Maybe PlatformRequest
+                -> Excepts
+                     '[ DistroNotFound
+                      , NoCompatiblePlatform
+                      , NoCompatibleArch
+                      , NoDownload
+                      ]
+                     m
+                     DownloadInfo
+getDownloadInfo bDls t v mpfReq = do
+  (PlatformRequest arch' plat ver) <- case mpfReq of
+    Just x  -> pure x
+    Nothing -> do
+      (PlatformResult rp rv) <- liftE getPlatform
+      ar                     <- lE getArchitecture
+      pure $ PlatformRequest ar rp rv
+
+  lE $ getDownloadInfo' t v arch' plat ver bDls
+
+
+getDownloadInfo' :: Tool
+                 -> Version
+                -- ^ tool version
+                 -> Architecture
+                -- ^ user arch
+                 -> Platform
+                -- ^ user platform
+                 -> Maybe Versioning
+                -- ^ optional version of the platform
+                 -> GHCupDownloads
+                 -> Either NoDownload DownloadInfo
+getDownloadInfo' t v a p mv dls = maybe
+  (Left NoDownload)
+  Right
+  (with_distro <|> without_distro_ver <|> without_distro)
+
+ where
+  with_distro        = distro_preview id id
+  without_distro_ver = distro_preview id (const Nothing)
+  without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
+
+  distro_preview f g =
+    preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
+
+
+-- | Tries to download from the given http or https url
+-- and saves the result in continuous memory into a file.
+-- If the filename is not provided, then we:
+--   1. try to guess the filename from the url path
+--   2. otherwise create a random file
+--
+-- The file must not exist.
+download :: ( MonadMask m
+            , MonadReader Settings m
+            , MonadThrow m
+            , MonadLogger m
+            , MonadIO m
+            )
+         => DownloadInfo
+         -> Path Abs          -- ^ destination dir
+         -> Maybe (Path Rel)  -- ^ optional filename
+         -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
+download dli dest mfn
+  | scheme == [s|https|] = dl
+  | scheme == [s|http|] = dl
+  | scheme == [s|file|] = cp
+  | otherwise = throwE $ DownloadFailed (variantFromValue UnsupportedScheme)
+
+ where
+  scheme = view (dlUri % uriSchemeL' % schemeBSL') dli
+  cp     = do
+    -- destination dir must exist
+    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
+    destFile <- getDestFile
+    fromFile <- parseAbs path
+    liftIO $ copyFile fromFile destFile Strict
+    pure destFile
+  dl = do
+    let uri' = E.decodeUtf8 (serializeURIRef' (view dlUri dli))
+    lift $ $(logInfo) [i|downloading: #{uri'}|]
+
+    (https, host, fullPath, port) <- reThrowAll DownloadFailed
+      $ uriToQuadruple (view dlUri dli)
+
+    -- destination dir must exist
+    liftIO $ hideError AlreadyExists $ createDirRecursive newDirPerms dest
+    destFile <- getDestFile
+
+    -- download
+    fd       <- liftIO $ createRegularFileFd newFilePerms destFile
+    let stepper = fdWrite fd
+    flip finally (liftIO $ closeFd fd)
+      $ reThrowAll DownloadFailed
+      $ downloadInternal True https host fullPath port stepper
+
+    liftE $ checkDigest dli destFile
+    pure destFile
+
+  -- Manage to find a file we can write the body into.
+  getDestFile :: MonadThrow m => m (Path Abs)
+  getDestFile = maybe (urlBaseName path <&> (dest </>)) (pure . (dest </>)) mfn
+
+  path        = view (dlUri % pathL') dli
+
+
+-- | Download into tmpdir or use cached version, if it exists. If filename
+-- is omitted, infers the filename from the url.
+downloadCached :: ( MonadMask m
+                  , MonadResource m
+                  , MonadThrow m
+                  , MonadLogger m
+                  , MonadIO m
+                  , MonadReader Settings m
+                  )
+               => DownloadInfo
+               -> Maybe (Path Rel)  -- ^ optional filename
+               -> Excepts '[DigestError , DownloadFailed] m (Path Abs)
+downloadCached dli mfn = do
+  cache <- lift getCache
+  case cache of
+    True -> do
+      cachedir <- liftIO $ ghcupCacheDir
+      fn       <- maybe (urlBaseName $ view (dlUri % pathL') dli) pure mfn
+      let cachfile = cachedir </> fn
+      fileExists <- liftIO $ doesFileExist cachfile
+      if
+        | fileExists -> do
+          liftE $ checkDigest dli cachfile
+          pure $ cachfile
+        | otherwise -> liftE $ download dli cachedir mfn
+    False -> do
+      tmp <- lift withGHCupTmpDir
+      liftE $ download dli tmp mfn
+
+
+
+
+    ------------------
+    --[ Low-level ]--
+    ------------------
+
+
+-- | This is used for downloading the JSON.
+downloadBS :: (MonadCatch m, MonadIO m)
+           => URI
+           -> Excepts
+                '[ FileDoesNotExistError
+                 , HTTPStatusError
+                 , URIParseError
+                 , UnsupportedScheme
+                 , NoLocationHeader
+                 , TooManyRedirs
+                 ]
+                m
+                L.ByteString
+downloadBS uri'
+  | scheme == [s|https|]
+  = dl True
+  | scheme == [s|http|]
+  = dl False
+  | scheme == [s|file|]
+  = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
+    $ (liftIO $ RD.readFile path)
+  | otherwise
+  = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  path   = view pathL' uri'
+  dl https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ downloadBS' https host' fullPath' port'
+
+
+-- | Load the result of this download into memory at once.
+downloadBS' :: MonadIO m
+            => Bool             -- ^ https?
+            -> ByteString       -- ^ host (e.g. "www.example.com")
+            -> ByteString       -- ^ path (e.g. "/my/file") including query
+            -> Maybe Int        -- ^ optional port (e.g. 3000)
+            -> Excepts
+                 '[ HTTPStatusError
+                  , URIParseError
+                  , UnsupportedScheme
+                  , NoLocationHeader
+                  , TooManyRedirs
+                  ]
+                 m
+                 (L.ByteString)
+downloadBS' https host path port = do
+  bref <- liftIO $ newIORef (mempty :: Builder)
+  let stepper bs = modifyIORef bref (<> byteString bs)
+  downloadInternal False https host path port stepper
+  liftIO (readIORef bref <&> toLazyByteString)
+
+
+downloadInternal :: MonadIO m
+                 => Bool        -- ^ whether to show a progress bar
+                 -> Bool        -- ^ https?
+                 -> ByteString  -- ^ host
+                 -> ByteString  -- ^ path with query
+                 -> Maybe Int   -- ^ optional port
+                 -> (ByteString -> IO a)   -- ^ the consuming step function
+                 -> Excepts
+                      '[ HTTPStatusError
+                       , URIParseError
+                       , UnsupportedScheme
+                       , NoLocationHeader
+                       , TooManyRedirs
+                       ]
+                      m
+                      ()
+downloadInternal = go (5 :: Int)
+
+ where
+  go redirs progressBar https host path port consumer = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Just r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Nothing -> pure ()
+   where
+    action c = do
+      let q = buildRequest1 $ http GET path
+
+      sendRequest c q emptyBody
+
+      receiveResponse
+        c
+        (\r i' -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
+            | scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
+              Just r' -> pure $ Just $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer
+      Left e -> throwE e
+
+    downloadStream r i' = do
+      let size = case getHeader r [s|Content-Length|] of
+            Just x' -> case decimal $ E.decodeUtf8 x' of
+              Left  _       -> 0
+              Right (r', _) -> r'
+            Nothing -> 0
+
+      mpb <- if progressBar
+        then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
+        else pure Nothing
+
+      outStream <- liftIO $ Streams.makeOutputStream
+        (\case
+          Just bs -> do
+            forM_ mpb $ \pb -> incProgress pb (BS.length bs)
+            void $ consumer bs
+          Nothing -> pure ()
+        )
+      liftIO $ Streams.connect i' outStream
+
+
+
+getHead :: (MonadCatch m, MonadIO m)
+        => URI
+        -> Excepts
+             '[ HTTPStatusError
+              , URIParseError
+              , UnsupportedScheme
+              , NoLocationHeader
+              , TooManyRedirs
+              ]
+             m
+             (M.Map (CI ByteString) ByteString)
+getHead uri' | scheme == [s|https|] = head' True
+             | scheme == [s|http|] = head' False
+             | otherwise           = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  head' https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ headInternal https host' fullPath' port'
+
+
+
+headInternal :: MonadIO m
+             => Bool        -- ^ https?
+             -> ByteString  -- ^ host
+             -> ByteString  -- ^ path with query
+             -> Maybe Int   -- ^ optional port
+             -> Excepts
+                  '[ HTTPStatusError
+                   , URIParseError
+                   , UnsupportedScheme
+                   , TooManyRedirs
+                   , NoLocationHeader
+                   ]
+                  m
+                  (M.Map (CI ByteString) ByteString)
+headInternal = go (5 :: Int)
+
+ where
+  go redirs https host path port = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Left r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Right hs -> pure hs
+   where
+
+    action c = do
+      let q = buildRequest1 $ http HEAD path
+
+      sendRequest c q emptyBody
+
+      unsafeReceiveResponse
+        c
+        (\r _ -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> do
+              let headers = getHeaderMap r
+              pure $ Right $ headers
+            | scode >= 300 && scode < 400 -> case getHeader r [s|Location|] of
+              Just r' -> pure $ Left $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) https' host' fullPath' port'
+      Left e -> throwE e
+
+
+withConnection' :: Bool
+                -> ByteString
+                -> Maybe Int
+                -> (Connection -> IO a)
+                -> IO a
+withConnection' https host port action = bracket acquire closeConnection action
+
+ where
+  acquire = case https of
+    True -> do
+      ctx <- baselineContextSSL
+      openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
+    False -> openConnection host (fromIntegral $ fromMaybe 80 port)
+
+
+-- | Extracts from a URI type: (https?, host, path+query, port)
+uriToQuadruple :: Monad m
+               => URI
+               -> Excepts
+                    '[UnsupportedScheme]
+                    m
+                    (Bool, ByteString, ByteString, Maybe Int)
+uriToQuadruple URI {..} = do
+  let scheme = view schemeBSL' uriScheme
+
+  host <-
+    preview (_Just % authorityHostL' % hostBSL') uriAuthority
+      ?? UnsupportedScheme
+
+  https <- if
+    | scheme == [s|https|] -> pure True
+    | scheme == [s|http|] -> pure False
+    | otherwise           -> throwE UnsupportedScheme
+
+  let
+    queryBS =
+      BS.intercalate [s|&|]
+        . fmap (\(x, y) -> encodeQuery x <> [s|=|] <> encodeQuery y)
+        $ (queryPairs uriQuery)
+    port =
+      preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
+    fullpath =
+      if BS.null queryBS then uriPath else uriPath <> [s|?|] <> queryBS
+  pure (https, host, fullpath, port)
+  where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
+
+
+checkDigest :: (MonadIO m, MonadLogger m, MonadReader Settings m)
+            => DownloadInfo
+            -> Path Abs
+            -> Excepts '[DigestError] m ()
+checkDigest dli file = do
+  verify <- lift ask <&> (not . noVerify)
+  when verify $ do
+    let p' = toFilePath file
+    lift $ $(logInfo) [i|veryfing digest of: #{p'}|]
+    c <- liftIO $ readFile file
+    let cDigest = E.decodeUtf8 . toHex . digest (digestByName "sha256") $ c
+        eDigest = view dlHash dli
+    when ((cDigest /= eDigest) && verify) $ throwE (DigestError cDigest eDigest)

lib/GHCup/Errors.hs

@@ -0,0 +1,124 @@
+{-# LANGUAGE ExistentialQuantification #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE DataKinds #-}
+
+module GHCup.Errors where
+
+import           GHCup.Types
+
+import           Control.Exception.Safe
+import           Data.ByteString                ( ByteString )
+import           Data.Text                      ( Text )
+import           Data.Versions
+import           Haskus.Utils.Variant
+import           HPath
+
+
+
+    ------------------------
+    --[ Low-level errors ]--
+    ------------------------
+
+
+
+-- | A compatible platform could not be found.
+data NoCompatiblePlatform = NoCompatiblePlatform String -- the platform we got
+  deriving Show
+
+-- | Unable to find a download for the requested versio/distro.
+data NoDownload = NoDownload
+  deriving Show
+
+-- | The Architecture is unknown and unsupported.
+data NoCompatibleArch = NoCompatibleArch String
+  deriving Show
+
+-- | Unable to figure out the distribution of the host.
+data DistroNotFound = DistroNotFound
+  deriving Show
+
+-- | The archive format is unknown. We don't know how to extract it.
+data UnknownArchive = UnknownArchive ByteString
+  deriving Show
+
+-- | The scheme is not supported (such as ftp).
+data UnsupportedScheme = UnsupportedScheme
+  deriving Show
+
+-- | Unable to copy a file.
+data CopyError = CopyError String
+  deriving Show
+
+-- | Unable to find a tag of a tool.
+data TagNotFound = TagNotFound Tag Tool
+  deriving Show
+
+-- | The tool (such as GHC) is already installed with that version.
+data AlreadyInstalled = AlreadyInstalled Tool Version
+  deriving Show
+
+-- | The tool is not installed. Some operations rely on a tool
+-- to be installed (such as setting the current GHC version).
+data NotInstalled = NotInstalled Tool Version
+  deriving Show
+
+-- | JSON decoding failed.
+data JSONError = JSONDecodeError String
+  deriving Show
+
+-- | A file that is supposed to exist does not exist
+-- (e.g. when we use file scheme to "download" something).
+data FileDoesNotExistError = FileDoesNotExistError ByteString
+  deriving Show
+
+-- | File digest verification failed.
+data DigestError = DigestError Text Text
+  deriving Show
+
+-- | Unexpected HTTP status.
+data HTTPStatusError = HTTPStatusError Int
+  deriving Show
+
+-- | The 'Location' header was expected during a 3xx redirect, but not found.
+data NoLocationHeader = NoLocationHeader
+  deriving Show
+
+-- | Too many redirects.
+data TooManyRedirs = TooManyRedirs
+  deriving Show
+
+
+
+    -------------------------
+    --[ High-level errors ]--
+    -------------------------
+
+-- | A download failed. The underlying error is encapsulated.
+data DownloadFailed = forall es . Show (V es) => DownloadFailed (V es)
+
+deriving instance Show DownloadFailed
+
+
+-- | A build failed.
+data BuildFailed = forall es . Show (V es) => BuildFailed (Path Abs) (V es)
+
+deriving instance Show BuildFailed
+
+
+-- | Setting the current GHC version failed.
+data GHCupSetError = forall es . Show (V es) => GHCupSetError (V es)
+
+deriving instance Show GHCupSetError
+
+
+    ---------------------------------------------
+    --[ True Exceptions (e.g. for MonadThrow) ]--
+    ---------------------------------------------
+
+
+-- | Parsing failed.
+data ParseError = ParseError String
+  deriving Show
+
+instance Exception ParseError

lib/GHCup/Platform.hs

@@ -0,0 +1,166 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleInstances     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+
+
+module GHCup.Platform where
+
+
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Bash
+import           GHCup.Utils.File
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Class      ( lift )
+import           Data.Foldable
+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 qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified Data.Text.ICU                 as ICU
+
+    --------------------------
+    --[ Platform detection ]--
+    --------------------------
+
+
+getArchitecture :: Either NoCompatibleArch Architecture
+getArchitecture = case arch of
+  "x86_64" -> Right A_64
+  "i386"   -> Right A_32
+  what     -> Left (NoCompatibleArch what)
+
+
+
+getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
+            => Excepts
+                 '[NoCompatiblePlatform , DistroNotFound]
+                 m
+                 PlatformResult
+getPlatform = do
+  pfr <- case os of
+    "linux" -> do
+      (distro, ver) <- liftE getLinuxDistro
+      pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
+    -- TODO: these are not verified
+    "darwin" ->
+      pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
+    "freebsd" -> do
+      ver <- getFreeBSDVersion
+      pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
+    what -> throwE $ NoCompatiblePlatform what
+  lift $ $(logDebug) [i|Identified Platform as: #{pfr}|]
+  pure pfr
+  where getFreeBSDVersion = pure Nothing
+
+
+getLinuxDistro :: (MonadCatch m, MonadIO m)
+               => Excepts '[DistroNotFound] m (LinuxDistro, Maybe Versioning)
+getLinuxDistro = do
+  -- TODO: don't do alternative on IO, because it hides bugs
+  (name, ver) <- handleIO (\_ -> throwE DistroNotFound) $ liftIO $ asum
+    [ try_os_release
+    , try_lsb_release_cmd
+    , try_lsb_release
+    , try_redhat_release
+    , try_debian_version
+    ]
+  let parsedVer = ver >>= either (const Nothing) Just . versioning
+      distro    = if
+        | hasWord name ["debian"]  -> Debian
+        | hasWord name ["ubuntu"]  -> Ubuntu
+        | hasWord name ["linuxmint", "Linux Mint"] -> Mint
+        | hasWord name ["fedora"]  -> Fedora
+        | hasWord name ["centos"]  -> CentOS
+        | hasWord name ["Red Hat"] -> RedHat
+        | hasWord name ["alpine"]  -> Alpine
+        | hasWord name ["exherbo"] -> Exherbo
+        | hasWord name ["gentoo"]  -> Gentoo
+        | hasWord name ["amazonlinux", "Amazon Linux"] -> AmazonLinux
+        | otherwise                -> UnknownLinux
+  pure (distro, parsedVer)
+ where
+  hasWord t matches = foldr
+    (\x y ->
+      ( isJust
+        . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
+        $ t
+        )
+        || y
+    )
+    False
+    (T.pack <$> matches)
+
+  os_release :: Path Abs
+  os_release = [abs|/etc/os-release|]
+  lsb_release :: Path Abs
+  lsb_release = [abs|/etc/lsb-release|]
+  lsb_release_cmd :: Path Rel
+  lsb_release_cmd = [rel|lsb-release|]
+  redhat_release :: Path Abs
+  redhat_release = [abs|/etc/redhat-release|]
+  debian_version :: Path Abs
+  debian_version = [abs|/etc/debian_version|]
+
+  try_os_release :: IO (Text, Maybe Text)
+  try_os_release = do
+    (Just name) <- getAssignmentValueFor os_release "NAME"
+    ver         <- getAssignmentValueFor os_release "VERSION_ID"
+    pure (T.pack name, fmap T.pack ver)
+
+  try_lsb_release_cmd :: IO (Text, Maybe Text)
+  try_lsb_release_cmd = do
+    (Just _) <- findExecutable lsb_release_cmd
+    name     <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-si|]] Nothing
+    ver      <- fmap _stdOut $ executeOut lsb_release_cmd [[s|-sr|]] Nothing
+    pure (E.decodeUtf8 name, Just $ E.decodeUtf8 ver)
+
+  try_lsb_release :: IO (Text, Maybe Text)
+  try_lsb_release = do
+    (Just name) <- getAssignmentValueFor lsb_release "DISTRIB_ID"
+    ver         <- getAssignmentValueFor lsb_release "DISTRIB_RELEASE"
+    pure (T.pack name, fmap T.pack ver)
+
+  try_redhat_release :: IO (Text, Maybe Text)
+  try_redhat_release = do
+    t <- fmap lBS2sT $ readFile redhat_release
+    let nameRe n =
+          join
+            . fmap (ICU.group 0)
+            . ICU.find
+                (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> fS n <> [s|\b|]))
+            $ t
+        verRe =
+          join
+            . fmap (ICU.group 0)
+            . ICU.find
+                (ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
+            $ t
+    (Just name) <- pure
+      (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
+    pure (name, verRe)
+
+  try_debian_version :: IO (Text, Maybe Text)
+  try_debian_version = do
+    ver <- readFile debian_version
+    pure (T.pack "debian", Just $ lBS2sT ver)

lib/GHCup/Prelude.hs

@@ -1,183 +0,0 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-{-# LANGUAGE QuasiQuotes #-}
-{-# LANGUAGE TemplateHaskell #-}
-{-# LANGUAGE DataKinds #-}
-{-# LANGUAGE TypeOperators #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
-{-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
-{-# LANGUAGE TypeFamilies #-}
-
-module GHCup.Prelude where
-
-import           Control.Applicative
-import           Control.Monad
-import           Control.Monad.Trans.Class      ( lift )
-import           Control.Exception.Safe
-import           Data.ByteString                ( ByteString )
-import qualified Data.Strict.Maybe             as S
-import           Data.Monoid                    ( (<>) )
-import           Data.String
-import qualified Data.Text.Lazy.Encoding       as TLE
-import qualified Data.Text.Lazy                as TL
-import           Data.Text                      ( Text )
-import qualified Data.Text                     as T
-import           Data.Versions
-import qualified Data.ByteString.Lazy          as L
-import           Haskus.Utils.Variant.Excepts
-import           System.IO.Error
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Syntax     ( Exp(..)
-                                                , Lift
-                                                )
-import qualified Language.Haskell.TH.Syntax    as TH
-import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
-import           GHC.Base
-
-
-
-fS :: IsString a => String -> a
-fS = fromString
-
-fromStrictMaybe :: S.Maybe a -> Maybe a
-fromStrictMaybe = S.maybe Nothing Just
-
-fSM :: S.Maybe a -> Maybe a
-fSM = fromStrictMaybe
-
-toStrictMaybe :: Maybe a -> S.Maybe a
-toStrictMaybe = maybe S.Nothing S.Just
-
-tSM :: Maybe a -> S.Maybe a
-tSM = toStrictMaybe
-
-internalError :: String -> IO a
-internalError = fail . ("Internal error: " <>)
-
-iE :: String -> IO a
-iE = internalError
-
-
-showT :: Show a => a -> Text
-showT = fS . show
-
--- | Like 'when', but where the test can be monadic.
-whenM :: Monad m => m Bool -> m () -> m ()
-whenM ~b ~t = ifM b t (return ())
-
--- | Like 'unless', but where the test can be monadic.
-unlessM :: Monad m => m Bool -> m () -> m ()
-unlessM ~b ~f = ifM b (return ()) f
-
--- | Like @if@, but where the test can be monadic.
-ifM :: Monad m => m Bool -> m a -> m a -> m a
-ifM ~b ~t ~f = do
-  b' <- b
-  if b' then t else f
-
-whileM :: Monad m => m a -> (a -> m Bool) -> m a
-whileM ~action ~f = do
-  a  <- action
-  b' <- f a
-  if b' then whileM action f else pure a
-
-whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
-whileM_ ~action = void . whileM action
-
-guardM :: (Monad m, Alternative m) => m Bool -> m ()
-guardM ~f = guard =<< f
-
-lBS2sT :: L.ByteString -> Text
-lBS2sT = TL.toStrict . TLE.decodeUtf8
-
-
-handleIO' :: IOErrorType -> (IOException -> IO ()) -> IO () -> IO ()
-handleIO' err handler =
-  handleIO (\e -> if err == ioeGetErrorType e then handler e else ioError e)
-
-
-(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
-(??) m e = maybe (throwE e) pure m
-
-
-(!?) :: forall e es a m
-      . (Monad m, e :< es)
-     => m (Maybe a)
-     -> e
-     -> Excepts es m a
-(!?) em e = lift em >>= (?? e)
-
-
-lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
-lE = liftE . veitherToExcepts . fromEither
-
-lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
-lEM em = lift em >>= lE
-
-fromEither :: Either a b -> VEither '[a] b
-fromEither = either (VLeft . V) VRight
-
-hideExcept :: forall e es es' a m
-            . (Monad m, e :< es, LiftVariant (Remove e es) es')
-           => e
-           -> a
-           -> Excepts es m a
-           -> Excepts es' m a
-hideExcept h a action =
-  catchLiftLeft ((\(x@e) -> pure a) :: (e -> Excepts es' m a)) action
-
-
-
-deriving instance Lift Versioning
-deriving instance Lift Version
-deriving instance Lift SemVer
-deriving instance Lift Mess
-deriving instance Lift PVP
-deriving instance Lift (NonEmpty Word)
-deriving instance Lift VSep
-deriving instance Lift VUnit
-instance Lift Text
-
-qq :: (Text -> Q Exp) -> QuasiQuoter
-qq quoteExp' = QuasiQuoter
-  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
-  , quotePat  = \_ ->
-    fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
-  , quoteType = \_ ->
-    fail "illegal QuasiQuote (allowed as expression only, used as a type)"
-  , quoteDec  = \_ -> fail
-    "illegal QuasiQuote (allowed as expression only, used as a declaration)"
-  }
-
-ver :: QuasiQuoter
-ver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . version
-
-mver :: QuasiQuoter
-mver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . mess
-
-sver :: QuasiQuoter
-sver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . semver
-
-vers :: QuasiQuoter
-vers = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . versioning
-
-pver :: QuasiQuoter
-pver = qq mkV
- where
-  mkV :: Text -> Q Exp
-  mkV = either (fail . show) TH.lift . pvp

lib/GHCup/Types.hs

@@ -2,49 +2,66 @@
 
 module GHCup.Types where
 
-import           HPath
 import           Data.Map.Strict                ( Map )
-import qualified GHC.Generics                  as GHC
+import           Data.Text                      ( Text )
 import           Data.Versions
+import           HPath
 import           URI.ByteString
 
-
-data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
-            | SetGHCMajor -- ^ ghc-x.y
-            | SetGHCMinor -- ^ ghc-x.y.z
-            deriving Show
+import qualified GHC.Generics                  as GHC
 
 
-data Tag = Latest
-         | Recommended
-         deriving (Eq, Show)
 
-data VersionInfo = VersionInfo
-  { _viTags :: [Tag]
-  , _viArch :: ArchitectureSpec
-  }
-  deriving (Eq, Show)
 
-data DownloadInfo = DownloadInfo
-  { _dlUri    :: URI
-  , _dlSubdir :: Maybe (Path Rel)
-  }
-  deriving (Eq, Show)
+    ---------------------
+    --[ Download Tree ]--
+    ---------------------
 
+
+-- | Description of all binary and source downloads. This is a tree
+-- of nested maps.
+type GHCupDownloads = Map Tool ToolVersionSpec
+type ToolVersionSpec = Map Version VersionInfo
+type ArchitectureSpec = Map Architecture PlatformSpec
+type PlatformSpec = Map Platform PlatformVersionSpec
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
+
+
+-- | An installable tool.
 data Tool = GHC
           | Cabal
+          | GHCup
   deriving (Eq, GHC.Generic, Ord, Show)
 
-data ToolRequest = ToolRequest
-  { _tool        :: Tool
-  , _toolVersion :: Version
+
+-- | All necessary information of a tool version, including
+-- source download and per-architecture downloads.
+data VersionInfo = VersionInfo
+  { _viTags     :: [Tag]              -- ^ version specific tag
+  , _viSourceDL :: Maybe DownloadInfo -- ^ source tarball
+  , _viArch     :: ArchitectureSpec   -- ^ descend for binary downloads per arch
   }
   deriving (Eq, Show)
 
+
+-- | A tag. These are currently attached to a version of a tool.
+data Tag = Latest
+         | Recommended
+         deriving (Ord, Eq, Show)
+
+
 data Architecture = A_64
                   | A_32
   deriving (Eq, GHC.Generic, Ord, Show)
 
+
+data Platform = Linux LinuxDistro
+              -- ^ must exit
+              | Darwin
+              -- ^ must exit
+              | FreeBSD
+  deriving (Eq, GHC.Generic, Ord, Show)
+
 data LinuxDistro = Debian
                  | Ubuntu
                  | Mint
@@ -52,6 +69,7 @@ data LinuxDistro = Debian
                  | CentOS
                  | RedHat
                  | Alpine
+                 | AmazonLinux
                  -- rolling
                  | Gentoo
                  | Exherbo
@@ -60,12 +78,56 @@ data LinuxDistro = Debian
                  -- ^ must exit
   deriving (Eq, GHC.Generic, Ord, Show)
 
-data Platform = Linux LinuxDistro
-              -- ^ must exit
-              | Darwin
-              -- ^ must exit
-              | FreeBSD
-  deriving (Eq, GHC.Generic, Ord, Show)
+
+-- | An encapsulation of a download. This can be used
+-- to download, extract and install a tool.
+data DownloadInfo = DownloadInfo
+  { _dlUri    :: URI
+  , _dlSubdir :: Maybe (Path Rel)
+  , _dlHash   :: Text
+  }
+  deriving (Eq, Show)
+
+
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+-- | Where to fetch GHCupDownloads from.
+data URLSource = GHCupURL
+               | OwnSource URI
+               | OwnSpec GHCupDownloads
+               deriving Show
+
+
+data Settings = Settings
+  { cache     :: Bool
+  , urlSource :: URLSource
+  , noVerify  :: Bool
+  }
+  deriving Show
+
+
+data DebugInfo = DebugInfo
+  { diBaseDir   :: Path Abs
+  , diBinDir    :: Path Abs
+  , diGHCDir    :: Path Abs
+  , diCacheDir  :: Path Abs
+  , diURLSource :: URLSource
+  , diArch      :: Architecture
+  , diPlatform  :: PlatformResult
+  }
+  deriving Show
+
+
+data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
+            | SetGHC_XY   -- ^ ghc-x.y
+            | SetGHC_XYZ  -- ^ ghc-x.y.z
+            deriving (Eq, Show)
+
 
 data PlatformResult = PlatformResult
   { _platform      :: Platform
@@ -80,14 +142,3 @@ data PlatformRequest = PlatformRequest
   }
   deriving (Eq, Show)
 
-type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
-type PlatformSpec = Map Platform PlatformVersionSpec
-type ArchitectureSpec = Map Architecture PlatformSpec
-type ToolVersionSpec = Map Version VersionInfo
-type AvailableDownloads = Map Tool ToolVersionSpec
-
-
-data URLSource = GHCupURL
-               | OwnSource URI
-               | OwnSpec AvailableDownloads
-               deriving Show

lib/GHCup/Types/JSON.hs

@@ -3,36 +3,43 @@
 {-# LANGUAGE DataKinds             #-}
 {-# LANGUAGE DeriveGeneric         #-}
 {-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE FlexibleInstances     #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE QuasiQuotes           #-}
 {-# LANGUAGE TemplateHaskell       #-}
 {-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE FlexibleInstances          #-}
 
 module GHCup.Types.JSON where
 
 import           GHCup.Types
-import           Data.Versions
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
 import           Data.Aeson
 import           Data.Aeson.TH
-import qualified Data.Text                     as T
-import           Data.Text.Encoding             ( decodeUtf8
-                                                , encodeUtf8
-                                                )
 import           Data.Aeson.Types
+import           Data.Text.Encoding             ( decodeUtf8 )
 import           Data.Text.Encoding            as E
+import           Data.Versions
+import           Data.Word8
+import           HPath
 import           URI.ByteString
 
+import qualified Data.ByteString               as BS
+import qualified Data.Text                     as T
 
 
-
-deriveJSON defaultOptions ''Architecture
-deriveJSON defaultOptions ''LinuxDistro
-deriveJSON defaultOptions ''Mess
-deriveJSON defaultOptions ''Platform
-deriveJSON defaultOptions ''SemVer
-deriveJSON defaultOptions ''Tool
-deriveJSON defaultOptions ''VSep
-deriveJSON defaultOptions ''VUnit
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
 
 
 instance ToJSON URI where
@@ -127,3 +134,16 @@ 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 . E.decodeUtf8 $ fp
+    False -> String [s|/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

lib/GHCup/Types/Optics.hs

@@ -2,8 +2,9 @@
 
 module GHCup.Types.Optics where
 
-import           Data.ByteString                ( ByteString )
 import           GHCup.Types
+
+import           Data.ByteString                ( ByteString )
 import           Optics
 import           URI.ByteString
 
@@ -14,7 +15,6 @@ makePrisms ''Platform
 makePrisms ''Tag
 
 makeLenses ''PlatformResult
-makeLenses ''ToolRequest
 makeLenses ''DownloadInfo
 makeLenses ''Tag
 makeLenses ''VersionInfo
@@ -43,3 +43,6 @@ hostBSL' = lensVL hostBSL
 
 pathL' :: Lens' (URIRef a) ByteString
 pathL' = lensVL pathL
+
+queryL' :: Lens' (URIRef a) Query
+queryL' = lensVL queryL

lib/GHCup/Utils.hs

@@ -0,0 +1,330 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+
+
+module GHCup.Utils
+  ( module GHCup.Utils.Dirs
+  , module GHCup.Utils
+  )
+where
+
+
+import           GHCup.Errors
+import           GHCup.Types
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Dirs
+import           GHCup.Utils.File
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Fail             ( MonadFail )
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Class      ( lift )
+import           Data.Attoparsec.ByteString
+import           Data.ByteString                ( ByteString )
+import           Data.List
+import           Data.Maybe
+import           Data.String.Interpolate
+import           Data.Versions
+import           Data.Word8
+import           GHC.IO.Exception
+import           HPath
+import           HPath.IO
+import           Haskus.Utils.Variant.Excepts
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           Safe
+import           System.IO.Error
+import           System.Posix.FilePath          ( takeFileName )
+import           System.Posix.Files.ByteString  ( readSymbolicLink )
+import           URI.ByteString
+
+import qualified Codec.Archive.Tar             as Tar
+import qualified Codec.Compression.BZip        as BZip
+import qualified Codec.Compression.GZip        as GZip
+import qualified Codec.Compression.Lzma        as Lzma
+import qualified Data.ByteString               as B
+import qualified Data.Map.Strict               as Map
+import qualified Data.Text.Encoding            as E
+
+
+
+
+
+
+    ------------------------
+    --[ Symlink handling ]--
+    ------------------------
+
+
+-- | The symlink destination of a ghc tool.
+ghcLinkDestination :: ByteString -- ^ the tool, such as 'ghc', 'haddock' etc.
+                   -> Version
+                   -> ByteString
+ghcLinkDestination tool ver = [s|../ghc/|] <> verToBS ver <> [s|/bin/|] <> tool
+
+
+-- | Extract the version part of the result of `ghcLinkDestination`.
+ghcLinkVersion :: MonadThrow m => ByteString -> m Version
+ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser
+ where
+  parser    = string [s|../ghc/|] *> verParser <* string [s|/bin/ghc|]
+  verParser = many1' (notWord8 _slash) >>= \t ->
+    case version $ E.decodeUtf8 $ B.pack t of
+      Left  e -> fail $ show e
+      Right r -> pure r
+
+
+-- e.g. ghc-8.6.5
+rmMinorSymlinks :: (MonadIO m, MonadLogger m) => Version -> m ()
+rmMinorSymlinks ver = do
+  bindir <- liftIO $ ghcupBinDir
+  files  <- liftIO $ getDirsFiles' bindir
+  let myfiles =
+        filter (\x -> ([s|-|] <> verToBS ver) `B.isSuffixOf` toFilePath x) files
+  forM_ myfiles $ \f -> do
+    let fullF = (bindir </> f)
+    $(logDebug) [i|rm -f #{toFilePath fullF}|]
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+
+-- E.g. ghc, if this version is the set one.
+-- This reads `ghcupGHCDir`.
+rmPlain :: (MonadLogger m, MonadThrow m, MonadFail m, MonadIO m)
+        => Version
+        -> Excepts '[NotInstalled] m ()
+rmPlain ver = do
+  files  <- liftE $ ghcToolFiles ver
+  bindir <- liftIO $ ghcupBinDir
+  forM_ files $ \f -> do
+    let fullF = (bindir </> f)
+    lift $ $(logDebug) [i|rm -f #{toFilePath fullF}|]
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+  -- old ghcup
+  let hdc_file = (bindir </> [rel|haddock-ghc|])
+  lift $ $(logDebug) [i|rm -f #{toFilePath hdc_file}|]
+  liftIO $ hideError doesNotExistErrorType $ deleteFile hdc_file
+
+-- e.g. ghc-8.6
+rmMajorSymlinks :: (MonadLogger m, MonadIO m) => Version -> m ()
+rmMajorSymlinks ver = do
+  (mj, mi) <- liftIO $ getGHCMajor ver
+  let v' = E.encodeUtf8 $ intToText mj <> [s|.|] <> intToText mi
+
+  bindir <- liftIO ghcupBinDir
+
+  files  <- liftIO $ getDirsFiles' bindir
+  let myfiles = filter (\x -> ([s|-|] <> v') `B.isSuffixOf` toFilePath x) files
+  forM_ myfiles $ \f -> do
+    let fullF = (bindir </> f)
+    $(logDebug) [i|rm -f #{toFilePath fullF}|]
+    liftIO $ hideError doesNotExistErrorType $ deleteFile fullF
+
+
+
+
+    -----------------------------------
+    --[ Set/Installed introspection ]--
+    -----------------------------------
+
+
+toolAlreadyInstalled :: Tool -> Version -> IO Bool
+toolAlreadyInstalled tool ver = case tool of
+  GHC   -> ghcInstalled ver
+  Cabal -> cabalInstalled ver
+  GHCup -> pure True
+
+
+ghcInstalled :: Version -> IO Bool
+ghcInstalled ver = do
+  ghcdir <- ghcupGHCDir ver
+  doesDirectoryExist ghcdir
+
+
+ghcSrcInstalled :: Version -> IO Bool
+ghcSrcInstalled ver = do
+  ghcdir <- ghcupGHCDir ver
+  doesFileExist (ghcdir </> ghcUpSrcBuiltFile)
+
+
+ghcSet :: (MonadIO m, MonadThrow m) => m (Maybe Version)
+ghcSet = do
+  ghcBin <- (</> ([rel|ghc|] :: Path Rel)) <$> liftIO ghcupBinDir
+
+  -- link destination is of the form ../ghc/<ver>/bin/ghc
+  liftIO $ handleIO' NoSuchThing (\_ -> pure $ Nothing) $ do
+    link <- readSymbolicLink $ toFilePath ghcBin
+    Just <$> ghcLinkVersion link
+
+
+cabalInstalled :: Version -> IO Bool
+cabalInstalled ver = do
+  reportedVer <- cabalSet
+  pure (reportedVer == ver)
+
+cabalSet :: (MonadIO m, MonadThrow m) => m Version
+cabalSet = do
+  cabalbin <- (</> ([rel|cabal|] :: Path Rel)) <$> liftIO ghcupBinDir
+  mc       <- liftIO $ executeOut cabalbin [[s|--numeric-version|]] Nothing
+  let reportedVer = fst . B.spanEnd (== _lf) . _stdOut $ mc
+  case version (E.decodeUtf8 reportedVer) of
+    Left  e -> throwM e
+    Right r -> pure r
+
+
+
+    -----------------------------------------
+    --[ Major version introspection (X.Y) ]--
+    -----------------------------------------
+
+
+-- | We assume GHC is in semver format. I hope it is.
+getGHCMajor :: MonadThrow m => Version -> m (Int, Int)
+getGHCMajor ver = do
+  SemVer {..} <- throwEither (semver $ prettyVer ver)
+  pure (fromIntegral _svMajor, fromIntegral _svMinor)
+
+
+-- | Get the latest installed full GHC version that satisfies X.Y.
+-- This reads `ghcupGHCBaseDir`.
+getGHCForMajor :: (MonadIO m, MonadThrow m)
+               => Int -- ^ major version component
+               -> Int -- ^ minor version component
+               -> m (Maybe Version)
+getGHCForMajor major' minor' = do
+  p       <- liftIO $ ghcupGHCBaseDir
+  ghcs    <- liftIO $ getDirsFiles' p
+  semvers <- forM ghcs $ throwEither . semver . E.decodeUtf8 . toFilePath
+  mapM (throwEither . version)
+    . fmap prettySemVer
+    . lastMay
+    . sort
+    . filter
+        (\SemVer {..} ->
+          fromIntegral _svMajor == major' && fromIntegral _svMinor == minor'
+        )
+    $ semvers
+
+
+
+
+    -----------------
+    --[ Unpacking ]--
+    -----------------
+
+
+
+-- | Unpack an archive to a temporary directory and return that path.
+unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
+            => Path Abs       -- ^ destination dir
+            -> Path Abs       -- ^ archive path
+            -> Excepts '[UnknownArchive] m ()
+unpackToDir dest av = do
+  let fp = E.decodeUtf8 (toFilePath av)
+  lift $ $(logInfo) [i|Unpacking: #{fp}|]
+  fn <- toFilePath <$> basename av
+  let untar = Tar.unpack (toFilePath dest) . Tar.read
+
+  -- extract, depending on file extension
+  if
+    | [s|.tar.gz|] `B.isSuffixOf` fn -> liftIO
+      (untar . GZip.decompress =<< readFile av)
+    | [s|.tar.xz|] `B.isSuffixOf` fn -> do
+      filecontents <- liftIO $ readFile av
+      let decompressed = Lzma.decompress filecontents
+      liftIO $ untar decompressed
+    | [s|.tar.bz2|] `B.isSuffixOf` fn -> liftIO
+      (untar . BZip.decompress =<< readFile av)
+    | [s|.tar|] `B.isSuffixOf` fn -> liftIO (untar =<< readFile av)
+    | otherwise -> throwE $ UnknownArchive fn
+
+
+
+
+    ------------
+    --[ Tags ]--
+    ------------
+
+
+-- | Get the tool versions that have this tag.
+getTagged :: GHCupDownloads -> Tool -> Tag -> [Version]
+getTagged av tool tag = toListOf
+  ( ix tool
+  % to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
+  % to Map.keys
+  % folded
+  )
+  av
+
+getLatest :: GHCupDownloads -> Tool -> Maybe Version
+getLatest av tool = headOf folded $ getTagged av tool Latest
+
+getRecommended :: GHCupDownloads -> Tool -> Maybe Version
+getRecommended av tool = headOf folded $ getTagged av tool Recommended
+
+
+
+    -----------------------
+    --[ Settings Getter ]--
+    -----------------------
+
+
+getUrlSource :: MonadReader Settings m => m URLSource
+getUrlSource = ask <&> urlSource
+
+getCache :: MonadReader Settings m => m Bool
+getCache = ask <&> cache
+
+
+
+    -------------
+    --[ Other ]--
+    -------------
+
+
+urlBaseName :: MonadThrow m
+            => ByteString  -- ^ the url path (without scheme and host)
+            -> m (Path Rel)
+urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
+
+
+-- Get tool files from ~/.ghcup/bin/ghc/<ver>/bin/*
+-- while ignoring *-<ver> symlinks.
+--
+-- Returns unversioned relative files, e.g.:
+--   ["hsc2hs","haddock","hpc","runhaskell","ghc","ghc-pkg","ghci","runghc","hp2ps"]
+ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m)
+             => Version
+             -> Excepts '[NotInstalled] m [Path Rel]
+ghcToolFiles ver = do
+  ghcdir <- liftIO $ ghcupGHCDir ver
+  let bindir = ghcdir </> [rel|bin|]
+
+  -- fail if ghc is not installed
+  whenM (fmap not $ liftIO $ doesDirectoryExist ghcdir)
+        (throwE (NotInstalled GHC ver))
+
+  files         <- liftIO $ getDirsFiles' bindir
+  -- figure out the <ver> suffix, because this might not be `Version` for
+  -- alpha/rc releases, but x.y.a.somedate.
+  (Just symver) <-
+    (B.stripPrefix [s|ghc-|] . takeFileName)
+      <$> (liftIO $ readSymbolicLink $ toFilePath (bindir </> [rel|ghc|]))
+  when (B.null symver)
+       (throwIO $ userError $ "Fatal: ghc symlink target is broken")
+
+  pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files
+
+
+-- | This file, when residing in ~/.ghcup/ghc/<ver>/ signals that
+-- this GHC was built from source. It contains the build config.
+ghcUpSrcBuiltFile :: Path Rel
+ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]

lib/GHCup/Utils/Bash.hs

@@ -1,4 +1,4 @@
-module GHCup.Bash
+module GHCup.Utils.Bash
   ( findAssignment
   , equalsAssignmentWith
   , getRValue
@@ -6,17 +6,18 @@ module GHCup.Bash
   )
 where
 
-import           Language.Bash.Parse
-import           Language.Bash.Word
-import           Language.Bash.Syntax
+import           Control.Monad
+import           Data.ByteString.UTF8           ( toString )
+import           Data.List
+import           Data.Maybe
 import           HPath
 import           HPath.IO
-import           Data.ByteString.UTF8           ( toString )
-import           Control.Monad
-import           Data.Maybe
-import qualified Data.ByteString.Lazy.UTF8     as UTF8
+import           Language.Bash.Parse
+import           Language.Bash.Syntax
+import           Language.Bash.Word
 import           Prelude                 hiding ( readFile )
-import           Data.List
+
+import qualified Data.ByteString.Lazy.UTF8     as UTF8
 
 
 extractAssignments :: List -> [Assign]

lib/GHCup/Utils/Dirs.hs

@@ -0,0 +1,91 @@
+{-# LANGUAGE QuasiQuotes           #-}
+
+module GHCup.Utils.Dirs where
+
+
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Reader
+import           Control.Monad.Trans.Resource
+import           Data.Maybe
+import           Data.Versions
+import           HPath
+import           HPath.IO
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           System.Posix.Env.ByteString    ( getEnv
+                                                , getEnvDefault
+                                                )
+import           System.Posix.Temp.ByteString   ( mkdtemp )
+
+import qualified Data.ByteString.UTF8          as UTF8
+import qualified System.Posix.FilePath         as FP
+import qualified System.Posix.User             as PU
+
+
+
+    -------------------------
+    --[ GHCup directories ]--
+    -------------------------
+
+
+ghcupBaseDir :: IO (Path Abs)
+ghcupBaseDir = do
+  getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case
+    Just r  -> parseAbs r
+    Nothing -> do
+      home <- liftIO getHomeDirectory
+      pure (home </> ([rel|.ghcup|] :: Path Rel))
+
+ghcupGHCBaseDir :: IO (Path Abs)
+ghcupGHCBaseDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
+
+ghcupGHCDir :: Version -> IO (Path Abs)
+ghcupGHCDir ver = do
+  ghcbasedir <- ghcupGHCBaseDir
+  verdir     <- parseRel (verToBS ver)
+  pure (ghcbasedir </> verdir)
+
+
+ghcupBinDir :: IO (Path Abs)
+ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
+
+ghcupCacheDir :: IO (Path Abs)
+ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
+
+ghcupLogsDir :: IO (Path Abs)
+ghcupLogsDir = ghcupBaseDir <&> (</> ([rel|logs|] :: Path Rel))
+
+
+mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
+mkGhcupTmpDir = do
+  tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
+  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
+  parseAbs tmp
+
+
+withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs)
+withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
+
+
+    --------------
+    --[ Others ]--
+    --------------
+
+
+getHomeDirectory :: IO (Path Abs)
+getHomeDirectory = do
+  e <- getEnv [s|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

lib/GHCup/Utils/File.hs

@@ -1,57 +1,48 @@
 {-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
-module GHCup.File where
+module GHCup.Utils.File where
 
+import           GHCup.Utils.Dirs
+import           GHCup.Utils.Prelude
+
+import           Control.Exception.Safe
+import           Control.Monad
 import           Data.ByteString
-import qualified Data.ByteString.Lazy          as L
+import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
 import           Data.Char
+import           Data.Foldable
+import           Data.Functor
 import           Data.Maybe
-import           Data.String.QQ
+import           GHC.Foreign                    ( peekCStringLen )
+import           GHC.IO.Encoding                ( getLocaleEncoding )
+import           GHC.IO.Exception
 import           HPath
 import           HPath.IO
 import           Optics
+import           Streamly
 import           Streamly.External.ByteString
 import           Streamly.External.ByteString.Lazy
-import           Streamly
-import           System.Posix.FilePath   hiding ( (</>) )
-import           Data.Foldable
-import           Control.Monad
-import           Control.Exception.Safe
-import           Data.Functor
-import           System.Posix.Files.ByteString
-import           System.Posix.Foreign           ( oExcl )
-import           System.Posix.Env.ByteString
 import           System.IO
-import qualified System.Posix.FilePath         as FP
+import           System.Posix.Directory.ByteString
+import           System.Posix.FD               as FD
+import           System.Posix.FilePath   hiding ( (</>) )
+import           System.Posix.Foreign           ( oExcl )
 import "unix"    System.Posix.IO.ByteString
                                          hiding ( openFd )
+import           System.Posix.Process           ( ProcessStatus(..) )
+import           System.Posix.Types
+
+
 import qualified System.Posix.Process.ByteString
                                                as SPPB
-import           System.Posix.Directory.ByteString
-import           System.Posix.Process           ( ProcessStatus(..) )
-import           System.Posix.Temp.ByteString
-import           System.Posix.Types
-import qualified System.Posix.User             as PU
-
+import           Streamly.External.Posix.DirStream
 import qualified Streamly.Internal.Memory.ArrayStream
                                                as AS
 import qualified Streamly.FileSystem.Handle    as FH
 import qualified Streamly.Internal.Data.Unfold as SU
 import qualified Streamly.Prelude              as S
-import           System.Exit
-import qualified Streamly.Data.Fold            as FL
-import           Data.ByteString.Builder
-import           Foreign.C.Error
-import           GHCup.Prelude
-import           Control.Concurrent.Async
-import           Control.Concurrent
-import           System.Posix.FD               as FD
-import qualified Data.ByteString.UTF8          as UTF8
-import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
-import           GHC.IO.Encoding                ( getLocaleEncoding )
-import           GHC.Foreign                    ( peekCStringLen )
-
+import qualified Data.ByteString.Lazy          as L
 
 
 data ProcessError = NonZeroExit Int ByteString [ByteString]
@@ -61,11 +52,12 @@ data ProcessError = NonZeroExit Int ByteString [ByteString]
                   deriving Show
 
 
-data CapturedProcess = CapturedProcess {
-    _exitCode :: ExitCode
+data CapturedProcess = CapturedProcess
+  { _exitCode :: ExitCode
   , _stdOut   :: ByteString
   , _stdErr   :: ByteString
-} deriving (Eq, Show)
+  }
+  deriving (Eq, Show)
 
 makeLenses ''CapturedProcess
 
@@ -101,7 +93,7 @@ findExecutable ex = do
   -- figure out if a file exists, then treat it as a negative result.
   asum $ fmap (handleIO (\_ -> pure Nothing)) $ fmap
     -- asum for short-circuiting behavior
-    (\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
+    (\s' -> (isExecutable (s' </> ex) >>= guard) $> (Just (s' </> ex)))
     sPaths
 
 
@@ -111,10 +103,39 @@ 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
+executeOut path args chdir = captureOutStreams $ do
+  maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+  SPPB.executeFile (toFilePath path) True args Nothing
+
+
+execLogged :: ByteString       -- ^ thing to execute
+           -> Bool             -- ^ whether to search PATH for the thing
+           -> [ByteString]     -- ^ args for the thing
+           -> Path Rel         -- ^ log filename
+           -> Maybe (Path Abs) -- ^ optionally chdir into this
+           -> Maybe [(ByteString, ByteString)] -- ^ optional environment
+           -> IO (Either ProcessError ())
+execLogged exe spath args lfile chdir env = do
+  ldir <- ghcupLogsDir
+  let logfile = ldir </> lfile
+  bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
+ where
+  action fd = do
+    pid <- SPPB.forkProcess $ do
+      -- dup stdout
+      void $ dupTo fd stdOutput
+
+      -- dup stderr
+      void $ dupTo fd stdError
+
+      -- execute the action
+      maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
+      SPPB.executeFile exe spath args env
+
+
+    SPPB.getProcessStatus True True pid >>= \case
+      i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
+      i                         -> pure $ toProcessError exe args i
 
 
 -- | Capture the stdout and stderr of the given action, which
@@ -150,9 +171,9 @@ captureOutStreams action =
           stdout' <- L.toStrict <$> readFd parentStdoutRead
           stderr' <- L.toStrict <$> readFd parentStderrRead
           pure $ CapturedProcess { _exitCode = es
-                                        , _stdOut   = stdout'
-                                        , _stdErr   = stderr'
-                                        }
+                                 , _stdOut   = stdout'
+                                 , _stdErr   = stderr'
+                                 }
         _ -> throwIO $ userError $ ("No such PID " ++ show pid)
 
  where
@@ -168,15 +189,17 @@ createRegularFileFd fm dest =
   FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
 
 
-exec :: ByteString      -- ^ thing to execute
-     -> [ByteString]     -- ^ args for the thing
+-- | 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 args spath chdir = do
+exec exe spath args chdir env = do
   pid <- SPPB.forkProcess $ do
     maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-    SPPB.executeFile exe spath args Nothing
+    SPPB.executeFile exe spath args env
 
   fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
 
@@ -193,26 +216,31 @@ toProcessError exe args mps = case mps of
   Nothing                            -> Left $ NoSuchPid exe args
 
 
-mkGhcupTmpDir :: IO (Path Abs)
-mkGhcupTmpDir = do
-  tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
-  tmp    <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
-  parseAbs tmp
-
-
-getHomeDirectory :: IO (Path Abs)
-getHomeDirectory = do
-  e <- getEnv [s|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
-
-
 -- | Convert the String to a ByteString with the current
 -- system encoding.
 unsafePathToString :: Path b -> IO FilePath
-unsafePathToString (Path p) = do
+unsafePathToString p = do
   enc <- getLocaleEncoding
-  unsafeUseAsCStringLen p (peekCStringLen enc)
+  unsafeUseAsCStringLen (toFilePath p) (peekCStringLen enc)
+
+
+-- | 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 PermissionDenied (go xs)
+      $ hideErrorDefM 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

lib/GHCup/Utils/Logger.hs

@@ -0,0 +1,60 @@
+{-# LANGUAGE QuasiQuotes           #-}
+
+module GHCup.Utils.Logger where
+
+import           GHCup.Utils
+
+import           Control.Monad
+import           Control.Monad.Logger
+import           HPath
+import           HPath.IO
+import           Prelude                 hiding ( appendFile )
+import           System.Console.Pretty
+import           System.IO.Error
+
+import qualified Data.ByteString               as B
+
+
+data LoggerConfig = LoggerConfig
+  { lcPrintDebug :: Bool                  -- ^ whether to print debug in colorOutter
+  , colorOutter  :: B.ByteString -> IO () -- ^ how to write the color output
+  , rawOutter    :: B.ByteString -> IO () -- ^ how to write the full raw output
+  }
+
+
+myLoggerT :: LoggerConfig -> LoggingT m a -> m a
+myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger
+ where
+  mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
+  mylogger _ _ level str' = do
+    -- color output
+    let l = case level of
+          LevelDebug   -> toLogStr (style Bold $ color Blue "[ Debug ]")
+          LevelInfo    -> toLogStr (style Bold $ color Green "[ Info  ]")
+          LevelWarn    -> toLogStr (style Bold $ color Yellow "[ Warn  ]")
+          LevelError   -> toLogStr (style Bold $ color Red "[ Error ]")
+          LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]"
+    let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n")
+
+    when (lcPrintDebug || (lcPrintDebug == False && not (level == LevelDebug)))
+      $ colorOutter out
+
+    -- raw output
+    let lr = case level of
+          LevelDebug   -> toLogStr "Debug: "
+          LevelInfo    -> toLogStr "Info:"
+          LevelWarn    -> toLogStr "Warn:"
+          LevelError   -> toLogStr "Error:"
+          LevelOther t -> toLogStr t <> toLogStr ":"
+    let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n")
+    rawOutter outr
+
+
+initGHCupFileLogging :: Path Rel -> IO (Path Abs)
+initGHCupFileLogging context = do
+  logs <- ghcupLogsDir
+  let logfile = logs </> context
+  createDirIfMissing newDirPerms logs
+  hideError doesNotExistErrorType $ deleteFile logfile
+  createRegularFile newFilePerms logfile
+  pure logfile

lib/GHCup/Utils/Prelude.hs

@@ -0,0 +1,243 @@
+{-# LANGUAGE DataKinds           #-}
+{-# LANGUAGE DeriveLift          #-}
+{-# LANGUAGE FlexibleContexts    #-}
+{-# LANGUAGE FlexibleInstances   #-}
+{-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+{-# LANGUAGE TypeApplications    #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
+
+module GHCup.Utils.Prelude where
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.IO.Class
+import           Control.Monad.Trans.Class      ( lift )
+import           Data.Bifunctor
+import           Data.ByteString                ( ByteString )
+import           Data.Monoid                    ( (<>) )
+import           Data.String
+import           Data.Text                      ( Text )
+import           Data.Versions
+import           Haskus.Utils.Types.List
+import           Haskus.Utils.Variant.Excepts
+import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment )
+
+import qualified Data.ByteString.Lazy          as L
+import qualified Data.Strict.Maybe             as S
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import qualified Data.Text.Lazy                as TL
+import qualified Data.Text.Lazy.Builder        as B
+import qualified Data.Text.Lazy.Builder.Int    as B
+import qualified Data.Text.Lazy.Encoding       as TLE
+
+
+
+fS :: IsString a => String -> a
+fS = fromString
+
+fromStrictMaybe :: S.Maybe a -> Maybe a
+fromStrictMaybe = S.maybe Nothing Just
+
+fSM :: S.Maybe a -> Maybe a
+fSM = fromStrictMaybe
+
+toStrictMaybe :: Maybe a -> S.Maybe a
+toStrictMaybe = maybe S.Nothing S.Just
+
+tSM :: Maybe a -> S.Maybe a
+tSM = toStrictMaybe
+
+internalError :: String -> IO a
+internalError = fail . ("Internal error: " <>)
+
+iE :: String -> IO a
+iE = internalError
+
+
+showT :: Show a => a -> Text
+showT = fS . show
+
+-- | Like 'when', but where the test can be monadic.
+whenM :: Monad m => m Bool -> m () -> m ()
+whenM ~b ~t = ifM b t (return ())
+
+-- | Like 'unless', but where the test can be monadic.
+unlessM :: Monad m => m Bool -> m () -> m ()
+unlessM ~b ~f = ifM b (return ()) f
+
+-- | Like @if@, but where the test can be monadic.
+ifM :: Monad m => m Bool -> m a -> m a -> m a
+ifM ~b ~t ~f = do
+  b' <- b
+  if b' then t else f
+
+whileM :: Monad m => m a -> (a -> m Bool) -> m a
+whileM ~action ~f = do
+  a  <- action
+  b' <- f a
+  if b' then whileM action f else pure a
+
+whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
+whileM_ ~action = void . whileM action
+
+guardM :: (Monad m, Alternative m) => m Bool -> m ()
+guardM ~f = guard =<< f
+
+lBS2sT :: L.ByteString -> Text
+lBS2sT = TL.toStrict . TLE.decodeUtf8
+
+
+
+handleIO' :: (MonadIO m, MonadCatch m)
+          => IOErrorType
+          -> (IOException -> m a)
+          -> m a
+          -> m a
+handleIO' err handler = handleIO
+  (\e -> if err == ioeGetErrorType e then handler e else liftIO $ ioError e)
+
+
+(??) :: forall e es a m . (Monad m, e :< es) => Maybe a -> e -> Excepts es m a
+(??) m e = maybe (throwE e) pure m
+
+
+(!?) :: forall e es a m
+      . (Monad m, e :< es)
+     => m (Maybe a)
+     -> e
+     -> Excepts es m a
+(!?) em e = lift em >>= (?? e)
+
+
+lE :: forall e es a m . (Monad m, e :< es) => Either e a -> Excepts es m a
+lE = liftE . veitherToExcepts . fromEither
+
+lE' :: forall e' e es a m
+     . (Monad m, e :< es)
+    => (e' -> e)
+    -> Either e' a
+    -> Excepts es m a
+lE' f = liftE . veitherToExcepts . fromEither . bimap f id
+
+lEM :: forall e es a m . (Monad m, e :< es) => m (Either e a) -> Excepts es m a
+lEM em = lift em >>= lE
+
+lEM' :: forall e' e es a m
+      . (Monad m, e :< es)
+     => (e' -> e)
+     -> m (Either e' a)
+     -> Excepts es m a
+lEM' f em = lift em >>= lE . bimap f id
+
+fromEither :: Either a b -> VEither '[a] b
+fromEither = either (VLeft . V) VRight
+
+
+liftIOException' :: ( MonadCatch m
+                    , MonadIO m
+                    , Monad m
+                    , e :< es'
+                    , LiftVariant es es'
+                    )
+                 => IOErrorType
+                 -> e
+                 -> Excepts es m a
+                 -> Excepts es' m a
+liftIOException' errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . liftE
+
+
+liftIOException :: (MonadCatch m, MonadIO m, Monad m, e :< es')
+                => IOErrorType
+                -> e
+                -> m a
+                -> Excepts es' m a
+liftIOException errType ex =
+  handleIO
+      (\e ->
+        if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
+      )
+    . lift
+
+
+hideErrorDef :: IOErrorType -> a -> IO a -> IO a
+hideErrorDef err def =
+  handleIO (\e -> if err == ioeGetErrorType e then pure def else ioError e)
+
+
+hideErrorDefM :: IOErrorType -> IO a -> IO a -> IO a
+hideErrorDefM err def =
+  handleIO (\e -> if err == ioeGetErrorType e then def else ioError e)
+
+
+-- TODO: does this work?
+hideExcept :: forall e es es' a m
+            . (Monad m, e :< es, LiftVariant (Remove e es) es')
+           => e
+           -> a
+           -> Excepts es m a
+           -> Excepts es' m a
+hideExcept _ a action =
+  catchLiftLeft ((\_ -> pure a) :: (e -> Excepts es' m a)) action
+
+
+hideExcept' :: forall e es es' m
+             . (Monad m, e :< es, LiftVariant (Remove e es) es')
+            => e
+            -> Excepts es m ()
+            -> Excepts es' m ()
+hideExcept' _ action =
+  catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action
+
+
+reThrowAll :: forall e es es' a m
+            . (Monad m, e :< es')
+           => (V es -> e)
+           -> Excepts es m a
+           -> Excepts es' m a
+reThrowAll f = catchAllE (throwE . f)
+
+
+reThrowAllIO :: forall e es es' a m
+              . (MonadCatch m, Monad m, MonadIO m, e :< es')
+             => (V es -> e)
+             -> (IOException -> e)
+             -> Excepts es m a
+             -> Excepts es' m a
+reThrowAllIO f g = handleIO (throwE . g) . catchAllE (throwE . f)
+
+
+throwEither :: (Exception a, MonadThrow m) => Either a b -> m b
+throwEither a = case a of
+  Left  e -> throwM e
+  Right r -> pure r
+
+
+verToBS :: Version -> ByteString
+verToBS = E.encodeUtf8 . prettyVer
+
+
+intToText :: Integral a => a -> T.Text
+intToText = TL.toStrict . B.toLazyText . B.decimal
+
+
+removeLensFieldLabel :: String -> String
+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)

lib/GHCup/Utils/String/QQ.hs

@@ -0,0 +1,48 @@
+{-# LANGUAGE TemplateHaskell #-}
+
+-- | QuasiQuoter for non-interpolated strings, texts and bytestrings.
+--
+-- The "s" quoter contains a multi-line string with no interpolation at all,
+-- except that the leading newline is trimmed and carriage returns stripped.
+--
+-- @
+-- {-\# LANGUAGE QuasiQuotes #-}
+-- import Data.Text (Text)
+-- import Data.String.QQ
+-- foo :: Text -- "String", "ByteString" etc also works
+-- foo = [s|
+-- Well here is a
+--     multi-line string!
+-- |]
+-- @
+--
+-- Any instance of the IsString type is permitted.
+--
+-- (For GHC versions 6, write "[$s||]" instead of "[s||]".)
+--
+module GHCup.Utils.String.QQ
+  ( s
+  )
+where
+
+
+import           Data.Char
+import           GHC.Exts                       ( IsString(..) )
+import           Language.Haskell.TH.Quote
+
+-- | QuasiQuoter for a non-interpolating ASCII IsString literal.
+-- The pattern portion is undefined.
+s :: QuasiQuoter
+s = QuasiQuoter
+  (\s' -> case and $ fmap isAscii s' of
+    True  -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s'
+    False -> fail "Not ascii"
+  )
+  (error "Cannot use q as a pattern")
+  (error "Cannot use q as a type")
+  (error "Cannot use q as a dec")
+ where
+  removeCRs = filter (/= '\r')
+  trimLeadingNewline ('\n' : xs) = xs
+  trimLeadingNewline xs          = xs
+

lib/GHCup/Utils/Version/QQ.hs

@@ -0,0 +1,89 @@
+{-# OPTIONS_GHC -Wno-orphans    #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveLift         #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE TemplateHaskell    #-}
+
+
+module GHCup.Utils.Version.QQ where
+
+import           Data.Data
+import           Data.Text                      ( Text )
+import           Data.Versions
+import           GHC.Base
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
+import           Language.Haskell.TH.Syntax     ( Exp(..)
+                                                , Lift
+                                                , dataToExpQ
+                                                )
+import qualified Data.Text                     as T
+import qualified Language.Haskell.TH.Syntax    as TH
+
+
+
+deriving instance Data Versioning
+deriving instance Lift Versioning
+deriving instance Data Version
+deriving instance Lift Version
+deriving instance Data SemVer
+deriving instance Lift SemVer
+deriving instance Data Mess
+deriving instance Lift Mess
+deriving instance Data PVP
+deriving instance Lift PVP
+deriving instance Lift (NonEmpty Word)
+deriving instance Lift VSep
+deriving instance Data VSep
+deriving instance Lift VUnit
+deriving instance Data VUnit
+instance Lift Text
+
+qq :: (Text -> Q Exp) -> QuasiQuoter
+qq quoteExp' = QuasiQuoter
+  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
+  , quotePat  = \_ ->
+    fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
+  , quoteType = \_ ->
+    fail "illegal QuasiQuote (allowed as expression only, used as a type)"
+  , quoteDec  = \_ -> fail
+    "illegal QuasiQuote (allowed as expression only, used as a declaration)"
+  }
+
+vver :: QuasiQuoter
+vver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . version
+
+mver :: QuasiQuoter
+mver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . mess
+
+sver :: QuasiQuoter
+sver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . semver
+
+vers :: QuasiQuoter
+vers = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . versioning
+
+pver :: QuasiQuoter
+pver = qq mkV
+ where
+  mkV :: Text -> Q Exp
+  mkV = either (fail . show) liftDataWithText . pvp
+
+-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable
+liftText :: T.Text -> Q Exp
+liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt)
+
+liftDataWithText :: Data a => a -> Q Exp
+liftDataWithText = dataToExpQ (\a -> liftText <$> cast a)

lib/GHCup/Version.hs

@@ -0,0 +1,11 @@
+{-# LANGUAGE QuasiQuotes       #-}
+
+
+module GHCup.Version where
+
+import           GHCup.Utils.Version.QQ
+
+import           Data.Versions
+
+ghcUpVer :: PVP
+ghcUpVer = [pver|0.1.0|]