Compare commits

...

29 Commits

Author SHA1 Message Date
63c70ee74b Fix changelog subcommand on darwin 2020-07-13 23:10:17 +02:00
2e0bbca2e0 Fix freebsd tui 2020-07-13 22:45:38 +02:00
b52fa23ca2 Update alpine install-deps 2020-07-13 22:34:38 +02:00
ba03b78f23 Update ghcup binaries 2020-07-13 22:15:39 +02:00
04ef472c15 Fix freebsd gitlab-ci 2020-07-13 21:29:13 +02:00
75cd8f2341 Fix stripping in travis 2020-07-13 21:17:01 +02:00
f2e26c1800 Fix release build 2020-07-13 20:48:37 +02:00
0f7dd597d2 Update .gitignore 2020-07-13 20:37:34 +02:00
fb0eba9201 Release 0.1.6 2020-07-13 20:31:14 +02:00
3c80929c38 Merge branch 'ghc-8.10.1' 2020-07-13 20:06:17 +02:00
b184ee835f Add freebsd 8.6.5 bindist 2020-07-13 20:05:02 +02:00
ef8e3bd940 Reduce number of os/dl lookups 2020-07-13 18:27:21 +02:00
1a64527e14 Improve verbosity 2020-07-13 16:27:01 +02:00
30b4d399b9 Add -ftui to travis build 2020-07-13 16:26:54 +02:00
50424c2801 Allow to build with tar-bytestring on e.g. 32bit 2020-07-13 15:41:31 +02:00
7e7c357e47 Fix freebsd CI 2020-07-13 15:41:30 +02:00
531b82a406 Add ghc-8.8.3 freebsd bindist 2020-07-13 15:41:30 +02:00
146ac38549 Add 8.10.1 freebsd bindist 2020-07-12 16:48:25 +02:00
c481956b07 Bump GHC versions in CI 2020-07-11 23:03:04 +02:00
8ef19f0825 Allow to build with ghc-8.10.1 and 8.6.5 2020-07-11 22:53:38 +02:00
c1e29a8f16 Rm bundled os-release 2020-07-11 21:25:45 +02:00
c3611eec6a Grey out versions without bindists in tui 2020-07-11 18:53:11 +02:00
74b58db7d1 Merge branch 'tui' 2020-07-11 13:32:34 +02:00
9e4763c640 Merge branch 'www-wsl' 2020-07-11 00:00:53 +02:00
abc4278fc8 Improve style 2020-07-10 23:55:01 +02:00
8c4cde3d14 Recommend the curl command for potential WSL users on website
Fixes #32
2020-07-10 23:53:55 +02:00
3824f6417a Update libarchive 2020-07-10 22:44:16 +02:00
Ben Gamari
2be1aa2707 Simplify upgrade copying logic 2020-07-10 22:03:04 +02:00
da94fa5f92 Create brick tui wrt #24 2020-07-10 21:55:12 +02:00
62 changed files with 762 additions and 1410 deletions

7
.gitignore vendored
View File

@@ -5,3 +5,10 @@ dist-newstyle/
cabal.project.local
.stack-work/
bin/
/*.prof
/*.ps
/*.hp
tags
TAGS
/tmp/
.entangled

View File

@@ -97,13 +97,13 @@ variables:
test:linux:recommended:
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.6.5"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
test:linux:latest:
extends: .test_ghcup_version:linux
variables:
GHC_VERSION: "8.8.3"
GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -113,13 +113,13 @@ test:linux:latest:
test:mac:recommended:
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.6.5"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
test:mac:latest:
extends: .test_ghcup_version:darwin
variables:
GHC_VERSION: "8.8.3"
GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -129,13 +129,13 @@ test:mac:latest:
test:freebsd:recommended:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.6.5"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"
test:freebsd:latest:
extends: .test_ghcup_version:freebsd
variables:
GHC_VERSION: "8.8.3"
GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0"
allow_failure: true
@@ -193,5 +193,6 @@ release:freebsd:
- ./.gitlab/before_script/freebsd/install_deps.sh
variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup"
GHC_VERSION: "8.6.5"
GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0"

View File

@@ -11,15 +11,8 @@ mkdir -p "${TMPDIR}"
curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin
chmod +x ghcup-bin
mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin
# ./ghcup-bin install ${GHC_VERSION}
# ./ghcup-bin install-cabal ${CABAL_VERSION}
# ./ghcup-bin set ${GHC_VERSION}
# install cabal-3.2.0.0
curl -sSfL -o cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-x86_64-portbld-freebsd.tar.xz
cp cabal "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
./ghcup-bin install ${GHC_VERSION}
./ghcup-bin install-cabal ${CABAL_VERSION}
./ghcup-bin set ${GHC_VERSION}
exit 0

View File

@@ -18,29 +18,18 @@ apk add --no-cache \
tar \
perl
ln -s libncurses.so /usr/lib/libtinfo.so
ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6
ln -sf libncurses.so /usr/lib/libtinfo.so
ln -sf libncursesw.so.6 /usr/lib/libtinfow.so.6
ln -sf libtinfow.so.6 /usr/lib/libtinfow.so
if [ "${BIT}" = "32" ] ; then
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/i386-linux-ghcup-0.1.4 > ./ghcup-bin
curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
else
curl -sSfL https://downloads.haskell.org/~ghcup/0.1.4/x86_64-linux-ghcup-0.1.4 > ./ghcup-bin
curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
fi
chmod +x ghcup-bin
./ghcup-bin upgrade
./ghcup-bin install ${GHC_VERSION}
# ./ghcup-bin install-cabal ${CABAL_VERSION}
# install cabal-3.2.0.0
if [ "${BIT}" = "32" ] ; then
curl -sSfL -o cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-i386-alpine-linux-musl.tar.xz
cp cabal-install-3.2.0.0-i386-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
else
curl -sSfL -o cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz 'https://hasufell.de/d/d3e215db133e4fcaa61e/files/?p=/cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz&dl=1'
tar xf cabal-install-3.2.0.0-x86_64-alpine-linux-musl.tar.xz
cp cabal-install-3.2.0.0-x86_64-alpine-linux-musl "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
fi
chmod +x "${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/bin/cabal"
./ghcup-bin install-cabal ${CABAL_VERSION}
# utils
apk add --no-cache \
@@ -57,7 +46,8 @@ apk add --no-cache \
openssl-dev \
openssl-libs-static \
xz \
xz-dev
xz-dev \
ncurses-static
ln -sf libncursesw.a /usr/lib/libtinfow.a

View File

@@ -16,16 +16,24 @@ git describe
ecabal update
if [ "${OS}" = "LINUX" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
if [ "${BIT}" = "32" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
else
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
fi
elif [ "${OS}" = "FREEBSD" ] ; then
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" -ftui
else
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static"
ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
fi
mkdir out
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
ver=$(./ghcup --numeric-version)
strip -s ./ghcup
if [ "${OS}" = "DARWIN" ] ; then
strip ./ghcup
else
strip -s ./ghcup
fi
cp ghcup out/${ARTIFACT}-${ver}

View File

@@ -21,9 +21,9 @@ git describe --always
ecabal update
if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION}
ecabal build -w ghc-${GHC_VERSION} -ftui
else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" .

View File

@@ -18,7 +18,7 @@ ghcup set 8.8.3
## install ghcup
cabal update
cabal build --constraint="zlib static" --constraint="lzma static"
cabal build --constraint="zlib static" --constraint="lzma static" -ftui
cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
strip -s ghcup
strip ./ghcup
cp ghcup "./${ARTIFACT}"

View File

@@ -260,7 +260,7 @@
/* #undef HAVE_ACL_IS_TRIVIAL_NP */
/* Define to 1 if you have the <acl/libacl.h> header file. */
#define HAVE_ACL_LIBACL_H 1
/* #undef HAVE_ACL_LIBACL_H */
/* Define to 1 if the system has the type `acl_permset_t'. */
/* #undef HAVE_ACL_PERMSET_T */
@@ -453,6 +453,7 @@
/* #undef HAVE_EXPAT_H */
/* Define to 1 if you have the <ext2fs/ext2_fs.h> header file. */
/* #undef HAVE_EXT2FS_EXT2_FS_H */
/* Define to 1 if you have the `extattr_get_fd' function. */
/* #undef HAVE_EXTATTR_GET_FD */
@@ -605,7 +606,7 @@
/* #undef HAVE_LCHFLAGS */
/* Define to 1 if you have the `lchmod' function. */
/* #undef HAVE_LCHMOD */
/* #undef HAVE_LCHMOD 1 */
/* Define to 1 if you have the `lchown' function. */
#define HAVE_LCHOWN 1
@@ -1027,10 +1028,10 @@
/* #undef HAVE_STRUCT_STAT_ST_UMTIME */
/* Define to 1 if `tm_gmtoff' is a member of `struct tm'. */
#define HAVE_STRUCT_TM_TM_GMTOFF 1
/* #undef HAVE_STRUCT_TM_TM_GMTOFF 1 */
/* Define to 1 if `__tm_gmtoff' is a member of `struct tm'. */
/* #undef HAVE_STRUCT_TM___TM_GMTOFF */
/* #undef HAVE_STRUCT_TM___TM_GMTOFF 1 */
/* Define to 1 if the system has the type `struct vfsconf'. */
/* #undef HAVE_STRUCT_VFSCONF */
@@ -1042,9 +1043,10 @@
#define HAVE_SYMLINK 1
/* Define to 1 if you have the <sys/acl.h> header file. */
/* #undef HAVE_SYS_ACL_H */
/* Define to 1 if you have the <sys/cdefs.h> header file. */
#define HAVE_SYS_CDEFS_H 1
/* #undef HAVE_SYS_CDEFS_H */
/* Define to 1 if you have the <sys/dir.h> header file, and it defines `DIR'.
*/
@@ -1202,7 +1204,7 @@
#define HAVE_WMEMMOVE 1
/* Define to 1 if you have a working EXT2_IOC_GETFLAGS */
#define HAVE_WORKING_EXT2_IOC_GETFLAGS 1
/* #undef HAVE_WORKING_EXT2_IOC_GETFLAGS */
/* Define to 1 if you have a working FS_IOC_GETFLAGS */
#define HAVE_WORKING_FS_IOC_GETFLAGS 1
@@ -1289,7 +1291,7 @@
#define STDC_HEADERS 1
/* Define to 1 if strerror_r returns char *. */
#define STRERROR_R_CHAR_P 1
/* #undef STRERROR_R_CHAR_P */
/* Define to 1 if you can safely include both <sys/time.h> and <time.h>. */
#define TIME_WITH_SYS_TIME 1

View File

@@ -1 +0,0 @@
*.golden -text

View File

@@ -1 +0,0 @@
dist-newstyle/

View File

@@ -1,16 +0,0 @@
1.0.0
=====
- Redo of the entire API
0.2.2
=====
- Fixes builds failing just due to -Werror
- README.rst and ChangeLog.rst are distributed with cabal package
0.2.1
=====
- Initial release

View File

@@ -1,26 +0,0 @@
Copyright (c) 2014, Jan Matejka <yac@blesmrt.net>
All rights reserved.
Redistribution and use in source and binary forms, with or without
modification, are permitted provided that the following conditions are met:
1. Redistributions of source code must retain the above copyright notice,
this list of conditions and the following disclaimer.
2. Redistributions in binary form must reproduce the above copyright
notice, this list of conditions and the following disclaimer in the
documentation and/or other materials provided with the distribution.
3. Neither the name of the cbugzilla nor the names of its
contributors may be used to endorse or promote products derived from
this software without specific prior written permission.
THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS"
AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE
IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE
ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT OWNER OR CONTRIBUTORS BE
LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR
CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF
SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS
INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN
CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE)
ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE
POSSIBILITY OF SUCH DAMAGE.

View File

