Show a warning if xattr can't be executed

.gitlab/script/ghcup_version.sh

@@ -49,6 +49,15 @@ elif [ "${OS}" = "LINUX" ] ; then
 		ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui
 		ecabal test -w ghc-${GHC_VERSION} -finternal-downloader -ftui ghcup-test
 		ecabal haddock -w ghc-${GHC_VERSION} -finternal-downloader -ftui
+
+		# doctest
+		curl -sL https://github.com/phadej/cabal-extras/releases/download/cabal-docspec-0.0.0.20210111/cabal-docspec-0.0.0.20210111.xz > cabal-docspec.xz
+		echo '0829bd034fba901cbcfe491d98ed8b28fd54f9cb5c91fa8e1ac62dc4413c9562  cabal-docspec.xz' | sha256sum -c -
+		xz -d < cabal-docspec.xz > "$CI_PROJECT_DIR"/.local/bin/cabal-docspec
+		rm -f cabal-docspec.xz
+		chmod a+x "$CI_PROJECT_DIR"/.local/bin/cabal-docspec
+
+		cabal-docspec -XCPP -XTypeSynonymInstances -XOverloadedStrings -XPackageImports --check-properties
 	fi
 elif [ "${OS}" = "FREEBSD" ] ; then
 	ecabal build -w ghc-${GHC_VERSION} -finternal-downloader -ftui --constraint="zip +disable-zstd"

lib/GHCup.hs

@@ -83,7 +83,7 @@ import           System.IO.Error
 #if defined(IS_WINDOWS)
 import           System.IO.Temp
 #endif
-import           Text.PrettyPrint.HughesPJClass ( prettyShow )
+import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
 import           Text.Regex.Posix
 
 import qualified Crypto.Hash.SHA256            as SHA256
@@ -276,7 +276,7 @@ installPackedGHC dl msubdir inst ver = do
   -- unpack
   tmpUnpack <- lift mkGhcupTmpDir
   liftE $ unpackToDir tmpUnpack dl
-  void $ lift $ darwinNotarization _rPlatform tmpUnpack
+  liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
   workdir <- maybe (pure tmpUnpack)
@@ -451,7 +451,7 @@ installCabalBindist dlinfo ver isoFilepath = do
   -- unpack
   tmpUnpack <- lift withGHCupTmpDir
   liftE $ unpackToDir tmpUnpack dl
-  void $ lift $ darwinNotarization _rPlatform tmpUnpack
+  liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
   workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@@ -579,7 +579,7 @@ installHLSBindist dlinfo ver isoFilepath = do
   -- unpack
   tmpUnpack <- lift withGHCupTmpDir
   liftE $ unpackToDir tmpUnpack dl
-  void $ lift $ darwinNotarization _rPlatform tmpUnpack
+  liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
   workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@@ -760,7 +760,7 @@ installStackBindist dlinfo ver isoFilepath = do
   -- unpack
   tmpUnpack <- lift withGHCupTmpDir
   liftE $ unpackToDir tmpUnpack dl
-  void $ lift $ darwinNotarization _rPlatform tmpUnpack
+  liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
   -- the subdir of the archive where we do the work
   workdir <- maybe (pure tmpUnpack) (liftE . intoSubdir tmpUnpack) (view dlSubdir dlinfo)
@@ -1816,7 +1816,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
         -- unpack
         tmpUnpack <- lift mkGhcupTmpDir
         liftE $ unpackToDir tmpUnpack dl
-        void $ lift $ darwinNotarization _rPlatform tmpUnpack
+        liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
 
         workdir <- maybe (pure tmpUnpack)
                          (liftE . intoSubdir tmpUnpack)
