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

First take

Browse Source
This commit is contained in:
Julian Ospald 2020-01-14 22:55:34 +01:00
parent e414ca4b0c
commit 3fb5c612c1
No known key found for this signature in database
GPG Key ID: 511B62C09D50CD28
11 changed files with 692 additions and 16 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
ghcup.cabal
View File

@ -1,35 +1,97 @@
cabal-version: 2.0
-- Initial package description 'ghcup.cabal' generated by 'cabal init'.
-- For further documentation, see http://haskell.org/cabal/users-guide/
cabal-version: 2.2
name: ghcup
version: 0.1.0.0
synopsis: ghc toolchain installer as an exe/library
-- description:
description: A rewrite of the shell script ghcup, for providing
a more stable user experience and exposing an API.
homepage: https://github.com/hasufell/ghcup-hs
-- bug-reports:
license: LGPL-3
bug-reports: https://github.com/hasufell/ghcup-hs/issues
license: LGPL-3.0-only
license-file: LICENSE
author: Julian Ospald
maintainer: hasufell@posteo.de
-- copyright:
copyright: Julian Ospald 2020
category: System
build-type: Simple
extra-source-files: CHANGELOG.md
library
exposed-modules: MyLib
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.12.0.0
hs-source-dirs: lib
source-repository head
type: git
location: https://github.com/hasufell/ghcup-hs
common ascii-string { build-depends: ascii-string >= 1.0 }
common base { build-depends: base >= 4.12.0.0 && < 5 }
common bytestring { build-depends: bytestring >= 0.10 }
common containers { build-depends: containers >= 0.6 }
common generics-sop { build-depends: generics-sop >= 0.5 }
common hpath { build-depends: hpath >= 0.10.1 }
common hpath-filepath { build-depends: hpath-filepath >= 0.10 }
common hpath-io { build-depends: hpath-io >= 0.10.1 }
common language-bash { build-depends: language-bash >= 0.9 }
common optics { build-depends: optics >= 0.2 }
common parsec { build-depends: parsec >= 3.1 }
common safe-exceptions { build-depends: safe-exceptions >= 0.1 }
common streamly { build-depends: streamly >= 0.7 }
common strict-base { build-depends: strict-base >= 0.4 }
common template-haskell { build-depends: template-haskell >= 2.7 }
common text { build-depends: text >= 1.2 }
common transformers { build-depends: transformers >= 0.5 }
common unix { build-depends: unix >= 2.7 }
common url { build-depends: url >= 2.1 }
common utf8-string { build-depends: utf8-string >= 1.0 }
common vector { build-depends: vector >= 0.12 }
common waargonaut { build-depends: waargonaut >= 0.8 }
common config
default-language: Haskell2010
ghc-options: -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns -fwarn-incomplete-record-updates -O2 -fspec-constr-recursive=16 -fmax-worker-args=16
default-extensions: LambdaCase, MultiWayIf, ScopedTypeVariables, StrictData, Strict, TupleSections
library
import: config
, base
-- deps
, ascii-string
, bytestring
, containers
, generics-sop
, hpath
, hpath-filepath
, hpath-io
, language-bash
, optics
, parsec
, safe-exceptions
, streamly
, strict-base
, template-haskell
, text
, transformers
, unix
, url
, utf8-string
, vector
, waargonaut
exposed-modules: GHCup
GHCup.Bash
GHCup.File
GHCup.Prelude
GHCup.Types
GHCup.Types.JSON
GHCup.Types.Optics
other-modules: Streamly.ByteString
-- other-extensions:
hs-source-dirs: lib
executable ghcup
import: config
, base
main-is: Main.hs
-- other-modules:
-- other-extensions:
build-depends: base ^>=4.12.0.0, ghcup
build-depends: ghcup
hs-source-dirs: app
default-language: Haskell2010

169
lib/GHCup.hs Normal file
View File

