Lol

app/Main.hs

@@ -1,8 +1,151 @@
+{-# LANGUAGE DataKinds         #-}
+{-# LANGUAGE TypeApplications  #-}
+{-# LANGUAGE OverloadedStrings #-}
+
 module Main where
 
-import qualified MyLib (someFunc)
+import           Control.Monad.Logger
+import           Control.Monad.Reader
+import           Control.Monad.IO.Class
+import           Data.Bifunctor
+import           Data.ByteString                ( ByteString )
+import           Data.Functor                   ( (<&>) )
+import           Data.Maybe
+import           Data.Semigroup                 ( (<>) )
+import           Data.Text                      ( Text )
+import qualified Data.Text                     as T
+import qualified Data.Text.Encoding            as E
+import           Data.Traversable
+import           Data.Versions
+import           GHCup
+import           GHCup.File
+import           GHCup.Prelude
+import           GHCup.Types
+import           Haskus.Utils.Variant.Excepts
+import           HPath
+import           Options.Applicative
+import           System.Console.Pretty
+import           System.Exit
+
+
+
+data Options = Options
+  { optVerbose :: Bool
+  , optCache :: Bool
+  , optCommand :: Command
+  }
+
+data Command
+  = InstallGHC InstallGHCOptions
+  | InstallCabal InstallCabalOptions
+
+data InstallGHCOptions = InstallGHCOptions
+  {
+    ghcVer          :: Maybe Version
+  }
+
+data InstallCabalOptions = InstallCabalOptions
+  {
+    cabalVer        :: Maybe Version
+  }
+
+
+opts :: Parser Options
+opts =
+  Options
+    <$> switch
+          (short 'v' <> long "verbose" <> help "Whether to enable verbosity")
+    <*> switch (short 'c' <> long "cache" <> help "Whether to cache downloads")
+    <*> com
+
+
+com :: Parser Command
+com = subparser
+  (  command
+      "install-ghc"
+      (   InstallGHC
+      <$> (info (installGHCOpts <**> helper)
+                (progDesc "Install a GHC version")
+          )
+      )
+  <> command
+       "install-cabal"
+       (   InstallCabal
+       <$> (info (installCabalOpts <**> helper)
+                 (progDesc "Install a cabal-install version")
+           )
+       )
+  )
+
+installGHCOpts :: Parser InstallGHCOptions
+installGHCOpts = InstallGHCOptions <$> optional
+  (option
+    (eitherReader
+      (\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
+    )
+    (short 'v' <> long "version" <> metavar "VERSION" <> help
+      "The GHC version to install"
+    )
+  )
+
+
+installCabalOpts :: Parser InstallCabalOptions
+installCabalOpts = InstallCabalOptions <$> optional
+  (option
+    (eitherReader
+      (\s -> bimap (const "Not a valid version") id . version . T.pack $ s)
+    )
+    (short 'v' <> long "version" <> metavar "VERSION" <> help
+      "The Cabal version to install"
+    )
+  )
+
+
+toSettings :: Options -> Settings
+toSettings Options{..} =
+  let cache = optCache
+  in Settings{..}
+
 
 main :: IO ()
 main = do
-  putStrLn "Hello, Haskell!"
+  e <-
-  MyLib.someFunc
+    customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm)
+      >>= \opt@Options {..} -> do
+        let settings = toSettings opt
+        -- wrapper to run effects with settings
+        let run = flip runReaderT settings . runStderrLoggingT . runE
+                @'[ FileError
+                     , ArchiveError
+                     , ProcessError
+                     , URLException
+                     , PlatformResultError
+                     , NoDownload
+                     , NoCompatibleArch
+                     , DistroNotFound
+                     , TagNotFound
+                    ]
+
+        case optCommand of
+            InstallGHC (InstallGHCOptions {..}) ->
+              run
+                $ do
+                    d <- liftIO $ ghcupBaseDir
+                    case ghcVer of
+                      Just ver -> liftE $ installTool (ToolRequest GHC ver)
+                                              Nothing
+                                              (OwnSpec availableDownloads)
+                      Nothing -> do
+                        ver <-
+                          getRecommended availableDownloads GHC
+                            ?? TagNotFound Recommended GHC
+                        liftE $ installTool (ToolRequest GHC ver) Nothing (OwnSpec availableDownloads)
+            InstallCabal (InstallCabalOptions {..}) -> undefined
+
+  pure ()
+
+
+  -- print error, if any
+  -- case e of
+    -- Right () -> pure ()
+    -- Left  t  -> die (color Red $ t)

cabal.project

@@ -14,3 +14,8 @@ 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

ghcup.cabal

@@ -38,10 +38,13 @@ common http-io-streams { build-depends: http-io-streams >= 0.1 }
 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 }
+common monad-logger { build-depends: monad-logger >= 0.3.31 }
 common mtl { build-depends: mtl >= 2.2 }
 common optics { build-depends: optics >= 0.2 }
 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 safe-exceptions { build-depends: safe-exceptions >= 0.1 }
 common streamly { build-depends: streamly >= 0.7 }
 common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
@@ -65,7 +68,7 @@ common zlib { build-depends: zlib >= 0.6.2.1 }
 
 common config
   default-language:     Haskell2010
-  ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates
+  ghc-options:          -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -threaded
   default-extensions:     LambdaCase
                         , MultiWayIf
                         , PackageImports
@@ -96,6 +99,7 @@ library
                      , io-streams
                      , language-bash
                      , lzma
+                     , monad-logger
                      , mtl
                      , optics
                      , optics-vl
@@ -132,6 +136,15 @@ library
 executable ghcup
   import:                config
                        , base
+                       , bytestring
+                       , haskus-utils-variant
+                       , monad-logger
+                       , mtl
+                       , optparse-applicative
+                       , text
+                       , versions
+                       , hpath
+                       , pretty-terminal
   main-is:             Main.hs
   -- other-modules:
   -- other-extensions:

lib/GHCup.hs

@@ -14,7 +14,10 @@ module GHCup where
 import qualified Codec.Archive.Tar             as Tar
 import           Control.Applicative
 import           Control.Monad
+import           Control.Monad.Reader
+import           Control.Monad.Logger
 import           Control.Monad.Trans.Maybe
+import           Control.Monad.Trans.Class      ( lift )
 import           Control.Monad.IO.Class
 import           Control.Exception.Safe
 import           Data.ByteString                ( ByteString )
@@ -83,6 +86,12 @@ import           URI.ByteString.QQ
 
 
 
+data Settings = Settings {
+  cache :: Bool
+} deriving Show
+
+
+
 
     ---------------------------
     --[ Excepts Error types ]--
@@ -107,11 +116,18 @@ data ArchiveError = UnknownArchive ByteString
 data URLException = UnsupportedURL
                   deriving Show
 
+data FileError = CopyError
+               deriving Show
+
+data TagNotFound = TagNotFound Tag Tool
+                 deriving Show
 
 
-    ----------------------
+
-    --[ Download stuff ]--
+
-    ----------------------
+    --------------------------------
+    --[ AvailableDownloads stuff ]--
+    --------------------------------
 
 
 -- TODO: version quasiquoter
@@ -119,24 +135,60 @@ availableDownloads :: AvailableDownloads
 availableDownloads = Map.fromList
   [ ( GHC
     , Map.fromList
-      [ ( (\(Right x) -> x) $ version [s|8.6.5|]
+      [ ( [ver|8.6.5|]
-        , Map.fromList
+        , VersionInfo [Latest] $ Map.fromList
           [ ( A_64
             , Map.fromList
               [ ( Linux UnknownLinux
                 , Map.fromList
                   [ ( Nothing
-                    , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz|]
+                    , 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
+                , Map.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
                 , Map.fromList
                   [ ( Nothing
-                    , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian9-linux.tar.xz|]
+                    , 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 $ (\(Right x) -> x) $ versioning [s|8|]
+                  , ( Just $ [vers|8|]
-                    , [uri|https://downloads.haskell.org/~ghc/8.6.5/ghc-8.6.5-x86_64-debian8-linux.tar.xz|]
+                    , 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
+    , Map.fromList
+      [ ( [ver|3.0.0.0|]
+        , VersionInfo [Latest] $ Map.fromList
+          [ ( A_64
+            , Map.fromList
+              [ ( Linux UnknownLinux
+                , Map.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
                     )
                   ]
                 )
@@ -150,15 +202,40 @@ availableDownloads = Map.fromList
 
 
 
-getDownloadURL :: (MonadCatch m, MonadIO m)
+-- | Get the tool versions that have this tag.
-               => ToolRequest
+getTagged :: AvailableDownloads -> Tool -> Tag -> [Version]
-               -> Maybe PlatformRequest
+getTagged av tool tag = toListOf
-               -> URLSource
+  ( ix tool
-               -> Excepts
+  % to (Map.filter (\VersionInfo {..} -> elem tag _viTags))
-                    '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
+  % to Map.keys
-                    m
+  % folded
-                    URI
+  )
-getDownloadURL (ToolRequest t v) mpfReq urlSource = do
+  av
+
+getLatest :: AvailableDownloads -> Tool -> Maybe Version
+getLatest av tool = headOf folded $ getTagged av tool Latest
+
+getRecommended :: AvailableDownloads -> Tool -> Maybe Version
+getRecommended av tool = headOf folded $ getTagged av tool Recommended
+
+
+
+    ----------------------
+    --[ Download stuff ]--
+    ----------------------
+
+
+getDownloadInfo :: (MonadLogger m, MonadCatch m, MonadIO m)
+                => ToolRequest
+                -> Maybe PlatformRequest
+                -> URLSource
+                -> Excepts
+                     '[PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
+                     m
+                     DownloadInfo
+getDownloadInfo (ToolRequest t v) mpfReq urlSource = do
+  lift $ $(logDebug) ([s|Receiving download info from: |] <> showT urlSource)
+  -- lift $ monadLoggerLog undefined undefined undefined ""
   (PlatformRequest arch plat ver) <- case mpfReq of
     Just x  -> pure x
     Nothing -> do
@@ -171,21 +248,21 @@ getDownloadURL (ToolRequest t v) mpfReq urlSource = do
     OwnSource url -> fail "Not implemented"
     OwnSpec   dls -> pure dls
 
-  lE $ getDownloadURL' t v arch plat ver dls
+  lE $ getDownloadInfo' t v arch plat ver dls
 
 
-getDownloadURL' :: Tool
+getDownloadInfo' :: Tool
-                -> Version
+                 -> Version
-             -- ^ tool version
+                -- ^ tool version
-                -> Architecture
+                 -> Architecture
-             -- ^ user arch
+                -- ^ user arch
-                -> Platform
+                 -> Platform
-             -- ^ user platform
+                -- ^ user platform
-                -> Maybe Versioning
+                 -> Maybe Versioning
-             -- ^ optional version of the platform
+                -- ^ optional version of the platform
-                -> AvailableDownloads
+                 -> AvailableDownloads
-                -> Either NoDownload URI
+                 -> Either NoDownload DownloadInfo
-getDownloadURL' t v a p mv dls = maybe
+getDownloadInfo' t v a p mv dls = maybe
   (Left NoDownload)
   Right
   (with_distro <|> without_distro_ver <|> without_distro)
@@ -196,8 +273,7 @@ getDownloadURL' t v a p mv dls = maybe
   without_distro     = distro_preview (set _Linux UnknownLinux) (const Nothing)
 
   distro_preview f g =
-    preview (atJust t % atJust v % atJust a % atJust (f p) % atJust (g mv)) dls
+    preview (ix t % ix v % viArch % ix a % ix (f p) % ix (g mv)) dls
-  atJust x = at x % _Just
 
 
 -- | Tries to download from the given http or https url
@@ -221,25 +297,27 @@ download https host path port dest mfn = do
 -- throw an exception if the url type or host protocol is not supported.
 --
 -- Only Absolute HTTP/HTTPS is supported.
-download' :: MonadIO m
+download' :: (MonadLogger m, MonadIO m)
-          => URI
+          => DownloadInfo
           -> Path Abs          -- ^ destination dir
           -> Maybe (Path Rel)  -- ^ optional filename
           -> Excepts '[URLException] m (Path Abs)
-download' url dest mfn
+download' dli dest mfn
-  | view (uriSchemeL' % schemeBSL') url == [s|https|] = dl True
+  | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|https|] = dl True
-  | view (uriSchemeL' % schemeBSL') url == [s|http|] = dl False
+  | view (dlUri % uriSchemeL' % schemeBSL') dli == [s|http|] = dl False
   | otherwise = throwE UnsupportedURL
 
  where
   dl https = do
+    lift $ $(logInfo)
+      ([s|downloading: |] <> E.decodeUtf8 (serializeURIRef' (view dlUri dli)))
     host <-
-      preview (authorityL' % _Just % authorityHostL' % hostBSL') url
+      preview (dlUri % authorityL' % _Just % authorityHostL' % hostBSL') dli
         ?? UnsupportedURL
-    let path = view pathL' url
+    let path = view (dlUri % pathL') dli
     let port = preview
-          (authorityL' % _Just % authorityPortL' % _Just % portNumberL')
+          (dlUri % authorityL' % _Just % authorityPortL' % _Just % portNumberL')
-          url
+          dli
     liftIO $ download https host path port dest mfn
 
 -- | Same as 'download', except with a file descriptor. Allows to e.g.
@@ -308,8 +386,7 @@ downloadInternal https host path port dest = do
         in  fmap (, fp) $ createRegularFileFd newFilePerms fp
       Nothing -> do
         -- ...otherwise try to infer the filename from the URL path
-        let urlBaseName = snd . B.breakEnd (== _slash) $ urlDecode False path
+        fn' <- urlBaseName path
-        fn' <- parseRel urlBaseName
         let fp = dest </> fn'
         fmap (, fp) $ createRegularFileFd newFilePerms fp
 
@@ -328,22 +405,25 @@ getArchitecture = case arch of
 
 
 
-getPlatform :: (MonadCatch m, MonadIO m)
+getPlatform :: (MonadLogger m, MonadCatch m, MonadIO m)
             => Excepts
                  '[PlatformResultError, DistroNotFound]
                  m
                  PlatformResult
-getPlatform = case os of
+getPlatform = do
-  "linux" -> do
+  pfr <- case os of
-    (distro, ver) <- liftE getLinuxDistro
+    "linux" -> do
-    pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
+      (distro, ver) <- liftE getLinuxDistro
-  -- TODO: these are not verified
+      pure $ PlatformResult { _platform = Linux distro, _distroVersion = ver }
-  "darwin" ->
+    -- TODO: these are not verified
-    pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
+    "darwin" ->
-  "freebsd" -> do
+      pure $ PlatformResult { _platform = Darwin, _distroVersion = Nothing }
-    ver <- getFreeBSDVersion
+    "freebsd" -> do
-    pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
+      ver <- getFreeBSDVersion
-  what -> throwE NoCompatiblePlatform
+      pure $ PlatformResult { _platform = FreeBSD, _distroVersion = ver }
+    what -> throwE NoCompatiblePlatform
+  lift $ $(logDebug) ([s|Identified Platform as: |] <> showT pfr)
+  pure pfr
   where getFreeBSDVersion = pure Nothing
 
 
@@ -374,7 +454,7 @@ getLinuxDistro = do
   hasWord t matches = foldr
     (\x y ->
       ( isJust
-        . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> x <> [s|\\b|]))
+        . ICU.find (ICU.regex [ICU.CaseInsensitive] ([s|\b|] <> x <> [s|\b|]))
         $ t
         )
         || y
@@ -421,14 +501,13 @@ getLinuxDistro = do
           join
             . fmap (ICU.group 0)
             . ICU.find
-                (ICU.regex [ICU.CaseInsensitive] ([s|\\b|] <> fS n <> [s|\\b|])
+                (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|])
+                (ICU.regex [ICU.CaseInsensitive] [s|\b(\d)+(.(\d)+)*\b|])
             $ t
     (Just name) <- pure
       (nameRe "CentOS" <|> nameRe "Fedora" <|> nameRe "Red Hat")
@@ -440,58 +519,142 @@ getLinuxDistro = do
     pure (T.pack "debian", Just $ lBS2sT ver)
 
 
+-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
+-- parseAvailableDownloads = undefined
 
-    ------------------------
+-- TODO: subdir to configure script in availableDownloads?
-    --[ GHC installation ]--
-    ------------------------
 
 
--- TODO: quasiquote for ascii bytestrings
+    -------------------------
+    --[ Tool installation ]--
+    -------------------------
 
 
--- | Unpack an archive to a temporary directory and return that path.
+installTool :: ( MonadThrow m
-unpackToTmpDir :: Path Abs       -- ^ archive path
+               , MonadReader Settings m
-               -> IO (Either ArchiveError (Path Abs))
+               , MonadLogger m
-unpackToTmpDir av = do
+               , MonadCatch m
-  fn <- basename av
+               , MonadIO m
-  let (fnrest, ext) = splitExtension $ toFilePath fn
+               )
-  let ext2          = takeExtension fnrest
+            => ToolRequest
-  tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|]
+            -> Maybe PlatformRequest
-  tmp    <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
+            -> URLSource
-  let untar bs = do
+            -> Excepts
-        Tar.unpack tmp . Tar.read $ bs
+                 '[FileError, ArchiveError, ProcessError, URLException, PlatformResultError, NoDownload, NoCompatibleArch, DistroNotFound]
-        Right <$> parseAbs tmp
+                 m
+                 ()
+installTool treq mpfReq urlSource = do
+  Settings {..} <- lift ask
+  lift $ $(logDebug) ([s|Requested to install: |] <> showT treq)
+  dlinfo <- liftE $ getDownloadInfo treq mpfReq urlSource
+  dl     <- case cache of
+    True -> do
+      cachedir <- liftIO $ ghcupCacheDir
+      fn       <- urlBaseName $ view (dlUri % pathL') dlinfo
+      let cachfile = cachedir </> fn
+      fileExists <- liftIO $ doesFileExist cachfile
+      if
+        | fileExists -> pure $ cachfile
+        | otherwise  -> liftE $ download' dlinfo cachedir Nothing
+    False -> do
+      tmp <- liftIO mkGhcupTmpDir
+      liftE $ download' dlinfo tmp Nothing
+  unpacked <- liftE $ unpackToTmpDir dl
+  ghcdir   <- liftIO $ do
+    toolsubdir <- ghcupGHCDir
+    versubdir  <- parseRel (E.encodeUtf8 . prettyVer . view toolVersion $ treq)
+    pure (toolsubdir </> versubdir)
+  bindir <- liftIO ghcupBinDir
 
-  -- extract, depending on file extension
+  -- the subdir of the archive where we do the work
-  if
+  let archiveSubdir = maybe unpacked (unpacked </>) (view dlSubdir dlinfo)
-    | ext == [s|.gz|] && ext2 == [s|.tar|]
-    -> untar . GZip.decompress =<< readFile av
-    | ext == [s|.xz|] && ext2 == [s|.tar|]
-    -> do
-      filecontents <- readFile av
-      let decompressed = Lzma.decompress filecontents
-      -- putStrLn $ show decompressed
-      untar decompressed
-    | ext == [s|.bz2|] && ext2 == [s|.tar|]
-    -> untar . BZip.decompress =<< readFile av
-    | ext == [s|.tar|]
-    -> untar =<< readFile av
-    | otherwise
-    -> pure $ Left $ UnknownArchive ext
 
- where
+  case treq of
-  isTar ext | ext == [s|.tar|] = pure ()
+    (ToolRequest GHC   ver) -> liftE $ installGHC archiveSubdir ghcdir
-            | otherwise       = throwE $ UnknownArchive ext
+    (ToolRequest Cabal ver) -> liftE $ installCabal archiveSubdir bindir
+  pure ()
 
 
 -- | Install an unpacked GHC distribution.
-installGHC :: Path Abs      -- ^ Path to the unpacked GHC bindist
+installGHC :: (MonadLogger m, MonadIO m)
+           => Path Abs      -- ^ Path to the unpacked GHC bindist
            -> Path Abs      -- ^ Path to install to
-           -> IO ()
+           -> Excepts '[ProcessError] m ()
 installGHC path inst = do
-  exec [s|./configure|] [[s|--prefix=|] <> toFilePath inst] False (Just path)
+  lift $ $(logInfo) ([s|Installing GHC|])
-  exec [s|make|]        [[s|install|]]                      True  (Just path)
+  lEM $ liftIO $ exec [s|./configure|]
+                      [[s|--prefix=|] <> toFilePath inst]
+                      False
+                      (Just path)
+  lEM $ liftIO $ exec [s|make|] [[s|install|]] True (Just path)
   pure ()
 
--- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
+
--- parseAvailableDownloads = undefined
+-- | Install an unpacked cabal distribution.
+installCabal :: (MonadLogger m, MonadCatch m, MonadIO m)
+             => Path Abs      -- ^ Path to the unpacked cabal bindist
+             -> Path Abs      -- ^ Path to install to
+             -> Excepts '[FileError] m ()
+installCabal path inst = do
+  lift $ $(logInfo) ([s|Installing cabal|])
+  let cabalFile = [rel|cabal|] :: Path Rel
+  handleIO (\_ -> throwE CopyError) $ liftIO $ copyFile (path </> cabalFile)
+                                                        (inst </> cabalFile)
+                                                        Overwrite
+
+
+
+    -----------------
+    --[ Utilities ]--
+    -----------------
+
+
+ghcupBaseDir :: IO (Path Abs)
+ghcupBaseDir = do
+  home <- liftIO getHomeDirectory
+  pure (home </> ([rel|.ghcup|] :: Path Rel))
+
+ghcupGHCDir :: IO (Path Abs)
+ghcupGHCDir = ghcupBaseDir <&> (</> ([rel|ghc|] :: Path Rel))
+
+ghcupBinDir :: IO (Path Abs)
+ghcupBinDir = ghcupBaseDir <&> (</> ([rel|bin|] :: Path Rel))
+
+ghcupCacheDir :: IO (Path Abs)
+ghcupCacheDir = ghcupBaseDir <&> (</> ([rel|cache|] :: Path Rel))
+
+
+urlBaseName :: MonadThrow m
+            => ByteString  -- ^ the url path (without scheme and host)
+            -> m (Path Rel)
+urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
+
+
+
+-- | Unpack an archive to a temporary directory and return that path.
+unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m)
+               => Path Abs       -- ^ archive path
+               -> Excepts '[ArchiveError] m (Path Abs)
+unpackToTmpDir av = do
+  lift $ $(logInfo) ([s|Unpacking: |] <> E.decodeUtf8 (toFilePath av))
+  fn <- basename av
+  let (fnrest, ext) = splitExtension $ toFilePath fn
+  let ext2          = takeExtension fnrest
+  tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
+  tmp    <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
+  let untar bs = do
+        Tar.unpack tmp . Tar.read $ bs
+        parseAbs tmp
+
+  -- extract, depending on file extension
+  if
+    | ext == [s|.gz|], ext2 == [s|.tar|] -> liftIO
+      (untar . GZip.decompress =<< readFile av)
+    | ext == [s|.xz|], ext2 == [s|.tar|] -> do
+      filecontents <- liftIO $ readFile av
+      let decompressed = Lzma.decompress filecontents
+      liftIO $ untar decompressed
+    | ext == [s|.bz2|], ext2 == [s|.tar|] -> liftIO
+      (untar . BZip.decompress =<< readFile av)
+    | ext == [s|.tar|] -> liftIO (untar =<< readFile av)
+    | otherwise -> throwE $ UnknownArchive ext

lib/GHCup/File.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE QuasiQuotes     #-}
 {-# LANGUAGE TemplateHaskell #-}
 
 module GHCup.File where
@@ -6,6 +7,7 @@ import           Data.ByteString
 import qualified Data.ByteString.Lazy          as L
 import           Data.Char
 import           Data.Maybe
+import           Data.String.QQ
 import           HPath
 import           HPath.IO
 import           Optics
@@ -19,14 +21,18 @@ import           Control.Exception.Safe
 import           Data.Functor
 import           System.Posix.Files.ByteString
 import           System.Posix.Foreign           ( oExcl )
+import           System.Posix.Env.ByteString
 import           System.IO
+import qualified System.Posix.FilePath         as FP
 import "unix"    System.Posix.IO.ByteString
                                          hiding ( openFd )
 import qualified System.Posix.Process.ByteString
                                                as SPPB
 import           System.Posix.Directory.ByteString
 import           System.Posix.Process           ( ProcessStatus(..) )
+import           System.Posix.Temp.ByteString
 import           System.Posix.Types
+import qualified System.Posix.User             as PU
 
 import qualified Streamly.Internal.Memory.ArrayStream
                                                as AS
@@ -41,12 +47,17 @@ import           GHCup.Prelude
 import           Control.Concurrent.Async
 import           Control.Concurrent
 import           System.Posix.FD               as FD
+import qualified Data.ByteString.UTF8          as UTF8
+import           Data.ByteString.Unsafe         ( unsafeUseAsCStringLen )
+import           GHC.IO.Encoding                ( getLocaleEncoding )
+import           GHC.Foreign                    ( peekCStringLen )
 
 
-data ProcessError = NonZeroExit Int
+
-                  | PTerminated
+data ProcessError = NonZeroExit Int ByteString [ByteString]
-                  | PStopped
+                  | PTerminated ByteString [ByteString]
-                  | NoSuchPid
+                  | PStopped ByteString [ByteString]
+                  | NoSuchPid ByteString [ByteString]
                   deriving Show
 
 
@@ -169,13 +180,41 @@ exec exe args spath chdir = do
     maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
     SPPB.executeFile exe spath args Nothing
 
-  fmap toProcessError $ SPPB.getProcessStatus True True pid
+  fmap (toProcessError exe args) $ SPPB.getProcessStatus True True pid
 
 
-toProcessError :: Maybe ProcessStatus -> Either ProcessError ()
+toProcessError :: ByteString
-toProcessError mps = case mps of
+               -> [ByteString]
-  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i
+               -> Maybe ProcessStatus
+               -> Either ProcessError ()
+toProcessError exe args mps = case mps of
+  Just (SPPB.Exited (ExitFailure i)) -> Left $ NonZeroExit i exe args
   Just (SPPB.Exited ExitSuccess    ) -> Right ()
-  Just (Terminated _ _             ) -> Left $ PTerminated
+  Just (Terminated _ _             ) -> Left $ PTerminated exe args
-  Just (Stopped _                  ) -> Left $ PStopped
+  Just (Stopped _                  ) -> Left $ PStopped exe args
-  Nothing                            -> Left $ NoSuchPid
+  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
+  enc <- getLocaleEncoding
+  unsafeUseAsCStringLen p (peekCStringLen enc)

lib/GHCup/Prelude.hs

@@ -3,6 +3,9 @@
 {-# LANGUAGE TemplateHaskell #-}
 {-# LANGUAGE DataKinds #-}
 {-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE DeriveLift #-}
+{-# LANGUAGE StandaloneDeriving #-}
+{-# LANGUAGE FlexibleInstances #-}
 
 module GHCup.Prelude where
 
@@ -10,15 +13,23 @@ import           Control.Applicative
 import           Control.Monad
 import           Control.Monad.Trans.Class      ( lift )
 import           Control.Exception.Safe
+import           Data.ByteString (ByteString)
 import qualified Data.Strict.Maybe             as S
 import           Data.Monoid                    ( (<>) )
 import           Data.String
 import qualified Data.Text.Lazy.Encoding       as TLE
 import qualified Data.Text.Lazy                as TL
 import           Data.Text                      ( Text )
+import qualified Data.Text as T
+import           Data.Versions
 import qualified Data.ByteString.Lazy          as L
 import           Haskus.Utils.Variant.Excepts
 import           System.IO.Error
+import           Language.Haskell.TH
+import           Language.Haskell.TH.Syntax (Exp(..), Lift)
+import qualified Language.Haskell.TH.Syntax as TH
+import           Language.Haskell.TH.Quote (QuasiQuoter(..))
+import GHC.Base
 
 
 
@@ -44,6 +55,9 @@ iE :: String -> IO a
 iE = internalError
 
 
+showT :: Show a => a -> Text
+showT = fS . show
+
 -- | Like 'when', but where the test can be monadic.
 whenM :: Monad m => m Bool -> m () -> m ()
 whenM ~b ~t = ifM b t (return ())
@@ -99,3 +113,58 @@ lEM em = lift em >>= lE
 
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
+
+
+
+deriving instance Lift Versioning
+deriving instance Lift Version
+deriving instance Lift SemVer
+deriving instance Lift Mess
+deriving instance Lift PVP
+deriving instance Lift (NonEmpty Word)
+deriving instance Lift VSep
+deriving instance Lift VUnit
+instance Lift Text
+
+qq :: (Text -> Q Exp) -> QuasiQuoter
+qq quoteExp' =
+  QuasiQuoter
+  { quoteExp  = (\s -> quoteExp' . T.pack $ s)
+  , quotePat  = \_ ->
+      fail "illegal QuasiQuote (allowed as expression only, used as a pattern)"
+  , quoteType = \_ ->
+      fail "illegal QuasiQuote (allowed as expression only, used as a type)"
+  , quoteDec  = \_ ->
+      fail "illegal QuasiQuote (allowed as expression only, used as a declaration)"
+  }
+
+ver :: QuasiQuoter
+ver = qq mkV
+  where
+    mkV :: Text -> Q Exp
+    mkV = either (fail . show) TH.lift . version
+
+mver :: QuasiQuoter
+mver = qq mkV
+  where
+    mkV :: Text -> Q Exp
+    mkV = either (fail . show) TH.lift . mess
+
+sver :: QuasiQuoter
+sver = qq mkV
+  where
+    mkV :: Text -> Q Exp
+    mkV = either (fail . show) TH.lift . semver
+
+vers :: QuasiQuoter
+vers = qq mkV
+  where
+    mkV :: Text -> Q Exp
+    mkV = either (fail . show) TH.lift . versioning
+
+pver :: QuasiQuoter
+pver = qq mkV
+  where
+    mkV :: Text -> Q Exp
+    mkV = either (fail . show) TH.lift . pvp
+

lib/GHCup/Types.hs

@@ -2,15 +2,29 @@
 
 module GHCup.Types where
 
+import           HPath
 import           Data.Map.Strict                ( Map )
 import qualified GHC.Generics                  as GHC
 import           Data.Versions
 import           URI.ByteString
 
 
+data Tag = Latest
+         | Recommended
+         deriving (Eq, Show)
+
+data VersionInfo = VersionInfo {
+    _viTags :: [Tag]
+  , _viArch :: ArchitectureSpec
+} deriving (Eq, Show)
+
+data DownloadInfo = DownloadInfo {
+    _dlUri    :: URI
+  , _dlSubdir :: Maybe (Path Rel)
+} deriving (Eq, Show)
+
 data Tool = GHC
           | Cabal
-          | Stack
   deriving (Eq, GHC.Generic, Ord, Show)
 
 data ToolRequest = ToolRequest {
@@ -55,13 +69,14 @@ data PlatformRequest = PlatformRequest {
   , _rVersion :: Maybe Versioning
 } deriving (Eq, Show)
 
-type PlatformVersionSpec = Map (Maybe Versioning) URI
+type PlatformVersionSpec = Map (Maybe Versioning) DownloadInfo
 type PlatformSpec = Map Platform PlatformVersionSpec
 type ArchitectureSpec = Map Architecture PlatformSpec
-type ToolVersionSpec = Map Version ArchitectureSpec
+type ToolVersionSpec = Map Version VersionInfo
 type AvailableDownloads = Map Tool ToolVersionSpec
 
 
 data URLSource = GHCupURL
                | OwnSource URI
                | OwnSpec AvailableDownloads
+               deriving Show

lib/GHCup/Types/Optics.hs

@@ -11,9 +11,13 @@ makePrisms ''Tool
 makePrisms ''Architecture
 makePrisms ''LinuxDistro
 makePrisms ''Platform
+makePrisms ''Tag
 
 makeLenses ''PlatformResult
 makeLenses ''ToolRequest
+makeLenses ''DownloadInfo
+makeLenses ''Tag
+makeLenses ''VersionInfo
 
 
 uriSchemeL' :: Lens' (URIRef Absolute) Scheme