@@ -1856,7 +1856,7 @@ compileGHC targetGhc ov bstrap jobs mbuildConfig patchdir aargs buildFlavour had
             ExitSuccess -> throwEither . MP.parse ghcProjectVersion "" . decUTF8Safe' $ _stdOut
             ExitFailure c -> fail ("Could not figure out GHC project version. Exit code was: " <> show c <> ". Error was: " <> T.unpack (decUTF8Safe' _stdErr))
 
-        void $ lift $ darwinNotarization _rPlatform tmpUnpack
+        liftE $ catchWarn $ lEM @_ @'[ProcessError] $ darwinNotarization _rPlatform tmpUnpack
         lift $ $(logInfo) [i|Git version #{ref} corresponds to GHC version #{prettyVer tver}|]
 
         pure (tmpUnpack, tmpUnpack, GHCTargetVersion Nothing tver)
@@ -2354,4 +2354,3 @@ whereIsTool tool ver@GHCTargetVersion {..} = do
       liftIO $ canonicalizePath currentRunningExecPath
 
 
-

lib/GHCup/Download.hs

@@ -368,7 +368,7 @@ download uri eDigest dest mfn etags
 
                           -- this nonsense is necessary, because some older versions of curl would overwrite
                           -- the destination file when 304 is returned
-                          case fmap T.words . listToMaybe . fmap T.strip . T.lines $ headers of
+                          case fmap T.words . listToMaybe . fmap T.strip . T.lines . getLastHeader $ headers of
                             Just (http':sc:_)
                               | sc == "304"
                               , T.pack "HTTP" `T.isPrefixOf` http' -> $logDebug [i|Status code was 304, not overwriting|]
@@ -447,7 +447,7 @@ download uri eDigest dest mfn etags
 
   parseEtags :: (MonadLogger m, MonadIO m, MonadThrow m) => T.Text -> m (Maybe T.Text)
   parseEtags stderr = do
-    let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines $ stderr
+    let mEtag = find (\line -> T.pack "etag:" `T.isPrefixOf` T.toLower line) . fmap T.strip . T.lines . getLastHeader $ stderr
     case T.words <$> mEtag of
       (Just []) -> do
         $logDebug "Couldn't parse etags, no input: "
@@ -585,7 +585,23 @@ getWgetOpts =
     Nothing -> pure []
 
 
+-- | Get the url base name.
+--
+-- >>> urlBaseName "/foo/bar/baz"
+-- "baz"
 urlBaseName :: ByteString  -- ^ the url path (without scheme and host)
             -> ByteString
 urlBaseName = snd . B.breakEnd (== _slash) . urlDecode False
 
+
+-- | Curl saves all intermediate connect headers as well, not just the last one, so we make an effort to take the
+-- last HTTP block only. Passing '--suppress-connect-headers' would be better, but it isn't supported by all versions,
+-- also see:
+--   https://gitlab.haskell.org/haskell/ghcup-hs/-/issues/213
+--
+-- >>> getLastHeader "\n\nHTTP/1.0 200 Connection established\n\nHTTP/1.1 304 Not Modified\n"
+-- "HTTP/1.1 304 Not Modified\n"
+-- >>> getLastHeader "HTTP/1.1 304 Not Modified\n"
+-- "HTTP/1.1 304 Not Modified\n"
+getLastHeader :: T.Text -> T.Text
+getLastHeader = T.unlines . lastDef [] . filter (\x -> not (null x)) . splitOn [""] . fmap T.stripEnd . T.lines

lib/GHCup/Utils/Prelude.hs

@@ -5,6 +5,7 @@
 {-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}
 {-# LANGUAGE TypeOperators       #-}
+{-# LANGUAGE TemplateHaskell     #-}
 
 {-|
 Module      : GHCup.Utils.Prelude
@@ -29,6 +30,7 @@ import           Control.Exception.Safe
 import           Control.Monad
 import           Control.Monad.IO.Class
 import           Control.Monad.Reader
+import           Control.Monad.Logger
 import           Data.Bifunctor
 import           Data.ByteString                ( ByteString )
 import           Data.List                      ( nub, intercalate )
@@ -39,6 +41,7 @@ import           Data.Versions
 import           Data.Word8
 import           Haskus.Utils.Types.List
 import           Haskus.Utils.Variant.Excepts
+import           Text.PrettyPrint.HughesPJClass ( prettyShow, Pretty )
 import           System.IO.Error
 #if defined(IS_WINDOWS)
 import           System.IO.Temp
@@ -68,6 +71,14 @@ import qualified System.Win32.File             as Win32
 #endif
 
 
+-- $setup
+-- >>> import Data.ByteString.Internal (c2w, w2c)
+-- >>> import Test.QuickCheck
+-- >>> import Data.Word8
+-- >>> import Data.Word8
+-- >>> import qualified Data.Text as T
+-- >>> instance Arbitrary T.Text where arbitrary = T.pack <$> arbitrary
+
 
 fS :: IsString a => String -> a
 fS = fromString
@@ -162,6 +173,10 @@ lEM' :: forall e' e es a m
      -> Excepts es m a
 lEM' f em = lift em >>= lE . first f
 
+-- for some obscure reason... this won't type-check if we move it to a different module
+catchWarn :: forall es m . (Pretty (V es), MonadLogger m, Monad m) => Excepts es m () -> Excepts '[] m ()
+catchWarn = catchAllE @_ @es (\v -> lift $ $(logWarn) (T.pack . prettyShow $ v))
+
 fromEither :: Either a b -> VEither '[a] b
 fromEither = either (VLeft . V) VRight
 
@@ -489,7 +504,14 @@ recover action =
 #endif
 
 
--- Gathering monoidal values
+-- | Gathering monoidal values
+--
+-- >>> traverseFold (pure . (:["0"])) ["1","2"]
+-- ["1","0","2","0"]
+-- >>> traverseFold Just ["1","2","3","4","5"]
+-- Just "12345"
+--
+-- prop> \t -> traverseFold Just t === Just (mconcat t)
 traverseFold :: (Foldable t, Applicative m, Monoid b) => (a -> m b) -> t a -> m b
 traverseFold f = foldl (\mb a -> (<>) <$> mb <*> f a) (pure mempty)
 
@@ -499,6 +521,16 @@ forFold = \t -> (`traverseFold` t)
 
 
 -- | Strip @\\r@ and @\\n@ from 'ByteString's
+--
+-- >>> stripNewline "foo\n\n\n"
+-- "foo"
+-- >>> stripNewline "foo\r"
+-- "foo"
+-- >>> stripNewline "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewline (t <> "\n") === stripNewline t
+-- prop> \t -> not (any (isNewLine . c2w) t) ==> stripNewline t == t
 stripNewline :: String -> String
 stripNewline s
   | null s               = []
@@ -507,6 +539,16 @@ stripNewline s
 
 
 -- | Strip @\\r@ and @\\n@ from 'ByteString's
+--
+-- >>> stripNewline' "foo\n\n\n"
+-- "foo"
+-- >>> stripNewline' "foo\r"
+-- "foo"
+-- >>> stripNewline' "foo"
+-- "foo"
+--
+-- prop> \t -> stripNewline' (t <> "\n") === stripNewline' t
+-- prop> \t -> not (T.any (isNewLine . c2w) t) ==> stripNewline' t == t
 stripNewline' :: T.Text -> T.Text
 stripNewline' s
   | T.null s               = mempty
@@ -514,6 +556,14 @@ stripNewline' s
   | otherwise              = T.singleton (T.head s) <> stripNewline' (T.tail s)
 
 
+-- | Is the word8 a newline?
+--
+-- >>> isNewLine (c2w '\n')
+-- True
+-- >>> isNewLine (c2w '\r')
+-- True
+--
+-- prop> \w -> w /= _lf && w /= _cr ==> not (isNewLine w)
 isNewLine :: Word8 -> Bool
 isNewLine w
   | w == _lf = True
@@ -523,8 +573,10 @@ isNewLine w
 
 -- | Split on a PVP suffix.
 --
--- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706" == ("ghc-iserv-dyn", "9.3.20210706")
--- >>> splitOnPVP "-" "ghc-iserv-dyn"              == ("ghc-iserv-dyn", "")
+-- >>> splitOnPVP "-" "ghc-iserv-dyn-9.3.20210706"
+-- ("ghc-iserv-dyn","9.3.20210706")
+-- >>> splitOnPVP "-" "ghc-iserv-dyn"
+-- ("ghc-iserv-dyn","")
 splitOnPVP :: String -> String -> (String, String)
 splitOnPVP c s = case Split.splitOn c s of
   []  -> def