Yoo

README.md

@@ -1,28 +1,25 @@
 # ghcup
 
-A rewrite of ghcup in haskell. This can be used as a library
+A rewrite of ghcup in haskell.
-and may be redistributed as a binary in the future.
 
 ## 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,32 +1,41 @@
 # TODOs and Remarks
 
-## New
+## Now
 
-* download progress
+* print-system-reqs
+
+## Cleanups
+
+* avoid alternative for IO
+* don't use Excepts?
+
+## Maybe
 
-* upgrade            Upgrade this script in-place
 * maybe: changelog          Show the changelog of a GHC release (online)
-* maybe: print-system-reqs  Print an approximation of system requirements
+* OS faking
+* sign the JSON? (Or check gpg keys?)
 
 * testing (especially distro detection -> unit tests)
 
-* TODO: cleanup temp files after use
+* 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?
-
-* 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/ghcup-gen/AvailableDownloads.hs

@@ -1,127 +0,0 @@
-{-# LANGUAGE DataKinds         #-}
-{-# LANGUAGE TypeApplications  #-}
-{-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE TemplateHaskell   #-}
-{-# LANGUAGE QuasiQuotes       #-}
-{-# LANGUAGE DuplicateRecordFields #-}
-
-
-module AvailableDownloads where
-
-import qualified Data.Map                      as M
-import           GHCup.Prelude
-import           GHCup.Types
-import           HPath
-import           URI.ByteString.QQ
-
-
-
--- TODO: version quasiquoter
-availableDownloads :: AvailableDownloads
-availableDownloads = M.fromList
-  [ ( GHC
-    , M.fromList
-      [ ( [vver|8.6.5|]
-        , VersionInfo [Latest] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [ ( Linux UnknownLinux
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
-                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-                    )
-                  ]
-                )
-              , ( Linux Ubuntu
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-deb9-linux.tar.xz|]
-                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-                    )
-                  ]
-                )
-              , ( Linux Debian
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
-                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-                    )
-                  , ( Just $ [vers|8|]
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
-                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-                    )
-                  ]
-                )
-              ]
-            )
-          ]
-        ),
-        ( [vver|8.4.4|]
-        , VersionInfo [Latest] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [ ( Linux UnknownLinux
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-fedora27-linux.tar.xz|]
-                      (Just ([rel|ghc-8.4.4|] :: Path Rel))
-                    )
-                  ]
-                )
-              , ( Linux Ubuntu
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.4.4/ghc-8.4.4-x86_64-deb9-linux.tar.xz|]
-                      (Just ([rel|ghc-8.4.4|] :: Path Rel))
-                    )
-                  ]
-                )
-              , ( Linux Debian
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
-                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-                    )
-                  , ( Just $ [vers|8|]
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
-                      (Just ([rel|ghc-8.6.5|] :: Path Rel))
-                    )
-                  ]
-                )
-              ]
-            )
-          ]
-        )
-      ]
-    )
-  , ( Cabal
-    , M.fromList
-      [ ( [vver|3.0.0.0|]
-        , VersionInfo [Recommended, Latest] $ M.fromList
-          [ ( A_64
-            , M.fromList
-              [ ( Linux UnknownLinux
-                , M.fromList
-                  [ ( Nothing
-                    , DownloadInfo
-                      [uri|https://downloads.haskell.org/~cabal/cabal-install-3.0.0.0/cabal-install-3.0.0.0-x86_64-unknown-linux.tar.xz|]
-                      Nothing
-                    )
-                  ]
-                )
-              ]
-            )
-          ]
-        )
-      ]
-    )
-  ]

app/ghcup-gen/Main.hs

@@ -8,19 +8,21 @@
 
 module Main where
 
-import           AvailableDownloads
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Logger
+import           GHCupDownloads
+
 import           Data.Aeson                     ( eitherDecode )
 import           Data.Aeson.Encode.Pretty
-import qualified Data.ByteString.Lazy          as L
 import           Data.Semigroup                 ( (<>) )
-import           GHCup.Types.JSON               ( )
 import           Options.Applicative     hiding ( style )
-import           GHCup.Logger
 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
