Compare commits

..

30 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
35bf9b5ff2 Merge branch 'libarchive' 2020-07-05 23:33:47 +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 cabal.project.local
.stack-work/ .stack-work/
bin/ bin/
/*.prof
/*.ps
/*.hp
tags
TAGS
/tmp/
.entangled

View File

@@ -97,13 +97,13 @@ variables:
test:linux:recommended: test:linux:recommended:
extends: .test_ghcup_version:linux extends: .test_ghcup_version:linux
variables: variables:
GHC_VERSION: "8.6.5" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
test:linux:latest: test:linux:latest:
extends: .test_ghcup_version:linux extends: .test_ghcup_version:linux
variables: variables:
GHC_VERSION: "8.8.3" GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
allow_failure: true allow_failure: true
@@ -113,13 +113,13 @@ test:linux:latest:
test:mac:recommended: test:mac:recommended:
extends: .test_ghcup_version:darwin extends: .test_ghcup_version:darwin
variables: variables:
GHC_VERSION: "8.6.5" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
test:mac:latest: test:mac:latest:
extends: .test_ghcup_version:darwin extends: .test_ghcup_version:darwin
variables: variables:
GHC_VERSION: "8.8.3" GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
allow_failure: true allow_failure: true
@@ -129,13 +129,13 @@ test:mac:latest:
test:freebsd:recommended: test:freebsd:recommended:
extends: .test_ghcup_version:freebsd extends: .test_ghcup_version:freebsd
variables: variables:
GHC_VERSION: "8.6.5" GHC_VERSION: "8.8.3"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
test:freebsd:latest: test:freebsd:latest:
extends: .test_ghcup_version:freebsd extends: .test_ghcup_version:freebsd
variables: variables:
GHC_VERSION: "8.8.3" GHC_VERSION: "8.10.1"
CABAL_VERSION: "3.2.0.0" CABAL_VERSION: "3.2.0.0"
allow_failure: true allow_failure: true
@@ -193,5 +193,6 @@ release:freebsd:
- ./.gitlab/before_script/freebsd/install_deps.sh - ./.gitlab/before_script/freebsd/install_deps.sh
variables: variables:
ARTIFACT: "x86_64-portbld-freebsd-ghcup" 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 curl -sSfL https://downloads.haskell.org/~ghcup/x86_64-portbld-freebsd-ghcup > ./ghcup-bin
chmod +x ghcup-bin chmod +x ghcup-bin
mkdir -p "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin ./ghcup-bin install ${GHC_VERSION}
# ./ghcup-bin install ${GHC_VERSION} ./ghcup-bin install-cabal ${CABAL_VERSION}
# ./ghcup-bin install-cabal ${CABAL_VERSION} ./ghcup-bin set ${GHC_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"
exit 0 exit 0

View File

@@ -18,29 +18,18 @@ apk add --no-cache \
tar \ tar \
perl perl
ln -s libncurses.so /usr/lib/libtinfo.so ln -sf libncurses.so /usr/lib/libtinfo.so
ln -s libncursesw.so.6 /usr/lib/libtinfow.so.6 ln -sf libncursesw.so.6 /usr/lib/libtinfow.so.6
ln -sf libtinfow.so.6 /usr/lib/libtinfow.so
if [ "${BIT}" = "32" ] ; then 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 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 fi
chmod +x ghcup-bin chmod +x ghcup-bin
./ghcup-bin upgrade
./ghcup-bin install ${GHC_VERSION} ./ghcup-bin install ${GHC_VERSION}
# ./ghcup-bin install-cabal ${CABAL_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"
# utils # utils
apk add --no-cache \ apk add --no-cache \
@@ -57,7 +46,8 @@ apk add --no-cache \
openssl-dev \ openssl-dev \
openssl-libs-static \ openssl-libs-static \
xz \ 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 ecabal update
if [ "${OS}" = "LINUX" ] ; then 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 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 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 fi
mkdir out mkdir out
cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" . cp "$(ecabal new-exec -w ghc-${GHC_VERSION} --verbose=0 --offline sh -- -c 'command -v ghcup')" .
ver=$(./ghcup --numeric-version) ver=$(./ghcup --numeric-version)
strip -s ./ghcup if [ "${OS}" = "DARWIN" ] ; then
strip ./ghcup
else
strip -s ./ghcup
fi
cp ghcup out/${ARTIFACT}-${ver} cp ghcup out/${ARTIFACT}-${ver}

View File

@@ -21,9 +21,9 @@ git describe --always
ecabal update ecabal update
if [ "${OS}" = "DARWIN" ] ; then if [ "${OS}" = "DARWIN" ] ; then
ecabal build -w ghc-${GHC_VERSION} ecabal build -w ghc-${GHC_VERSION} -ftui
else else
ecabal build -w ghc-${GHC_VERSION} -finternal-downloader ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
fi fi
cp "$(ecabal new-exec --enable-tests --verbose=0 --offline sh -- -c 'command -v ghcup')" . 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 ## install ghcup
cabal update 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')" . cp "$(cabal new-exec --verbose=0 --offline sh -- -c 'command -v ghcup')" .
strip -s ghcup strip ./ghcup
cp ghcup "./${ARTIFACT}" cp ghcup "./${ARTIFACT}"

View File

@@ -260,7 +260,7 @@
/* #undef HAVE_ACL_IS_TRIVIAL_NP */ /* #undef HAVE_ACL_IS_TRIVIAL_NP */
/* Define to 1 if you have the <acl/libacl.h> header file. */ /* 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'. */ /* Define to 1 if the system has the type `acl_permset_t'. */
/* #undef HAVE_ACL_PERMSET_T */ /* #undef HAVE_ACL_PERMSET_T */
@@ -453,6 +453,7 @@
/* #undef HAVE_EXPAT_H */ /* #undef HAVE_EXPAT_H */
/* Define to 1 if you have the <ext2fs/ext2_fs.h> header file. */ /* 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. */ /* Define to 1 if you have the `extattr_get_fd' function. */
/* #undef HAVE_EXTATTR_GET_FD */ /* #undef HAVE_EXTATTR_GET_FD */
@@ -605,7 +606,7 @@
/* #undef HAVE_LCHFLAGS */ /* #undef HAVE_LCHFLAGS */
/* Define to 1 if you have the `lchmod' function. */ /* 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 to 1 if you have the `lchown' function. */
#define HAVE_LCHOWN 1 #define HAVE_LCHOWN 1
@@ -1027,10 +1028,10 @@
/* #undef HAVE_STRUCT_STAT_ST_UMTIME */ /* #undef HAVE_STRUCT_STAT_ST_UMTIME */
/* Define to 1 if `tm_gmtoff' is a member of `struct tm'. */ /* 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'. */ /* 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'. */ /* Define to 1 if the system has the type `struct vfsconf'. */
/* #undef HAVE_STRUCT_VFSCONF */ /* #undef HAVE_STRUCT_VFSCONF */
@@ -1042,9 +1043,10 @@
#define HAVE_SYMLINK 1 #define HAVE_SYMLINK 1
/* Define to 1 if you have the <sys/acl.h> header file. */ /* 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 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'. /* 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 HAVE_WMEMMOVE 1
/* Define to 1 if you have a working EXT2_IOC_GETFLAGS */ /* 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 to 1 if you have a working FS_IOC_GETFLAGS */
#define HAVE_WORKING_FS_IOC_GETFLAGS 1 #define HAVE_WORKING_FS_IOC_GETFLAGS 1
@@ -1289,7 +1291,7 @@
#define STDC_HEADERS 1 #define STDC_HEADERS 1
/* Define to 1 if strerror_r returns char *. */ /* 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 to 1 if you can safely include both <sys/time.h> and <time.h>. */
#define TIME_WITH_SYS_TIME 1 #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 # 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 ## 0.1.5 -- 2020-04-30
* Fix errors when PATH variable contains path components that are actually files * 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`. See `ghcup --help`.
Common use cases are: For the simple interactive TUI, run:
```sh
ghcup tui
```
For the full functionality via cli:
```sh ```sh
# list available ghc/cabal versions # list available ghc/cabal versions

View File

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

View File

@@ -28,7 +28,7 @@ eghcup() {
download_ghcup() { download_ghcup() {
_plat="$(uname -s)" _plat="$(uname -s)"
_arch=$(uname -m) _arch=$(uname -m)
_ghver="0.1.5" _ghver="0.1.6"
case "${_plat}" in case "${_plat}" in
"linux"|"Linux") "linux"|"Linux")
@@ -65,7 +65,7 @@ download_ghcup() {
*) die "Unknown architecture: ${_arch}" *) die "Unknown architecture: ${_arch}"
;; ;;
esac 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}" *) die "Unknown platform: ${_plat}"
;; ;;
esac esac

View File

@@ -2,6 +2,12 @@ packages: ./ghcup.cabal
optional-packages: ./3rdparty/*/*.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 optimization: 2
package streamly package streamly
@@ -15,4 +21,4 @@ constraints: http-io-streams -brotli
package libarchive package libarchive
flags: static 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" "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": { "Linux_Debian": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "d1cf7886f27af070f3b7dbe1975a78b43ef2d32b86362cbe953e79464fe70761", "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" "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": { "Linux_Debian": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "bc75f5601a9f41d58b2ba161b9e28fad52143a7229060f1e084168d9b2e914df", "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" "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": { "Linux_Debian": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "42fde2ef5a143e1e6b47ae8875162ea2d4d54b06f0f7fa32ee4f0eb86f2be7ad", "dlHash": "42fde2ef5a143e1e6b47ae8875162ea2d4d54b06f0f7fa32ee4f0eb86f2be7ad",
@@ -2301,37 +2322,37 @@
} }
}, },
"GHCup": { "GHCup": {
"0.1.5": { "0.1.6": {
"viArch": { "viArch": {
"A_64": { "A_64": {
"FreeBSD": { "FreeBSD": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "6dd57cc5958ef3a6ba7de22808d9292d31dada8af95277578b69be35fc090194", "dlHash": "52707d89c3a4114b577855612d915c1e10295c4354e7e641b4a37a90c34fea53",
"dlSubdir": null, "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": { "Darwin": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "456770c3b1510d44a0e401e0677faa9f5670ef81a11646f47cbba1b95404e788", "dlHash": "bbf56b5820f97b5ee15d292803a2df06922d31b396f9322459f9e3782e78d59c",
"dlSubdir": null, "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": { "Linux_UnknownLinux": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "cfdb01dde77121859b5d90b6707238b54e23787fcbb3003e18ab52a5dbfee330", "dlHash": "bdbec0cdf4c8511c4082dd83993d15034c0fbcb5722ecf418c1cee40667da8af",
"dlSubdir": null, "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": { "A_32": {
"Linux_UnknownLinux": { "Linux_UnknownLinux": {
"unknown_versioning": { "unknown_versioning": {
"dlHash": "3707f60d703912709335dc0103fb1af5e5dfa83050825a8156b56bc81760b2a8", "dlHash": "0366ed6c00862c3c002cdefc3e37523ad80e655387956c7ab58b268aaa6fae5d",
"dlSubdir": null, "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 cabal-version: 3.0
name: ghcup name: ghcup
version: 0.1.5 version: 0.1.6
synopsis: ghc toolchain installer as an exe/library synopsis: ghc toolchain installer as an exe/library
description: description:
A rewrite of the shell script ghcup, for providing A rewrite of the shell script ghcup, for providing
@@ -21,11 +21,21 @@ source-repository head
type: git type: git
location: https://gitlab.haskell.org/haskell/ghcup-hs.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 flag internal-downloader
description: Compile the internal downloader, which links against OpenSSL description: Compile the internal downloader, which links against OpenSSL
default: False default: False
manual: True manual: True
flag tar
description: Use tar-bytestring instead of libarchive
default: False
manual: True
common HsOpenSSL common HsOpenSSL
build-depends: HsOpenSSL >=0.11.4.18 build-depends: HsOpenSSL >=0.11.4.18
@@ -50,6 +60,9 @@ common base16-bytestring
common binary common binary
build-depends: binary >=0.8.6.0 build-depends: binary >=0.8.6.0
common brick
build-depends: brick >=0.54
common bytestring common bytestring
build-depends: bytestring >=0.10 build-depends: bytestring >=0.10
@@ -158,15 +171,17 @@ common string-interpolate
common table-layout common table-layout
build-depends: table-layout >=0.8 build-depends: table-layout >=0.8
common template-haskell common template-haskell
build-depends: template-haskell >=2.7 build-depends: template-haskell >=2.7
common tar-bytestring
build-depends: tar-bytestring >=0.6.3.1
common terminal-progress-bar common terminal-progress-bar
build-depends: terminal-progress-bar >=0.4.1 build-depends: terminal-progress-bar >=0.4.1
common text common text
build-depends: text >=1.2 build-depends: text >=1.2.4.0
common time common time
build-depends: time >=1.9.3 build-depends: time >=1.9.3
@@ -198,6 +213,9 @@ common vector
common versions common versions
build-depends: versions >=3.5 build-depends: versions >=3.5
common vty
build-depends: vty >=5.28.2
common word8 common word8
build-depends: word8 >=0.1.3 build-depends: word8 >=0.1.3
@@ -243,7 +261,6 @@ library
, hpath-filepath , hpath-filepath
, hpath-io , hpath-io
, hpath-posix , hpath-posix
, libarchive
, lzma , lzma
, megaparsec , megaparsec
, monad-logger , monad-logger
@@ -305,13 +322,21 @@ library
if flag(internal-downloader) if flag(internal-downloader)
import: import:
, HsOpenSSL HsOpenSSL
, http-io-streams , http-io-streams
, io-streams , io-streams
, terminal-progress-bar , terminal-progress-bar
exposed-modules: GHCup.Download.IOStreams exposed-modules: GHCup.Download.IOStreams
cpp-options: -DINTERNAL_DOWNLOADER cpp-options: -DINTERNAL_DOWNLOADER
if flag(tar)
import:
tar-bytestring
cpp-options: -DTAR
else
import:
libarchive
executable ghcup executable ghcup
import: import:
config config
@@ -321,7 +346,6 @@ executable ghcup
, haskus-utils-variant , haskus-utils-variant
, hpath , hpath
, hpath-io , hpath-io
, libarchive
, megaparsec , megaparsec
, monad-logger , monad-logger
, mtl , mtl
@@ -350,6 +374,19 @@ executable ghcup
if flag(internal-downloader) if flag(internal-downloader)
cpp-options: -DINTERNAL_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 executable ghcup-gen
import: import:

View File

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

View File

@@ -2,7 +2,10 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
module GHCup.Data.GHCupDownloads where module GHCup.Data.GHCupDownloads
( ghcupDownloads
)
where
import GHCup.Types import GHCup.Types
import GHCup.Utils.Version.QQ import GHCup.Utils.Version.QQ
@@ -661,6 +664,12 @@ ghc_865_32_musl = DownloadInfo
(Just [rel|ghc-8.6.5|]) (Just [rel|ghc-8.6.5|])
"db13ff894faf431f9c64db21c090a1e4e42803794d56720a704c50166c7ca05d" "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|]) (Just [rel|ghc-8.8.3|])
"7a5f41646d06777e75636291a1855d60a0984552bbdf33c3d107565d302f38a4" "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" "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_016_32_linux :: DownloadInfo
ghcup_015_32_linux = DownloadInfo ghcup_016_32_linux = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5|] [uri|https://downloads.haskell.org/ghcup/0.1.6/i386-linux-ghcup-0.1.6|]
Nothing Nothing
"3707f60d703912709335dc0103fb1af5e5dfa83050825a8156b56bc81760b2a8" "0366ed6c00862c3c002cdefc3e37523ad80e655387956c7ab58b268aaa6fae5d"
ghcup_015_64_linux :: DownloadInfo ghcup_016_64_linux :: DownloadInfo
ghcup_015_64_linux = DownloadInfo ghcup_016_64_linux = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5|] [uri|https://downloads.haskell.org/ghcup/0.1.6/x86_64-linux-ghcup-0.1.6|]
Nothing Nothing
"cfdb01dde77121859b5d90b6707238b54e23787fcbb3003e18ab52a5dbfee330" "bdbec0cdf4c8511c4082dd83993d15034c0fbcb5722ecf418c1cee40667da8af"
ghcup_015_64_freebsd :: DownloadInfo ghcup_016_64_freebsd :: DownloadInfo
ghcup_015_64_freebsd = DownloadInfo ghcup_016_64_freebsd = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-portbld-freebsd-ghcup-0.1.5|] [uri|https://downloads.haskell.org/ghcup/0.1.6/x86_64-portbld-freebsd-ghcup-0.1.6|]
Nothing Nothing
"6dd57cc5958ef3a6ba7de22808d9292d31dada8af95277578b69be35fc090194" "52707d89c3a4114b577855612d915c1e10295c4354e7e641b4a37a90c34fea53"
ghcup_015_64_darwin10_13 :: DownloadInfo ghcup_016_64_darwin10_13 :: DownloadInfo
ghcup_015_64_darwin10_13 = DownloadInfo ghcup_016_64_darwin10_13 = DownloadInfo
[uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2|] [uri|https://downloads.haskell.org/ghcup/0.1.6/x86_64-apple-darwin-ghcup-0.1.6|]
Nothing Nothing
"456770c3b1510d44a0e401e0677faa9f5670ef81a11646f47cbba1b95404e788" "bbf56b5820f97b5ee15d292803a2df06922d31b396f9322459f9e3782e78d59c"
@@ -1634,6 +1653,7 @@ ghcupDownloads = M.fromList
) )
, (Darwin , M.fromList [(Nothing, ghc_865_64_darwin)]) , (Darwin , M.fromList [(Nothing, ghc_865_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_865_64_musl)]) , (Linux Alpine, M.fromList [(Nothing, ghc_865_64_musl)])
, (FreeBSD, M.fromList [(Nothing, ghc_865_64_freebsd)])
] ]
) )
, ( A_32 , ( A_32
@@ -1796,6 +1816,7 @@ ghcupDownloads = M.fromList
) )
, (Darwin , M.fromList [(Nothing, ghc_883_64_darwin)]) , (Darwin , M.fromList [(Nothing, ghc_883_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_883_64_musl)]) , (Linux Alpine, M.fromList [(Nothing, ghc_883_64_musl)])
, (FreeBSD , M.fromList [(Nothing, ghc_883_64_freebsd)])
] ]
) )
, ( A_32 , ( A_32
@@ -1840,7 +1861,7 @@ ghcupDownloads = M.fromList
, (Just [vers|7|], ghc_8101_64_centos) , (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 , ( Linux AmazonLinux
, M.fromList [(Nothing, ghc_8101_64_centos)] , M.fromList [(Nothing, ghc_8101_64_centos)]
) )
@@ -1861,6 +1882,7 @@ ghcupDownloads = M.fromList
) )
, (Darwin , M.fromList [(Nothing, ghc_8101_64_darwin)]) , (Darwin , M.fromList [(Nothing, ghc_8101_64_darwin)])
, (Linux Alpine, M.fromList [(Nothing, ghc_8101_64_alpine)]) , (Linux Alpine, M.fromList [(Nothing, ghc_8101_64_alpine)])
, (FreeBSD , M.fromList [(Nothing, ghc_8101_64_freebsd)])
] ]
) )
, ( A_32 , ( A_32
@@ -1983,7 +2005,7 @@ ghcupDownloads = M.fromList
) )
, ( GHCup , ( GHCup
, M.fromList , M.fromList
[ ( [vver|0.1.5|] [ ( [vver|0.1.6|]
, VersionInfo , VersionInfo
[Recommended, Latest] [Recommended, Latest]
(Just (Just
@@ -1994,16 +2016,16 @@ ghcupDownloads = M.fromList
[ ( A_64 [ ( A_64
, M.fromList , M.fromList
[ ( Linux UnknownLinux [ ( 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)]) , (Darwin , M.fromList [(Nothing, ghcup_016_64_darwin10_13)])
, (FreeBSD, M.fromList [(Nothing, ghcup_015_64_freebsd)]) , (FreeBSD, M.fromList [(Nothing, ghcup_016_64_freebsd)])
] ]
) )
, ( A_32 , ( A_32
, M.fromList , M.fromList
[ ( Linux UnknownLinux [ ( 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 , noVerify :: Bool
, keepDirs :: KeepDirs , keepDirs :: KeepDirs
, downloader :: Downloader , downloader :: Downloader
, verbose :: Bool
} }
deriving Show deriving Show

View File

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

View File

@@ -1,16 +1,19 @@
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
module GHCup.Utils.File where module GHCup.Utils.File where
import GHCup.Utils.Dirs import GHCup.Utils.Dirs
import GHCup.Utils.Prelude import GHCup.Utils.Prelude
import GHCup.Types
import Control.Concurrent import Control.Concurrent
import Control.Exception ( evaluate ) import Control.Exception ( evaluate )
import Control.Exception.Safe import Control.Exception.Safe
import Control.Monad import Control.Monad
import Control.Monad.Reader
import Data.ByteString ( ByteString ) import Data.ByteString ( ByteString )
import Data.Foldable import Data.Foldable
import Data.Functor import Data.Functor
@@ -101,19 +104,21 @@ executeOut path args chdir = captureOutStreams $ do
SPPB.executeFile (toFilePath path) True args Nothing 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 -> Bool -- ^ whether to search PATH for the thing
-> [ByteString] -- ^ args for the thing -> [ByteString] -- ^ args for the thing
-> Path Rel -- ^ log filename -> Path Rel -- ^ log filename
-> Maybe (Path Abs) -- ^ optionally chdir into this -> Maybe (Path Abs) -- ^ optionally chdir into this
-> Maybe [(ByteString, ByteString)] -- ^ optional environment -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-> IO (Either ProcessError ()) -> m (Either ProcessError ())
execLogged exe spath args lfile chdir env = do execLogged exe spath args lfile chdir env = do
ldir <- ghcupLogsDir Settings{..} <- ask
ldir <- liftIO ghcupLogsDir
logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log") logfile <- (ldir </>) <$> parseRel (toFilePath lfile <> ".log")
bracket (createFile (toFilePath logfile) newFilePerms) closeFd action liftIO $ bracket (createFile (toFilePath logfile) newFilePerms) closeFd (action verbose)
where where
action fd = do action verbose fd = do
actionWithPipes $ \(stdoutRead, stdoutWrite) -> do actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-- start the thread that logs to stdout in a region -- start the thread that logs to stdout in a region
done <- newEmptyMVar done <- newEmptyMVar
@@ -122,7 +127,7 @@ execLogged exe spath args lfile chdir env = do
$ EX.handle (\(_ :: StopThread) -> pure ()) $ EX.handle (\(_ :: StopThread) -> pure ())
$ EX.handle (\(_ :: IOException) -> pure ()) $ EX.handle (\(_ :: IOException) -> pure ())
$ flip finally (putMVar done ()) $ flip finally (putMVar done ())
$ printToRegion fd stdoutRead 6 $ (if verbose then tee fd stdoutRead else printToRegion fd stdoutRead 6)
-- fork our subprocess -- fork our subprocess
pid <- SPPB.forkProcess $ do pid <- SPPB.forkProcess $ do
@@ -151,6 +156,17 @@ execLogged exe spath args lfile chdir env = do
closeFd stdoutRead closeFd stdoutRead
pure e 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 -- Reads fdIn and logs the output in a continous scrolling area
-- of 'size' terminal lines. Also writes to a log file. -- of 'size' terminal lines. Also writes to a log file.
printToRegion fileFd fdIn size = do printToRegion fileFd fdIn size = do
@@ -170,6 +186,7 @@ execLogged exe spath args lfile chdir env = do
where where
-- action to perform line by line -- action to perform line by line
-- TODO: do this with vty for efficiency
lineAction ref rs bs' = do lineAction ref rs bs' = do
modifyIORef' ref (swapRegs bs') modifyIORef' ref (swapRegs bs')
regs <- readIORef ref 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 <> "..." trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
| otherwise = bs | otherwise = bs
-- read an entire line from the file descriptor (removes the newline char) -- read an entire line from the file descriptor (removes the newline char)
readLine fd' = do readLine fd' = do
bs <- SPIB.fdRead fd' 1 bs <- SPIB.fdRead fd' 1
if if
| bs == "\n" -> pure "" | bs == "\n" -> pure ""
| bs == "" -> pure "" | bs == "" -> pure ""
| otherwise -> fmap (bs <>) $ readLine fd' | otherwise -> fmap (bs <>) $ readLine fd'
readTilEOF action' fd' = do readTilEOF action' fd' = do
bs <- readLine fd' bs <- readLine fd'
void $ action' bs void $ action' bs
readTilEOF action' fd' readTilEOF action' fd'
-- | Capture the stdout and stderr of the given action, which -- | 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) #if !MIN_VERSION_base(4,13,0)
deriving instance Lift (NonEmpty Word) deriving instance Lift (NonEmpty Word)
instance Lift Text
#endif #endif
qq :: (Text -> Q Exp) -> QuasiQuoter 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|] ghcupURL = [uri|https://www.haskell.org/ghcup/data/ghcup-0.0.2.json|]
ghcUpVer :: PVP ghcUpVer :: PVP
ghcUpVer = [pver|0.1.5|] ghcUpVer = [pver|0.1.6|]
numericVer :: String numericVer :: String
numericVer = T.unpack . prettyPVP $ ghcUpVer numericVer = T.unpack . prettyPVP $ ghcUpVer

View File

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

View File

@@ -46,6 +46,9 @@
<p> <p>
To install Haskell, follow the instructions on To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a> <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>
<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> <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> </div>
@@ -55,6 +58,9 @@
To install Haskell, follow the instructions on To install Haskell, follow the instructions on
<a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a> <a class="windows-download" href="https://www.haskell.org/platform/#windows">Haskell Platform</a>
</p> </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> <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> </div>
@@ -77,7 +83,7 @@
<!-- duplicate the default cross-platform instructions --> <!-- duplicate the default cross-platform instructions -->
<div> <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> <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> <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> </div>
@@ -95,7 +101,7 @@
<div id="platform-instructions-default" class="instructions"> <div id="platform-instructions-default" class="instructions">
<div> <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> 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> <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> <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 id="platform-instructions-default" class="instructions">
<div> <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> 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> <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> <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>