hasufell/ghcup-hs
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

Yooo

Browse Source
This commit is contained in:
Julian Ospald 2020-03-01 02:21:40 +01:00
parent 998f194d23
commit 12da293100
5 changed files with 34 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
TODO.md
View File

@ -2,15 +2,15 @@
## New ## New
* download progress * proper subcommands: ghcup install ghc
* download progress
* upgrade Upgrade this script in-place * upgrade Upgrade this script in-place
* maybe: changelog Show the changelog of a GHC release (online) * maybe: changelog Show the changelog of a GHC release (online)
* maybe: print-system-reqs Print an approximation of system requirements * maybe: print-system-reqs Print an approximation of system requirements
* testing (especially distro detection -> unit tests) * testing (especially distro detection -> unit tests)
* TODO: cleanup temp files after use
## Old ## Old

2
app/ghcup/Main.hs
View File

@ -16,6 +16,7 @@ import GHCup.Types
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bifunctor import Data.Bifunctor
import Data.Char import Data.Char
import Data.List ( intercalate ) import Data.List ( intercalate )
@ -252,6 +253,7 @@ main = do
let runInstTool = let runInstTool =
runLogger runLogger
. flip runReaderT settings . flip runReaderT settings
. runResourceT
. runE . runE
@'[ AlreadyInstalled @'[ AlreadyInstalled
, ArchiveError , ArchiveError

13
ghcup.cabal
View File

@ -23,16 +23,16 @@ source-repository head
common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 } common HsOpenSSL { build-depends: HsOpenSSL >= 0.11 }
common aeson { build-depends: aeson >= 1.4 } common aeson { build-depends: aeson >= 1.4 }
common aeson-pretty { build-depends: aeson-pretty >= 0.8.8 } 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 ascii-string { build-depends: ascii-string >= 1.0 }
common async { build-depends: async >= 0.8 } common async { build-depends: async >= 0.8 }
common attoparsec { build-depends: attoparsec >= 0.13 }
common base { build-depends: base >= 4.12 && < 5 } common base { build-depends: base >= 4.12 && < 5 }
common bytestring { build-depends: bytestring >= 0.10 } common bytestring { build-depends: bytestring >= 0.10 }
common bzlib { build-depends: bzlib >= 0.5.0.5 } common bzlib { build-depends: bzlib >= 0.5.0.5 }
common containers { build-depends: containers >= 0.6 } common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 } 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-types { build-depends: haskus-utils-types >= 1.5 }
common haskus-utils-variant { build-depends: haskus-utils-variant >= 3.0 }
common hpath { build-depends: hpath >= 0.11 } common hpath { build-depends: hpath >= 0.11 }
common hpath-directory { build-depends: hpath-directory >= 0.13.2 } common hpath-directory { build-depends: hpath-directory >= 0.13.2 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 } common hpath-filepath { build-depends: hpath-filepath >= 0.10.3 }
@ -49,13 +49,14 @@ common optics-vl { build-depends: optics-vl >= 0.2 }
common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 } common optparse-applicative { build-depends: optparse-applicative >= 0.15.1.0 }
common parsec { build-depends: parsec >= 3.1 } common parsec { build-depends: parsec >= 3.1 }
common pretty-terminal { build-depends: pretty-terminal >= 0.1.0.0 } 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 { build-depends: safe >= 0.3.18 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 } common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 } common streamly { build-depends: streamly >= 0.7 }
common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 }
common strict-base { build-depends: strict-base >= 0.4 } 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 string-interpolate { build-depends: string-interpolate >= 0.2.0.0 }
common string-qq { build-depends: string-qq >= 0.0.4 }
common table-layout { build-depends: table-layout >= 0.8 } 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.2.0 }
common template-haskell { build-depends: template-haskell >= 2.7 } common template-haskell { build-depends: template-haskell >= 2.7 }
@ -98,8 +99,8 @@ library
, bzlib , bzlib
, containers , containers
, generics-sop , generics-sop
, haskus-utils-variant
, haskus-utils-types , haskus-utils-types
, haskus-utils-variant
, hpath , hpath
, hpath-directory , hpath-directory
, hpath-filepath , hpath-filepath
@ -115,13 +116,14 @@ library
, optics-vl , optics-vl
, parsec , parsec
, pretty-terminal , pretty-terminal
, resourcet
, safe , safe
, safe-exceptions , safe-exceptions
, streamly , streamly
, streamly-bytestring , streamly-bytestring
, strict-base , strict-base
, string-qq
, string-interpolate , string-interpolate
, string-qq
, tar-bytestring , tar-bytestring
, template-haskell , template-haskell
, text , text
@ -161,6 +163,7 @@ executable ghcup
, versions , versions
, hpath , hpath
, pretty-terminal , pretty-terminal
, resourcet
, string-qq , string-qq
, string-interpolate , string-interpolate
, table-layout , table-layout

22
lib/GHCup.hs
View File