@@ -29,6 +31,7 @@ data Options = Options
 
 data Command = GenJSON GenJSONOpts
              | ValidateJSON ValidateJSONOpts
+             | ValidateTarballs ValidateJSONOpts
 
 data Output
   = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway
@@ -105,7 +108,16 @@ com = subparser
        "check"
        (   ValidateJSON
        <$> (info (validateJSONOpts <**> helper)
-                 (progDesc "Generate the json downloads file")
+                 (progDesc "Validate the JSON")
+           )
+       )
+     )
+  <> (command
+       "check-tarballs"
+       (   ValidateTarballs
+       <$> (info
+             (validateJSONOpts <**> helper)
+             (progDesc "Validate all tarballs (download and checksum)")
            )
        )
      )
@@ -120,7 +132,7 @@ main = do
           GenJSON gopts -> do
             let
               bs = encodePretty' (defConfig { confIndent = Spaces 2 })
-                                 availableDownloads
+                                 ghcupDownloads
             case gopts of
               GenJSONOpts { output = Nothing }        -> L.hPutStr stdout bs
               GenJSONOpts { output = Just StdOutput } -> L.hPutStr stdout bs
@@ -128,16 +140,25 @@ main = do
                 L.writeFile file bs
           ValidateJSON vopts -> case vopts of
             ValidateJSONOpts { input = Nothing } ->
-              L.getContents >>= valAndExit
+              L.getContents >>= valAndExit validate
             ValidateJSONOpts { input = Just StdInput } ->
-              L.getContents >>= valAndExit
+              L.getContents >>= valAndExit validate
             ValidateJSONOpts { input = Just (FileInput file) } ->
-              L.readFile file >>= valAndExit
+              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 contents = do
+  valAndExit f contents = do
     av <- case eitherDecode contents of
       Right r -> pure r
       Left  e -> die (color Red $ show e)
-    myLoggerTStdout (validate av) >>= exitWith
+    myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av)
+      >>= exitWith
+

app/ghcup-gen/Validate.hs

@@ -5,52 +5,72 @@
 module Validate where
 
 import           GHCup
+import           GHCup.Download
 import           GHCup.Types
+import           GHCup.Utils.Logger
 
-import           Control.Monad
 import           Control.Exception.Safe
-import           Control.Monad.Reader.Class
+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           Data.IORef
+import           Haskus.Utils.Variant.Excepts
+import           Optics
 import           System.Exit
-import           Control.Monad.Logger
+import           System.IO
 
+import qualified Data.ByteString               as B
 import qualified Data.Map.Strict               as M
 
 
--- TODO: improve logging
-
-
 data ValidationError = InternalError String
   deriving Show
 
 instance Exception ValidationError
 
 
--- TODO: test that GHC is in semver
+addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
-validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m)
+addError = do
-         => AvailableDownloads
+  ref <- ask
+  liftIO $ modifyIORef ref (+ 1)
+
+
+validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m)
+         => GHCupDownloads
          -> m ExitCode
-validate av = do
+validate dls = do
   ref <- liftIO $ newIORef 0
+
+  -- * verify binary downloads * --
   flip runReaderT ref $ do
     -- unique tags
-    forM_ (M.toList av) $ \(t, _) -> checkUniqueTags t
+    forM_ (M.toList dls) $ \(t, _) -> checkUniqueTags t
 
     -- required platforms
-    forM_ (M.toList av) $ \(t, versions) ->
+    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 pure ExitSuccess
+    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
@@ -58,14 +78,14 @@ validate av = do
       lift $ $(logError)
         [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|]
       addError
-    when (not $ any (== Darwin) pspecs) $ do
+    when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do
       lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|]
       addError
-    when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn)
+    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 av tool
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
     let nonUnique =
           fmap fst
             .   filter (\(_, b) -> not b)
@@ -82,14 +102,80 @@ validate av = do
     case join nonUnique of
       [] -> pure ()
       xs -> do