@ -0,0 +1,169 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
-- TODO: handle SIGTERM, SIGUSR
module GHCup where
import Control.Applicative
import Data.Strict.Maybe
import Data.Version
import GHCup.Prelude
import GHCup.Bash
import GHCup.File
import GHCup.Types
import GHCup.Types.Optics
import HPath
import HPath.IO
import Network.URL
import qualified Data.ByteString.Lazy.UTF8 as UTF8
import Optics
import Prelude hiding ( abs
, Maybe
, Just
, Nothing
)
import System.Info
import qualified Data.Map.Strict as Map
import qualified GHC.Exts as GE
import qualified Prelude as P
import qualified System.Posix.Process.ByteString
as SPPB
availableDownloads :: AvailableDownloads
availableDownloads = Map.fromList
[ ( GHC
, Map.fromList
[ ( mkV [8, 6, 5]
, Map.fromList
[ ( A_64
, Map.fromList
[ ( Linux UnknownLinux
, mkGHCUrl "~ghc/8.6.5/ghc-8.6.5-x86_64-fedora27-linux.tar.xz"
)
]
)
]
)
]
)
]
where
mkV = makeVersion
mkGHCUrl path = URL
{ url_type = Absolute $ Host (HTTP True) "downloads.haskell.org" P.Nothing
, url_path = path
, url_params = []
}
downloadURL :: Tool
-> Version
-> Architecture
-> Platform
-> AvailableDownloads
-> Maybe URL
downloadURL t v a p dls = with_distro <|> without_ver <|> without_distro
where
with_distro = distro_preview id
without_distro = distro_preview withoutDistro
without_ver = distro_preview withoutVer
distro_preview f =
toStrictMaybe $ preview (atJust t % atJust v % atJust a % atJust (f p)) dls
atJust x = at x % _Just
-- | If we can't find a version with the given distro,
-- then just try with the platform.
withoutDistro :: Platform -> Platform
withoutDistro (Linux _) = Linux UnknownLinux
withoutDistro Darwin = Darwin
withoutDistro (FreeBSD _) = FreeBSD Nothing
-- | If we can't find a match with the given distro version,
-- we gotta try without it.
withoutVer :: Platform -> Platform
withoutVer (Linux (Debian _) ) = Linux $ Debian Nothing
withoutVer (Linux (Ubuntu _) ) = Linux $ Ubuntu Nothing
withoutVer (Linux (Mint _) ) = Linux $ Mint Nothing
withoutVer (Linux (Fedora _) ) = Linux $ Fedora Nothing
withoutVer (Linux UnknownLinux) = Linux $ UnknownLinux
withoutVer Darwin = Darwin
withoutVer (FreeBSD _) = FreeBSD Nothing
getArchitecture :: IO Architecture
getArchitecture = case arch of
"x86_64" -> pure A_64
"i386" -> pure A_32
what -> fail ("Could not find compatible architecture. Was: " <> what)
getPlatform :: IO Platform
getPlatform = case os of
"linux" -> do
distro <- getLinuxDistro
pure $ Linux distro
-- TODO: these are not verified
"darwin" -> pure $ Darwin
"freebsd" -> do
ver <- getFreeBSDVersion
pure $ FreeBSD ver
what -> fail ("Could not find compatible platform. Was: " <> what)
where
getLinuxDistro :: IO LinuxDistro
getLinuxDistro = do
let os_release = [abs|/etc/os-release|]
lsb_release = [abs|/etc/lsb-release|]
redhat_release = [abs|/etc/redhat-release|]
debian_version = [abs|/etc/debian_version|]
pure undefined
getFreeBSDVersion = pure Nothing
-- Try various methods for getting distro name and version.
-- Failure is signalled with an IO exception.
try_os_release :: IO (String, P.Maybe String)
try_os_release = do
name <- getAssignmentValueFor [abs|/etc/os-release|] "NAME" >>= \case
P.Just s -> pure $ s
P.Nothing -> fail "No value found"
version <- getAssignmentValueFor [abs|/etc/os-release|] "VERSION_ID"
pure (name, version)
try_lsb_release_cmd :: IO (String, P.Maybe String)
try_lsb_release_cmd = findExecutable ([fn|lsb_release|] :: Path Fn) >>= \case
P.Nothing -> fail "lsb_release not found"
P.Just path -> do
name <- executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"] >>= \case
P.Just (out, _) -> pure out
_ -> fail "Barfed output of lsb_release"
version <- (fmap . fmap) (UTF8.toString . fst)
$ executeOut ([fn|lsb_release|] :: Path Fn) [fS "-si"]
pure (UTF8.toString name, version)
-- download :: URL -> Path Abs -> IO (Path Abs)
-- download = undefined
-- unpack :: Path Abs -> IO (Path Abs)
-- unpack = undefined
-- install :: DownloadURL -> IO (Path Abs)
-- install = undefined
-- parseAvailableDownloads :: Maybe (Path Abs) -> IO AvailableDownloads
-- parseAvailableDownloads = undefined

