Fix

This should only be necessary in edge cases.

.gitignore

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

.gitlab-ci.yml

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

.gitlab/before_script/freebsd/install_deps.sh

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

.gitlab/before_script/linux/alpine/install_deps.sh

@@ -23,13 +23,26 @@ ln -sf libncursesw.so.6 /usr/lib/libtinfow.so.6
 ln -sf libtinfow.so.6 /usr/lib/libtinfow.so
 
 if [ "${BIT}" = "32" ] ; then
-	curl -sSfL https://downloads.haskell.org/ghcup/i386-linux-ghcup > ./ghcup-bin
+	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5 > ./ghcup-bin
 else
-	curl -sSfL https://downloads.haskell.org/ghcup/x86_64-linux-ghcup > ./ghcup-bin
+	curl -sSfL https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5 > ./ghcup-bin
 fi
 chmod +x ghcup-bin
+./ghcup-bin upgrade
 ./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
 apk add --no-cache \

.gitlab/script/ghcup_release.sh

@@ -17,12 +17,13 @@ ecabal update
 
 if [ "${OS}" = "LINUX" ] ; then
 	if [ "${BIT}" = "32" ] ; then
-		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -ftar
+		rm -r 3rdparty/libarchive
+		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static'
 	else
-		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui -finternal-downloader
+		ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections -optl-static' -ftui
 	fi
 elif [ "${OS}" = "FREEBSD" ] ; then
-	ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static" -ftui
+	ecabal build -w ghc-${GHC_VERSION} --ghc-options='-split-sections' --constraint="zlib static"
 else
 	ecabal build -w ghc-${GHC_VERSION} --constraint="zlib static" --constraint="lzma static" -ftui
 fi

.travis/build.sh

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

3rdparty/libarchive/c/autoconf-linux/config.h

@@ -606,7 +606,7 @@
 /* #undef HAVE_LCHFLAGS */
 
 /* Define to 1 if you have the `lchmod' function. */
-/* #undef HAVE_LCHMOD 1 */
+#define HAVE_LCHMOD 1
 
 /* Define to 1 if you have the `lchown' function. */
 #define HAVE_LCHOWN 1
@@ -1028,10 +1028,10 @@
 /* #undef HAVE_STRUCT_STAT_ST_UMTIME */
 
 /* Define to 1 if `tm_gmtoff' is a member of `struct tm'. */
-/* #undef HAVE_STRUCT_TM_TM_GMTOFF 1 */
+#define HAVE_STRUCT_TM_TM_GMTOFF 1
 
 /* Define to 1 if `__tm_gmtoff' is a member of `struct tm'. */
-/* #undef HAVE_STRUCT_TM___TM_GMTOFF 1 */
+#define HAVE_STRUCT_TM___TM_GMTOFF 1
 
 /* Define to 1 if the system has the type `struct vfsconf'. */
 /* #undef HAVE_STRUCT_VFSCONF */

3rdparty/os-release/.gitattributes

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

3rdparty/os-release/.gitignore

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

3rdparty/os-release/ChangeLog.rst

@@ -0,0 +1,16 @@
+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

3rdparty/os-release/LICENSE

@@ -0,0 +1,26 @@
+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.

3rdparty/os-release/README.rst

@@ -0,0 +1,17 @@
+##########
+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")])

3rdparty/os-release/Setup.hs

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

3rdparty/os-release/library/System/OsRelease.hs

@@ -0,0 +1,192 @@
+{-# 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

3rdparty/os-release/library/System/OsRelease/Megaparsec.hs

@@ -0,0 +1,102 @@
+{-# 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

3rdparty/os-release/os-release.cabal

@@ -0,0 +1,131 @@
+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

3rdparty/os-release/tests/Golden/Real.hs

@@ -0,0 +1,35 @@
+{-# 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

3rdparty/os-release/tests/Golden/data/alpine.golden

@@ -0,0 +1,24 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/alpine.in

@@ -0,0 +1,7 @@
+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/"
+

3rdparty/os-release/tests/Golden/data/arch.golden

@@ -0,0 +1,29 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/arch.in

@@ -0,0 +1,11 @@
+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
+

3rdparty/os-release/tests/Golden/data/centos.golden

@@ -0,0 +1,45 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/centos.in

@@ -0,0 +1,17 @@
+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"
+

3rdparty/os-release/tests/Golden/data/debian.golden

@@ -0,0 +1,24 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/debian.in

@@ -0,0 +1,8 @@
+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/"

3rdparty/os-release/tests/Golden/data/empty.golden

@@ -0,0 +1,24 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/empty.in

@@ -0,0 +1 @@
+

3rdparty/os-release/tests/Golden/data/exherbo.golden

@@ -0,0 +1,24 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/exherbo.in

@@ -0,0 +1,9 @@
+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/"
+

3rdparty/os-release/tests/Golden/data/fedora.golden

@@ -0,0 +1,49 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/fedora.in

@@ -0,0 +1,21 @@
+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

3rdparty/os-release/tests/Golden/data/gentoo.golden

@@ -0,0 +1,24 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/gentoo.in

@@ -0,0 +1,8 @@
+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/"
+

3rdparty/os-release/tests/Golden/data/mint.golden

@@ -0,0 +1,29 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/mint.in

@@ -0,0 +1,12 @@
+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
+

3rdparty/os-release/tests/Golden/data/red-hat.golden

@@ -0,0 +1,41 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/red-hat.in

@@ -0,0 +1,17 @@
+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"

3rdparty/os-release/tests/Golden/data/red-hat_parseErrors.golden

@@ -0,0 +1,49 @@
+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" ) ]
+            )
+        ]
+    }

3rdparty/os-release/tests/Golden/data/red-hat_parseErrors.in

@@ -0,0 +1,18 @@
+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.'

3rdparty/os-release/tests/Golden/data/ubuntu.golden

@@ -0,0 +1,29 @@
+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 = []
+    }

3rdparty/os-release/tests/Golden/data/ubuntu.in

@@ -0,0 +1,13 @@
+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
+

3rdparty/os-release/tests/Main.hs

@@ -0,0 +1,16 @@
+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++[])
+

3rdparty/os-release/tests/Specs/Megaparsec.hs

@@ -0,0 +1,88 @@
+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

CHANGELOG.md

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

app/ghcup-gen/Validate.hs

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

app/ghcup/BrickMain.hs

@@ -1,4 +1,3 @@
-{-# LANGUAGE CPP               #-}
 {-# LANGUAGE DataKinds         #-}
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE TypeApplications  #-}
@@ -20,9 +19,7 @@ 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
@@ -30,7 +27,6 @@ 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
@@ -50,22 +46,11 @@ 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
@@ -74,13 +59,15 @@ ui AppState {..} =
       $ (center $ renderList renderItem True lr)
       )
     )
-    <=> ( withAttr "help"
+    <=> foldr1
-        . txtWrap
+          (\x y -> x <+> str "  " <+> y)
-        . T.pack
+          [ (str "q:Quit")
-        . foldr1 (\x y -> x <> "  " <> y)
+          , (str "i:Install")
-        . (++ ["↑↓:Navigation"])
+          , (str "s:Set")
-        $ (fmap (\(c, s, _) -> (c : ':' : s)) keyHandlers)
+          , (str "u:Uninstall")
-        )
+          , (str "c:ChangeLog")
+          , (str "↑↓:Navigation")
+          ]
 
  where
   renderItem b ListResult {..} =
@@ -91,24 +78,21 @@ ui AppState {..} =
         ver = case lCross of
           Nothing -> T.unpack . prettyVer $ lVer
           Just c  -> T.unpack (c <> "-" <> prettyVer lVer)