@ -26,6 +26,8 @@ import Control.Monad.Fail ( MonadFail )
import Control.Monad.Logger import Control.Monad.Logger
import Control.Monad.Reader import Control.Monad.Reader
import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Class ( lift )
import Control.Monad.Trans.Resource
hiding ( throwM )
import Data.Aeson import Data.Aeson
import Data.Attoparsec.ByteString import Data.Attoparsec.ByteString
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
@ -51,9 +53,7 @@ import Prelude hiding ( abs
import Safe import Safe
import System.IO.Error import System.IO.Error
import System.Info import System.Info
import System.Posix.Env.ByteString ( getEnvDefault import System.Posix.Env.ByteString ( getEnv )
, getEnv
)
import System.Posix.FilePath ( takeFileName ) import System.Posix.FilePath ( takeFileName )
import System.Posix.Files.ByteString ( readSymbolicLink ) import System.Posix.Files.ByteString ( readSymbolicLink )
import "unix" System.Posix.IO.ByteString import "unix" System.Posix.IO.ByteString
@ -62,7 +62,6 @@ import "unix-bytestring" System.Posix.IO.ByteString
( fdWrite ) ( fdWrite )
import System.Posix.RawFilePath.Directory.Errors import System.Posix.RawFilePath.Directory.Errors
( hideError ) ( hideError )
import System.Posix.Temp.ByteString
import System.Posix.Types import System.Posix.Types
import URI.ByteString import URI.ByteString
import URI.ByteString.QQ import URI.ByteString.QQ
@ -553,7 +552,8 @@ installTool :: ( MonadThrow m
, MonadCatch m , MonadCatch m
, MonadIO m , MonadIO m
, MonadFail m , MonadFail m
) , MonadResource m
) -- tmp file
=> ToolRequest => ToolRequest
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform -> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> Excepts -> Excepts
@ -591,7 +591,7 @@ installTool treq mpfReq = do
| fileExists -> pure $ cachfile | fileExists -> pure $ cachfile
| otherwise -> liftE $ download dlinfo cachedir Nothing | otherwise -> liftE $ download dlinfo cachedir Nothing
False -> do False -> do
tmp <- liftIO mkGhcupTmpDir tmp <- lift withGHCupTmpDir
liftE $ download dlinfo tmp Nothing liftE $ download dlinfo tmp Nothing
-- unpack -- unpack
@ -821,7 +821,7 @@ rmGHCVer ver = do
lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|] lift $ $(logInfo) [i|Removing ghc-x.y.z symlinks|]
liftIO $ rmMinorSymlinks liftIO $ rmMinorSymlinks
lift $ $(logInfo) [i|Removing ghc-x.y symlinks|] lift $ $(logInfo) [i|Removing/rewiring ghc-x.y symlinks|]
liftE fixMajorSymlinks liftE fixMajorSymlinks
when isSetGHC $ liftE $ do when isSetGHC $ liftE $ do
@ -1011,15 +1011,15 @@ urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False
-- | Unpack an archive to a temporary directory and return that path. -- | Unpack an archive to a temporary directory and return that path.
unpackToTmpDir :: (MonadLogger m, MonadIO m, MonadThrow m) unpackToTmpDir :: (MonadResource m -- temp file
, MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ archive path => Path Abs -- ^ archive path
-> Excepts '[ArchiveError] m (Path Abs) -> Excepts '[ArchiveError] m (Path Abs)
unpackToTmpDir av = do unpackToTmpDir av = do
let fp = E.decodeUtf8 (toFilePath av) let fp = E.decodeUtf8 (toFilePath av)
lift $ $(logInfo) [i|Unpacking: #{fp}|] lift $ $(logInfo) [i|Unpacking: #{fp}|]
fn <- toFilePath <$> basename av fn <- toFilePath <$> basename av
tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] tmp <- toFilePath <$> lift withGHCupTmpDir
tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
let untar bs = do let untar bs = do
Tar.unpack tmp . Tar.read $ bs Tar.unpack tmp . Tar.read $ bs
parseAbs tmp parseAbs tmp

14
lib/GHCup/File.hs
View File

@ -5,6 +5,8 @@ module GHCup.File where
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Resource
import Data.ByteString import Data.ByteString
import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) import Data.ByteString.Unsafe ( unsafeUseAsCStringLen )
import Data.Char import Data.Char
@ -186,13 +188,19 @@ toProcessError exe args mps = case mps of
Nothing -> Left $ NoSuchPid exe args Nothing -> Left $ NoSuchPid exe args
mkGhcupTmpDir :: IO (Path Abs) mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs)
mkGhcupTmpDir = do mkGhcupTmpDir = do
tmpdir <- getEnvDefault [s|TMPDIR|] [s|/tmp|] tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|]
tmp <- mkdtemp $ (tmpdir FP.</> [s|ghcup-|]) tmp <- liftIO $ mkdtemp $ (tmpdir FP.</> [s|ghcup-|])
liftIO $ System.IO.putStrLn $ show tmp
parseAbs tmp parseAbs tmp
withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m)
=> m (Path Abs)
withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive
getHomeDirectory :: IO (Path Abs) getHomeDirectory :: IO (Path Abs)
getHomeDirectory = do getHomeDirectory = do
e <- getEnv [s|HOME|] e <- getEnv [s|HOME|]