79
lib/GHCup/Bash.hs Normal file
View File

@ -0,0 +1,79 @@
module GHCup.Bash where
import Data.ByteString
import Language.Bash.Parse.Word
import Language.Bash.Word
import Language.Bash.Syntax
import Text.Parsec
import HPath
import Data.ByteString.UTF8 ( toString )
import Streamly
import GHCup.File
import GHCup.Prelude ( internalError )
import qualified Streamly.Prelude as S
import Control.Monad
import Data.Maybe
-- | Parse a single assignment of the given line.
parseAssignment :: SourceName -- ^ file/location of the parser
-> ByteString -- ^ the line as a bytestring
-> Either ParseError Assign
parseAssignment = runParser assign ()
-- | Parse assignments in a stream.
parseAssignments :: Monad m
=> SourceName -- ^ file/location of the parser
-> SerialT m (ByteString)
-> SerialT m (Either ParseError Assign)
parseAssignments sn = fmap (parseAssignment sn)
-- | Find an assignment matching the predicate in the given file.
findAssignment :: Path b
-> (Assign -> Bool) -- ^ predicate
-> IO (Maybe Assign)
findAssignment p predicate = do
let fn' = toString . toFilePath $ p
stream <- fmap (parseAssignments fn') $ readFileLines p
res <-
S.find -- empties the stream on first match, but doesn't terminate it
(\case
Right ass -> predicate ass
Left _ -> False
)
stream
>>= \case
Just (Right x) -> pure (Just x)
Just (Left _) ->
internalError "unexpected Left in findAssignment"
Nothing -> pure Nothing
-- Closes the file handle. Because if there was a match, then
-- the stream is not terminated.
when (isJust res) $ S.drain stream
pure res
-- | Check that the assignment is of the form Foo= ignoring the
-- right hand-side.
equalsAssignmentWith :: String -> Assign -> Bool
equalsAssignmentWith n ass = case ass of
(Assign (Parameter name' Nothing) Equals _) -> n == name'
_ -> False
-- | This pretty-prints the right hand of an Equals assignment, removing
-- quotations. No evaluation is performed.
getRValue :: Assign -> Maybe String
getRValue ass = case ass of
(Assign (Parameter _ _) Equals (RValue w)) -> Just $ unquote w
_ -> Nothing
-- | Given a bash assignment such as Foo="Bar" in the given file,
-- will return "Bar" (without quotations).
getAssignmentValueFor :: Path b -> String -> IO (Maybe String)
getAssignmentValueFor p n = do
mass <- findAssignment p (equalsAssignmentWith n)
pure (mass >>= getRValue)

133
lib/GHCup/File.hs Normal file
View File

@ -0,0 +1,133 @@
module GHCup.File where
import Data.ByteString hiding (putStrLn)
import qualified Data.ByteString.Lazy as L
import Data.Char
import Data.Maybe
import HPath
import HPath.IO
import Streamly.ByteString
import Streamly
import System.Posix.FilePath hiding ( (</>) )
import Data.Foldable
import Control.Monad
import Control.Exception.Safe
import Data.Functor
import System.Posix.Files.ByteString
import System.Posix.IO.ByteString hiding (openFd)
import qualified System.Posix.Process.ByteString
as SPPB
import System.Posix.Types
import qualified Streamly.Internal.Memory.ArrayStream
as AS
import qualified Streamly.FileSystem.Handle as FH
import qualified Streamly.Internal.Data.Unfold as SU
import qualified Streamly.Prelude as S
import System.IO
import System.Exit
import qualified Streamly.Data.Fold as FL
import Data.ByteString.Builder
import Foreign.C.Error
import GHCup.Prelude
import Control.Monad.Trans.Maybe
import HPath.Internal
import System.Posix.FD
(
openFd
)
-- |Checks whether a file is executable. Follows symlinks.
--
-- Only eACCES, eROFS, eTXTBSY, ePERM are catched (and return False).
--
-- Throws:
--
-- - `NoSuchThing` if the file does not exist
--
-- Note: calls `access`
isExecutable :: Path b -> IO Bool
isExecutable p = fileAccess (toFilePath p) False False True
readFd :: Fd -> IO L.ByteString
readFd fd = do
handle' <- fdToHandle fd
let stream =
(S.unfold (SU.finally hClose FH.readChunks) handle')
>>= arrayToByteString
toLazyByteString <$> S.fold FL.mconcat (fmap byteString stream)
-- | Read the lines of a file into a stream. The stream holds
-- a file handle as a resource and will close it once the stream
-- terminates (either through exception or because it's drained).
readFileLines :: Path b -> IO (SerialT IO ByteString)
readFileLines p = do
stream <- readFileStream' p
pure
. (>>= arrayToByteString)
. AS.splitOn (fromIntegral $ ord '\n')
. (>>= byteStringToArray)
$ stream
where
readFileStream' :: Path b
-> IO (SerialT IO ByteString)
readFileStream' (MkPath fp) = do
fd <- openFd fp ReadOnly [] Nothing
handle' <- fdToHandle fd
let stream = (S.unfold (SU.finally (\x -> putStrLn "hClose" >> hClose x) FH.readChunks) handle') >>= arrayToByteString
pure stream
-- | Find the given executable by searching all *absolute* PATH components.
-- Relative paths in PATH are ignored.
--
-- This shouldn't throw IO exceptions, unless getting the environment variable
-- PATH does.
findExecutable :: RelC r => Path r -> IO (Maybe (Path Abs))
findExecutable ex = do
sPaths <- fmap catMaybes . (fmap . fmap) parseAbs $ getSearchPath
-- We don't want exceptions to mess up our result. If we can't
-- figure out if a file exists, then treat it as a negative result.
asum $ fmap (handleIOError (\_ -> pure Nothing)) $ fmap
-- asum for short-circuiting behavior
(\s -> (isExecutable (s </> ex) >>= guard) $> (Just (s </> ex)))
sPaths
findExecutablee :: RelC r => Path r -> IO (Maybe (Path Abs))
findExecutablee ex = do
sPaths <- mapMaybe parseAbs <$> getSearchPath
runMaybeT $ asum (MaybeT . eExists <$> sPaths)
where
eExists sp = let path = sp </> ex in handleIOError (pure $ pure Nothing) $ Just path <$ doesFileExist path
-- TODO: fd leak
-- | Execute the given command and collect the stdout and the exit code.
executeOut :: Path Fn -- ^ command as filename, e.g. 'ls'
-> [ByteString] -- ^ arguments to the command
-> IO (Maybe (L.ByteString, ExitCode)) -- ^ fst of the tuple is the stdout
executeOut path args = withFnPath path $ \fp -> do
(readE, writeE) <- createPipe
pid <- SPPB.forkProcess $ do
whileM_
(dupTo writeE stdOutput)
(\r ->
getErrno >>= \e -> pure $ r == fromIntegral (-1 :: Int) && e == eINTR
)
closeFd writeE
closeFd readE
SPPB.executeFile fp True args Nothing
closeFd writeE
-- readFd will take care of closing the fd
SPPB.getProcessStatus True True pid >>= \case
Just (SPPB.Exited es) -> do
out <- readFd readE
pure $ Just (out, es)
_ -> pure Nothing

66
lib/GHCup/Prelude.hs Normal file
View File

@ -0,0 +1,66 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Prelude where
import Control.Applicative
import Data.Strict.Maybe
import Data.Monoid ( (<>) )
import Prelude ( Monad
, Bool
, return
, (.)
, (>>=)
)
import qualified Prelude as P
import Data.String
fS :: IsString a => P.String -> a
fS = fromString
fromStrictMaybe :: Maybe a -> P.Maybe a
fromStrictMaybe = maybe P.Nothing P.Just
toStrictMaybe :: P.Maybe a -> Maybe a
toStrictMaybe = P.maybe Nothing Just
instance Applicative Maybe where
pure = Just
Just f <*> m = P.fmap f m
Nothing <*> _m = Nothing
liftA2 f (Just x) (Just y) = Just (f x y)
liftA2 _ _ _ = Nothing
Just _m1 *> m2 = m2
Nothing *> _m2 = Nothing
instance Alternative Maybe where
empty = Nothing
Nothing <|> r = r
l <|> _ = l
internalError :: P.String -> P.IO a
internalError = P.fail . ("Internal error: " <>)
-- | Like 'when', but where the test can be monadic.
whenM :: Monad m => m Bool -> m () -> m ()
whenM ~b ~t = ifM b t (return ())
-- | Like 'unless', but where the test can be monadic.
unlessM :: Monad m => m Bool -> m () -> m ()
unlessM ~b ~f = ifM b (return ()) f
-- | Like @if@, but where the test can be monadic.
ifM :: Monad m => m Bool -> m a -> m a -> m a
ifM ~b ~t ~f = do
b' <- b
if b' then t else f
whileM_ :: Monad m => m a -> (a -> m Bool) -> m ()
whileM_ action f = whenM (action >>= f) (whileM_ action f)

51
lib/GHCup/Types.hs Normal file
View File

@ -0,0 +1,51 @@
{-# LANGUAGE DeriveGeneric #-}
module GHCup.Types where
import Data.Map.Strict (Map)
import Data.Strict.Maybe
import Data.Text
import Data.Version
import Network.URL
import Prelude hiding (
Maybe
, Just
, Nothing)
import qualified GHC.Generics as GHC
-- | Requested tool to be installed. User input.
data Tool = GHC
| Cabal
| Stack
deriving (Eq, Ord, Show)
-- | Architecture we run on.
data Architecture = A_64
| A_32
deriving (Eq, Ord, Show)
data LinuxDistro = Debian (Maybe CustomVersion)
| Ubuntu (Maybe CustomVersion)
| Mint (Maybe CustomVersion)
| Fedora (Maybe CustomVersion)
-- not known
| UnknownLinux
-- ^ must exit
deriving (Eq, GHC.Generic, Ord, Show)
data Platform = Linux LinuxDistro
-- ^ must exit
| Darwin
-- ^ must exit
| FreeBSD (Maybe CustomVersion)
deriving (Eq, GHC.Generic, Ord, Show)
type CustomVersion = Text
type PlatformSpec = Map Platform URL
type ArchitectureSpec = Map Architecture PlatformSpec
type VersionSpec = Map Version ArchitectureSpec
type AvailableDownloads = Map Tool VersionSpec

18
lib/GHCup/Types/Foo.hs Normal file
View File

@ -0,0 +1,18 @@
encToJsonNoSpaces
:: ( Monoid t
, Applicative f
)
=> AReview Json (b, t)
-> (a -> b)
-> Encoder f a
encToJsonNoSpaces c f =
encodeA (pure . review c . (, mempty) . f)
bytestring :: Applicative f => Encoder f ByteString
bytestring = encToJsonNoSpaces _JStr (_JStringBS #)
_JStringBS :: (Profunctor p, Applicative f)
=> p ByteString (f ByteString)
-> p JString (f JString)
_JStringBS = iso (C.pack . review _JString)
(JString' . V.fromList . fmap utf8CharToJChar . C.unpack)

40
lib/GHCup/Types/JSON.hs Normal file
View File

@ -0,0 +1,40 @@
{-# OPTIONS_GHC -Wno-orphans #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE TypeFamilies #-}
module GHCup.Types.JSON where
import Data.Strict.Maybe
import GHCup.Types
import Generics.SOP.TH
import Prelude hiding (
Maybe
, Just
, Nothing)
import Waargonaut.Generic (
JsonEncode
, JsonDecode
, GWaarg)
deriveGeneric ''Maybe
instance JsonEncode GWaarg a => JsonEncode GWaarg (Maybe a)
instance JsonDecode GWaarg a => JsonDecode GWaarg (Maybe a)
deriveGeneric ''Tool
instance JsonEncode GWaarg Tool
instance JsonDecode GWaarg Tool
deriveGeneric ''Architecture
instance JsonEncode GWaarg Architecture
instance JsonDecode GWaarg Architecture
deriveGeneric ''LinuxDistro
instance JsonEncode GWaarg LinuxDistro
instance JsonDecode GWaarg LinuxDistro

5
lib/GHCup/Types/Optics.hs Normal file
View File

@ -0,0 +1,5 @@
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Types.Optics where

4
lib/MyLib.hs
View File

@ -1,4 +0,0 @@
module MyLib (someFunc) where
someFunc :: IO ()
someFunc = putStrLn "someFunc"

57
lib/Streamly/ByteString.hs Normal file
View File

@ -0,0 +1,57 @@
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Streamly.ByteString where
import Control.Monad.IO.Class
import Data.ByteString hiding (length)
import qualified Data.ByteString as BS
import Data.ByteString.Unsafe
import Data.Word (Word8)
import Foreign.ForeignPtr
import Foreign.ForeignPtr.Unsafe
import Foreign.Ptr (castPtr, minusPtr, plusPtr)
import Prelude hiding (length)
import Streamly
import Streamly.Internal.Memory.Array.Types
import Streamly.Memory.Array
import qualified Streamly.Prelude as S
toByteString ::
forall m. (MonadIO m, MonadAsync m)
=> SerialT m (Array Word8)
-> m ByteString
toByteString stream =
let xs = S.mapM arrayToByteString stream
ys = S.foldlM' (\a b -> pure $ a <> b) mempty xs
in ys
arrayToByteString :: (MonadIO m) => Array Word8 -> m ByteString
arrayToByteString arr
| length arr == 0 = return mempty
arrayToByteString Array {..} =
liftIO $
withForeignPtr aStart $ \ptr ->
unsafePackCStringFinalizer ptr aLen (return ())
where
aLen =
let p = unsafeForeignPtrToPtr aStart
in aEnd `minusPtr` p
byteStringToArray :: (MonadIO m) => ByteString -> m (Array Word8)
byteStringToArray bs =
liftIO $
unsafeUseAsCStringLen
bs
(\(ptr, _) -> do
let endPtr pr = (castPtr pr `plusPtr` (BS.length bs))
fptr <- newForeignPtr_ (castPtr ptr)
return $ Array {aStart = fptr, aEnd = endPtr ptr, aBound = endPtr ptr})
fromByteString ::
forall m. (MonadIO m)
=> ByteString
-> m (Array Word8)
fromByteString bs = byteStringToArray bs