-        dim = if lNoBindist
+    in  (   marks
-          then updateAttrMap (const dimAttributes) . withAttr "no-bindist"
+        <+> ( padLeft (Pad 2)
-          else id
+            $ minHSize 20
-    in  dim
+            $ (withAttr
-          (   marks
+                (bool "inactive" "active" b)
-          <+> ( padLeft (Pad 2)
+                (str (fmap toLower . show $ lTool) <+> str " " <+> str ver)
-              $ minHSize 20
-              $ ((if b then withAttr "active" else id)
-                  (str $ (fmap toLower . show $ lTool) <> " " <> ver)
-                )
               )
-          <+> (padLeft (Pad 1) $ if null lTag
+            )
-                then emptyWidget
+        <+> (padLeft (Pad 1) $ if null lTag
-                else
+              then str ""
-                  foldr1 (\x y -> x <+> str "," <+> y)
+              else
-                    $ (fmap printTag $ sort lTag)
+                foldr1 (\x y -> x <+> str "," <+> y)
-              )
+                  $ (fmap printTag $ sort lTag)
-          )
+            )
+        )
 
   printTag Recommended        = withAttr "recommended" $ str "recommended"
   printTag Latest             = withAttr "latest" $ str "latest"
@@ -117,37 +101,26 @@ ui AppState {..} =
 
 
 minHSize :: Int -> Widget n -> Widget n
-minHSize s' = hLimit s' . vLimit 1 . (<+> fill ' ')
+minHSize s' = hLimit s' . vLimit 1 . (<+> str (replicate s' ' '))
 
 
 app :: App AppState e String
 app = App { appDraw         = \st -> [ui st]
           , appHandleEvent  = eventHandler
           , appStartEvent   = return
-          , appAttrMap      = const defaultAttributes
+          , appAttrMap      = const theMap
           , appChooseCursor = neverShowCursor
           }
-
+ where
-defaultAttributes :: AttrMap
+  theMap = attrMap
-defaultAttributes = attrMap
+    Vty.defAttr
-  Vty.defAttr
+    [ ("active"       , bg Vty.blue)
-  [ ("active"       , Vty.defAttr `Vty.withBackColor` Vty.blue)
+    , ("not-installed", fg Vty.red)
-  , ("not-installed", Vty.defAttr `Vty.withForeColor` Vty.red)
+    , ("set"          , fg Vty.green)
-  , ("set"          , Vty.defAttr `Vty.withForeColor` Vty.green)
+    , ("installed"    , fg Vty.green)
-  , ("installed"    , Vty.defAttr `Vty.withForeColor` Vty.green)
+    , ("recommended"  , fg Vty.green)
-  , ("recommended"  , Vty.defAttr `Vty.withForeColor` Vty.green)
+    , ("latest"       , fg Vty.yellow)
-  , ("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)
@@ -155,43 +128,37 @@ 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)
+  continue (AppState (listMoveUp lr) dls)
 eventHandler AppState {..} (VtyEvent (Vty.EvKey (Vty.KDown) _)) =
-  continue (AppState (listMoveDown lr) dls pfreq)
+  continue (AppState (listMoveDown lr) dls)
-eventHandler as (VtyEvent (Vty.EvKey (Vty.KChar c) _)) =
+eventHandler AppState { dls = dls', lr = lr' } (VtyEvent (Vty.EvKey (Vty.KChar c) _))
-  case find (\(c', _, _) -> c' == c) keyHandlers of
+  | (Just (ix, e)) <- listSelectedElement lr'
-    Nothing              -> continue as
+  , c `elem` ['i', 's', 'u', 'c']
-    Just (_, _, handler) -> handler as
+  = suspendAndResume $ do
-eventHandler st _ = continue st
+    r <- case c of
-
+      'i' -> install' e dls'
-
+      's' -> set' e
--- | Suspend the current UI and run an IO action in terminal. If the
+      'u' -> del' e
--- IO action returns a Left value, then it's thrown as userError.
+      'c' -> changelog' e dls'
-withIOAction :: (AppState -> (Int, ListResult) -> IO (Either String a))
+      _   -> error ""
-             -> 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)
+          getAppState
         case apps of
-          Right nas -> do
+          Right as  -> do
             putStrLn "Press enter to continue"
             _ <- getLine
-            pure nas
+            pure as
-          Left err -> throwIO $ userError err
+          Left  err -> throwIO $ userError err
+eventHandler st _ = continue st
 
 
-install' :: AppState -> (Int, ListResult) -> IO (Either String ())
+install' :: ListResult -> GHCupDownloads -> IO (Either String ())
-install' AppState {..} (_, ListResult {..}) = do
+install' ListResult {..} dls = do
-  settings <- readIORef settings'
+  l <- readIORef logger'
-  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   let
@@ -200,26 +167,13 @@ install' AppState {..} (_, ListResult {..}) = do
         . flip runReaderT settings
         . runResourceT
         . runE
-          @'[AlreadyInstalled
+          @'[AlreadyInstalled, UnknownArchive, ArchiveResult, DistroNotFound, FileDoesNotExistError, CopyError, NoCompatibleArch, NoDownload, NotInstalled, NoCompatiblePlatform, BuildFailed, TagNotFound, DigestError, DownloadFailed, NoUpdate]
-            , UnknownArchive
-#if !defined(TAR)
-            , ArchiveResult
-#endif
-            , FileDoesNotExistError
-            , CopyError
-            , NoDownload
-            , NotInstalled
-            , BuildFailed
-            , TagNotFound
-            , DigestError
-            , DownloadFailed
-            , NoUpdate]
 
   (run $ do
       case lTool of
-        GHC   -> liftE $ installGHCBin dls lVer pfreq
+        GHC   -> liftE $ installGHCBin dls lVer Nothing
-        Cabal -> liftE $ installCabalBin dls lVer pfreq
+        Cabal -> liftE $ installCabalBin dls lVer Nothing
-        GHCup -> liftE $ upgradeGHCup dls Nothing False pfreq $> ()
+        GHCup -> liftE $ upgradeGHCup dls Nothing False $> ()
     )
     >>= \case
           VRight _                          -> pure $ Right ()
@@ -233,10 +187,9 @@ install' AppState {..} (_, ListResult {..}) = do
 Also check the logs in ~/.ghcup/logs|]
 
 
-set' :: AppState -> (Int, ListResult) -> IO (Either String ())
+set' :: ListResult -> IO (Either String ())
-set' _ (_, ListResult {..}) = do
+set' ListResult {..} = do
-  settings <- readIORef settings'
+  l <- readIORef logger'
-  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   let run =
@@ -255,10 +208,9 @@ set' _ (_, ListResult {..}) = do
           VLeft  e -> pure $ Left [i|#{e}|]
 
 
-del' :: AppState -> (Int, ListResult) -> IO (Either String ())
+del' :: ListResult -> IO (Either String ())
-del' _ (_, ListResult {..}) = do
+del' ListResult {..} = do
-  settings <- readIORef settings'
+  l <- readIORef logger'
-  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   let run = runLogger . flip runReaderT settings . runE @'[NotInstalled]
@@ -274,36 +226,23 @@ del' _ (_, ListResult {..}) = do
           VLeft  e -> pure $ Left [i|#{e}|]
 
 
-changelog' :: AppState -> (Int, ListResult) -> IO (Either String ())
+changelog' :: ListResult -> GHCupDownloads -> IO (Either String ())
-changelog' AppState {..} (_, ListResult {..}) = do
+changelog' ListResult {..} dls = 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
+      exec "xdg-open" True [serializeURIRef' uri] Nothing Nothing >>= \case
-                  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)
+settings :: Settings
-{-# NOINLINE uri' #-}
+settings = Settings { cache      = True
-uri' = unsafePerformIO (newIORef Nothing)
+                    , noVerify   = False
-
+                    , keepDirs   = Never
-
+                    , downloader = Curl
-settings' :: IORef Settings
+                    }
-{-# NOINLINE settings' #-}
-settings' = unsafePerformIO
-  (newIORef Settings { cache      = True
-                     , noVerify   = False
-                     , keepDirs   = Never
-                     , downloader = Curl
-                     , verbose    = False
-                     }
-  )
 
 
 logger' :: IORef LoggerConfig
@@ -316,47 +255,37 @@ logger' = unsafePerformIO
   )
 
 
-brickMain :: Settings -> Maybe URI -> LoggerConfig -> GHCupDownloads -> PlatformRequest -> IO ()
+brickMain :: LoggerConfig -> IO ()
-brickMain s muri l av pfreq' = do
+brickMain l = do
-  writeIORef uri'      muri
-  writeIORef settings' s
   -- logger interpreter
-  writeIORef logger'   l
+  writeIORef logger' l
   let runLogger = myLoggerT l
 
-  eApps <- getAppState (Just av) pfreq'
+  eApps <- getAppState
   case eApps of
-    Right as -> defaultMain app (selectLatest as) $> ()
+    Right as -> defaultMain app as $> ()
-    Left  e  -> do
+    Left  _  -> do
-      runLogger ($(logError) [i|Error building app state: #{show e}|])
+      runLogger ($(logError) [i|Error building app state|])
       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 :: IO (Either String AppState)
-getAppState mg pfreq' = do
+getAppState = do
-  muri     <- readIORef uri'
+  l <- readIORef logger'
-  settings <- readIORef settings'
-  l        <- readIORef logger'
   let runLogger = myLoggerT l
 
   r <-
     runLogger
     . flip runReaderT settings
     . runE
-      @'[JSONError, DownloadFailed, FileDoesNotExistError]
+      @'[JSONError, DownloadFailed, FileDoesNotExistError, NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
     $ do
-        dls <- maybe (fmap _ghcupDownloads $ liftE $ getDownloadsF (maybe GHCupURL OwnSource muri)) pure mg
+        (GHCupInfo _ dls) <- liftE $ getDownloadsF GHCupURL
 
-        lV <- lift $ listVersions dls Nothing Nothing pfreq'
+        lV                 <- liftE $ listVersions dls Nothing Nothing
-        pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls pfreq')
+        pure $ (AppState (list "Tool versions" (V.fromList lV) 1) dls)
 
   case r of
     VRight a -> pure $ Right a
     VLeft  e -> pure $ Left [i|#{e}|]
+

app/ghcup/Main.hs

@@ -28,9 +28,7 @@ import           GHCup.Utils.Prelude
 import           GHCup.Utils.String.QQ
 import           GHCup.Version
 
-#if !defined(TAR)
 import           Codec.Archive
-#endif
 import           Control.Exception.Safe
 #if !MIN_VERSION_base(4,13,0)
 import           Control.Monad.Fail             ( MonadFail )
@@ -808,7 +806,6 @@ toSettings Options {..} =
       noVerify   = optNoVerify
       keepDirs   = optKeepDirs
       downloader = optsDownloader
-      verbose    = optVerbose
   in  Settings { .. }
 
 
@@ -912,13 +909,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                   . runE
                     @'[ AlreadyInstalled
                       , UnknownArchive
-#if !defined(TAR)
                       , ArchiveResult
-#endif
+                      , DistroNotFound
                       , FileDoesNotExistError
                       , CopyError
+                      , NoCompatibleArch
                       , NoDownload
                       , NotInstalled
+                      , NoCompatiblePlatform
                       , BuildFailed
                       , TagNotFound
                       , DigestError
@@ -943,7 +941,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                     , TagNotFound
                     ]
 
-          let runListGHC = runLogger
+          let runListGHC = runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound]
 
           let runRm =
                 runLogger . flip runReaderT settings . runE @'[NotInstalled]
@@ -962,15 +960,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                     @'[ AlreadyInstalled
                       , BuildFailed
                       , DigestError
+                      , DistroNotFound
                       , DownloadFailed
                       , GHCupSetError
+                      , NoCompatibleArch
+                      , NoCompatiblePlatform
                       , NoDownload
                       , NotFoundInPATH
                       , PatchFailed
                       , UnknownArchive
-#if !defined(TAR)
                       , ArchiveResult
-#endif
                       ]
 
           let runCompileCabal =
@@ -982,14 +981,15 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       , BuildFailed
                       , CopyError
                       , DigestError
+                      , DistroNotFound
                       , DownloadFailed
+                      , NoCompatibleArch
+                      , NoCompatiblePlatform
                       , NoDownload
                       , NotInstalled
                       , PatchFailed
                       , UnknownArchive
-#if !defined(TAR)
                       , ArchiveResult
-#endif
                       ]
 
           let runUpgrade =
@@ -998,6 +998,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                   . runResourceT
                   . runE
                     @'[ DigestError
+                      , DistroNotFound
+                      , NoCompatiblePlatform
+                      , NoCompatibleArch
                       , NoDownload
                       , NoUpdate
                       , FileDoesNotExistError
@@ -1006,19 +1009,9 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       ]
 
 
-          ----------------------------------------
+          ---------------------------
-          -- Getting download and platform info --
+          -- Getting download info --
-          ----------------------------------------
+          ---------------------------
-
-          pfreq <- (
-            runLogger . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] . liftE $ platformRequest
-            ) >>= \case
-                    VRight r -> pure r
-                    VLeft e -> do
-                      runLogger
-                        ($(logError) [i|Error determining Platform: #{e}|])
-                      exitWith (ExitFailure 2)
-
 
           (GHCupInfo treq dls) <-
             ( runLogger
@@ -1033,8 +1026,14 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                       runLogger
                         ($(logError) [i|Error fetching download info: #{e}|])
                       exitWith (ExitFailure 2)
-          runLogger $ checkForUpdates dls pfreq
+          (runLogger
-
+              . runE @'[NoCompatiblePlatform, NoCompatibleArch, DistroNotFound] $ checkForUpdates dls
+              )
+              >>= \case
+                    VRight _ -> pure ()
+                    VLeft  e -> do
+                      runLogger
+                        ($(logError) [i|Error checking for upgrades: #{e}|])
 
 
           -----------------------
@@ -1044,7 +1043,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let installGHC InstallOptions{..} =
                   (runInstTool $ do
                       v <- liftE $ fromVersion dls instVer GHC
-                      liftE $ installGHCBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
+                      liftE $ installGHCBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
                     )
                     >>= \case
                           VRight _ -> do
@@ -1078,7 +1077,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
           let installCabal InstallOptions{..} =
                 (runInstTool $ do
                     v <- liftE $ fromVersion dls instVer Cabal
-                    liftE $ installCabalBin dls (_tvVersion v) (fromMaybe pfreq instPlatform) -- FIXME: ugly sharing of tool version
+                    liftE $ installCabalBin dls (_tvVersion v) instPlatform -- FIXME: ugly sharing of tool version
                   )
                   >>= \case
                         VRight _ -> do
@@ -1151,7 +1150,7 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
           res <- case optCommand of
 #if defined(BRICK)
-            Interactive -> liftIO $ brickMain settings optUrlSource loggerConfig dls pfreq >> pure ExitSuccess
+            Interactive -> liftIO $ brickMain loggerConfig >> pure ExitSuccess
 #endif
             Install (Right iopts) -> do
               runLogger ($(logWarn) [i|This is an old-style command for installing GHC. Use 'ghcup install ghc' instead.|])
@@ -1170,10 +1169,16 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
 
             List (ListOptions {..}) ->
               (runListGHC $ do
-                  l <- listVersions dls lTool lCriteria pfreq
+                  l <- listVersions dls lTool lCriteria
-                  liftIO $ printListResult lRawFormat l
+                  pure l
-                  pure ExitSuccess
                 )
+                >>= \case
+                      VRight r -> do
+                        liftIO $ printListResult lRawFormat r
+                        pure ExitSuccess
+                      VLeft e -> do
+                        runLogger ($(logError) [i|#{e}|])
+                        pure $ ExitFailure 6
 
             Rm (Right rmopts) -> do
               runLogger ($(logWarn) [i|This is an old-style command for removing GHC. Use 'ghcup rm ghc' instead.|])
@@ -1200,7 +1205,6 @@ Report bugs at <https://gitlab.haskell.org/haskell/ghcup-hs/issues>|]
                                                   buildConfig
                                                   patchDir
                                                   addConfArgs
-                                                  pfreq
                 )
                 >>= \case
                       VRight _ -> do
@@ -1225,7 +1229,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
 
             Compile (CompileCabal CabalCompileOptions {..}) ->
               (runCompileCabal $ do
-                  liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir pfreq
+                  liftE $ compileCabal dls targetVer bootstrapGhc jobs patchDir
                 )
                 >>= \case
                       VRight _ -> do
@@ -1256,7 +1260,7 @@ Make sure to clean up #{tmpdir} afterwards.|])
                   bdir <- liftIO $ ghcupBinDir
                   pure (Just (bdir </> [rel|ghcup|]))
 
-              (runUpgrade $ (liftE $ upgradeGHCup dls target force pfreq)) >>= \case
+              (runUpgrade $ (liftE $ upgradeGHCup dls target force)) >>= \case
                 VRight v' -> do
                   let pretty_v = prettyVer v'
                   runLogger $ $(logInfo)
@@ -1308,14 +1312,9 @@ Make sure to clean up #{tmpdir} afterwards.|])
                   pure ExitSuccess
                 Just uri -> do
                   let uri' = T.unpack . decUTF8Safe . serializeURIRef' $ uri
-                      cmd = case _rPlatform pfreq of
-                              Darwin  -> "open"
-                              Linux _ -> "xdg-open"
-                              FreeBSD -> "xdg-open"
-
                   if clOpen
                     then
-                      exec cmd
+                      exec "xdg-open"
                            True
                            [serializeURIRef' uri]
                            Nothing
@@ -1407,32 +1406,37 @@ printListResult raw lr = do
 
 checkForUpdates :: (MonadCatch m, MonadLogger m, MonadThrow m, MonadIO m, MonadFail m, MonadLogger m)
                 => GHCupDownloads
-                -> PlatformRequest
+                -> Excepts
-                -> m ()
+                     '[ NoCompatiblePlatform
-checkForUpdates dls pfreq = do
+                      , NoCompatibleArch
+                      , DistroNotFound
+                      ]
+                     m
+                     ()
+checkForUpdates dls = do
   forM_ (getLatest dls GHCup) $ \l -> do
     (Right ghc_ver) <- pure $ version $ prettyPVP ghcUpVer
     when (l > ghc_ver)
-      $ $(logWarn)
+      $ lift $ $(logWarn)
           [i|New GHCup version available: #{prettyVer l}. To upgrade, run 'ghcup upgrade'|]
 
   forM_ (getLatest dls GHC) $ \l -> do
     mghc_ver <- latestInstalled GHC
     forM mghc_ver $ \ghc_ver ->
       when (l > ghc_ver)
-        $ $(logWarn)
+        $ lift $ $(logWarn)
             [i|New GHC version available: #{prettyVer l}. To upgrade, run 'ghcup install ghc #{prettyVer l}'|]
 
   forM_ (getLatest dls Cabal) $ \l -> do
     mcabal_ver <- latestInstalled Cabal
     forM mcabal_ver $ \cabal_ver ->
       when (l > cabal_ver)
-        $ $(logWarn)
+        $ lift $ $(logWarn)
             [i|New Cabal version available: #{prettyVer l}. To upgrade, run 'ghcup install cabal #{prettyVer l}'|]
 
  where
   latestInstalled tool = (fmap lVer . lastMay)
-    <$> (listVersions dls (Just tool) (Just ListInstalled) pfreq)
+    <$> (listVersions dls (Just tool) (Just ListInstalled))
 
 
 prettyDebugInfo :: DebugInfo -> String

bootstrap-haskell

@@ -28,17 +28,16 @@ eghcup() {
 download_ghcup() {
 	_plat="$(uname -s)"
 	_arch=$(uname -m)
-	_ghver="0.1.6"
+	_ghver="0.1.5"
-	_base_url="https://downloads.haskell.org/~ghcup"
 
     case "${_plat}" in
         "linux"|"Linux")
 			case "${_arch}" in
 				x86_64|amd64)
-					_url=${_base_url}/${_ghver}/x86_64-linux-ghcup-${_ghver}
+					_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-linux-ghcup-${_ghver}
 					;;
 				i*86)
-					_url=${_base_url}/${_ghver}/i386-linux-ghcup-${_ghver}
+					_url=https://downloads.haskell.org/~ghcup/${_ghver}/i386-linux-ghcup-${_ghver}
 					;;
 				*) die "Unknown architecture: ${_arch}"
 					;;
@@ -54,7 +53,7 @@ download_ghcup() {
 				*) die "Unknown architecture: ${_arch}"
 					;;
 			esac
-			_url=${_base_url}/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
+			_url=https://downloads.haskell.org/~ghcup/${_ghver}/x86_64-portbld-freebsd-ghcup-${_ghver}
             ;;
         "Darwin"|"darwin")
 			case "${_arch}" in
@@ -66,14 +65,14 @@ download_ghcup() {
 				*) die "Unknown architecture: ${_arch}"
 					;;
 			esac
-			_url=${_base_url}/${_ghver}/x86_64-apple-darwin-ghcup-${_ghver} ;;
+			_url=https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2 ;;
         *) die "Unknown platform: ${_plat}"
 			;;
     esac
 
 	edo curl -Lf "${_url}" > "${GHCUP_INSTALL_BASE_PREFIX}"/.ghcup/bin/ghcup
 
-	unset _plat _arch _url _ghver _base_url
+	unset _plat _arch _url _ghver
 }
 
 
@@ -130,10 +129,10 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
     read -r answer </dev/tty
 fi
 
-eghcup --cache install ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
+eghcup --cache install "${BOOTSTRAP_HASKELL_GHC_VERSION}"
 
-eghcup set ghc "${BOOTSTRAP_HASKELL_GHC_VERSION}"
+eghcup set "${BOOTSTRAP_HASKELL_GHC_VERSION}"
-eghcup --cache install cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
+eghcup --cache install-cabal "${BOOTSTRAP_HASKELL_CABAL_VERSION}"
 
 edo cabal new-update
 
@@ -164,9 +163,6 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
 				exit 0
 			fi
 			;;
-		*/fish) # login shell is fish
-			GHCUP_PROFILE_FILE="$HOME/.config/fish/config.fish"
-			MY_SHELL="fish" ;;
 		*) exit 0 ;;
 	esac
 
@@ -182,16 +178,7 @@ if [ -z "${BOOTSTRAP_HASKELL_NONINTERACTIVE}" ] ; then
 
         case $next_answer in
             [Yy]*)
-				case $MY_SHELL in
+                echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
-					"") break ;;
-					fish)
-						echo "set -q GHCUP_INSTALL_BASE_PREFIX[1]; or set GHCUP_INSTALL_BASE_PREFIX \$HOME" >> "${GHCUP_PROFILE_FILE}"
-						echo "test -f \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/env ; and set -gx PATH \$HOME/.cabal/bin \$GHCUP_INSTALL_BASE_PREFIX/.ghcup/bin \$PATH" >> "${GHCUP_PROFILE_FILE}"
-						break ;;
-					*)
-						echo "[ -f \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\" ] && source \"\${GHCUP_INSTALL_BASE_PREFIX:=\$HOME}/.ghcup/env\"" >> "${GHCUP_PROFILE_FILE}"
-						break ;;
-				esac
                 printf "\\033[0;35m%s\\033[0m\\n" "OK! ${GHCUP_PROFILE_FILE} has been modified. Restart your terminal for the changes to take effect,"
                 printf "\\033[0;35m%s\\033[0m\\n" "or type \"source ${GHCUP_INSTALL_BASE_PREFIX}/.ghcup/env\" to apply them in your current terminal session."
                 exit 0;;

cabal.project

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

ghcup-0.0.2.json

@@ -698,13 +698,6 @@
                 "dlUri": "https://downloads.haskell.org/~ghc/8.10.1/ghc-8.10.1-x86_64-alpine3.10-linux-integer-simple.tar.xz"
               }
             },
-            "FreeBSD": {
-              "unknown_versioning": {
-                "dlHash": "52d27dbf9de82005dde9bfc521bff612e381b5228af194259c2306d2b75825c2",
-                "dlSubdir": "ghc-8.10.1",
-                "dlUri": "https://downloads.haskell.org/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz"
-              }
-            },
             "Linux_Debian": {
               "unknown_versioning": {
                 "dlHash": "d1cf7886f27af070f3b7dbe1975a78b43ef2d32b86362cbe953e79464fe70761",
@@ -856,13 +849,6 @@
                 "dlUri": "https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.6.5-musl/ghc-8.6.5-x86_64-unknown-linux-musl.tar.xz"
               }
             },
-            "FreeBSD": {
-              "unknown_versioning": {
-                "dlHash": "83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37",
-                "dlSubdir": "ghc-8.6.5",
-                "dlUri": "https://files.hasufell.de/ghc/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz"
-              }
-            },
             "Linux_Debian": {
               "unknown_versioning": {
                 "dlHash": "bc75f5601a9f41d58b2ba161b9e28fad52143a7229060f1e084168d9b2e914df",
@@ -1250,136 +1236,6 @@
           "base-4.13.0.0"
         ]
       },
-      "8.8.4": {
-        "viArch": {
-          "A_64": {
-            "Linux_Debian": {
-              "unknown_versioning": {
-                "dlHash": "4862559d221153caf978f4bf2c15a82c114d1e1f43b298b2ecff2ac94b586d20",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb9-linux.tar.xz"
-              },
-              "8": {
-                "dlHash": "51a36892f1264744195274187298d13ac62bce2da86d4ddf76d8054ab90f2feb",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb8-linux.tar.xz"
-              }
-            },
-            "Linux_Ubuntu": {
-              "unknown_versioning": {
-                "dlHash": "f32e37f8aa03e74bad533ae02f62dc27a4521e78199576af490888ba34b515db",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-fedora27-linux.tar.xz"
-              },
-              "16.04": {
-                "dlHash": "4862559d221153caf978f4bf2c15a82c114d1e1f43b298b2ecff2ac94b586d20",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb9-linux.tar.xz"
-              },
-              "18.04": {
-                "dlHash": "4862559d221153caf978f4bf2c15a82c114d1e1f43b298b2ecff2ac94b586d20",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb9-linux.tar.xz"
-              }
-            },
-            "Darwin": {
-              "unknown_versioning": {
-                "dlHash": "e80a789e9d8cfb41dd87f3284b75432427c4461c1731d220d04ead8733ccdb5e",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-apple-darwin.tar.xz"
-              }
-            },
-            "Linux_RedHat": {
-              "unknown_versioning": {
-                "dlHash": "a12aa4b1fd3c64240a8a6d15196d33e1c0e0d55b51ff78c387242126d0ef7910",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-centos7-linux.tar.xz"
-              }
-            },
-            "Linux_UnknownLinux": {
-              "unknown_versioning": {
-                "dlHash": "f32e37f8aa03e74bad533ae02f62dc27a4521e78199576af490888ba34b515db",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-fedora27-linux.tar.xz"
-              }
-            },
-            "Linux_Mint": {
-              "unknown_versioning": {
-                "dlHash": "4862559d221153caf978f4bf2c15a82c114d1e1f43b298b2ecff2ac94b586d20",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb9-linux.tar.xz"
-              }
-            },
-            "Linux_Fedora": {
-              "unknown_versioning": {
-                "dlHash": "f32e37f8aa03e74bad533ae02f62dc27a4521e78199576af490888ba34b515db",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-fedora27-linux.tar.xz"
-              }
-            },
-            "Linux_CentOS": {
-              "unknown_versioning": {
-                "dlHash": "a12aa4b1fd3c64240a8a6d15196d33e1c0e0d55b51ff78c387242126d0ef7910",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-centos7-linux.tar.xz"
-              }
-            },
-            "Linux_AmazonLinux": {
-              "unknown_versioning": {
-                "dlHash": "a12aa4b1fd3c64240a8a6d15196d33e1c0e0d55b51ff78c387242126d0ef7910",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-centos7-linux.tar.xz"
-              }
-            }
-          },
-          "A_32": {
-            "FreeBSD": {
-              "unknown_versioning": {
-                "dlHash": "8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://files.hasufell.de/ghc/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz"
-              }
-            },
-            "Linux_Debian": {
-              "unknown_versioning": {
-                "dlHash": "43dd954910c9027694312cef0aabc7774d102d0422b7172802cfb72f7d5da3a0",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-i386-deb9-linux.tar.xz"
-              }
-            },
-            "Linux_Ubuntu": {
-              "unknown_versioning": {
-                "dlHash": "43dd954910c9027694312cef0aabc7774d102d0422b7172802cfb72f7d5da3a0",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-i386-deb9-linux.tar.xz"
-              }
-            },
-            "Linux_UnknownLinux": {
-              "unknown_versioning": {
-                "dlHash": "43dd954910c9027694312cef0aabc7774d102d0422b7172802cfb72f7d5da3a0",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-i386-deb9-linux.tar.xz"
-              }
-            },
-            "Linux_Mint": {
-              "unknown_versioning": {
-                "dlHash": "43dd954910c9027694312cef0aabc7774d102d0422b7172802cfb72f7d5da3a0",
-                "dlSubdir": "ghc-8.8.4",
-                "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-i386-deb9-linux.tar.xz"
-              }
-            }
-          }
-        },
-        "viSourceDL": {
-          "dlHash": "f0505e38b2235ff9f1090b51f44d6c8efd371068e5a6bb42a2a6d8b67b5ffc2d",
-          "dlSubdir": "ghc-8.8.4",
-          "dlUri": "https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-src.tar.xz"
-        },
-        "viChangeLog": "https://downloads.haskell.org/~ghc/8.8.4/docs/html/users_guide/8.8.4-notes.html",
-        "viTags": [
-          "base-4.13.0.0"
-        ]
-      },
       "8.4.3": {
         "viArch": {
           "A_64": {
@@ -2146,13 +2002,6 @@
                 "dlUri": "https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.8.3-musl/ghc-8.8.3-x86_64-unknown-linux-musl.tar.xz"
               }
             },
-            "FreeBSD": {
-              "unknown_versioning": {
-                "dlHash": "569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be",
-                "dlSubdir": "ghc-8.8.3",
-                "dlUri": "https://files.hasufell.de/ghc/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz"
-              }
-            },
             "Linux_Debian": {
               "unknown_versioning": {
                 "dlHash": "42fde2ef5a143e1e6b47ae8875162ea2d4d54b06f0f7fa32ee4f0eb86f2be7ad",
@@ -2452,37 +2301,37 @@
       }
     },
     "GHCup": {
-      "0.1.6": {
+      "0.1.5": {
         "viArch": {
           "A_64": {
             "FreeBSD": {
               "unknown_versioning": {
-                "dlHash": "6bbfb1047691ff3ae9249e8805cf9f37bab30a008dae130cb2a4b3aa5253e6e5",
+                "dlHash": "6dd57cc5958ef3a6ba7de22808d9292d31dada8af95277578b69be35fc090194",
                 "dlSubdir": null,
-                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.6/x86_64-portbld-freebsd-ghcup-0.1.6"
+                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/x86_64-portbld-freebsd-ghcup-0.1.5"
               }
             },
             "Darwin": {
               "unknown_versioning": {
-                "dlHash": "1e025e66d7f7b75d94f17a7da6120efd7e2df918a8eac88c4711ed11d2aac4ec",
+                "dlHash": "456770c3b1510d44a0e401e0677faa9f5670ef81a11646f47cbba1b95404e788",
                 "dlSubdir": null,
-                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.6/x86_64-apple-darwin-ghcup-0.1.6"
+                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2"
               }
             },
             "Linux_UnknownLinux": {
               "unknown_versioning": {
-                "dlHash": "bdbec0cdf4c8511c4082dd83993d15034c0fbcb5722ecf418c1cee40667da8af",
+                "dlHash": "cfdb01dde77121859b5d90b6707238b54e23787fcbb3003e18ab52a5dbfee330",
                 "dlSubdir": null,
-                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.6/x86_64-linux-ghcup-0.1.6"
+                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5"
               }
             }
           },
           "A_32": {
             "Linux_UnknownLinux": {
               "unknown_versioning": {
-                "dlHash": "0366ed6c00862c3c002cdefc3e37523ad80e655387956c7ab58b268aaa6fae5d",
+                "dlHash": "3707f60d703912709335dc0103fb1af5e5dfa83050825a8156b56bc81760b2a8",
                 "dlSubdir": null,
-                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.6/i386-linux-ghcup-0.1.6"
+                "dlUri": "https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5"
               }
             }
           }

ghcup.cabal

@@ -1,6 +1,6 @@
 cabal-version:      3.0
 name:               ghcup
-version:            0.1.6
+version:            0.1.5
 synopsis:           ghc toolchain installer as an exe/library
 description:
   A rewrite of the shell script ghcup, for providing
@@ -22,7 +22,7 @@ source-repository head
   location: https://gitlab.haskell.org/haskell/ghcup-hs.git
 
 flag tui
-  description: Build the brick powered tui (ghcup tui)
+  description: Build the brick powered tui (ghcup \-\-interactive)
   default:     False
   manual:      True
 
@@ -31,11 +31,6 @@ flag internal-downloader
   default:     False
   manual:      True
 
-flag tar
-  description: Use tar-bytestring instead of libarchive
-  default:     False
-  manual:      True
-
 common HsOpenSSL
   build-depends: HsOpenSSL >=0.11.4.18
 
@@ -105,14 +100,11 @@ common hpath-io
 common hpath-posix
   build-depends: hpath-posix >=0.13.2
 
-common http-client
+common http-io-streams
-  build-depends: http-client >=0.7.1
+  build-depends: http-io-streams >=0.1.2.0
 
-common http-client-openssl
+common io-streams
-  build-depends: http-client-openssl >=0.3.1.0
+  build-depends: io-streams >=1.5
-
-common http-types
-  build-depends: http-types >=0.12.3
 
 common libarchive
   build-depends: libarchive >= 2.2.5.0
@@ -123,9 +115,6 @@ common lzma
 common megaparsec
   build-depends: megaparsec >=8.0.0
 
-common monad-control
-  build-depends: monad-control >=1.0.2.3
-
 common monad-logger
   build-depends: monad-logger >=0.3.31
 
@@ -180,14 +169,11 @@ common table-layout
 common template-haskell
   build-depends: template-haskell >=2.7
 
-common tar-bytestring
-  build-depends: tar-bytestring >=0.6.3.1
-
 common terminal-progress-bar
   build-depends: terminal-progress-bar >=0.4.1
 
 common text
-  build-depends: text >=1.2.4.0
+  build-depends: text >=1.2
 
 common time
   build-depends: time >=1.9.3
@@ -195,9 +181,6 @@ common time
 common transformers
   build-depends: transformers >=0.5
 
-common transformers-base
-  build-depends: transformers-base >=0.4.4
-
 common os-release
   build-depends: os-release >=1.0.0
 
@@ -270,9 +253,9 @@ library
     , hpath-filepath
     , hpath-io
     , hpath-posix
+    , libarchive
     , lzma
     , megaparsec
-    , monad-control
     , monad-logger
     , mtl
     , optics
@@ -292,7 +275,6 @@ library
     , text
     , time
     , transformers
-    , transformers-base
     , os-release
     , unix
     , unix-bytestring
@@ -310,6 +292,7 @@ library
     GHCup.Data.GHCupInfo
     GHCup.Data.ToolRequirements
     GHCup.Download
+    GHCup.Download.Utils
     GHCup.Errors
     GHCup.Platform
     GHCup.Requirements
@@ -332,22 +315,13 @@ library
 
   if flag(internal-downloader)
     import:
-        HsOpenSSL
+      , HsOpenSSL
-      , http-client
+      , http-io-streams
-      , http-client-openssl
+      , io-streams
-      , http-types
       , terminal-progress-bar
-    exposed-modules: GHCup.Download.Internal
+    exposed-modules: GHCup.Download.IOStreams
     cpp-options:     -DINTERNAL_DOWNLOADER
 
-  if flag(tar)
-    import:
-        tar-bytestring
-    cpp-options:     -DTAR
-  else
-    import:
-        libarchive
-
 executable ghcup
   import:
     config
@@ -357,6 +331,7 @@ executable ghcup
     , haskus-utils-variant
     , hpath
     , hpath-io
+    , libarchive
     , megaparsec
     , monad-logger
     , mtl
@@ -393,12 +368,6 @@ executable ghcup
     other-modules: BrickMain
     cpp-options:     -DBRICK
 
-  if flag(tar)
-    cpp-options:     -DTAR
-  else
-    import:
-        libarchive
-
 executable ghcup-gen
   import:
     config

lib/GHCup.hs

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

lib/GHCup/Data/GHCupDownloads.hs

@@ -2,10 +2,7 @@
 {-# LANGUAGE QuasiQuotes       #-}
 
 
-module GHCup.Data.GHCupDownloads
+module GHCup.Data.GHCupDownloads where
-  ( ghcupDownloads
-  )
-where
 
 import           GHCup.Types
 import           GHCup.Utils.Version.QQ
@@ -664,12 +661,6 @@ ghc_865_32_musl = DownloadInfo
   (Just [rel|ghc-8.6.5|])
   "db13ff894faf431f9c64db21c090a1e4e42803794d56720a704c50166c7ca05d"
 
-ghc_865_64_freebsd :: DownloadInfo
-ghc_865_64_freebsd = DownloadInfo
-  [uri|https://files.hasufell.de/ghc/ghc-8.6.5-x86_64-portbld-freebsd.tar.xz|]
-  (Just [rel|ghc-8.6.5|])
-  "83a3059a630d40a98e26cb5b520354e12094a96e36ba2f5ab002dad94cf2fb37"
-
 
 
     -----------------
@@ -838,61 +829,6 @@ ghc_883_32_musl = DownloadInfo
   (Just [rel|ghc-8.8.3|])
   "7a5f41646d06777e75636291a1855d60a0984552bbdf33c3d107565d302f38a4"
 
-ghc_883_64_freebsd :: DownloadInfo
-ghc_883_64_freebsd = DownloadInfo
-  [uri|https://files.hasufell.de/ghc/ghc-8.8.3-x86_64-portbld-freebsd.tar.xz|]
-  (Just [rel|ghc-8.8.3|])
-  "569719075b4d14b3875a899df522090ae31e6fe085e6dffe518e875b09a2f0be"
-
-
-
-    -----------------
-    --[ GHC 8.8.4 ]--
-    -----------------
-
-
-
-ghc_884_64_deb8 :: DownloadInfo
-ghc_884_64_deb8 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb8-linux.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "51a36892f1264744195274187298d13ac62bce2da86d4ddf76d8054ab90f2feb"
-
-ghc_884_64_deb9 :: DownloadInfo
-ghc_884_64_deb9 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-deb9-linux.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "4862559d221153caf978f4bf2c15a82c114d1e1f43b298b2ecff2ac94b586d20"
-
-ghc_884_32_deb9 :: DownloadInfo
-ghc_884_32_deb9 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-i386-deb9-linux.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "43dd954910c9027694312cef0aabc7774d102d0422b7172802cfb72f7d5da3a0"
-
-ghc_884_64_fedora :: DownloadInfo
-ghc_884_64_fedora = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-fedora27-linux.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "f32e37f8aa03e74bad533ae02f62dc27a4521e78199576af490888ba34b515db"
-
-ghc_884_64_centos :: DownloadInfo
-ghc_884_64_centos = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-centos7-linux.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "a12aa4b1fd3c64240a8a6d15196d33e1c0e0d55b51ff78c387242126d0ef7910"
-
-ghc_884_64_darwin :: DownloadInfo
-ghc_884_64_darwin = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-x86_64-apple-darwin.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "e80a789e9d8cfb41dd87f3284b75432427c4461c1731d220d04ead8733ccdb5e"
-
-ghc_884_64_freebsd :: DownloadInfo
-ghc_884_64_freebsd = DownloadInfo
-  [uri|https://files.hasufell.de/ghc/ghc-8.8.4-x86_64-portbld-freebsd.tar.xz|]
-  (Just [rel|ghc-8.8.4|])
-  "8cebe5ccf454e82acd1ff52ca57590d1ab0f3f44a981b46257ec12158c8c447e"
 
 
 
@@ -951,11 +887,6 @@ ghc_8101_64_alpine = DownloadInfo
   "cb13b645d103e2fba2eb8dfcc4e5f2fbd9550c00c4df42f342b4210436dcb8a8"
 
 
-ghc_8101_64_freebsd :: DownloadInfo
-ghc_8101_64_freebsd = DownloadInfo
-  [uri|https://downloads.haskell.org/ghc/8.10.1/ghc-8.10.1-x86_64-portbld-freebsd.tar.xz|]
-  (Just [rel|ghc-8.10.1|])
-  "52d27dbf9de82005dde9bfc521bff612e381b5228af194259c2306d2b75825c2"
 
 
 
@@ -1089,32 +1020,32 @@ cabal_3200_64_alpine = DownloadInfo
     -------------
 
 
-ghcup_016_32_linux :: DownloadInfo
+ghcup_015_32_linux :: DownloadInfo
-ghcup_016_32_linux = DownloadInfo
+ghcup_015_32_linux = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghcup/0.1.6/i386-linux-ghcup-0.1.6|]
+  [uri|https://downloads.haskell.org/~ghcup/0.1.5/i386-linux-ghcup-0.1.5|]
   Nothing
-  "0366ed6c00862c3c002cdefc3e37523ad80e655387956c7ab58b268aaa6fae5d"
+  "3707f60d703912709335dc0103fb1af5e5dfa83050825a8156b56bc81760b2a8"
 
 
-ghcup_016_64_linux :: DownloadInfo
+ghcup_015_64_linux :: DownloadInfo
-ghcup_016_64_linux = DownloadInfo
+ghcup_015_64_linux = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghcup/0.1.6/x86_64-linux-ghcup-0.1.6|]
+  [uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-linux-ghcup-0.1.5|]
   Nothing
-  "bdbec0cdf4c8511c4082dd83993d15034c0fbcb5722ecf418c1cee40667da8af"
+  "cfdb01dde77121859b5d90b6707238b54e23787fcbb3003e18ab52a5dbfee330"
 
 
-ghcup_016_64_freebsd :: DownloadInfo
+ghcup_015_64_freebsd :: DownloadInfo
-ghcup_016_64_freebsd = DownloadInfo
+ghcup_015_64_freebsd = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghcup/0.1.6/x86_64-portbld-freebsd-ghcup-0.1.6|]
+  [uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-portbld-freebsd-ghcup-0.1.5|]
   Nothing
-  "6bbfb1047691ff3ae9249e8805cf9f37bab30a008dae130cb2a4b3aa5253e6e5"
+  "6dd57cc5958ef3a6ba7de22808d9292d31dada8af95277578b69be35fc090194"
 
 
-ghcup_016_64_darwin10_13 :: DownloadInfo
+ghcup_015_64_darwin10_13 :: DownloadInfo
-ghcup_016_64_darwin10_13 = DownloadInfo
+ghcup_015_64_darwin10_13 = DownloadInfo
-  [uri|https://downloads.haskell.org/~ghcup/0.1.6/x86_64-apple-darwin-ghcup-0.1.6|]
+  [uri|https://downloads.haskell.org/~ghcup/0.1.5/x86_64-apple-darwin-ghcup-0.1.5-p2|]
   Nothing
-  "1e025e66d7f7b75d94f17a7da6120efd7e2df918a8eac88c4711ed11d2aac4ec"
+  "456770c3b1510d44a0e401e0677faa9f5670ef81a11646f47cbba1b95404e788"
 
 
 
@@ -1703,7 +1634,6 @@ ghcupDownloads = M.fromList
                     )
                   , (Darwin      , M.fromList [(Nothing, ghc_865_64_darwin)])
                   , (Linux Alpine, M.fromList [(Nothing, ghc_865_64_musl)])
-                  , (FreeBSD     , M.fromList [(Nothing, ghc_865_64_freebsd)])
                   ]
                 )
               , ( A_32
@@ -1866,7 +1796,6 @@ ghcupDownloads = M.fromList
                     )
                   , (Darwin      , M.fromList [(Nothing, ghc_883_64_darwin)])
                   , (Linux Alpine, M.fromList [(Nothing, ghc_883_64_musl)])
-                  , (FreeBSD     , M.fromList [(Nothing, ghc_883_64_freebsd)])
                   ]
                 )
               , ( A_32
@@ -1882,59 +1811,6 @@ ghcupDownloads = M.fromList
                 )
               ]
         )
-      , ( [vver|8.8.4|]
-        , VersionInfo
-            [Base [pver|4.13.0.0|]]
-            (Just
-              [uri|https://downloads.haskell.org/~ghc/8.8.4/docs/html/users_guide/8.8.4-notes.html|]
-            )
-            (Just $ DownloadInfo
-              [uri|https://downloads.haskell.org/~ghc/8.8.4/ghc-8.8.4-src.tar.xz|]
-              (Just [rel|ghc-8.8.4|])
-              "f0505e38b2235ff9f1090b51f44d6c8efd371068e5a6bb42a2a6d8b67b5ffc2d"
-            )
-          $ M.fromList
-              [ ( A_64
-                , M.fromList
-                  [ ( Linux UnknownLinux
-                    , M.fromList [(Nothing, ghc_884_64_fedora)]
-                    )
-                  , (Linux Fedora, M.fromList [(Nothing, ghc_884_64_fedora)])
-                  , (Linux CentOS, M.fromList [(Nothing, ghc_884_64_centos)])
-                  , (Linux RedHat, M.fromList [(Nothing, ghc_884_64_centos)])
-                  , ( Linux AmazonLinux
-                    , M.fromList [(Nothing, ghc_884_64_centos)]
-                    )
-                  , ( Linux Ubuntu
-                    , M.fromList
-                      [ (Nothing           , ghc_884_64_fedora)
-                      , (Just [vers|16.04|], ghc_884_64_deb9)
-                      , (Just [vers|18.04|], ghc_884_64_deb9)
-                      ]
-                    )
-                  , (Linux Mint, M.fromList [(Nothing, ghc_884_64_deb9)])
-                  , ( Linux Debian
-                    , M.fromList
-                      [ (Nothing       , ghc_884_64_deb9)
-                      , (Just [vers|8|], ghc_884_64_deb8)
-                      ]
-                    )
-                  , (Darwin, M.fromList [(Nothing, ghc_884_64_darwin)])
-                  ]
-                )
-              , ( A_32
-                , M.fromList
-                  [ ( Linux UnknownLinux
-                    , M.fromList [(Nothing, ghc_884_32_deb9)]
-                    )
-                  , (Linux Ubuntu, M.fromList [(Nothing, ghc_884_32_deb9)])
-                  , (Linux Mint  , M.fromList [(Nothing, ghc_884_32_deb9)])
-                  , (Linux Debian, M.fromList [(Nothing, ghc_884_32_deb9)])
-                  , (FreeBSD     , M.fromList [(Nothing, ghc_884_64_freebsd)])
-                  ]
-                )
-              ]
-        )
       , ( [vver|8.10.1|]
         , VersionInfo
             [Latest, Base [pver|4.14.0.0|]]
@@ -1964,7 +1840,7 @@ ghcupDownloads = M.fromList
                       , (Just [vers|7|], ghc_8101_64_centos)
                       ]
                     )
-                  , (Linux RedHat, M.fromList [(Nothing, ghc_8101_64_centos)])
+                  , ( Linux RedHat, M.fromList [(Nothing, ghc_8101_64_centos)])
                   , ( Linux AmazonLinux
                     , M.fromList [(Nothing, ghc_8101_64_centos)]
                     )
@@ -1985,7 +1861,6 @@ ghcupDownloads = M.fromList
                     )
                   , (Darwin      , M.fromList [(Nothing, ghc_8101_64_darwin)])
                   , (Linux Alpine, M.fromList [(Nothing, ghc_8101_64_alpine)])
-                  , (FreeBSD     , M.fromList [(Nothing, ghc_8101_64_freebsd)])
                   ]
                 )
               , ( A_32
@@ -2108,7 +1983,7 @@ ghcupDownloads = M.fromList
     )
   , ( GHCup
     , M.fromList
-      [ ( [vver|0.1.6|]
+      [ ( [vver|0.1.5|]
         , VersionInfo
             [Recommended, Latest]
             (Just
@@ -2119,16 +1994,16 @@ ghcupDownloads = M.fromList
               [ ( A_64
                 , M.fromList
                   [ ( Linux UnknownLinux
-                    , M.fromList [(Nothing, ghcup_016_64_linux)]
+                    , M.fromList [(Nothing, ghcup_015_64_linux)]
                     )
-                  , (Darwin , M.fromList [(Nothing, ghcup_016_64_darwin10_13)])
+                  , (Darwin , M.fromList [(Nothing, ghcup_015_64_darwin10_13)])
-                  , (FreeBSD, M.fromList [(Nothing, ghcup_016_64_freebsd)])
+                  , (FreeBSD, M.fromList [(Nothing, ghcup_015_64_freebsd)])
                   ]
                 )
               , ( A_32
                 , M.fromList
                   [ ( Linux UnknownLinux
-                    , M.fromList [(Nothing, ghcup_016_32_linux)]
+                    , M.fromList [(Nothing, ghcup_015_32_linux)]
                     )
                   ]
                 )

lib/GHCup/Download.hs

@@ -12,7 +12,8 @@
 module GHCup.Download where
 
 #if defined(INTERNAL_DOWNLOADER)
-import           GHCup.Download.Internal
+import           GHCup.Download.IOStreams
+import           GHCup.Download.Utils
 #endif
 import           GHCup.Errors
 import           GHCup.Types
@@ -49,7 +50,7 @@ import           Data.Versions
 import           Data.Word8
 import           GHC.IO.Exception
 import           HPath
-import           HPath.IO                     as HIO hiding ( hideError )
+import           HPath.IO                      as HIO
 import           Haskus.Utils.Variant.Excepts
 import           Optics
 import           Prelude                 hiding ( abs
@@ -232,20 +233,16 @@ getDownloads urlSource = do
 #if !defined(INTERNAL_DOWNLOADER)
       pure Nothing
 #else
-      Settings{..} <- lift ask
+      headers <-
-      case downloader of
+        handleIO (\_ -> pure mempty)
-        Internal -> do
+        $ liftE
-          headers <-
+        $ ( catchAllE
-            handleIO (\_ -> pure mempty)
+              (\_ ->
-            $ liftE
+                pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
-            $ ( catchAllE
-                  (\_ ->
-                    pure mempty :: Excepts '[] m1 (M.Map (CI ByteString) ByteString)
-                  )
-              $ getHead uri'
               )
-          pure $ parseModifiedHeader headers
+          $ getHead uri'
-        _ -> pure Nothing
+          )
+      pure $ parseModifiedHeader headers
 
   parseModifiedHeader :: (M.Map (CI ByteString) ByteString) -> Maybe UTCTime
   parseModifiedHeader headers =
@@ -342,7 +339,9 @@ download dli dest mfn
                   liftE $ lEM @_ @'[ProcessError] $ liftIO $ exec "wget" True
                     (o' ++ ["-O", toFilePath destFile , serializeURIRef' $ view dlUri dli]) Nothing Nothing
 #if defined(INTERNAL_DOWNLOADER)
-                Internal -> liftE $ downloadToFile (_dlUri dli) destFile
+                Internal -> do
+                  (https, host, fullPath, port) <- liftE $ uriToQuadruple (view dlUri dli)
+                  liftE $ downloadToFile https host fullPath port destFile
 #endif
 
     liftE $ checkDigest dli destFile
@@ -409,8 +408,10 @@ downloadBS :: (MonadReader Settings m, MonadCatch m, MonadIO m, MonadLogger m)
                 m
                 L.ByteString
 downloadBS uri'
-  | scheme == "https" || scheme == "http"
+  | scheme == "https"
-  = dl
+  = dl True
+  | scheme == "http"
+  = dl False
   | scheme == "file"
   = liftIOException doesNotExistErrorType (FileDoesNotExistError path)
     $ (liftIO $ RD.readFile path)
@@ -420,7 +421,11 @@ downloadBS uri'
  where
   scheme = view (uriSchemeL' % schemeBSL') uri'
   path   = view pathL' uri'
-  dl = do
+#if defined(INTERNAL_DOWNLOADER)
+  dl https = do
+#else
+  dl _ = do
+#endif
     lift $ $(logDebug) [i|downloading: #{serializeURIRef' uri'}|]
     lift getDownloader >>= \case
       Curl -> do
@@ -440,7 +445,9 @@ downloadBS uri'
             pure $ L.fromStrict stdout
           CapturedProcess (ExitFailure i') _ _ -> throwE $ NonZeroExit i' (toFilePath exe) args
 #if defined(INTERNAL_DOWNLOADER)
-      Internal -> liftE $ downloadBS' uri'
+      Internal -> do
+        (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        liftE $ downloadBS' https host' fullPath' port'
 #endif
 
 

lib/GHCup/Download/IOStreams.hs

@@ -0,0 +1,253 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+
+module GHCup.Download.IOStreams where
+
+
+import           GHCup.Download.Utils
+import           GHCup.Errors
+import           GHCup.Types.Optics
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.File
+import           GHCup.Utils.Prelude
+
+import           Control.Applicative
+import           Control.Exception.Safe
+import           Control.Monad
+import           Control.Monad.Reader
+import           Data.ByteString                ( ByteString )
+import           Data.ByteString.Builder
+import           Data.CaseInsensitive           ( CI )
+import           Data.IORef
+import           Data.Maybe
+import           Data.Text.Read
+import           HPath
+import           HPath.IO                      as HIO
+import           Haskus.Utils.Variant.Excepts
+import           Network.Http.Client     hiding ( URL )
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import "unix"    System.Posix.IO.ByteString
+                                         hiding ( fdWrite )
+import "unix-bytestring" System.Posix.IO.ByteString
+                                                ( fdWrite )
+import           System.ProgressBar
+import           URI.ByteString
+
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+import qualified Data.Map.Strict               as M
+import qualified System.IO.Streams             as Streams
+
+
+
+
+
+    ----------------------------
+    --[ Low-level (non-curl) ]--
+    ----------------------------
+
+
+-- | Load the result of this download into memory at once.
+downloadBS' :: MonadIO m
+            => Bool             -- ^ https?
+            -> ByteString       -- ^ host (e.g. "www.example.com")
+            -> ByteString       -- ^ path (e.g. "/my/file") including query
+            -> Maybe Int        -- ^ optional port (e.g. 3000)
+            -> Excepts
+                 '[ HTTPStatusError
+                  , URIParseError
+                  , UnsupportedScheme
+                  , NoLocationHeader
+                  , TooManyRedirs
+                  ]
+                 m
+                 (L.ByteString)
+downloadBS' https host path port = do
+  bref <- liftIO $ newIORef (mempty :: Builder)
+  let stepper bs = modifyIORef bref (<> byteString bs)
+  downloadInternal False https host path port stepper
+  liftIO (readIORef bref <&> toLazyByteString)
+
+
+downloadToFile :: (MonadMask m, MonadIO m)
+               => Bool             -- ^ https?
+               -> ByteString       -- ^ host (e.g. "www.example.com")
+               -> ByteString       -- ^ path (e.g. "/my/file") including query
+               -> Maybe Int        -- ^ optional port (e.g. 3000)
+               -> Path Abs         -- ^ destination file to create and write to
+               -> Excepts '[DownloadFailed] m ()
+downloadToFile https host fullPath port destFile = do
+  fd <- liftIO $ createRegularFileFd newFilePerms destFile
+  let stepper = fdWrite fd
+  flip finally (liftIO $ closeFd fd)
+    $ reThrowAll DownloadFailed $ downloadInternal True https host fullPath port stepper
+
+
+downloadInternal :: MonadIO m
+                 => Bool        -- ^ whether to show a progress bar
+                 -> Bool        -- ^ https?
+                 -> ByteString  -- ^ host
+                 -> ByteString  -- ^ path with query
+                 -> Maybe Int   -- ^ optional port
+                 -> (ByteString -> IO a)   -- ^ the consuming step function
+                 -> Excepts
+                      '[ HTTPStatusError
+                       , URIParseError
+                       , UnsupportedScheme
+                       , NoLocationHeader
+                       , TooManyRedirs
+                       ]
+                      m
+                      ()
+downloadInternal = go (5 :: Int)
+
+ where
+  go redirs progressBar https host path port consumer = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Just r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Nothing -> pure ()
+   where
+    action c = do
+      let q = buildRequest1 $ http GET path
+
+      sendRequest c q emptyBody
+
+      receiveResponse
+        c
+        (\r i' -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> downloadStream r i' >> pure Nothing
+            | scode >= 300 && scode < 400 -> case getHeader r "Location" of
+              Just r' -> pure $ Just $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) progressBar https' host' fullPath' port' consumer
+      Left e -> throwE e
+
+    downloadStream r i' = do
+      let size = case getHeader r "Content-Length" of
+            Just x' -> case decimal $ decUTF8Safe x' of
+              Left  _       -> 0
+              Right (r', _) -> r'
+            Nothing -> 0
+
+      mpb <- if progressBar
+        then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
+        else pure Nothing
+
+      outStream <- liftIO $ Streams.makeOutputStream
+        (\case
+          Just bs -> do
+            forM_ mpb $ \pb -> incProgress pb (BS.length bs)
+            void $ consumer bs
+          Nothing -> pure ()
+        )
+      liftIO $ Streams.connect i' outStream
+
+
+getHead :: (MonadCatch m, MonadIO m)
+        => URI
+        -> Excepts
+             '[ HTTPStatusError
+              , URIParseError
+              , UnsupportedScheme
+              , NoLocationHeader
+              , TooManyRedirs
+              , ProcessError
+              ]
+             m
+             (M.Map (CI ByteString) ByteString)
+getHead uri' | scheme == "https" = head' True
+             | scheme == "http"  = head' False
+             | otherwise         = throwE UnsupportedScheme
+
+ where
+  scheme = view (uriSchemeL' % schemeBSL') uri'
+  head' https = do
+    (_, host', fullPath', port') <- liftE $ uriToQuadruple uri'
+    liftE $ headInternal https host' fullPath' port'
+
+
+headInternal :: MonadIO m
+             => Bool        -- ^ https?
+             -> ByteString  -- ^ host
+             -> ByteString  -- ^ path with query
+             -> Maybe Int   -- ^ optional port
+             -> Excepts
+                  '[ HTTPStatusError
+                   , URIParseError
+                   , UnsupportedScheme
+                   , TooManyRedirs
+                   , NoLocationHeader
+                   ]
+                  m
+                  (M.Map (CI ByteString) ByteString)
+headInternal = go (5 :: Int)
+
+ where
+  go redirs https host path port = do
+    r <- liftIO $ withConnection' https host port action
+    veitherToExcepts r >>= \case
+      Left r' ->
+        if redirs > 0 then followRedirectURL r' else throwE TooManyRedirs
+      Right hs -> pure hs
+   where
+
+    action c = do
+      let q = buildRequest1 $ http HEAD path
+
+      sendRequest c q emptyBody
+
+      unsafeReceiveResponse
+        c
+        (\r _ -> runE $ do
+          let scode = getStatusCode r
+          if
+            | scode >= 200 && scode < 300 -> do
+              let headers = getHeaderMap r
+              pure $ Right $ headers
+            | scode >= 300 && scode < 400 -> case getHeader r "Location" of
+              Just r' -> pure $ Left $ r'
+              Nothing -> throwE NoLocationHeader
+            | otherwise -> throwE $ HTTPStatusError scode
+        )
+
+    followRedirectURL bs = case parseURI strictURIParserOptions bs of
+      Right uri' -> do
+        (https', host', fullPath', port') <- liftE $ uriToQuadruple uri'
+        go (redirs - 1) https' host' fullPath' port'
+      Left e -> throwE e
+
+
+withConnection' :: Bool
+                -> ByteString
+                -> Maybe Int
+                -> (Connection -> IO a)
+                -> IO a
+withConnection' https host port action = bracket acquire closeConnection action
+
+ where
+  acquire = case https of
+    True -> do
+      ctx <- baselineContextSSL
+      openConnectionSSL ctx host (fromIntegral $ fromMaybe 443 port)
+    False -> openConnection host (fromIntegral $ fromMaybe 80 port)

lib/GHCup/Download/Internal.hs

@@ -1,214 +0,0 @@
-{-# LANGUAGE CPP                   #-}
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DeriveGeneric         #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE OverloadedStrings     #-}
-{-# LANGUAGE QuasiQuotes           #-}
-{-# LANGUAGE TemplateHaskell       #-}
-{-# LANGUAGE TypeApplications      #-}
-{-# LANGUAGE TypeFamilies          #-}
-
-
-module GHCup.Download.Internal where
-
-
-import           GHCup.Errors
-import           GHCup.Types.Optics
-import           GHCup.Types.JSON               ( )
-import           GHCup.Utils.File
-import           GHCup.Utils.Prelude
-
-import           Control.Applicative
-import           Control.Exception.Safe
-import           Control.Monad
-import           Control.Monad.Reader
-import           Data.ByteString                ( ByteString )
-import           Data.ByteString.Builder
-import           Data.CaseInsensitive           ( CI )
-import           Data.IORef
-import           Data.Maybe
-import           Data.Text.Read
-import           HPath
-import           HPath.IO                      as HIO
-import           Haskus.Utils.Variant.Excepts
-import           Network.HTTP.Client
-import           Network.HTTP.Client.OpenSSL
-import           Network.HTTP.Types.Status
-import           Network.HTTP.Types.Header
-import           Optics
-import           Prelude                 hiding ( abs
-                                                , readFile
-                                                , writeFile
-                                                )
-import "unix"    System.Posix.IO.ByteString
-                                         hiding ( fdWrite )
-import "unix-bytestring" System.Posix.IO.ByteString
-                                                ( fdWrite )
-import           System.ProgressBar
-import           URI.ByteString
-
-import qualified Data.ByteString               as BS
-import qualified Data.ByteString.Lazy          as L
-import qualified Data.Map.Strict               as M
-import qualified Data.Text                     as T
-import qualified OpenSSL.Session               as SSL
-
-
-
-
-
-    ----------------------------
-    --[ Low-level (non-curl) ]--
-    ----------------------------
-
-
--- | Load the result of this download into memory at once.
-downloadBS' :: (MonadThrow m, MonadIO m)
-            => URI
-            -> Excepts
-                 '[HTTPStatusError]
-                 m
-                 (L.ByteString)
-downloadBS' uri' = do
-  bref <- liftIO $ newIORef (mempty :: Builder)
-  -- TODO: performance
-  let stepper bs = modifyIORef bref (<> byteString bs)
-  downloadInternal False
-                   (T.unpack . decUTF8Safe . serializeURIRef' $ uri')
-                   stepper
-  liftIO (readIORef bref <&> toLazyByteString)
-
-
-downloadToFile :: (MonadMask m, MonadIO m)
-               => URI
-               -> Path Abs         -- ^ destination file to create and write to
-               -> Excepts '[DownloadFailed] m ()
-downloadToFile uri' destFile = do
-  fd <- liftIO $ createRegularFileFd newFilePerms destFile
-  let stepper = fdWrite fd
-  flip finally (liftIO $ closeFd fd)
-    $ reThrowAll DownloadFailed
-    $ downloadInternal True
-                       (T.unpack . decUTF8Safe . serializeURIRef' $ uri')
-                       stepper
-
-
-downloadInternal :: (MonadThrow m, MonadIO m)
-                 => Bool        -- ^ whether to show a progress bar
-                 -> String
-                 -> (ByteString -> IO a)   -- ^ the consuming step function
-                 -> Excepts
-                      '[HTTPStatusError]
-                      m
-                      ()
-downloadInternal progressBar uri' consumer = lEM $ liftIO $ withConnection' action
- where
-  action :: (MonadThrow m, MonadIO m) => Manager -> m (Either HTTPStatusError ())
-  action m = do
-    request <- parseRequest ("GET " <> uri')
-    liftIO $ withResponse
-      request
-      m
-      (\r -> do
-        let scode = statusCode . responseStatus $ r
-        if
-          | scode >= 200 && scode < 300 ->
-              let headers = M.fromList . responseHeaders $ r
-              in fmap Right $ liftIO $ downloadStream (responseBody r) headers
-          | otherwise -> pure $ Left $ HTTPStatusError scode
-      )
-
-  downloadStream :: BodyReader -> M.Map HeaderName ByteString -> IO ()
-  downloadStream br headers = do
-    let size = case M.lookup "Content-Length" headers of
-          Just x' -> case decimal $ decUTF8Safe x' of
-            Left  _       -> 0
-            Right (r', _) -> r'
-          Nothing -> 0
-
-    mpb <- if progressBar
-      then Just <$> (liftIO $ newProgressBar defStyle 10 (Progress 0 size ()))
-      else pure Nothing
-
-    loop mpb
-
-   where
-    loop mpb = do
-      bs <- brRead br
-      if BS.length bs == 0 then pure () else do
-        void $ consumer bs
-        forM_ mpb $ \pb -> incProgress pb (BS.length bs)
-        loop mpb
-
-
-getHead :: (MonadCatch m, MonadIO m)
-        => URI
-        -> Excepts
-             '[HTTPStatusError, UnsupportedScheme]
-             m
-             (M.Map (CI ByteString) ByteString)
-getHead uri' | scheme == "https" || scheme == "http" = head'
-             | otherwise                             = throwE UnsupportedScheme
-
- where
-  scheme = view (uriSchemeL' % schemeBSL') uri'
-  head' =
-    liftE $ headInternal (T.unpack . decUTF8Safe . serializeURIRef' $ uri')
-
-
-headInternal :: (MonadThrow m, MonadIO m)
-             => String
-             -> Excepts
-                  '[HTTPStatusError]
-                  m
-                  (M.Map (CI ByteString) ByteString)
-headInternal uri' = lEM $ liftIO $ withConnection' action
- where
-  action :: (MonadThrow m, MonadIO m)
-         => Manager
-         -> m (Either HTTPStatusError (M.Map (CI ByteString) ByteString))
-  action m = do
-    request <- parseRequest ("HEAD " <> uri')
-    liftIO $ withResponse
-      request
-      m
-      (\r -> do
-        let scode = statusCode . responseStatus $ r
-        if
-          | scode >= 200 && scode < 300 -> do
-            let headers = responseHeaders r
-            pure $ Right $ M.fromList $ headers
-          | otherwise -> pure $ Left (HTTPStatusError scode)
-      )
-
-
-withConnection' :: (Manager -> IO a) -> IO a
-withConnection' action = do
-  mg  <- newManager $ opensslManagerSettings baselineContextSSL
-  withOpenSSL (action mg)
-
-
-baselineContextSSL :: IO SSL.SSLContext
-baselineContextSSL = withOpenSSL $ do
-    ctx <- SSL.context
-    SSL.contextSetDefaultCiphers ctx
-#if defined(darwin_HOST_OS)
-    SSL.contextSetVerificationMode ctx SSL.VerifyNone
-#elif defined(mingw32_HOST_OS)
-    SSL.contextSetVerificationMode ctx SSL.VerifyNone
-#elif defined(freebsd_HOST_OS)
-    SSL.contextSetCAFile ctx "/usr/local/etc/ssl/cert.pem"
-    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
-#elif defined(openbsd_HOST_OS)
-    SSL.contextSetCAFile ctx "/etc/ssl/cert.pem"
-    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
-#else
-    fedora <- doesDirectoryExist [abs|/etc/pki/tls|]
-    if fedora
-        then do
-            SSL.contextSetCAFile ctx "/etc/pki/tls/certs/ca-bundle.crt"
-        else do
-            SSL.contextSetCADirectory ctx "/etc/ssl/certs"
-    SSL.contextSetVerificationMode ctx $ SSL.VerifyPeer True True Nothing
-#endif
-    return ctx

lib/GHCup/Download/Utils.hs

@@ -0,0 +1,64 @@
+{-# LANGUAGE DataKinds             #-}
+{-# LANGUAGE DeriveGeneric         #-}
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeApplications      #-}
+{-# LANGUAGE TypeFamilies          #-}
+
+
+module GHCup.Download.Utils where
+
+
+import           GHCup.Errors
+import           GHCup.Types.Optics
+import           GHCup.Types.JSON               ( )
+import           GHCup.Utils.Prelude
+
+import           Control.Applicative
+import           Control.Monad
+import           Data.ByteString                ( ByteString )
+import           Data.Maybe
+import           Haskus.Utils.Variant.Excepts
+import           Optics
+import           Prelude                 hiding ( abs
+                                                , readFile
+                                                , writeFile
+                                                )
+import           URI.ByteString
+
+import qualified Data.Binary.Builder           as B
+import qualified Data.ByteString               as BS
+import qualified Data.ByteString.Lazy          as L
+
+
+-- | Extracts from a URI type: (https?, host, path+query, port)
+uriToQuadruple :: Monad m
+               => URI
+               -> Excepts
+                    '[UnsupportedScheme]
+                    m
+                    (Bool, ByteString, ByteString, Maybe Int)
+uriToQuadruple URI {..} = do
+  let scheme = view schemeBSL' uriScheme
+
+  host <-
+    preview (_Just % authorityHostL' % hostBSL') uriAuthority
+      ?? UnsupportedScheme
+
+  https <- if
+    | scheme == "https" -> pure True
+    | scheme == "http"  -> pure False
+    | otherwise         -> throwE UnsupportedScheme
+
+  let queryBS =
+        BS.intercalate "&"
+          . fmap (\(x, y) -> encodeQuery x <> "=" <> encodeQuery y)
+          $ (queryPairs uriQuery)
+      port =
+        preview (_Just % authorityPortL' % _Just % portNumberL') uriAuthority
+      fullpath = if BS.null queryBS then uriPath else uriPath <> "?" <> queryBS
+  pure (https, host, fullpath, port)
+  where encodeQuery = L.toStrict . B.toLazyByteString . urlEncodeQuery
+

lib/GHCup/Types.hs

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

lib/GHCup/Utils.hs

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

lib/GHCup/Utils/File.hs

@@ -1,33 +1,27 @@
 {-# LANGUAGE QuasiQuotes       #-}
 {-# LANGUAGE OverloadedStrings #-}
-{-# LANGUAGE FlexibleContexts  #-}
 {-# LANGUAGE TemplateHaskell   #-}
 
 module GHCup.Utils.File where
 
 import           GHCup.Utils.Dirs
 import           GHCup.Utils.Prelude
-import           GHCup.Types
 
 import           Control.Concurrent
 import           Control.Exception              ( evaluate )
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.Reader
-import           Control.Monad.Trans.State.Strict
 import           Data.ByteString                ( ByteString )
 import           Data.Foldable
 import           Data.Functor
 import           Data.IORef
 import           Data.Maybe
-import           Data.Sequence                  ( Seq, (|>) )
 import           Data.Text                      ( Text )
 import           Data.Void
-import           Data.Word8
 import           GHC.IO.Exception
 import           HPath
-import           HPath.IO                hiding ( hideError )
+import           HPath.IO
-import           Optics                  hiding ((<|), (|>))
+import           Optics
 import           System.Console.Pretty
 import           System.Console.Regions
 import           System.IO.Error
@@ -43,7 +37,6 @@ import           Text.Regex.Posix
 
 
 import qualified Control.Exception             as EX
-import qualified Data.Sequence                 as Sq
 import qualified Data.Text                     as T
 import qualified Data.Text.Encoding            as E
 import qualified System.Posix.Process.ByteString
@@ -57,7 +50,6 @@ import qualified "unix-bytestring" System.Posix.IO.ByteString
 
 
 
-
 -- | Bool signals whether the regions should be cleaned.
 data StopThread = StopThread Bool
   deriving Show
@@ -109,149 +101,110 @@ executeOut path args chdir = captureOutStreams $ do
   SPPB.executeFile (toFilePath path) True args Nothing
 
 
-execLogged :: (MonadReader Settings m, MonadIO m, MonadThrow m)
+execLogged :: ByteString       -- ^ thing to execute
-           => ByteString       -- ^ thing to execute
            -> Bool             -- ^ whether to search PATH for the thing
            -> [ByteString]     -- ^ args for the thing
            -> Path Rel         -- ^ log filename
            -> Maybe (Path Abs) -- ^ optionally chdir into this
            -> Maybe [(ByteString, ByteString)] -- ^ optional environment
-           -> m (Either ProcessError ())
+           -> IO (Either ProcessError ())
 execLogged exe spath args lfile chdir env = do
-  Settings {..} <- ask
+  ldir    <- ghcupLogsDir
-  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
-  action verbose fd = do
+  action fd = do
     actionWithPipes $ \(stdoutRead, stdoutWrite) -> do
-      -- start the thread that logs to stdout
+      -- start the thread that logs to stdout in a region
-      pState <- newEmptyMVar
+      done <- newEmptyMVar
-      done   <- newEmptyMVar
+      tid  <-
-      void
+        forkIO
-        $ forkOS
         $ EX.handle (\(_ :: StopThread) -> pure ())
         $ EX.handle (\(_ :: IOException) -> pure ())
         $ flip finally (putMVar done ())
-        $ (if verbose
+        $ printToRegion fd stdoutRead 6
-            then tee fd stdoutRead
-            else printToRegion fd stdoutRead 6 pState
-          )
 
-      -- fork the subprocess
+      -- fork our subprocess
       pid <- SPPB.forkProcess $ do
         void $ dupTo stdoutWrite stdOutput
         void $ dupTo stdoutWrite stdError
-        closeFd stdoutRead
         closeFd stdoutWrite
+        closeFd stdoutRead
 
         -- execute the action
         maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir
-        void $ SPPB.executeFile exe spath args env
+        SPPB.executeFile exe spath args env
 
       closeFd stdoutWrite
 
       -- wait for the subprocess to finish
-      e <- toProcessError exe args <$!> SPPB.getProcessStatus True True pid
+      e <- SPPB.getProcessStatus True True pid >>= \case
-      putMVar pState (either (const False) (const True) e)
+        i@(Just (SPPB.Exited _)) -> pure $ toProcessError exe args i
+        i                        -> pure $ toProcessError exe args i
 
+      -- make sure the logging thread stops
+      case e of
+        Left  _ -> EX.throwTo tid (StopThread False)
+        Right _ -> EX.throwTo tid (StopThread True)
       takeMVar done
+
       closeFd stdoutRead
-
       pure e
 
-  tee :: Fd -> Fd -> IO ()
-  tee fileFd fdIn = readTilEOF lineAction fdIn
-
-   where
-    lineAction :: ByteString -> IO ()
-    lineAction bs' = do
-      void $ SPIB.fdWrite fileFd (bs' <> "\n")
-      void $ SPIB.fdWrite stdOutput (bs' <> "\n")
-
   -- Reads fdIn and logs the output in a continous scrolling area
   -- of 'size' terminal lines. Also writes to a log file.
-  printToRegion :: Fd -> Fd -> Int -> MVar Bool -> IO ()
+  printToRegion fileFd fdIn size = do
-  printToRegion fileFd fdIn size pState = do
+    ref <- newIORef ([] :: [ByteString])
-    void $ displayConsoleRegions $ do
+    displayConsoleRegions $ do
-      rs <-
+      rs <- sequence . replicate size . openConsoleRegion $ Linear
-        liftIO
+      flip finally (readTilEOF (lineAction ref rs) fdIn) -- make sure the last few lines don't get cut off
-        . fmap Sq.fromList
-        . sequence
-        . replicate size
-        . openConsoleRegion
-        $ Linear
-      flip runStateT mempty
         $ handle
-            (\(ex :: SomeException) -> do
+            (\(StopThread b) -> do
-              ps <- liftIO $ takeMVar pState
+              when b (forM_ rs closeConsoleRegion)
-              when (ps == True) (forM_ rs (liftIO . closeConsoleRegion))
+              EX.throw (StopThread b)
-              throw ex
             )
-        $ readTilEOF (lineAction rs) fdIn
+        $ do
+            hideError eofErrorType $ readTilEOF (lineAction ref rs) fdIn
+            -- wait for explicit stop from the parent to signal what cleanup to run
+            forever (threadDelay 5000)
 
    where
     -- action to perform line by line
-    -- TODO: do this with vty for efficiency
+    lineAction ref rs bs' = do
-    lineAction :: (MonadMask m, MonadIO m)
+      modifyIORef' ref (swapRegs bs')
-               => Seq ConsoleRegion
+      regs <- readIORef ref
-               -> ByteString
+      void $ SPIB.fdWrite fileFd (bs' <> "\n")
-               -> StateT (Seq ByteString) m ()
+      forM (zip regs rs) $ \(bs, r) -> do
-    lineAction rs = \bs' -> do
+        setConsoleRegion r $ do
-      void $ liftIO $ SPIB.fdWrite fileFd (bs' <> "\n")
+          w <- consoleWidth
-      modify (swapRegs bs')
+          return
-      regs <- get
+            . T.pack
-      liftIO $ forM_ (Sq.zip regs rs) $ \(bs, r) -> setConsoleRegion r $ do
+            . color Blue
-        w <- consoleWidth
+            . T.unpack
-        return
+            . decUTF8Safe
-          . T.pack
+            . trim w
-          . color Blue
+            . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
-          . T.unpack
+            $ bs
-          . decUTF8Safe
-          . trim w
-          . (\b -> "[ " <> toFilePath lfile <> " ] " <> b)
-          $ bs
 
-    swapRegs :: a -> Seq a -> Seq a
+    swapRegs bs regs | length regs < size = regs ++ [bs]
-    swapRegs bs = \regs -> if
+                     | otherwise          = tail regs ++ [bs]
-      | Sq.length regs < size -> regs |> bs
-      | otherwise             -> Sq.drop 1 regs |> bs
 
     -- trim output line to terminal width
-    trim :: Int -> ByteString -> ByteString
+    trim w bs | BS.length bs > w && w > 5 = BS.take (w - 4) bs <> "..."
-    trim w = \bs -> if
+              | otherwise                 = bs
-      | BS.length bs > w && w > 5 -> BS.take (w - 4) bs <> "..."
-      | otherwise                 -> bs
 
-  -- read an entire line from the file descriptor (removes the newline char)
+    -- read an entire line from the file descriptor (removes the newline char)
-  readLine :: MonadIO m => Fd -> ByteString -> m (ByteString, ByteString)
+    readLine fd' = do
-  readLine fd = go
+      bs <- SPIB.fdRead fd' 1
-   where
-    go inBs = do
-      bs <-
-        liftIO
-        $ handleIO (\e -> if isEOFError e then pure "" else ioError e)
-        $ SPIB.fdRead fd 512
-      let nbs          = BS.append inBs bs
-          (line, rest) = BS.span (/= _lf) nbs
       if
-        | BS.length rest /= 0 -> pure (line, BS.tail rest)
+        | bs == "\n" -> pure ""
-        | BS.length line == 0 -> pure (mempty, mempty)
+        | bs == ""   -> pure ""
-        | otherwise           -> (\(l, r) -> (line <> l, r)) <$!> go mempty
+        | otherwise  -> fmap (bs <>) $ readLine fd'
 
-  readTilEOF :: MonadIO m => (ByteString -> m a) -> Fd -> m ()
+    readTilEOF action' fd' = do
-  readTilEOF ~action' fd' = go mempty
+      bs <- readLine fd'
-   where
+      void $ action' bs
-    go bs' = do
+      readTilEOF action' fd'
-      (bs, rest) <- readLine fd' bs'
-      if
-        | BS.length bs == 0 -> liftIO
-        $ ioError (mkIOError eofErrorType "" Nothing Nothing)
-        | otherwise -> do
-          void $ action' bs
-          go rest
 
 
 -- | Capture the stdout and stderr of the given action, which

lib/GHCup/Utils/Prelude.hs

@@ -1,12 +1,8 @@
-{-# OPTIONS_GHC -Wno-orphans #-}
-
 {-# LANGUAGE DataKinds           #-}
 {-# LANGUAGE DeriveLift          #-}
 {-# LANGUAGE FlexibleContexts    #-}
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE UndecidableInstances #-}
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeApplications    #-}
 {-# LANGUAGE TypeFamilies        #-}
@@ -17,10 +13,8 @@ module GHCup.Utils.Prelude where
 import           Control.Applicative
 import           Control.Exception.Safe
 import           Control.Monad
-import           Control.Monad.Base
 import           Control.Monad.IO.Class
 import           Control.Monad.Trans.Class      ( lift )
-import           Control.Monad.Trans.Control
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 import           Data.String
@@ -171,11 +165,6 @@ liftIOException errType ex =
     . lift
 
 
--- | Uses safe-exceptions.
-hideError :: (MonadIO m, MonadCatch m) => IOErrorType -> m () -> m ()
-hideError err = handleIO (\e -> if err == ioeGetErrorType e then pure () else liftIO . ioError $ e)
-
-
 hideErrorDef :: [IOErrorType] -> a -> IO a -> IO a
 hideErrorDef errs def =
   handleIO (\e -> if ioeGetErrorType e `elem` errs then pure def else ioError e)
@@ -270,40 +259,3 @@ decUTF8Safe = E.decodeUtf8With E.lenientDecode
 
 decUTF8Safe' :: L.ByteString -> Text
 decUTF8Safe' = TL.toStrict . TLE.decodeUtf8With E.lenientDecode
-
-
-instance MonadBaseControl b m => MonadBaseControl b (Excepts e m) where
-    type StM (Excepts e m) a = ComposeSt (Excepts e) m a
-    liftBaseWith   = defaultLiftBaseWith
-    restoreM       = defaultRestoreM
-    {-# INLINABLE liftBaseWith #-}
-    {-# INLINABLE restoreM #-}
-
-instance MonadTransControl (Excepts e) where
-    type StT (Excepts e) a = VEither e a
-    liftWith f = veitherMToExcepts <$> liftM return $ f $ runE
-    restoreT = veitherMToExcepts
-    {-# INLINABLE liftWith #-}
-    {-# INLINABLE restoreT #-}
-
-instance MonadBase b m => MonadBase b (Excepts e m) where
-  liftBase = liftBaseDefault
-  {-# INLINABLE liftBase #-}
-
-instance MonadBaseControl (VEither e) (VEither e) where
-  type StM (VEither e) a = a
-  liftBaseWith f = f id
-  restoreM = return
-  {-# INLINABLE liftBaseWith #-}
-  {-# INLINABLE restoreM #-}
-
-instance MonadBase (VEither e) (VEither e) where
-  liftBase = id
-  {-# INLINABLE liftBase #-}
-
-
-veitherMToExcepts :: Monad m => m (VEither es a) -> Excepts es m a
-veitherMToExcepts ma = do
-  ve <- lift ma
-  veitherToExcepts ve
-

lib/GHCup/Utils/Version/QQ.hs

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

lib/GHCup/Version.hs

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

www/ghcup.css

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

www/index.html

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