@@ -1,17 +0,0 @@
##########
os-release
##########
http://www.freedesktop.org/software/systemd/man/os-release.html
Usage
#####
.. code-block:: haskell
import System.OsRelease
main = readOs >>= print
.. code-block::
Right (fromList [(OsReleaseKey "ANSI_COLOR",OsReleaseValue "1;32"),(OsReleaseKey "BUG_REPORT_URL",OsReleaseValue "https://bugs.gentoo.org/"),(OsReleaseKey "HOME_URL",OsReleaseValue "http://www.gentoo.org/"),(OsReleaseKey "ID",OsReleaseValue "gentoo"),(OsReleaseKey "NAME",OsReleaseValue "Gentoo"),(OsReleaseKey "PRETTY_NAME",OsReleaseValue "Gentoo/Linux"),(OsReleaseKey "SUPPORT_URL",OsReleaseValue "http://www.gentoo.org/main/en/support.xml")])

View File

@@ -1,2 +0,0 @@
import Distribution.Simple
main = defaultMain

View File

@@ -1,192 +0,0 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE TypeOperators #-}
-- | A module to retrieve os-release information according to the
-- freedesktop standard:
-- https://www.freedesktop.org/software/systemd/man/os-release.html
--
-- Usage example:
--
-- @
-- do
-- Just (OsRelease {..}) <- fmap osRelease <$\> parseOsRelease
-- putStrLn name
-- @
module System.OsRelease
(
-- * data types
OsReleaseResult(..)
, OsRelease(..)
-- * read/parse os-release
, parseOsRelease
, readOsRelease
-- * defaults
, defaultOsRelease
, defaultAssignments
-- * low-level
, parseAssignments
, parseAssignment
, getAllAssignments
, getOsRelease
, parseOsRelease'
)
where
import System.OsRelease.Megaparsec
import Control.Applicative
import Control.Monad
import Control.Exception.Safe
import Data.Aeson
import Data.Aeson.TH
import Data.Char
import Data.Either
import Data.List
import Data.Maybe
import Data.Void
import GHC.Generics
import Prelude hiding ( id
)
import qualified Data.HashMap.Strict as HM
import qualified Data.Text as T
import qualified Text.Megaparsec as MP
data OsReleaseResult = OsReleaseResult {
osRelease :: !OsRelease
, unknown_fields :: [(String, String)]
, parse_errors :: [MP.ParseError String Void]
} deriving (Show)
-- | All the explicitly documented fields of @os-release@.
data OsRelease = OsRelease {
name :: !(String)
, version :: !(Maybe String)
, id :: !(String)
, id_like :: !(Maybe String)
, version_codename :: !(Maybe String)
, version_id :: !(Maybe String)
, pretty_name :: !(String)
, ansi_color :: !(Maybe String)
, cpe_name :: !(Maybe String)
, home_url :: !(Maybe String)
, documentation_url :: !(Maybe String)
, support_url :: !(Maybe String)
, bug_report_url :: !(Maybe String)
, privacy_policy_url :: !(Maybe String)
, build_id :: !(Maybe String)
, variant :: !(Maybe String)
, variant_id :: !(Maybe String)
, logo :: !(Maybe String)
} deriving (Generic, Show)
class GetRecords a where
getRecords :: a -> [String]
instance {-# OVERLAPPABLE #-} GetRecords (f p) => GetRecords (M1 i c f p) where
getRecords (M1 x) = getRecords x
instance {-# OVERLAPPING #-} Selector c => GetRecords (M1 S c f p) where
getRecords x = [selName x]
instance (GetRecords (a p), GetRecords (b p)) => GetRecords ((a :*: b) p) where
getRecords (a :*: b) = getRecords a ++ getRecords b
-- | The defaults as per the spec:
--
-- @
-- NAME=Linux
-- ID=linux
-- PRETTY_NAME=Linux
-- @
defaultOsRelease :: OsRelease
defaultOsRelease = OsRelease { name = "Linux"
, version = Nothing
, id = "linux"
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = "Linux"
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Nothing
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Nothing
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
-- | Like `defaultOsRelease`, except as key-value pair.
defaultAssignments :: [(String, String)]
defaultAssignments =
[("NAME", "Linux"), ("ID", "linux"), ("PRETTY_NAME", "Linux")]
-- | Get all allAssignments as @(key, val)@ from the @os-release@
-- file contents.
getAllAssignments :: String -- ^ file contents of os-release
-> [Either (MP.ParseError String Void) (String, String)]
getAllAssignments = fromRight [] . MP.parse parseAssignments "os-release"
-- | Parse the assignments into `OsRelease`. This is merged with the
-- defaults as per the spec. In case of no assignments, also returns
-- the defaults.
getOsRelease :: [(String, String)] -- ^ assignments
-> OsRelease
getOsRelease =
(\case
Error _ -> defaultOsRelease
Success v -> v
)
. fromJSON
. Object
. (\x -> HM.union x (HM.fromList . aesonify $ defaultAssignments))
. HM.fromList
. aesonify
where
aesonify = fmap (\(k, v) -> (T.toLower . T.pack $ k, String . T.pack $ v))
-- | Tries to read @\"\/etc\/os-release\"@ and @\"\/usr\/lib\/os_release\"@ in order.
--
-- Throws @IOError@ if both files could not be read.
readOsRelease :: IO String
readOsRelease = readFile "/etc/os-release" <|> readFile "/usr/lib/os-release"
-- | Tries to read @\"\/etc\/os-release\"@ and @\"\/usr\/lib\/os_release\"@ in order
-- and parses into `OsReleaseResult`. Returns @Nothing@ if both files could
-- not be read.
parseOsRelease :: IO (Maybe OsReleaseResult)
parseOsRelease =
handleIO (\_ -> pure Nothing) . fmap (Just . parseOsRelease') $ readOsRelease
-- | Like `parseOsRelease`, except taking the input String explicitly.
-- Primarily for tests.
parseOsRelease' :: String -> OsReleaseResult
parseOsRelease' s =
let (errs, ass) = partitionEithers . getAllAssignments $ s
osr = getOsRelease ass
unknown_fields' =
HM.toList
. foldr (\x y -> HM.delete (fmap toUpper x) y) (HM.fromList ass)
$ (init . getRecords . from $ defaultOsRelease)
in OsReleaseResult osr unknown_fields' errs
deriveJSON defaultOptions ''OsRelease

View File

@@ -1,102 +0,0 @@
{-# LANGUAGE CPP #-}
module System.OsRelease.Megaparsec where
import Control.Applicative
import Control.Monad
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
#endif
import Data.Char
import Data.Functor
import Data.Void
import qualified Text.Megaparsec as MP
import qualified Text.Megaparsec.Char as MP
-- | Parse the entire file, handling newlines and comments gracefully.
--
-- This parser generally shouldn't fail, but instead report a failed
-- parsed line as @Left@ value.
parseAssignments :: MP.Parsec
Void
String
[Either (MP.ParseError String Void) (String, String)]
parseAssignments =
(\xs x -> join xs ++ x) <$> many (line MP.eol) <*> line MP.eof
where
line eol = choice'
[ comment $> []
, blank $> []
, fmap
(: [])
( MP.withRecovery (\e -> parseUntil eol $> Left e)
. fmap Right
$ (parseAssignment <* eol)
)
]
where
comment = pWs *> MP.char '#' *> parseUntil eol *> eol
blank = pWs *> eol
-- | Parse a single line assignment and extract the right hand side.
-- This is only a subset of a shell parser, refer to the spec for
-- details.
parseAssignment :: MP.Parsec Void String (String, String)
parseAssignment =
(,) <$> (pWs *> key) <*> (MP.char '=' *> (MP.try qval <|> mempty) <* pWs)
where
dropSpace :: String -> String
dropSpace = reverse . dropWhile (\x -> x == ' ' || x == '\t') . reverse
key :: MP.Parsec Void String String
key = some (MP.try MP.alphaNumChar <|> MP.char '_')
qval :: MP.Parsec Void String String
qval = do
c <- MP.lookAhead MP.printChar
case c of
' ' -> pure ""
'"' -> MP.char c *> val c <* MP.char c
'\'' -> MP.char c *> val c <* MP.char c
-- no quote, have to drop trailing spaces
_ -> fmap
dropSpace
(some $ MP.satisfy (\x -> isAlphaNum x || (x `elem` ['_', '-', '.']))) -- this is more lax than the spec
val :: Char -> MP.Parsec Void String String
val !q = many (qspecial q <|> MP.noneOf (specials q)) -- noneOf may be too lax
qspecial :: Char -> MP.Parsec Void String Char
qspecial !q =
fmap (!! 1)
. (\xs -> choice' xs)
. fmap (\s -> MP.try . MP.chunk $ ['\\', s])
$ (specials q)
specials :: Char -> [Char]
specials !q = [q, '\\', '$', '`']
parseUntil :: MP.Parsec Void String a -> MP.Parsec Void String String
parseUntil !p = do
(MP.try (MP.lookAhead p) $> [])
<|> (do
c <- MP.anySingle
c2 <- parseUntil p
pure ([c] `mappend` c2)
)
-- | Parse one or more white spaces or tabs.
pWs :: MP.Parsec Void String ()
pWs = many (MP.satisfy (\x -> x == ' ' || x == '\t')) $> ()
-- | Try all parses in order, failing if all failed. Also fails
-- on empty list.
choice' :: (MonadFail f, MP.MonadParsec e s f) => [f a] -> f a
choice' = \case
[] -> fail "Empty list"
xs -> foldr1 (\x y -> MP.try x <|> MP.try y) xs

View File

@@ -1,131 +0,0 @@
cabal-version: 3.0
author: Jan Matějka
category: System
license-file: LICENSE
build-type: Simple
copyright: 2014 Jan Matějka <yac@blesmrt.net>
license: BSD-3-Clause
maintainer: Julian Ospald <hasufell@posteo.de>
homepage: https://github.com/yaccz/os-release
name: os-release
synopsis: /etc/os-release helpers
version: 1.0.0
description:
\/etc\/os-release helpers as per the freedesktop spec: https://www.freedesktop.org/software/systemd/man/os-release.html
extra-doc-files:
ChangeLog.rst
README.rst
extra-source-files: tests/Golden/data/*.golden tests/Golden/data/*.in
flag devel
description: Enables -Werror
default: False
manual: True
source-repository head
type: git
location: https://github.com/yaccz/os-release.git
common base
build-depends: base >=4.11 && <5
common bytestring
build-depends: bytestring
common aeson
build-depends: aeson >=1.4
common filepath
build-depends: filepath >=1.4.2.1
common hspec
build-depends: hspec >=2.7.1
common hspec-megaparsec
build-depends: hspec-megaparsec >=2.1.0
common megaparsec
build-depends: megaparsec >=8.0.0
common pretty-simple
build-depends: pretty-simple >=1.0.0.0
common safe-exceptions
build-depends: safe-exceptions >=0.1.7.0
common tasty
build-depends: tasty >=1.3
common tasty-golden
build-depends: tasty-golden >=2.3.4
common tasty-hspec
build-depends: tasty-hspec >=1.1.5.1
common text
build-depends: text >=1.2
common unordered-containers
build-depends: unordered-containers >=0.2.10.0
common config
default-language: Haskell2010
if flag(devel)
ghc-options:
-Werror -Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates
else
ghc-options:
-Wall -fwarn-tabs -fwarn-incomplete-uni-patterns
-fwarn-incomplete-record-updates
default-extensions:
BangPatterns
LambdaCase
OverloadedStrings
QuasiQuotes
TemplateHaskell
TupleSections
TypeFamilies
library
import:
config
, base
, aeson
, megaparsec
, safe-exceptions
, text
, unordered-containers
exposed-modules: System.OsRelease
other-modules: System.OsRelease.Megaparsec
hs-source-dirs: library
test-suite tests
import:
config
, base
, bytestring
, filepath
, hspec
, hspec-megaparsec
, megaparsec
, pretty-simple
, tasty
, tasty-golden
, tasty-hspec
, text
build-depends: os-release
hs-source-dirs: tests
main-is: Main.hs
other-modules:
Golden.Real
Specs.Megaparsec
type: exitcode-stdio-1.0

View File

@@ -1,35 +0,0 @@
{-# LANGUAGE CPP #-}
module Golden.Real where
import System.OsRelease
import System.FilePath
import Text.Pretty.Simple
import Test.Tasty
import Test.Tasty.Golden
import qualified Data.ByteString.Lazy as B
import qualified Data.Text.Lazy as L
import qualified Data.Text.Encoding as E
goldenTests :: IO TestTree
goldenTests = do
files <- findByExtension [".in"] (takeDirectory (__FILE__) </> "data")
return $ testGroup
"Parse os-release into OsRelease"
(flip fmap files $ \file ->
let out = replaceExtension file ".golden"
in goldenVsString (takeBaseName file) out (parse file)
)
where
parse f = do
c <- readFile f
pure
. B.fromStrict
. E.encodeUtf8
. L.toStrict
. pShowNoColor
. parseOsRelease'
$ c

View File

@@ -1,24 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Alpine Linux"
, version = Nothing
, id = "alpine"
, id_like = Nothing
, version_codename = Nothing
, version_id = Just "3.11.3"
, pretty_name = "Alpine Linux v3.11"
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Just "https://alpinelinux.org/"
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Just "https://bugs.alpinelinux.org/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields = []
, parse_errors = []
}

View File

@@ -1,7 +0,0 @@
NAME="Alpine Linux"
ID=alpine
VERSION_ID=3.11.3
PRETTY_NAME="Alpine Linux v3.11"
HOME_URL="https://alpinelinux.org/"
BUG_REPORT_URL="https://bugs.alpinelinux.org/"

View File

@@ -1,29 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Arch Linux"
, version = Nothing
, id = "arch"
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = "Arch Linux"
, ansi_color = Just "38;2;23;147;209"
, cpe_name = Nothing
, home_url = Just "https://www.archlinux.org/"
, documentation_url = Just "https://wiki.archlinux.org/"
, support_url = Just "https://bbs.archlinux.org/"
, bug_report_url = Just "https://bugs.archlinux.org/"
, privacy_policy_url = Nothing
, build_id = Just "rolling"
, variant = Nothing
, variant_id = Nothing
, logo = Just "archlinux"
}
, unknown_fields =
[
( "LOGO"
, "archlinux"
)
]
, parse_errors = []
}

View File

@@ -1,11 +0,0 @@
NAME="Arch Linux"
PRETTY_NAME="Arch Linux"
ID=arch
BUILD_ID=rolling
ANSI_COLOR="38;2;23;147;209"
HOME_URL="https://www.archlinux.org/"
DOCUMENTATION_URL="https://wiki.archlinux.org/"
SUPPORT_URL="https://bbs.archlinux.org/"
BUG_REPORT_URL="https://bugs.archlinux.org/"
LOGO=archlinux

View File

@@ -1,45 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "CentOS Linux"
, version = Just "8 (Core)"
, id = "centos"
, id_like = Just "rhel fedora"
, version_codename = Nothing
, version_id = Just "8"
, pretty_name = "CentOS Linux 8 (Core)"
, ansi_color = Just "0;31"
, cpe_name = Just "cpe:/o:centos:centos:8"
, home_url = Just "https://www.centos.org/"
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Just "https://bugs.centos.org/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields =
[
( "REDHAT_SUPPORT_PRODUCT_VERSION"
, "8"
)
,
( "CENTOS_MANTISBT_PROJECT"
, "CentOS-8"
)
,
( "REDHAT_SUPPORT_PRODUCT"
, "centos"
)
,
( "PLATFORM_ID"
, "platform:el8"
)
,
( "CENTOS_MANTISBT_PROJECT_VERSION"
, "8"
)
]
, parse_errors = []
}

View File

@@ -1,17 +0,0 @@
NAME="CentOS Linux"
VERSION="8 (Core)"
ID="centos"
ID_LIKE="rhel fedora"
VERSION_ID="8"
PLATFORM_ID="platform:el8"
PRETTY_NAME="CentOS Linux 8 (Core)"
ANSI_COLOR="0;31"
CPE_NAME="cpe:/o:centos:centos:8"
HOME_URL="https://www.centos.org/"
BUG_REPORT_URL="https://bugs.centos.org/"
CENTOS_MANTISBT_PROJECT="CentOS-8"
CENTOS_MANTISBT_PROJECT_VERSION="8"
REDHAT_SUPPORT_PRODUCT="centos"
REDHAT_SUPPORT_PRODUCT_VERSION="8"

View File

@@ -1,24 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Debian GNU/Linux"
, version = Just "8 (jessie)"
, id = "debian"
, id_like = Nothing
, version_codename = Nothing
, version_id = Just "8"
, pretty_name = "Debian GNU/Linux 8 (jessie)"
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Just "http://www.debian.org/"
, documentation_url = Nothing
, support_url = Just "http://www.debian.org/support/"
, bug_report_url = Just "https://bugs.debian.org/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields = []
, parse_errors = []
}

View File

@@ -1,8 +0,0 @@
PRETTY_NAME="Debian GNU/Linux 8 (jessie)"
NAME="Debian GNU/Linux"
VERSION_ID="8"
VERSION="8 (jessie)"
ID=debian
HOME_URL="http://www.debian.org/"
SUPPORT_URL="http://www.debian.org/support/"
BUG_REPORT_URL="https://bugs.debian.org/"

View File

@@ -1,24 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Linux"
, version = Nothing
, id = "linux"
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = "Linux"
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Nothing
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Nothing
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields = []
, parse_errors = []
}

View File

@@ -1 +0,0 @@

View File

@@ -1,24 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Exherbo"
, version = Nothing
, id = "exherbo"
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = "Exherbo Linux"
, ansi_color = Just "0;32"
, cpe_name = Nothing
, home_url = Just "https://www.exherbo.org/"
, documentation_url = Nothing
, support_url = Just "irc://irc.freenode.net/#exherbo"
, bug_report_url = Just "https://bugs.exherbo.org/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields = []
, parse_errors = []
}

View File

@@ -1,9 +0,0 @@
NAME="Exherbo"
PRETTY_NAME="Exherbo Linux"
ID="exherbo"
# comment
ANSI_COLOR="0;32"
HOME_URL="https://www.exherbo.org/"
SUPPORT_URL="irc://irc.freenode.net/#exherbo"
BUG_REPORT_URL="https://bugs.exherbo.org/"

View File

@@ -1,49 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Fedora"
, version = Just "31 (Container Image)"
, id = "fedora"
, id_like = Nothing
, version_codename = Just ""
, version_id = Just "31"
, pretty_name = "Fedora 31 (Container Image)"
, ansi_color = Just "0;34"
, cpe_name = Just "cpe:/o:fedoraproject:fedora:31"
, home_url = Just "https://fedoraproject.org/"
, documentation_url = Just "https://docs.fedoraproject.org/en-US/fedora/f31/system-administrators-guide/"
, support_url = Just "https://fedoraproject.org/wiki/Communicating_and_getting_help"
, bug_report_url = Just "https://bugzilla.redhat.com/"
, privacy_policy_url = Just "https://fedoraproject.org/wiki/Legal:PrivacyPolicy"
, build_id = Nothing
, variant = Just "Container Image"
, variant_id = Just "container"
, logo = Just "fedora-logo-icon"
}
, unknown_fields =
[
( "REDHAT_SUPPORT_PRODUCT_VERSION"
, "31"
)
,
( "REDHAT_BUGZILLA_PRODUCT"
, "Fedora"
)
,
( "REDHAT_SUPPORT_PRODUCT"
, "Fedora"
)
,
( "PLATFORM_ID"
, "platform:f31"
)
,
( "REDHAT_BUGZILLA_PRODUCT_VERSION"
, "31"
)
,
( "LOGO"
, "fedora-logo-icon"
)
]
, parse_errors = []
}

View File

@@ -1,21 +0,0 @@
NAME=Fedora
VERSION="31 (Container Image)"
ID=fedora
VERSION_ID=31
VERSION_CODENAME=""
PLATFORM_ID="platform:f31"
PRETTY_NAME="Fedora 31 (Container Image)"
ANSI_COLOR="0;34"
LOGO=fedora-logo-icon
CPE_NAME="cpe:/o:fedoraproject:fedora:31"
HOME_URL="https://fedoraproject.org/"
DOCUMENTATION_URL="https://docs.fedoraproject.org/en-US/fedora/f31/system-administrators-guide/"
SUPPORT_URL="https://fedoraproject.org/wiki/Communicating_and_getting_help"
BUG_REPORT_URL="https://bugzilla.redhat.com/"
REDHAT_BUGZILLA_PRODUCT="Fedora"
REDHAT_BUGZILLA_PRODUCT_VERSION=31
REDHAT_SUPPORT_PRODUCT="Fedora"
REDHAT_SUPPORT_PRODUCT_VERSION=31
PRIVACY_POLICY_URL="https://fedoraproject.org/wiki/Legal:PrivacyPolicy"
VARIANT="Container Image"
VARIANT_ID=container

View File

@@ -1,24 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Gentoo"
, version = Nothing
, id = "gentoo"
, id_like = Nothing
, version_codename = Nothing
, version_id = Nothing
, pretty_name = "Gentoo/Linux"
, ansi_color = Just "1;32"
, cpe_name = Nothing
, home_url = Just "https://www.gentoo.org/"
, documentation_url = Nothing
, support_url = Just "https://www.gentoo.org/support/"
, bug_report_url = Just "https://bugs.gentoo.org/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields = []
, parse_errors = []
}

View File

@@ -1,8 +0,0 @@
NAME=Gentoo
ID=gentoo
PRETTY_NAME="Gentoo/Linux"
ANSI_COLOR="1;32"
HOME_URL="https://www.gentoo.org/"
SUPPORT_URL="https://www.gentoo.org/support/"
BUG_REPORT_URL="https://bugs.gentoo.org/"

View File

@@ -1,29 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Linux Mint"
, version = Just "18.2 (Sonya)"
, id = "linuxmint"
, id_like = Just "ubuntu"
, version_codename = Just "sonya"
, version_id = Just "18.2"
, pretty_name = "Linux Mint 18.2"
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Just "http://www.linuxmint.com/"
, documentation_url = Nothing
, support_url = Just "http://forums.linuxmint.com/"
, bug_report_url = Just "http://bugs.launchpad.net/linuxmint/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields =
[
( "UBUNTU_CODENAME"
, "xenial"
)
]
, parse_errors = []
}

View File

@@ -1,12 +0,0 @@
NAME="Linux Mint"
VERSION="18.2 (Sonya)"
ID=linuxmint
ID_LIKE=ubuntu
PRETTY_NAME="Linux Mint 18.2"
VERSION_ID="18.2"
HOME_URL="http://www.linuxmint.com/"
SUPPORT_URL="http://forums.linuxmint.com/"
BUG_REPORT_URL="http://bugs.launchpad.net/linuxmint/"
VERSION_CODENAME=sonya
UBUNTU_CODENAME=xenial

View File

@@ -1,41 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Red Hat Enterprise Linux Server"
, version = Just "7.6 (Maipo)"
, id = "rhel"
, id_like = Just "fedora"
, version_codename = Nothing
, version_id = Just "7.6"
, pretty_name = "Red Hat Enterprise Linux"
, ansi_color = Just "0;31"
, cpe_name = Just "cpe:/o:redhat:enterprise_linux:7.6:GA:server"
, home_url = Just "https://www.redhat.com/"
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Just "https://bugzilla.redhat.com/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Just "Server"
, variant_id = Just "server"
, logo = Nothing
}
, unknown_fields =
[
( "REDHAT_SUPPORT_PRODUCT_VERSION"
, "7.6"
)
,
( "REDHAT_BUGZILLA_PRODUCT"
, "Red Hat Enterprise Linux 7"
)
,
( "REDHAT_SUPPORT_PRODUCT"
, "Red Hat Enterprise Linux"
)
,
( "REDHAT_BUGZILLA_PRODUCT_VERSION"
, "7.6"
)
]
, parse_errors = []
}

View File

@@ -1,17 +0,0 @@
NAME="Red Hat Enterprise Linux Server"
VERSION="7.6 (Maipo)"
ID="rhel"
ID_LIKE="fedora"
VARIANT="Server"
VARIANT_ID="server"
VERSION_ID="7.6"
PRETTY_NAME="Red Hat Enterprise Linux"
ANSI_COLOR="0;31"
CPE_NAME="cpe:/o:redhat:enterprise_linux:7.6:GA:server"
HOME_URL="https://www.redhat.com/"
BUG_REPORT_URL="https://bugzilla.redhat.com/"
REDHAT_BUGZILLA_PRODUCT="Red Hat Enterprise Linux 7"
REDHAT_BUGZILLA_PRODUCT_VERSION=7.6
REDHAT_SUPPORT_PRODUCT="Red Hat Enterprise Linux"
REDHAT_SUPPORT_PRODUCT_VERSION="7.6"

View File

@@ -1,49 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Red Hat Enterprise Linux Server"
, version = Just "7.6 (Maipo)"
, id = "rhel"
, id_like = Just "fedora"
, version_codename = Nothing
, version_id = Just "7.6"
, pretty_name = "Red Hat Enterprise Linux"
, ansi_color = Just "0;31"
, cpe_name = Just "cpe:/o:redhat:enterprise_linux:7.6:GA:server"
, home_url = Just "https://www.redhat.com/"
, documentation_url = Nothing
, support_url = Nothing
, bug_report_url = Just "https://bugzilla.redhat.com/"
, privacy_policy_url = Nothing
, build_id = Nothing
, variant = Just "Server"
, variant_id = Just "server"
, logo = Nothing
}
, unknown_fields =
[
( "REDHAT_SUPPORT_PRODUCT_VERSION"
, "7.6"
)
,
( "REDHAT_BUGZILLA_PRODUCT"
, "Red Hat Enterprise Linux 7"
)
,
( "REDHAT_SUPPORT_PRODUCT"
, "Red Hat Enterprise Linux"
)
,
( "REDHAT_BUGZILLA_PRODUCT_VERSION"
, "7.6"
)
]
, parse_errors =
[ TrivialError 520
( Just
( Tokens ( '\'' :| "" ) )
)
( fromList
[ Label ( 'e' :| "nd of line" ) ]
)
]
}

View File

@@ -1,18 +0,0 @@
NAME="Red Hat Enterprise Linux Server"
VERSION="7.6 (Maipo)"
ID="rhel"
ID_LIKE="fedora"
VARIANT="Server"
VARIANT_ID="server"
VERSION_ID="7.6"
PRETTY_NAME="Red Hat Enterprise Linux"
ANSI_COLOR="0;31"
CPE_NAME="cpe:/o:redhat:enterprise_linux:7.6:GA:server"
HOME_URL="https://www.redhat.com/"
BUG_REPORT_URL="https://bugzilla.redhat.com/"
REDHAT_BUGZILLA_PRODUCT="Red Hat Enterprise Linux 7"
REDHAT_BUGZILLA_PRODUCT_VERSION=7.6
REDHAT_SUPPORT_PRODUCT="Red Hat Enterprise Linux"
REDHAT_SUPPORT_PRODUCT_VERSION="7.6"
foo=1.'

View File

@@ -1,29 +0,0 @@
OsReleaseResult
{ osRelease = OsRelease
{ name = "Ubuntu"
, version = Just "20.04 LTS (Focal Fossa)"
, id = "ubuntu"
, id_like = Just "debian"
, version_codename = Just "focal"
, version_id = Just "20.04"
, pretty_name = "Ubuntu 20.04 LTS"
, ansi_color = Nothing
, cpe_name = Nothing
, home_url = Just "https://www.ubuntu.com/"
, documentation_url = Nothing
, support_url = Just "https://help.ubuntu.com/"
, bug_report_url = Just "https://bugs.launchpad.net/ubuntu/"
, privacy_policy_url = Just "https://www.ubuntu.com/legal/terms-and-policies/privacy-policy"
, build_id = Nothing
, variant = Nothing
, variant_id = Nothing
, logo = Nothing
}
, unknown_fields =
[
( "UBUNTU_CODENAME"
, "focal"
)
]
, parse_errors = []
}

View File

@@ -1,13 +0,0 @@
NAME="Ubuntu"
VERSION="20.04 LTS (Focal Fossa)"
ID=ubuntu
ID_LIKE=debian
PRETTY_NAME="Ubuntu 20.04 LTS"
VERSION_ID="20.04"
HOME_URL="https://www.ubuntu.com/"
SUPPORT_URL="https://help.ubuntu.com/"
BUG_REPORT_URL="https://bugs.launchpad.net/ubuntu/"
PRIVACY_POLICY_URL="https://www.ubuntu.com/legal/terms-and-policies/privacy-policy"
VERSION_CODENAME=focal
UBUNTU_CODENAME=focal

View File

@@ -1,16 +0,0 @@
import Golden.Real
import Specs.Megaparsec
import Test.Tasty
import Test.Tasty.Hspec
main :: IO ()
main = do
ms <- testSpec "megaparsec spec" megaparsecSpec
gs <- goldenTests
defaultMain (tests [ms, gs])
tests :: [TestTree] -> TestTree
tests ts = testGroup "Tests" (ts++[])

View File

@@ -1,88 +0,0 @@
module Specs.Megaparsec where
import System.OsRelease
import Data.Either
import Data.Void
import Test.Hspec
import Test.Hspec.Megaparsec
import qualified Text.Megaparsec as MP
megaparsecSpec :: Spec
megaparsecSpec = do
describe "parseAssignment" $ do
it "parses simple value" $ shouldParse' "foo=bar" ("foo", "bar")
it "parses single quoted value" $ shouldParse' "foo='bar'" ("foo", "bar")
it "parses double quoted value" $ shouldParse' "foo=\"bar\"" ("foo", "bar")
it "parses _ var" $ shouldParse' "f_x=''" ("f_x", "")
-- this is not valid per spec, but many files do this
it "parses ._- in unquoted assignment"
$ shouldParse' "VERSION_ID=bar-1.9_rc2" ("VERSION_ID", "bar-1.9_rc2")
it "parses quoted space" $ shouldParse' "f='a b'" ("f", "a b")
it "parses quoted -" $ shouldParse' "f='a-b'" ("f", "a-b")
it "parses special \\" $ shouldParse' "foo='ba\\\\r'" ("foo", "ba\\r")
it "parses special `" $ shouldParse' "foo='ba\\`r'" ("foo", "ba`r")
it "parses special '" $ shouldParse' "foo='ba\\'r'" ("foo", "ba'r")
it "parses special $" $ shouldParse' "foo='ba\\$r'" ("foo", "ba$r")
it "parses special \"" $ shouldParse' "foo=\"ba\\\"r\"" ("foo", "ba\"r")
it "parses empty val noquotes" $ shouldParse' "foo=" ("foo", "")
it "parses empty val quote \"" $ shouldParse' "foo=\"\"" ("foo", "")
it "parses empty val quote '" $ shouldParse' "foo=''" ("foo", "")
it "breaks on comments" $ shouldFail' "# foo=\"bar'"
it "breaks on misquoting 1" $ shouldFail' "foo=\"bar'"
it "breaks on misquoting 2" $ shouldFail' "foo='bar\""
it "breaks on unquoted $" $ shouldFail' "foo='ba$r'"
it "breaks on unquoted `" $ shouldFail' "foo='ba`r'"
it "breaks on unquoted \"" $ shouldFail' "foo=\"ba\"r\""
it "breaks on unquoted '" $ shouldFail' "foo='ba'r'"
it "breaks on unquoted \\" $ shouldFail' "foo='ba\\r'"
it "breaks on unquoted val with space" $ shouldFail' "foo=ba r"
it "breaks on unquoted val with ;" $ shouldFail' "foo=ba;r"
it "breaks on unquoted val with \\" $ shouldFail' "foo=ba\\r"
it "breaks on trailing NL" $ shouldFail' "foo=bar\n"
describe "parseAssignments" $ do
it "parses simple values" $ shouldParseMany "foo=bar" [("foo", "bar")]
it "parses multiple values"
$ shouldParseMany "foo=bar\nbar=baz" [("foo", "bar"), ("bar", "baz")]
it "parses multiple values with comments" $ shouldParseMany
"foo=bar\n# comment\nbar=baz"
[("foo", "bar"), ("bar", "baz")]
it "parses gracefully" $ shouldParseMany "foo=bar\nbar=baz\"" [("foo", "bar")]
it "parses empty files" $ shouldParseMany "" []
it "parses empty files with newlines" $ shouldParseMany "\n\n" []
it "parses empty files with newlines and comments"
$ shouldParseMany "\n\n#\n" []
it "parses comments with leading spaces" $ shouldParseMany " #" []
parse :: String -> Either (MP.ParseErrorBundle String Void) (String, String)
parse = MP.parse (parseAssignment <* MP.eof) ""
shouldParse' :: String -> (String, String) -> Expectation
shouldParse' s s' = parse s `shouldParse` s'
shouldFail' :: String -> Expectation
shouldFail' s = parse `shouldFailOn` s
parseMany :: String
-> Either (MP.ParseErrorBundle String Void) [(String, String)]
parseMany = fmap rights . MP.parse parseAssignments ""
shouldParseMany :: String -> [(String, String)] -> Expectation
shouldParseMany s s' = parseMany s `shouldParse` s'
shouldFailMany :: String -> Expectation
shouldFailMany s = parseMany `shouldFailOn` s

View File

@@ -1,5 +1,15 @@
# Revision history for ghcup
## 0.1.6 -- 2020-07-13
* Create a new curses (brick) based TUI, accessible via `ghcup tui` #24
* Support multiple installed versions of cabal #23
* Improvements to `ghcup list` (show unavailable bindists for platform)
* Fix redhat downloads #29
* Support for hadrian bindists (fixes alpine-8.10.1) #31
* Add FreeBSD bindists 8.6.5 and 8.8.3
* Fix memory leak during unpack
## 0.1.5 -- 2020-04-30
* Fix errors when PATH variable contains path components that are actually files

View File

@@ -40,7 +40,13 @@ export PATH="$HOME/.cabal/bin:$HOME/.ghcup/bin:$PATH"
See `ghcup --help`.
Common use cases are:
For the simple interactive TUI, run:
```sh
ghcup tui
```
For the full functionality via cli:
```sh
# list available ghc/cabal versions

View File

@@ -179,7 +179,7 @@ validateTarballs dls = do
where
downloadAll dli = do
let settings = Settings True False Never Curl
let settings = Settings True False Never Curl False
let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True
, colorOutter = B.hPut stderr
, rawOutter = (\_ -> pure ())

365
app/ghcup/BrickMain.hs Normal file
View File

@@ -0,0 +1,365 @@
{-# LANGUAGE CPP #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE OverloadedStrings #-}
module BrickMain where
import GHCup
import GHCup.Download
import GHCup.Errors
import GHCup.Types
import GHCup.Utils
import GHCup.Utils.File
import GHCup.Utils.Logger
import Brick
import Brick.Widgets.Border
import Brick.Widgets.Border.Style
import Brick.Widgets.Center
import Brick.Widgets.List
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe
import Control.Monad.Logger
import Control.Monad.Reader
import Control.Monad.Trans.Resource
import Data.Bool
import Data.Functor
import Data.List
import Data.Maybe
import Data.Char
import Data.IORef
import Data.String.Interpolate
import Data.Vector ( Vector )
import Data.Versions hiding ( str )
import Haskus.Utils.Variant.Excepts
import Prelude hiding ( appendFile )
import System.Exit
import System.IO.Unsafe
import URI.ByteString
import qualified Data.Text as T
import qualified Graphics.Vty as Vty
import qualified Data.Vector as V
data AppState = AppState {
lr :: LR
, dls :: GHCupDownloads
, pfreq :: PlatformRequest
}
type LR = GenericList String Vector ListResult
keyHandlers :: [(Char, String, AppState -> EventM n (Next AppState))]
keyHandlers =
[ ('q', "Quit" , halt)
, ('i', "Install" , withIOAction install')
, ('u', "Uninstall", withIOAction del')
, ('s', "Set" , withIOAction set')
, ('c', "ChangeLog", withIOAction changelog')
]
ui :: AppState -> Widget String
ui AppState {..} =
( padBottom Max
$ ( withBorderStyle unicode
$ borderWithLabel (str "GHCup")
$ (center $ renderList renderItem True lr)
)
)
<=> ( withAttr "help"
. txtWrap
. T.pack
. foldr1 (\x y -> x <> " " <> y)
. (++ ["↑↓:Navigation"])
$ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
)
where
renderItem b ListResult {..} =
let marks = if
| lSet -> (withAttr "set" $ str "✔✔")
| lInstalled -> (withAttr "installed" $ str "")
| otherwise -> (withAttr "not-installed" $ str "")
ver = case lCross of
Nothing -> T.unpack . prettyVer $ lVer
Just c -> T.unpack (c <> "-" <> prettyVer lVer)
dim = if lNoBindist
then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
else id
in dim
( marks
<+> ( padLeft (Pad 2)
$ minHSize 20
$ ((if b then withAttr "active" else id)
(str $ (fmap toLower . show $ lTool) <> " " <> ver)
)
)
<+> (padLeft (Pad 1) $ if null lTag
then emptyWidget
else
foldr1 (\x y -> x <+> str "," <+> y)
$ (fmap printTag $ sort lTag)
)
)
printTag Recommended = withAttr "recommended" $ str "recommended"
printTag Latest = withAttr "latest" $ str "latest"
printTag (Base pvp'') = str ("base-" ++ T.unpack (prettyPVP pvp''))
printTag (UnknownTag t ) = str t
minHSize :: Int -> Widget n -> Widget n
minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
app :: App AppState e String
app = App { appDraw = \st -> [ui st]
, appHandleEvent = eventHandler
, appStartEvent = return
, appAttrMap = const defaultAttributes
, appChooseCursor = neverShowCursor
}
defaultAttributes :: AttrMap
defaultAttributes = attrMap
Vty.defAttr
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
, ("set" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("installed" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("recommended" , Vty.defAttr `Vty.withForeColor` Vty.green)
, ("latest" , Vty.defAttr `Vty.withForeColor` Vty.yellow)
, ("help" , Vty.defAttr `Vty.withStyle` Vty.italic)
]
dimAttributes :: AttrMap
dimAttributes = attrMap
(Vty.defAttr `Vty.withStyle` Vty.dim)
[ ("active" , Vty.defAttr `Vty.withBackColor` Vty.blue)
, ("no-bindist", Vty.defAttr `Vty.withStyle` Vty.dim)
]
eventHandler :: AppState -> BrickEvent n e -> EventM n (Next AppState)
eventHandler st (VtyEvent (Vty.EvResize _ _)) = continue st
eventHandler st (VtyEvent (Vty.EvKey (Vty.KChar 'q') _)) = halt st
eventHandler st (VtyEvent (Vty.EvKey Vty.KEsc _)) = halt st
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KUp) _)) =
continue (AppState (listMoveUp lr) dls pfreq)
eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
continue (AppState (listMoveDown lr) dls pfreq)
eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
case find (\(c', _, _) -> c' == c) keyHandlers of
Nothing -> continue as
Just (_, _, handler) -> handler as
eventHandler st _ = continue st
-- | Suspend the current UI and run an IO action in terminal. If the
-- IO action returns a Left value, then it's thrown as userError.
withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
-> AppState
-> EventM n (Next AppState)
withIOAction action as = case listSelectedElement (lr as) of
Nothing -> continue as
Just (ix, e) -> suspendAndResume $ do
r <- action as (ix, e)
case r of
Left err -> throwIO $ userError err
Right _ -> do
apps <- (fmap . fmap)
(\AppState {..} -> AppState { lr = listMoveTo ix lr, .. })
$ getAppState Nothing (pfreq as)
case apps of
Right nas -> do
putStrLn "Press enter to continue"
_ <- getLine
pure nas
Left err -> throwIO $ userError err
install' :: AppState -> (Int, ListResult) -> IO (Either String ())
install' AppState {..} (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let
run =
runLogger
. flip runReaderT settings
. runResourceT
. runE
@'[AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
, DistroNotFound
, FileDoesNotExistError
, CopyError
, NoCompatibleArch
, NoDownload
, NotInstalled
, NoCompatiblePlatform
, BuildFailed
, TagNotFound
, DigestError
, DownloadFailed
, NoUpdate]
(run $ do
case lTool of
GHC -> liftE $ installGHCBin dls lVer pfreq
Cabal -> liftE $ installCabalBin dls lVer pfreq
GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft (V (AlreadyInstalled _ _)) -> pure $ Right ()
VLeft (V (BuildFailed _ e)) ->
pure $ Left [i|Build failed with #{e}|]
VLeft (V NoDownload) ->
pure $ Left [i|No available version for #{prettyVer lVer}|]
VLeft (V NoUpdate) -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}
Also check the logs in ~/.ghcup/logs|]
set' :: AppState -> (Int, ListResult) -> IO (Either String ())
set' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run =
runLogger
. flip runReaderT settings
. runE @'[FileDoesNotExistError, NotInstalled, TagNotFound]
(run $ do
case lTool of
GHC -> liftE $ setGHC (GHCTargetVersion lCross lVer) SetGHCOnly $> ()
Cabal -> liftE $ setCabal lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
del' :: AppState -> (Int, ListResult) -> IO (Either String ())
del' _ (_, ListResult {..}) = do
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
(run $ do
case lTool of
GHC -> liftE $ rmGHCVer (GHCTargetVersion lCross lVer) $> ()
Cabal -> liftE $ rmCabalVer lVer $> ()
GHCup -> pure ()
)
>>= \case
VRight _ -> pure $ Right ()
VLeft e -> pure $ Left [i|#{e}|]
changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
changelog' AppState {..} (_, ListResult {..}) = do
case getChangeLog dls lTool (Left lVer) of
Nothing -> pure $ Left
[i|Could not find ChangeLog for #{lTool}, version #{prettyVer lVer}|]
Just uri -> do
let cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
exec cmd True [serializeURIRef' uri] Nothing Nothing >>= \case
Right _ -> pure $ Right ()
Left e -> pure $ Left [i|#{e}|]
uri' :: IORef (Maybe URI)
{-# NOINLINE uri' #-}
uri' = unsafePerformIO (newIORef Nothing)
settings' :: IORef Settings
{-# NOINLINE settings' #-}
settings' = unsafePerformIO
(newIORef Settings { cache = True
, noVerify = False
, keepDirs = Never
, downloader = Curl
, verbose = False
}
)
logger' :: IORef LoggerConfig
{-# NOINLINE logger' #-}
logger' = unsafePerformIO
(newIORef $ LoggerConfig { lcPrintDebug = False
, colorOutter = \_ -> pure ()
, rawOutter = \_ -> pure ()
}
)
brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
brickMain s muri l av pfreq' = do
writeIORef uri' muri
writeIORef settings' s
-- logger interpreter
writeIORef logger' l
let runLogger = myLoggerT l
eApps <- getAppState (Just av) pfreq'
case eApps of
Right as -> defaultMain app (selectLatest as) $> ()
Left e -> do
runLogger ($(logError) [i|Error building app state: #{show e}|])
exitWith $ ExitFailure 2
where
selectLatest :: AppState -> AppState
selectLatest AppState {..} =
(\ix -> AppState { lr = listMoveTo ix lr, .. })
. fromJust
. V.findIndex (\ListResult {..} -> lTool == GHC && Latest `elem` lTag)
$ (listElements lr)
getAppState :: Maybe GHCupDownloads -> PlatformRequest -> IO (Either String AppState)
getAppState mg pfreq' = do
muri <- readIORef uri'
settings <- readIORef settings'
l <- readIORef logger'
let runLogger = myLoggerT l
r <-
runLogger
. flip runReaderT settings
. runE
@'[JSONError, DownloadFailed, FileDoesNotExistError]
$ do
dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
lV <- lift $ listVersions dls Nothing Nothing pfreq'
pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
case r of
VRight a -> pure $ Right a
VLeft e -> pure $ Left [i|#{e}|]

View File

@@ -10,6 +10,10 @@
module Main where
#if defined(BRICK)
import BrickMain ( brickMain )
#endif
import GHCup
import GHCup.Download
import GHCup.Errors
@@ -24,7 +28,9 @@ import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
import GHCup.Version
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Exception.Safe
#if !MIN_VERSION_base(4,13,0)
import Control.Monad.Fail ( MonadFail )
@@ -95,6 +101,9 @@ data Command
| Upgrade UpgradeOpts Bool
| ToolRequirements
| ChangeLog ChangeLogOptions
#if defined(BRICK)
| Interactive
#endif
data ToolVersion = ToolVersion GHCTargetVersion -- target is ignored for cabal
| ToolTag Tag
@@ -223,7 +232,20 @@ opts =
com :: Parser Command
com =
subparser
#if defined(BRICK)
( command
"tui"
( (\_ -> Interactive)
<$> (info
helper
( progDesc "Start the interactive GHCup UI"
)
)
)
<> command
#else
( command
#endif
"install"
( Install
<$> (info
@@ -786,6 +808,7 @@ toSettings Options {..} =
noVerify = optNoVerify
keepDirs = optKeepDirs
downloader = optsDownloader
verbose = optVerbose
in Settings { .. }
@@ -870,11 +893,12 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
-- logger interpreter
logfile <- initGHCupFileLogging [rel|ghcup.log|]
let runLogger = myLoggerT LoggerConfig
let loggerConfig = LoggerConfig
{ lcPrintDebug = optVerbose
, colorOutter = B.hPut stderr
, rawOutter = appendFile logfile
}
let runLogger = myLoggerT loggerConfig
-------------------------
@@ -888,14 +912,13 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runE
@'[ AlreadyInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
, DistroNotFound
#endif
, FileDoesNotExistError
, CopyError
, NoCompatibleArch
, NoDownload
, NotInstalled
, NoCompatiblePlatform
, BuildFailed
, TagNotFound
, DigestError
@@ -910,7 +933,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ FileDoesNotExistError
, NotInstalled
, TagNotFound
, TagNotFound
]
let
@@ -921,9 +943,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, TagNotFound
]
let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
let runListGHC = runLogger
let runRmGHC =
let runRm =
runLogger . flip runReaderT settings . runE @'[NotInstalled]
let runDebugInfo =
@@ -940,16 +962,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
@'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
let runCompileCabal =
@@ -961,15 +982,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
let runUpgrade =
@@ -978,9 +998,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
. runResourceT
. runE
@'[ DigestError
, DistroNotFound
, NoCompatiblePlatform
, NoCompatibleArch
, NoDownload
, NoUpdate
, FileDoesNotExistError
@@ -989,9 +1006,19 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
]
---------------------------
-- Getting download info --
---------------------------
----------------------------------------
-- Getting download and platform info --
----------------------------------------
pfreq <- (
runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
) >>= \case
VRight r -> pure r
VLeft e -> do
runLogger
($(logError) [i|Error determining Platform: #{e}|])
exitWith (ExitFailure 2)
(GHCupInfo treq dls) <-
( runLogger
@@ -1006,14 +1033,8 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
runLogger
($(logError) [i|Error fetching download info: #{e}|])
exitWith (ExitFailure 2)
(runLogger
. runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
)
>>= \case
VRight _ -> pure ()
VLeft e -> do
runLogger
($(logError) [i|Error checking for upgrades: #{e}|])
runLogger $ checkForUpdates dls pfreq
-----------------------
@@ -1023,7 +1044,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installGHC InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer GHC
liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
@@ -1057,7 +1078,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
let installCabal InstallOptions{..} =
(runInstTool $ do
v <- liftE $ fromVersion dls instVer Cabal
liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
)
>>= \case
VRight _ -> do
@@ -1107,7 +1128,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 14
let rmGHC' RmOptions{..} =
(runRmGHC $ do
(runRm $ do
liftE $ rmGHCVer ghcVer
)
>>= \case
@@ -1117,7 +1138,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
pure $ ExitFailure 7
let rmCabal' tv =
(runSetCabal $ do
(runRm $ do
liftE $ rmCabalVer tv
)
>>= \case
@@ -1129,6 +1150,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
res <- case optCommand of
#if defined(BRICK)
Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
#endif
Install (Right iopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
installGHC iopts
@@ -1146,16 +1170,10 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
List (ListOptions {..}) ->
(runListGHC $ do
l <- listVersions dls lTool lCriteria
pure l
l <- listVersions dls lTool lCriteria pfreq
liftIO $ printListResult lRawFormat l
pure ExitSuccess
)
>>= \case
VRight r -> do
liftIO $ printListResult lRawFormat r
pure ExitSuccess
VLeft e -> do
runLogger ($(logError) [i|#{e}|])
pure $ ExitFailure 6
Rm (Right rmopts) -> do
runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
@@ -1182,6 +1200,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
buildConfig
patchDir
addConfArgs
pfreq
)
>>= \case
VRight _ -> do
@@ -1206,7 +1225,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
Compile (CompileCabal CabalCompileOptions {..}) ->
(runCompileCabal $ do
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
)
>>= \case
VRight _ -> do
@@ -1237,7 +1256,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
bdir <- liftIO $ ghcupBinDir
pure (Just (bdir </> [rel|ghcup|]))
(runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
(runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
VRight v' -> do
let pretty_v = prettyVer v'
runLogger $ $(logInfo)
@@ -1289,9 +1308,14 @@ Make sure to clean up #{tmpdir} afterwards.|])
pure ExitSuccess
Just uri -> do
let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
cmd = case _rPlatform pfreq of
Darwin -> "open"
Linux _ -> "xdg-open"
FreeBSD -> "xdg-open"
if clOpen
then
exec "xdg-open"
exec cmd
True
[serializeURIRef' uri]
Nothing
@@ -1383,37 +1407,32 @@ printListResult raw lr = do
checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
=> GHCupDownloads
-> Excepts
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
()
checkForUpdates dls = do
-> PlatformRequest
-> m ()
checkForUpdates dls pfreq = do
forM_ (getLatest dls GHCup) $ \l -> do
(Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
when (l > ghc_ver)
$ lift $ $(logWarn)
$ $(logWarn)
[i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
forM_ (getLatest dls GHC) $ \l -> do
mghc_ver <- latestInstalled GHC
forM mghc_ver $ \ghc_ver ->
when (l > ghc_ver)
$ lift $ $(logWarn)
$ $(logWarn)
[i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
forM_ (getLatest dls Cabal) $ \l -> do
mcabal_ver <- latestInstalled Cabal
forM mcabal_ver $ \cabal_ver ->
when (l > cabal_ver)
$ lift $ $(logWarn)
$ $(logWarn)
[i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
where
latestInstalled tool = (fmap lVer . lastMay)
<$> (listVersions dls (Just tool) (Just ListInstalled))
<$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
prettyDebugInfo :: DebugInfo -> String

View File

@@ -28,7 +28,7 @@ eghcup() {
download_ghcup() {
_plat="$(uname -s)"
_arch=$(uname -m)
_ghver="0.1.5"
_ghver="0.1.6"
case "${_plat}" in
"linux"|"Linux")
@@ -65,7 +65,7 @@ download_ghcup() {
*) die "Unknown architecture: ${_arch}"
;;
esac
_url=https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2 ;;
_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
*) die "Unknown platform: ${_plat}"
;;
esac

View File

@@ -2,6 +2,12 @@ packages: ./ghcup.cabal
optional-packages: ./3rdparty/*/*.cabal
source-repository-package
type: git
location: https://github.com/haskus/packages.git
tag: 80a1c5fc07f7226c424250ec17f674cd4d618f42
subdir: haskus-utils-types
optimization: 2
package streamly
@@ -15,4 +21,4 @@ constraints: http-io-streams -brotli
package libarchive
flags: static
allow-newer: base
allow-newer: base ghc-prim template-haskell

View File

@@ -698,6 +698,13 @@
"dlUri": "https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-alpine3.10-linux-integer-simple.tar.xz"
}
},
"FreeBSD": {
"unknown_versioning": {
"dlHash": "52d27dbf9de82005dde9bfc521bff612e381b5228af194259c2306d2b75825c2",
"dlSubdir": "ghc-8.10.1",
"dlUri": "https://downloads.haskell.org/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz"
}
},
"Linux_Debian": {
"unknown_versioning": {
"dlHash": "d1cf7886f27af070f3b7dbe1975a78b43ef2d32b86362cbe953e79464fe70761",
@@ -849,6 +856,13 @@
"dlUri": "https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.6.5-musl/ghc-8.6.5-x86_64-unknown-linux-musl.tar.xz"
}
},
"FreeBSD": {
"unknown_versioning": {
"dlHash": "83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37",
"dlSubdir": "ghc-8.6.5",
"dlUri": "https://files.hasufell.de/ghc/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz"
}
},
"Linux_Debian": {
"unknown_versioning": {
"dlHash": "bc75f5601a9f41d58b2ba161b9e28fad52143a7229060f1e084168d9b2e914df",
@@ -2002,6 +2016,13 @@
"dlUri": "https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.8.3-musl/ghc-8.8.3-x86_64-unknown-linux-musl.tar.xz"
}
},
"FreeBSD": {
"unknown_versioning": {
"dlHash": "569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be",
"dlSubdir": "ghc-8.8.3",
"dlUri": "https://files.hasufell.de/ghc/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz"
}
},
"Linux_Debian": {
"unknown_versioning": {
"dlHash": "42fde2ef5a143e1e6b47ae8875162ea2d4d54b06f0f7fa32ee4f0eb86f2be7ad",
@@ -2301,37 +2322,37 @@
}
},
"GHCup": {
"0.1.5": {
"0.1.6": {
"viArch": {
"A_64": {
"FreeBSD": {
"unknown_versioning": {
"dlHash": "6dd57cc5958ef3a6ba7de22808d9292d31dada8af95277578b69be35fc090194",
"dlHash": "52707d89c3a4114b577855612d915c1e10295c4354e7e641b4a37a90c34fea53",
"dlSubdir": null,
"dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/x86_64-portbld-freebsd-ghcup-0.1.5"
"dlUri": "https://downloads.haskell.org/ghcup/0.1.6/x86_64-portbld-freebsd-ghcup-0.1.6"
}
},
"Darwin": {
"unknown_versioning": {
"dlHash": "456770c3b1510d44a0e401e0677faa9f5670ef81a11646f47cbba1b95404e788",
"dlHash": "bbf56b5820f97b5ee15d292803a2df06922d31b396f9322459f9e3782e78d59c",
"dlSubdir": null,
"dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2"
"dlUri": "https://downloads.haskell.org/ghcup/0.1.6/x86_64-apple-darwin-ghcup-0.1.6"
}
},
"Linux_UnknownLinux": {
"unknown_versioning": {
"dlHash": "cfdb01dde77121859b5d90b6707238b54e23787fcbb3003e18ab52a5dbfee330",
"dlHash": "bdbec0cdf4c8511c4082dd83993d15034c0fbcb5722ecf418c1cee40667da8af",
"dlSubdir": null,
"dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5"
"dlUri": "https://downloads.haskell.org/ghcup/0.1.6/x86_64-linux-ghcup-0.1.6"
}
}
},
"A_32": {
"Linux_UnknownLinux": {
"unknown_versioning": {
"dlHash": "3707f60d703912709335dc0103fb1af5e5dfa83050825a8156b56bc81760b2a8",
"dlHash": "0366ed6c00862c3c002cdefc3e37523ad80e655387956c7ab58b268aaa6fae5d",
"dlSubdir": null,
"dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5"
"dlUri": "https://downloads.haskell.org/ghcup/0.1.6/i386-linux-ghcup-0.1.6"
}
}
}

View File

@@ -1,6 +1,6 @@
cabal-version: 3.0
name: ghcup
version: 0.1.5
version: 0.1.6
synopsis: ghc toolchain installer as an exe/library
description:
A rewrite of the shell script ghcup, for providing
@@ -21,11 +21,21 @@ source-repository head
type: git
location: https://gitlab.haskell.org/haskell/ghcup-hs.git
flag tui
description: Build the brick powered tui (ghcup tui)
default: False
manual: True
flag internal-downloader
description: Compile the internal downloader, which links against OpenSSL
default: False
manual: True
flag tar
description: Use tar-bytestring instead of libarchive
default: False
manual: True
common HsOpenSSL
build-depends: HsOpenSSL >=0.11.4.18
@@ -50,6 +60,9 @@ common base16-bytestring
common binary
build-depends: binary >=0.8.6.0
common brick
build-depends: brick >=0.54
common bytestring
build-depends: bytestring >=0.10
@@ -158,15 +171,17 @@ common string-interpolate
common table-layout
build-depends: table-layout >=0.8
common template-haskell
build-depends: template-haskell >=2.7
common tar-bytestring
build-depends: tar-bytestring >=0.6.3.1
common terminal-progress-bar
build-depends: terminal-progress-bar >=0.4.1
common text
build-depends: text >=1.2
build-depends: text >=1.2.4.0
common time
build-depends: time >=1.9.3
@@ -198,6 +213,9 @@ common vector
common versions
build-depends: versions >=3.5
common vty
build-depends: vty >=5.28.2
common word8
build-depends: word8 >=0.1.3
@@ -243,7 +261,6 @@ library
, hpath-filepath
, hpath-io
, hpath-posix
, libarchive
, lzma
, megaparsec
, monad-logger
@@ -305,13 +322,21 @@ library
if flag(internal-downloader)
import:
, HsOpenSSL
HsOpenSSL
, http-io-streams
, io-streams
, terminal-progress-bar
exposed-modules: GHCup.Download.IOStreams
cpp-options: -DINTERNAL_DOWNLOADER
if flag(tar)
import:
tar-bytestring
cpp-options: -DTAR
else
import:
libarchive
executable ghcup
import:
config
@@ -321,7 +346,6 @@ executable ghcup
, haskus-utils-variant
, hpath
, hpath-io
, libarchive
, megaparsec
, monad-logger
, mtl
@@ -350,6 +374,19 @@ executable ghcup
if flag(internal-downloader)
cpp-options: -DINTERNAL_DOWNLOADER
if flag(tui)
import:
brick
, vector
, vty
other-modules: BrickMain
cpp-options: -DBRICK
if flag(tar)
cpp-options: -DTAR
else
import:
libarchive
executable ghcup-gen
import:

View File

@@ -27,7 +27,9 @@ import GHCup.Utils.String.QQ
import GHCup.Utils.Version.QQ
import GHCup.Version
#if !defined(TAR)
import Codec.Archive ( ArchiveResult )
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
@@ -85,29 +87,26 @@ installGHCBin :: ( MonadFail m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installGHCBin bDls ver mpfReq = do
installGHCBin bDls ver pfreq@(PlatformRequest {..}) = do
let tver = (mkTVer ver)
lift $ $(logDebug) [i|Requested to install GHC with #{ver}|]
whenM (liftIO $ ghcInstalled tver)
$ (throwE $ AlreadyInstalled GHC ver)
Settings {..} <- lift ask
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
-- download (or use cached version)
dlinfo <- lE $ getDownloadInfo GHC ver pfreq bDls
@@ -130,19 +129,19 @@ installGHCBin bDls ver mpfReq = do
where
-- | Install an unpacked GHC distribution. This only deals with the GHC build system and nothing else.
installGHC' :: (MonadLogger m, MonadIO m)
installGHC' :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m)
=> Path Abs -- ^ Path to the unpacked GHC bindist (where the configure script resides)
-> Path Abs -- ^ Path to install to
-> Excepts '[ProcessError] m ()
installGHC' path inst = do
lift $ $(logInfo) "Installing GHC (this may take a while)"
lEM $ liftIO $ execLogged "./configure"
lEM $ execLogged "./configure"
False
["--prefix=" <> toFilePath inst]
[rel|ghc-configure|]
(Just path)
Nothing
lEM $ liftIO $ make ["install"] (Just path)
lEM $ make ["install"] (Just path)
pure ()
@@ -156,23 +155,22 @@ installCabalBin :: ( MonadMask m
)
=> GHCupDownloads
-> Version
-> Maybe PlatformRequest -- ^ if Nothing, looks up current host platform
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
installCabalBin bDls ver mpfReq = do
installCabalBin bDls ver pfreq@(PlatformRequest {..}) = do
lift $ $(logDebug) [i|Requested to install cabal version #{ver}|]
bindir <- liftIO ghcupBinDir
@@ -186,9 +184,6 @@ installCabalBin bDls ver mpfReq = do
)
$ (throwE $ AlreadyInstalled Cabal ver)
Settings {..} <- lift ask
pfreq@(PlatformRequest {..}) <- maybe (liftE $ platformRequest) pure mpfReq
-- download (or use cached version)
dlinfo <- lE $ getDownloadInfo Cabal ver pfreq bDls
dl <- liftE $ downloadCached dlinfo Nothing
@@ -382,31 +377,25 @@ listVersions :: ( MonadCatch m
=> GHCupDownloads
-> Maybe Tool
-> Maybe ListCriteria
-> Excepts
'[ NoCompatiblePlatform
, NoCompatibleArch
, DistroNotFound
]
m
[ListResult]
listVersions av lt criteria = do
pfreq <- platformRequest
-> PlatformRequest
-> m [ListResult]
listVersions av lt criteria pfreq = do
case lt of
Just t -> do
-- get versions from GHCupDownloads
let avTools = availableToolVersions av t
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult pfreq t)
lr <- filter' <$> forM (Map.toList avTools) (liftIO . toListResult t)
case t of
-- append stray GHCs
GHC -> do
slr <- lift $ strayGHCs avTools
slr <- strayGHCs avTools
pure $ (sort (slr ++ lr))
_ -> pure lr
Nothing -> do
ghcvers <- listVersions av (Just GHC) criteria
cabalvers <- listVersions av (Just Cabal) criteria
ghcupvers <- listVersions av (Just GHCup) criteria
ghcvers <- listVersions av (Just GHC) criteria pfreq
cabalvers <- listVersions av (Just Cabal) criteria pfreq
ghcupvers <- listVersions av (Just GHCup) criteria pfreq
pure (ghcvers <> cabalvers <> ghcupvers)
where
@@ -451,8 +440,8 @@ listVersions av lt criteria = do
pure Nothing
-- NOTE: this are not cross ones, because no bindists
toListResult :: PlatformRequest -> Tool -> (Version, [Tag]) -> IO ListResult
toListResult pfreq t (v, tags) = case t of
toListResult :: Tool -> (Version, [Tag]) -> IO ListResult
toListResult t (v, tags) = case t of
GHC -> do
let lNoBindist = isLeft $ getDownloadInfo GHC v pfreq av
let tver = mkTVer v
@@ -602,24 +591,24 @@ compileGHC :: ( MonadMask m
-> Maybe (Path Abs) -- ^ build config
-> Maybe (Path Abs) -- ^ patch directory
-> [Text] -- ^ additional args to ./configure
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, DigestError
, DistroNotFound
, DownloadFailed
, GHCupSetError
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotFoundInPATH
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs PlatformRequest {..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with #{bstrap}|]
whenM (liftIO $ ghcInstalled tver)
(throwE $ AlreadyInstalled GHC (tver ^. tvVersion))
@@ -633,7 +622,6 @@ compileGHC dls tver bstrap jobs mbuildConfig patchdir aargs = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
bghc <- case bstrap of
@@ -666,7 +654,7 @@ BUILD_SPHINX_PDF = NO
HADDOCK_DOCS = NO
Stage1Only = YES|]
compile :: (MonadCatch m, MonadLogger m, MonadIO m)
compile :: (MonadReader Settings m, MonadThrow m, MonadCatch m, MonadLogger m, MonadIO m)
=> Either (Path Rel) (Path Abs)
-> Path Abs
-> Path Abs
@@ -694,7 +682,7 @@ Stage1Only = YES|]
Left bver -> do
spaths <- catMaybes . fmap parseAbs <$> liftIO getSearchPath
(liftIO $ searchPath spaths bver) !? NotFoundInPATH bver
lEM $ liftIO $ execLogged
lEM $ execLogged
"./configure"
False
( ["--prefix=" <> toFilePath ghcdir]
@@ -708,7 +696,7 @@ Stage1Only = YES|]
(Just workdir)
(Just (("GHC", toFilePath bghcPath) : cEnv))
| otherwise -> do
lEM $ liftIO $ execLogged
lEM $ execLogged
"./configure"
False
( [ "--prefix=" <> toFilePath ghcdir
@@ -733,11 +721,11 @@ Stage1Only = YES|]
liftIO $ writeFile (build_mk workdir) (Just newFilePerms) defaultConf
lift $ $(logInfo) [i|Building (this may take a while)...|]
lEM $ liftIO $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
lEM $ make (maybe [] (\j -> ["-j" <> fS (show j)]) jobs)
(Just workdir)
lift $ $(logInfo) [i|Installing...|]
lEM $ liftIO $ make ["install"] (Just workdir)
lEM $ make ["install"] (Just workdir)
markSrcBuilt ghcdir workdir = do
let dest = (ghcdir </> ghcUpSrcBuiltFile)
@@ -781,24 +769,24 @@ compileCabal :: ( MonadReader Settings m
-> Either Version (Path Abs) -- ^ version to bootstrap with
-> Maybe Int
-> Maybe (Path Abs)
-> PlatformRequest
-> Excepts
'[ AlreadyInstalled
, BuildFailed
, CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NotInstalled
, PatchFailed
, UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
]
m
()
compileCabal dls tver bghc jobs patchdir = do
compileCabal dls tver bghc jobs patchdir PlatformRequest{..} = do
lift $ $(logDebug) [i|Requested to compile: #{tver} with ghc-#{bghc}|]
bindir <- liftIO ghcupBinDir
@@ -819,7 +807,6 @@ compileCabal dls tver bghc jobs patchdir = do
-- unpack
tmpUnpack <- lift mkGhcupTmpDir
liftE $ unpackToDir tmpUnpack dl
(PlatformRequest {..}) <- liftE $ platformRequest
void $ liftIO $ darwinNotarization _rPlatform tmpUnpack
let workdir = maybe id (flip (</>)) (view dlSubdir dlInfo) $ tmpUnpack
@@ -840,7 +827,7 @@ compileCabal dls tver bghc jobs patchdir = do
pure ()
where
compile :: (MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
compile :: (MonadReader Settings m, MonadThrow m, MonadLogger m, MonadIO m, MonadResource m)
=> Path Abs
-> Excepts '[ProcessError , PatchFailed] m (Path Abs)
compile workdir = do
@@ -873,7 +860,7 @@ compileCabal dls tver bghc jobs patchdir = do
newEnv <- lift $ addToCurrentEnv (("PREFIX", toFilePath tmp) : ghcEnv)
lift $ $(logDebug) [i|Environment: #{newEnv}|]
lEM $ liftIO $ execLogged "./bootstrap.sh"
lEM $ execLogged "./bootstrap.sh"
False
(maybe [] (\j -> ["-j", fS (show j)]) jobs)
[rel|cabal-bootstrap|]
@@ -901,23 +888,20 @@ upgradeGHCup :: ( MonadMask m
-> Maybe (Path Abs) -- ^ full file destination to write ghcup into
-> Bool -- ^ whether to force update regardless
-- of currently installed version
-> PlatformRequest
-> Excepts
'[ CopyError
, DigestError
, DistroNotFound
, DownloadFailed
, NoCompatibleArch
, NoCompatiblePlatform
, NoDownload
, NoUpdate
]
m
Version
upgradeGHCup dls mtarget force = do
upgradeGHCup dls mtarget force pfreq = do
lift $ $(logInfo) [i|Upgrading GHCup...|]
let latestVer = fromJust $ getLatest dls GHCup
when (not force && (latestVer <= pvpToVersion ghcUpVer)) $ throwE NoUpdate
pfreq <- liftE platformRequest
dli <- lE $ getDownloadInfo GHCup latestVer pfreq dls
tmp <- lift withGHCupTmpDir
let fn = [rel|ghcup|]
@@ -927,20 +911,13 @@ upgradeGHCup dls mtarget force = do
`unionFileModes` ownerExecuteMode
`unionFileModes` groupExecuteMode
`unionFileModes` otherExecuteMode
case mtarget of
Nothing -> do
dest <- liftIO $ ghcupBinDir
liftIO $ hideError NoSuchThing $ deleteFile (dest </> fn)
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
(dest </> fn)
Overwrite
liftIO $ setFileMode (toFilePath (dest </> fn)) fileMode'
Just fullDest -> do
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
liftIO $ setFileMode (toFilePath fullDest) fileMode'
binDir <- liftIO $ ghcupBinDir
let fullDest = fromMaybe (binDir </> fn) mtarget
liftIO $ hideError NoSuchThing $ deleteFile fullDest
handleIO (throwE . CopyError . show) $ liftIO $ copyFile p
fullDest
Overwrite
liftIO $ setFileMode (toFilePath fullDest) fileMode'
pure latestVer

View File

@@ -2,7 +2,10 @@
{-# LANGUAGE QuasiQuotes #-}
module GHCup.Data.GHCupDownloads where
module GHCup.Data.GHCupDownloads
( ghcupDownloads
)
where
import GHCup.Types
import GHCup.Utils.Version.QQ
@@ -661,6 +664,12 @@ ghc_865_32_musl = DownloadInfo
(Just [rel|ghc-8.6.5|])
"db13ff894faf431f9c64db21c090a1e4e42803794d56720a704c50166c7ca05d"
ghc_865_64_freebsd :: DownloadInfo
ghc_865_64_freebsd = DownloadInfo
[uri|https://files.hasufell.de/ghc/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz|]
(Just [rel|ghc-8.6.5|])
"83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37"
-----------------
@@ -829,6 +838,11 @@ ghc_883_32_musl = DownloadInfo
(Just [rel|ghc-8.8.3|])
"7a5f41646d06777e75636291a1855d60a0984552bbdf33c3d107565d302f38a4"
ghc_883_64_freebsd :: DownloadInfo
ghc_883_64_freebsd = DownloadInfo
[uri|https://files.hasufell.de/ghc/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz|]
(Just [rel|ghc-8.8.3|])
"569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be"
@@ -887,6 +901,11 @@ ghc_8101_64_alpine = DownloadInfo
"cb13b645d103e2fba2eb8dfcc4e5f2fbd9550c00c4df42f342b4210436dcb8a8"
ghc_8101_64_freebsd :: DownloadInfo
ghc_8101_64_freebsd = DownloadInfo
[uri|https://downloads.haskell.org/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz|]
(Just [rel|ghc-8.10.1|])
"52d27dbf9de82005dde9bfc521bff612e381b5228af194259c2306d2b75825c2"
@@ -1020,32 +1039,32 @@ cabal_3200_64_alpine = DownloadInfo
-------------
ghcup_015_32_linux :: DownloadInfo
ghcup_015_32_linux = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5|]
ghcup_016_32_linux :: DownloadInfo
ghcup_016_32_linux = DownloadInfo
[uri|https://downloads.haskell.org/ghcup/0.1.6/i386-linux-ghcup-0.1.6|]
Nothing
"3707f60d703912709335dc0103fb1af5e5dfa83050825a8156b56bc81760b2a8"
"0366ed6c00862c3c002cdefc3e37523ad80e655387956c7ab58b268aaa6fae5d"
ghcup_015_64_linux :: DownloadInfo
ghcup_015_64_linux = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5|]
ghcup_016_64_linux :: DownloadInfo
ghcup_016_64_linux = DownloadInfo
[uri|https://downloads.haskell.org/ghcup/0.1.6/x86_64-linux-ghcup-0.1.6|]
Nothing
"cfdb01dde77121859b5d90b6707238b54e23787fcbb3003e18ab52a5dbfee330"
"bdbec0cdf4c8511c4082dd83993d15034c0fbcb5722ecf418c1cee40667da8af"
ghcup_015_64_freebsd :: DownloadInfo
ghcup_015_64_freebsd = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-portbld-freebsd-ghcup-0.1.5|]
ghcup_016_64_freebsd :: DownloadInfo
ghcup_016_64_freebsd = DownloadInfo
[uri|https://downloads.haskell.org/ghcup/0.1.6/x86_64-portbld-freebsd-ghcup-0.1.6|]
Nothing
"6dd57cc5958ef3a6ba7de22808d9292d31dada8af95277578b69be35fc090194"
"52707d89c3a4114b577855612d915c1e10295c4354e7e641b4a37a90c34fea53"
ghcup_015_64_darwin10_13 :: DownloadInfo
ghcup_015_64_darwin10_13 = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2|]
ghcup_016_64_darwin10_13 :: DownloadInfo
ghcup_016_64_darwin10_13 = DownloadInfo
[uri|https://downloads.haskell.org/ghcup/0.1.6/x86_64-apple-darwin-ghcup-0.1.6|]
Nothing
"456770c3b1510d44a0e401e0677faa9f5670ef81a11646f47cbba1b95404e788"
"bbf56b5820f97b5ee15d292803a2df06922d31b396f9322459f9e3782e78d59c"
@@ -1634,6 +1653,7 @@ ghcupDownloads = M.fromList
)
, (Darwin , M.fromList [(Nothing, ghc_865_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_865_64_musl)])
, (FreeBSD, M.fromList [(Nothing, ghc_865_64_freebsd)])
]
)
, ( A_32
@@ -1796,6 +1816,7 @@ ghcupDownloads = M.fromList
)
, (Darwin , M.fromList [(Nothing, ghc_883_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_883_64_musl)])
, (FreeBSD , M.fromList [(Nothing, ghc_883_64_freebsd)])
]
)
, ( A_32
@@ -1840,7 +1861,7 @@ ghcupDownloads = M.fromList
, (Just [vers|7|], ghc_8101_64_centos)
]
)
, ( Linux RedHat, M.fromList [(Nothing, ghc_8101_64_centos)])
, (Linux RedHat, M.fromList [(Nothing, ghc_8101_64_centos)])
, ( Linux AmazonLinux
, M.fromList [(Nothing, ghc_8101_64_centos)]
)
@@ -1861,6 +1882,7 @@ ghcupDownloads = M.fromList
)
, (Darwin , M.fromList [(Nothing, ghc_8101_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_8101_64_alpine)])
, (FreeBSD , M.fromList [(Nothing, ghc_8101_64_freebsd)])
]
)
, ( A_32
@@ -1983,7 +2005,7 @@ ghcupDownloads = M.fromList
)
, ( GHCup
, M.fromList
[ ( [vver|0.1.5|]
[ ( [vver|0.1.6|]
, VersionInfo
[Recommended, Latest]
(Just
@@ -1994,16 +2016,16 @@ ghcupDownloads = M.fromList
[ ( A_64
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, ghcup_015_64_linux)]
, M.fromList [(Nothing, ghcup_016_64_linux)]
)
, (Darwin , M.fromList [(Nothing, ghcup_015_64_darwin10_13)])
, (FreeBSD, M.fromList [(Nothing, ghcup_015_64_freebsd)])
, (Darwin , M.fromList [(Nothing, ghcup_016_64_darwin10_13)])
, (FreeBSD, M.fromList [(Nothing, ghcup_016_64_freebsd)])
]
)
, ( A_32
, M.fromList
[ ( Linux UnknownLinux
, M.fromList [(Nothing, ghcup_015_32_linux)]
, M.fromList [(Nothing, ghcup_016_32_linux)]
)
]
)

View File

@@ -152,6 +152,7 @@ data Settings = Settings
, noVerify :: Bool
, keepDirs :: KeepDirs
, downloader :: Downloader
, verbose :: Bool
}
deriving Show

View File

@@ -24,7 +24,9 @@ import GHCup.Utils.MegaParsec
import GHCup.Utils.Prelude
import GHCup.Utils.String.QQ
#if !defined(TAR)
import Codec.Archive
#endif
import Control.Applicative
import Control.Exception.Safe
import Control.Monad
@@ -59,13 +61,18 @@ import System.Posix.Files.ByteString ( readSymbolicLink )
import Text.Regex.Posix
import URI.ByteString
#if defined(TAR)
import qualified Codec.Archive.Tar as Tar
#endif
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.ByteString.Lazy as BL
import qualified Data.Map.Strict as Map
#if !defined(TAR)
import qualified Data.Text as T
#endif
import qualified Data.Text.Encoding as E
import qualified Text.Megaparsec as MP
@@ -312,17 +319,30 @@ getLatestGHCFor major' minor' dls = do
unpackToDir :: (MonadLogger m, MonadIO m, MonadThrow m)
=> Path Abs -- ^ destination dir
-> Path Abs -- ^ archive path
-> Excepts '[UnknownArchive, ArchiveResult] m ()
-> Excepts '[UnknownArchive
#if !defined(TAR)
, ArchiveResult
#endif
] m ()
unpackToDir dest av = do
fp <- (decUTF8Safe . toFilePath) <$> basename av
let dfp = decUTF8Safe . toFilePath $ dest
lift $ $(logInfo) [i|Unpacking: #{fp} to #{dfp}|]
fn <- toFilePath <$> basename av
#if defined(TAR)
let untar :: MonadIO m => BL.ByteString -> Excepts '[] m ()
untar = liftIO . Tar.unpack (toFilePath dest) . Tar.read
#else
let untar :: MonadIO m => BL.ByteString -> Excepts '[ArchiveResult] m ()
untar = lEM . liftIO . runArchiveM . unpackToDirLazy (T.unpack . decUTF8Safe . toFilePath $ dest)
#endif
#if defined(TAR)
rf :: MonadIO m => Path Abs -> Excepts '[] m BL.ByteString
#else
rf :: MonadIO m => Path Abs -> Excepts '[ArchiveResult] m BL.ByteString
#endif
rf = liftIO . readFile
-- extract, depending on file extension
@@ -453,10 +473,13 @@ ghcUpSrcBuiltFile = [rel|.ghcup_src_built|]
-- | Calls gmake if it exists in PATH, otherwise make.
make :: [ByteString] -> Maybe (Path Abs) -> IO (Either ProcessError ())
make :: (MonadThrow m, MonadIO m, MonadReader Settings m)
=> [ByteString]
-> Maybe (Path Abs)
-> m (Either ProcessError ())
make args workdir = do
spaths <- catMaybes . fmap parseAbs <$> getSearchPath
has_gmake <- isJust <$> searchPath spaths [rel|gmake|]
spaths <- catMaybes . fmap parseAbs <$> (liftIO getSearchPath)
has_gmake <- isJust <$> (liftIO $ searchPath spaths [rel|gmake|])
let mymake = if has_gmake then "gmake" else "make"
execLogged mymake True args [rel|ghc-make|] workdir Nothing

View File

@@ -1,16 +1,19 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.File where
import GHCup.Utils.Dirs
import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent
import Control.Exception ( evaluate )
import Control.Exception.Safe
import Control.Monad
import Control.Monad.Reader
import Data.ByteString ( ByteString )
import Data.Foldable
import Data.Functor
@@ -101,19 +104,21 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing
execLogged :: ByteString -- ^ thing to execute
execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
=> 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 ())
-> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir
Settings{..} <- ask
ldir <- liftIO ghcupLogsDir
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action
liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd (action verbose)
where
action fd = do
action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout in a region
done <- newEmptyMVar
@@ -122,7 +127,7 @@ execLogged exe spath args lfile chdir env = do
$ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ())
$ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6
$ (if verbose then tee fd stdoutRead else printToRegion fd stdoutRead 6)
-- fork our subprocess
pid <- SPPB.forkProcess $ do
@@ -151,6 +156,17 @@ execLogged exe spath args lfile chdir env = do
closeFd stdoutRead
pure e
tee fileFd fdIn = do
flip finally (readTilEOF lineAction fdIn) -- make sure the last few lines don't get cut off
$ do
hideError eofErrorType $ readTilEOF lineAction fdIn
forever (threadDelay 5000)
where
lineAction bs' = do
void $ SPIB.fdWrite fileFd (bs' <> "\n")
void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file.
printToRegion fileFd fdIn size = do
@@ -170,6 +186,7 @@ execLogged exe spath args lfile chdir env = do
where
-- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction ref rs bs' = do
modifyIORef' ref (swapRegs bs')
regs <- readIORef ref
@@ -193,18 +210,18 @@ execLogged exe spath args lfile chdir env = do
trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
| otherwise = bs
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
-- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do
bs <- SPIB.fdRead fd' 1
if
| bs == "\n" -> pure ""
| bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd'
readTilEOF action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
readTilEOF action' fd' = do
bs <- readLine fd'
void $ action' bs
readTilEOF action' fd'
-- | Capture the stdout and stderr of the given action, which

View File

@@ -42,7 +42,6 @@ deriving instance Data VUnit
#if !MIN_VERSION_base(4,13,0)
deriving instance Lift (NonEmpty Word)
instance Lift Text
#endif
qq :: (Text -> Q Exp) -> QuasiQuoter

View File

@@ -16,7 +16,7 @@ ghcupURL :: URI
ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
ghcUpVer :: PVP
ghcUpVer = [pver|0.1.5|]
ghcUpVer = [pver|0.1.6|]
numericVer :: String
numericVer = T.unpack . prettyPVP $ ghcUpVer

View File

@@ -101,6 +101,7 @@ body#idx p.other-help {
.instructions div.command-button {
display: flex;
align-items: center;
}
.instructions div.command-button button {
@@ -111,7 +112,7 @@ body#idx p.other-help {
border-style: solid;
border-radius: 3px;
margin-left: 1rem;
margin-left: 0.5rem;
margin-right: auto;
margin-top: 25px;
margin-bottom: 25px;
@@ -134,20 +135,21 @@ hr {
#platform-instructions-linux > div > pre,
#platform-instructions-mac > div > pre,
#platform-instructions-freebsd > div > pre,
#platform-instructions-win32 > pre,
#platform-instructions-win64 > pre,
#platform-instructions-win32 > div > pre,
#platform-instructions-win64 > div > pre,
#platform-instructions-default > div > div > pre,
#platform-instructions-unknown > div > div > pre {
background-color: #515151;
color: white;
margin-left: auto;
margin-right: auto;
padding-top: 1rem;
padding-bottom: 1rem;
padding-right: 1rem;
text-align: center;
border-radius: 3px;
box-shadow: inset 0px 0px 20px 0px #333333;
font-size: 0.6em;
width: 40rem;
}
#platform-instructions-win32 a.windows-download,

View File

@@ -46,6 +46,9 @@
<p>
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
</p>
<p class="other-help">You appear to be running Windows 32-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
@@ -55,6 +58,9 @@
To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p>
<p>If you're a Windows Subsystem for Linux user run the following in your terminal, then follow the onscreen instructions to install Haskell.
</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">You appear to be running Windows 64-bit. If not, <a class="default-platform-button" href="#">display all supported installers</a>.</p>
</div>
@@ -77,7 +83,7 @@
<!-- duplicate the default cross-platform instructions -->
<div>
<p>If you are running Linux, macOS or FreeBSD,<br/>run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<p>If you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
</div>
@@ -95,7 +101,7 @@
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<div class="command-button"><pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre><button class="tooltip" onclick="copyToClipboard()"><img src="copy.svg" alt="" /><span class="tooltiptext">Copy to clipboard</span></button></div>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>
@@ -140,7 +146,7 @@
<div id="platform-instructions-default" class="instructions">
<div>
<p>To install Haskell, if you are running Linux, macOS or FreeBSD,<br/>run the following
<p>To install Haskell, if you are running Linux, macOS, FreeBSD or Windows Subsystem for Linux, run the following
in your terminal (as a user other than root), then follow the onscreen instructions.</p>
<pre><span class='ghcup-command'>curl --proto '=https' --tlsv1.2 -sSf https://get-ghcup.haskell.org | sh</span></pre>
<p class="other-help">If you don't like curl | sh, see <a href="https://gitlab.haskell.org/haskell/ghcup-hs#manual-install">other installation methods</a>.</p>