First take
This commit is contained in:
parent
e414ca4b0c
commit
3fb5c612c1
86
ghcup.cabal
86
ghcup.cabal
|
|
@ -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
|
||||
|
||||
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
|
||||
exposed-modules: MyLib
|
||||
-- other-modules:
|
||||
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:
|
||||
build-depends: base ^>=4.12.0.0
|
||||
hs-source-dirs: lib
|
||||
default-language: Haskell2010
|
||||
|
||||
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
|
||||
|
||||
|
|
|
|||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
|
@ -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)
|
||||
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -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)
|
||||
|
|
@ -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
|
||||
|
||||
|
|
@ -0,0 +1,5 @@
|
|||
{-# LANGUAGE TemplateHaskell #-}
|
||||
|
||||
module GHCup.Types.Optics where
|
||||
|
||||
|
||||
|
|
@ -1,4 +0,0 @@
|
|||
module MyLib (someFunc) where
|
||||
|
||||
someFunc :: IO ()
|
||||
someFunc = putStrLn "someFunc"
|
||||
|
|
@ -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
|
||||
Loading…
Reference in New Issue