-        lift $ $(logError) [i|Tags not unique: #{xs}|]
+        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 ()
 
-addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m ()
+  -- a tool must have at least one of each mandatory tags
-addError = do
+  checkMandatoryTags tool = do
-  ref <- ask
+    let allTags = join $ fmap snd $ availableToolVersions dls tool
-  liftIO $ modifyIORef ref (+ 1)
+    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

@@ -9,61 +9,77 @@
 module Main where
 
 import           GHCup
-import           GHCup.File
+import           GHCup.Download
-import           GHCup.Logger
+import           GHCup.Errors
-import           GHCup.Prelude
 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.String.QQ
 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
+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
-  { optVerbose   :: Bool
+  {
+  -- global options
+    optVerbose   :: Bool
   , optCache     :: Bool
   , optUrlSource :: Maybe URI
+  , optNoVerify  :: Bool
+  -- commands
   , optCommand   :: Command
   }
 
 data Command
-  = InstallGHC InstallGHCOptions
+  = Install InstallCommand
-  | InstallCabal InstallCabalOptions
   | SetGHC SetGHCOptions
   | List ListOptions
   | Rm RmOptions
   | DInfo
+  | Compile CompileCommand
+  | Upgrade UpgradeOpts
+  | NumericVersion
 
 data ToolVersion = ToolVersion Version
                  | ToolTag Tag
 
 
-data InstallGHCOptions = InstallGHCOptions
+data InstallCommand = InstallGHC InstallOptions
-  { ghcVer :: Maybe ToolVersion
+                    | InstallCabal InstallOptions
-  }
 
-data InstallCabalOptions = InstallCabalOptions
+data InstallOptions = InstallOptions
-  { cabalVer :: Maybe ToolVersion
+  { instVer :: Maybe ToolVersion
   }
 
 data SetGHCOptions = SetGHCOptions
@@ -80,6 +96,23 @@ data RmOptions = RmOptions
   }
 
 
+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
@@ -95,63 +128,105 @@ opts =
           (option
             (eitherReader parseUri)
             (short 's' <> long "url-source" <> metavar "URL" <> help
-              "Alternative ghcup download info url (default: internal)"
+              "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
+com =
-  (  command
+  subparser
-      "install-ghc"
+      (  command
-      (   InstallGHC
+          "install"
-      <$> (info (installGHCOpts <**> helper)
+          (   Install
-                (progDesc "Install a GHC version")
+          <$> (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
-       "install-cabal"
+       "cabal"
        (   InstallCabal
-       <$> (info (installCabalOpts <**> helper)
+       <$> (info (installOpts <**> helper)
-                 (progDesc "Install a cabal-install version")
+                 (progDesc "Install or update a Cabal version")
            )
        )
-  <> command
-       "set-ghc"
-       (   SetGHC
-       <$> (info (setGHCOpts <**> helper)
-                 (progDesc "Set the currently active GHC version")
-           )
-       )
-  <> command
-       "list"
-       (   List
-       <$> (info (listOpts <**> helper)
-                 (progDesc "Show available GHCs and other tools")
-           )
-       )
-  <> command
-       "rm"
-       (   Rm
-       <$> (info (rmOpts <**> helper)
-                 (progDesc "Remove a GHC version installed by ghcup")
-           )
-       )
-  <> command
-       "debug-info"
-       ((\_ -> DInfo) <$> (info (helper) (progDesc "Show debug info")))
   )
 
-installGHCOpts :: Parser InstallGHCOptions
+installOpts :: Parser InstallOptions
-installGHCOpts = InstallGHCOptions <$> optional toolVersionParser
+installOpts = InstallOptions <$> optional toolVersionParser
-
-
-installCabalOpts :: Parser InstallCabalOptions
-installCabalOpts = InstallCabalOptions <$> optional toolVersionParser
 
 setGHCOpts :: Parser SetGHCOptions
 setGHCOpts = SetGHCOptions <$> optional toolVersionParser
@@ -178,23 +253,75 @@ listOpts =
         )
 
 rmOpts :: Parser RmOptions
-rmOpts =
+rmOpts = RmOptions <$> versionParser
-  RmOptions
+
+
+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 GHC version to remove"
+            "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")
+  (short 'v' <> long "version" <> metavar "VERSION" <> help "The target version"
+  )
 
 
 toolVersionParser :: Parser ToolVersion
@@ -211,7 +338,7 @@ toolVersionParser = verP <|> toolP
                 other         -> Left ([i|Unknown tag #{other}|])
               )
             )
-            (short 't' <> long "tag" <> metavar "TAG")
+            (short 't' <> long "tag" <> metavar "TAG" <> help "The target tag")
           )
 
 
@@ -233,39 +360,71 @@ toSettings :: Options -> Settings
 toSettings Options {..} =
   let cache     = optCache
       urlSource = maybe GHCupURL OwnSource optUrlSource
+      noVerify  = optNoVerify
   in  Settings { .. }
 
 
--- TODO: something better than Show instance for errors
+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
+          let settings = toSettings opt
 
           -- logger interpreter
-          let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr)
+          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
-                      , ArchiveError
+                      , UnknownArchive
                       , DistroNotFound
                       , FileDoesNotExistError
-                      , FileError
+                      , CopyError
                       , JSONError
                       , NoCompatibleArch
                       , NoDownload
                       , NotInstalled
-                      , PlatformResultError
+                      , NoCompatiblePlatform
-                      , ProcessError
+                      , BuildFailed
                       , TagNotFound
-                      , URLException
+                      , DigestError
+                      , DownloadFailed
                       ]
 
           let runSetGHC =
@@ -275,15 +434,15 @@ main = do
                     @'[ FileDoesNotExistError
                       , NotInstalled
                       , TagNotFound
-                      , URLException
                       , JSONError
                       , TagNotFound
+                      , DownloadFailed
                       ]
 
           let runListGHC =
                 runLogger
                   . flip runReaderT settings
-                  . runE @'[FileDoesNotExistError , URLException , JSONError]
+                  . runE @'[FileDoesNotExistError , JSONError , DownloadFailed]
 
           let runRmGHC =
                 runLogger . flip runReaderT settings . runE @'[NotInstalled]
@@ -292,45 +451,103 @@ main = do
                 runLogger
                   . flip runReaderT settings
                   . runE
-                    @'[PlatformResultError , NoCompatibleArch , DistroNotFound]
+                    @'[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
-            InstallGHC (InstallGHCOptions {..}) ->
+            Install (InstallGHC InstallOptions {..}) ->
               void
                 $   (runInstTool $ do
-                      av <- liftE getDownloads
+                      dls <- liftE getDownloads
-                      v  <- liftE $ fromVersion av ghcVer GHC
+                      v   <- liftE $ fromVersion dls instVer GHC
-                      liftE $ installTool (ToolRequest GHC v) Nothing
+                      liftE $ installGHCBin dls v Nothing
                     )
                 >>= \case
                       VRight _ -> runLogger
                         $ $(logInfo) ([s|GHC installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
+                      VLeft (V (AlreadyInstalled _ v)) ->
                         runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
+                          [i|GHC ver #{prettyVer v} already installed|]
-                      VLeft e ->
+                      VLeft (V (BuildFailed tmpdir e)) ->
-                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+                        runLogger
-            InstallCabal (InstallCabalOptions {..}) ->
+                            ($(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
-                      av <- liftE getDownloads
+                      dls <- liftE getDownloads
-                      v  <- liftE $ fromVersion av cabalVer Cabal
+                      v   <- liftE $ fromVersion dls instVer Cabal
-                      liftE $ installTool (ToolRequest Cabal v) Nothing
+                      liftE $ installCabalBin dls v Nothing
                     )
                 >>= \case
                       VRight _ -> runLogger
                         $ $(logInfo) ([s|Cabal installation successful|])
-                      VLeft (V (AlreadyInstalled treq)) ->
+                      VLeft (V (AlreadyInstalled _ v)) ->
                         runLogger $ $(logWarn)
-                          (T.pack (show treq) <> [s| already installed|])
+                          [i|Cabal ver #{prettyVer v} already installed|]
-                      VLeft e ->
+                      VLeft e -> do
-                        runLogger ($(logError) [i|#{e}|]) >> exitFailure
+                        runLogger $ do
+                          $(logError) [i|#{e}|]
+                          $(logError) [i|Also check the logs in ~/.ghcup/logs|]
+                        exitFailure
 
             SetGHC (SetGHCOptions {..}) ->
               void
                 $   (runSetGHC $ do
-                      av <- liftE getDownloads
+                      dls <- liftE getDownloads
-                      v  <- liftE $ fromVersion av ghcVer GHC
+                      v   <- liftE $ fromVersion dls ghcVer GHC
                       liftE $ setGHC v SetGHCOnly
                     )
                 >>= \case
@@ -342,7 +559,8 @@ main = do
             List (ListOptions {..}) ->
               void
                 $   (runListGHC $ do
-                      liftE $ listVersions lTool lCriteria
+                      dls <- liftE getDownloads
+                      liftIO $ listVersions dls lTool lCriteria
                     )
                 >>= \case
                       VRight r -> liftIO $ printListResult r
@@ -368,11 +586,83 @@ main = do
                       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
-            => AvailableDownloads
+            => GHCupDownloads
             -> Maybe ToolVersion
             -> Tool
             -> Excepts '[TagNotFound] m Version
@@ -394,6 +684,7 @@ printListResult lr = do
           , column expand left def def
           , column expand left def def
           , column expand left def def
+          , column expand left def def
           ]
         $ fmap
             (\ListResult {..} ->
@@ -404,6 +695,7 @@ printListResult lr = do
               , fmap toLower . show $ lTool
               , T.unpack . prettyVer $ lVer
               , intercalate "," $ ((fmap . fmap) toLower . fmap show $ lTag)
+              , if fromSrc then (color Blue "compiled") else mempty
               ]
             )
             lr

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.free ==5.1.3,
-             any.gauge ==0.2.5,
+             any.fusion-plugin-types ==0.1.0,
-             gauge +analysis,
              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.http-io-streams ==0.1.2.0,
-             any.hspec-core ==2.7.1,
+             http-io-streams +brotli,
-             any.hspec-discover ==2.7.1,
-             any.hspec-expectations ==0.8.2,
-             any.http-io-streams ==0.1.0.0,
              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 ==3.1.1.1,
-             any.network-uri ==2.6.2.0,
+             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

@@ -23,22 +23,25 @@ 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 attoparsec { build-depends: attoparsec >= 0.13 }
 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-variant { build-depends: haskus-utils-variant >= 3.0 }
 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 }
@@ -49,18 +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 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.2.0 }
+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 }
@@ -94,12 +100,15 @@ library
                      , ascii-string
                      , async
                      , attoparsec
+                     , binary
                      , bytestring
                      , bzlib
+                     , case-insensitive
                      , containers
                      , generics-sop
-                     , haskus-utils-variant
                      , haskus-utils-types
+                     , haskus-utils-variant
+                     , hopenssl
                      , hpath
                      , hpath-directory
                      , hpath-filepath
@@ -115,17 +124,20 @@ library
                      , 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
@@ -136,13 +148,21 @@ library
                      , word8
                      , zlib
   exposed-modules:     GHCup
-                       GHCup.Bash
+                       GHCup.Download
-                       GHCup.File
+                       GHCup.Errors
-                       GHCup.Logger
+                       GHCup.Platform
-                       GHCup.Prelude
                        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
@@ -160,8 +180,9 @@ executable ghcup
                        , text
                        , versions
                        , hpath
+                       , hpath-io
                        , pretty-terminal
-                       , string-qq
+                       , resourcet
                        , string-interpolate
                        , table-layout
                        , uri-bytestring
@@ -191,14 +212,14 @@ executable ghcup-gen
                        , versions
                        , hpath
                        , pretty-terminal
-                       , string-qq
+                       , resourcet
                        , string-interpolate
                        , table-layout
                        , transformers
                        , uri-bytestring
                        , utf8-string
   main-is:             Main.hs
-  other-modules:       AvailableDownloads
+  other-modules:       GHCupDownloads
                        Validate
   -- other-extensions:
   build-depends:       ghcup

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/Logger.hs

@@ -1,28 +0,0 @@
-module GHCup.Logger where
-
-
-import           Control.Monad.Logger
-import           System.Console.Pretty
-
-import qualified Data.ByteString as B
-
-
-data LoggerConfig = LoggerConfig {
-    lcPrintDebug :: Bool
-  , outter :: B.ByteString -> IO ()
-}
-
-
-myLoggerT :: LoggerConfig -> LoggingT m a -> m a
-myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger
- where
-  mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO ()
-  mylogger _ _ level str' = do
-    let l = case level of
-          LevelDebug   -> if lcPrintDebug then toLogStr (style Bold $ color Blue   "[ Debug ]") else mempty
-          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")
-    outter out

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/Types.hs

@@ -3,6 +3,7 @@
 module GHCup.Types where
 
 import           Data.Map.Strict                ( Map )
+import           Data.Text                      ( Text )
 import           Data.Versions
 import           HPath
 import           URI.ByteString
@@ -10,6 +11,106 @@ import           URI.ByteString
 import qualified GHC.Generics                  as GHC
 
 
+
+
+    ---------------------
+    --[ 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)
+
+
+-- | 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
+                 | Fedora
+                 | CentOS
+                 | RedHat
+                 | Alpine
+                 | AmazonLinux
+                 -- rolling
+                 | Gentoo
+                 | Exherbo
+                 -- not known
+                 | UnknownLinux
+                 -- ^ must exit
+  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
@@ -23,64 +124,11 @@ data DebugInfo = DebugInfo
 
 
 data SetGHC = SetGHCOnly  -- ^ unversioned 'ghc'
-            | SetGHCMajor -- ^ ghc-x.y
+            | SetGHC_XY   -- ^ ghc-x.y
-            | SetGHCMinor -- ^ ghc-x.y.z -- TODO: rename
+            | SetGHC_XYZ  -- ^ ghc-x.y.z
-            deriving Show
+            deriving (Eq, Show)
 
 
-data Tag = Latest
-         | Recommended
-         deriving (Ord, Eq, Show)
-
-data VersionInfo = VersionInfo
-  { _viTags :: [Tag]
-  , _viArch :: ArchitectureSpec
-  }
-  deriving (Eq, Show)
-
-data DownloadInfo = DownloadInfo
-  { _dlUri    :: URI
-  , _dlSubdir :: Maybe (Path Rel)
-  }
-  deriving (Eq, Show)
-
-data Tool = GHC
-          | Cabal
-          | GHCUp
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data ToolRequest = ToolRequest
-  { _trTool        :: Tool
-  , _trVersion :: Version
-  }
-  deriving (Eq, Show)
-
-data Architecture = A_64
-                  | A_32
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data LinuxDistro = Debian
-                 | Ubuntu
-                 | Mint
-                 | Fedora
-                 | CentOS
-                 | RedHat
-                 | Alpine
-                 -- rolling
-                 | Gentoo
-                 | Exherbo
-                 -- not known
-                 | UnknownLinux
-                 -- ^ must exit
-  deriving (Eq, GHC.Generic, Ord, Show)
-
-data Platform = Linux LinuxDistro
-              -- ^ must exit
-              | Darwin
-              -- ^ must exit
-              | FreeBSD
-  deriving (Eq, GHC.Generic, Ord, Show)
-
 data PlatformResult = PlatformResult
   { _platform      :: Platform
   , _distroVersion :: Maybe Versioning
@@ -94,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

@@ -12,11 +12,12 @@
 module GHCup.Types.JSON where
 
 import           GHCup.Types
+import           GHCup.Utils.Prelude
+import           GHCup.Utils.String.QQ
 
 import           Data.Aeson
 import           Data.Aeson.TH
 import           Data.Aeson.Types
-import           Data.String.QQ
 import           Data.Text.Encoding             ( decodeUtf8 )
 import           Data.Text.Encoding            as E
 import           Data.Versions
@@ -28,19 +29,17 @@ import qualified Data.ByteString               as BS
 import qualified Data.Text                     as T
 
 
-
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture
-
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro
-deriveJSON defaultOptions ''Architecture
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess
-deriveJSON defaultOptions ''LinuxDistro
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform
-deriveJSON defaultOptions ''Mess
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer
-deriveJSON defaultOptions ''Platform
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool
-deriveJSON defaultOptions ''SemVer
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep
-deriveJSON defaultOptions ''Tool
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit
-deriveJSON defaultOptions ''VSep
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo
-deriveJSON defaultOptions ''VUnit
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag
-deriveJSON defaultOptions ''VersionInfo
+deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo
-deriveJSON defaultOptions ''Tag
-deriveJSON defaultOptions ''DownloadInfo
 
 
 instance ToJSON URI where

lib/GHCup/Types/Optics.hs

@@ -15,7 +15,6 @@ makePrisms ''Platform
 makePrisms ''Tag
 
 makeLenses ''PlatformResult
-makeLenses ''ToolRequest
 makeLenses ''DownloadInfo
 makeLenses ''Tag
 makeLenses ''VersionInfo
@@ -44,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

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,7 +1,10 @@
 {-# 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
@@ -11,39 +14,34 @@ 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           System.Exit
 import           System.IO
 import           System.Posix.Directory.ByteString
-import           System.Posix.Env.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.Temp.ByteString
 import           System.Posix.Types
 
 
 import qualified System.Posix.Process.ByteString
                                                as SPPB
-import qualified System.Posix.FilePath         as FP
+import           Streamly.External.Posix.DirStream
-import qualified System.Posix.User             as PU
 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 qualified Data.ByteString.UTF8          as UTF8
 import qualified Data.ByteString.Lazy          as L
 
 
@@ -110,6 +108,36 @@ executeOut path args chdir = captureOutStreams $ do
   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
 -- is run in a subprocess. Stdin is closed. You might want to
 -- 'race' this to make sure it terminates.
@@ -161,15 +189,17 @@ createRegularFileFd fm dest =
   FD.openFd (toFilePath dest) WriteOnly [oExcl] (Just fm)
 
 
-exec :: ByteString      -- ^ thing to execute
+-- | Thin wrapper around `executeFile`.
-     -> [ByteString]     -- ^ args for the thing
+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
 
@@ -186,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

@@ -1,17 +1,14 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
+{-# LANGUAGE DataKinds           #-}
-{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE DeriveLift          #-}
-{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE DeriveLift #-}
-{-# LANGUAGE StandaloneDeriving #-}
-{-# LANGUAGE FlexibleInstances #-}
-{-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE ScopedTypeVariables #-}
-{-# LANGUAGE AllowAmbiguousTypes #-}
+{-# LANGUAGE TypeApplications    #-}
-{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE TypeFamilies        #-}
+{-# LANGUAGE TypeOperators       #-}
 
-module GHCup.Prelude where
+module GHCup.Utils.Prelude where
 
 import           Control.Applicative
 import           Control.Exception.Safe
@@ -24,13 +21,10 @@ import           Data.Monoid                    ( (<>) )
 import           Data.String
 import           Data.Text                      ( Text )
 import           Data.Versions
-import           GHC.Base
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
-import           Language.Haskell.TH
-import           Language.Haskell.TH.Quote      ( QuasiQuoter(..) )
-import           Language.Haskell.TH.Syntax     ( Exp(..) , Lift)
 import           System.IO.Error
+import           System.Posix.Env.ByteString    ( getEnvironment )
 
 import qualified Data.ByteString.Lazy          as L
 import qualified Data.Strict.Maybe             as S
@@ -40,7 +34,6 @@ 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
-import qualified Language.Haskell.TH.Syntax    as TH
 
 
 
@@ -145,17 +138,17 @@ fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
 
-liftException :: ( MonadCatch m
+liftIOException' :: ( MonadCatch m
-                 , MonadIO m
+                    , MonadIO m
-                 , Monad m
+                    , Monad m
-                 , e :< es'
+                    , e :< es'
-                 , LiftVariant es es'
+                    , LiftVariant es es'
-                 )
+                    )
-              => IOErrorType
+                 => IOErrorType
-              -> e
+                 -> e
-              -> Excepts es m a
+                 -> Excepts es m a
-              -> Excepts es' m a
+                 -> Excepts es' m a
-liftException errType ex =
+liftIOException' errType ex =
   handleIO
       (\e ->
         if errType == ioeGetErrorType e then throwE ex else liftIO $ ioError e
@@ -163,6 +156,29 @@ liftException errType ex =
     . 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')
@@ -174,69 +190,54 @@ 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
 
 
-
-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)"
-  }
-
-vver :: QuasiQuoter
-vver = 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
-
-
 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|]