From 2d51ad89404fe85ea8cf83117a091968630f692b Mon Sep 17 00:00:00 2001 From: Julian Ospald Date: Thu, 5 Mar 2020 18:02:59 +0100 Subject: [PATCH] Lala --- TODO.md | 10 +-- app/ghcup-gen/BinaryDownloads.hs | 85 ++++++++++---------- app/ghcup-gen/Main.hs | 33 ++++++-- app/ghcup-gen/SourceDownloads.hs | 4 +- app/ghcup-gen/Validate.hs | 119 ++++++++++++++++++++++----- app/ghcup/Main.hs | 54 +++++++++---- ghcup.cabal | 9 ++- lib/GHCup.hs | 28 ++++--- lib/GHCup/Download.hs | 2 +- lib/GHCup/Platform.hs | 2 +- lib/GHCup/Types/JSON.hs | 29 ++++--- lib/GHCup/Utils.hs | 134 ++++++++++++++++++------------- lib/GHCup/Utils/Dirs.hs | 92 +++++++++++++++++++++ lib/GHCup/Utils/File.hs | 60 +++++++------- lib/GHCup/Utils/Logger.hs | 53 +++++++++--- lib/GHCup/Utils/Prelude.hs | 88 ++------------------ lib/GHCup/Utils/String/QQ.hs | 48 +++++++++++ lib/GHCup/Utils/Version/QQ.hs | 89 ++++++++++++++++++++ lib/GHCup/Version.hs | 3 +- 19 files changed, 635 insertions(+), 307 deletions(-) create mode 100644 lib/GHCup/Utils/Dirs.hs create mode 100644 lib/GHCup/Utils/String/QQ.hs create mode 100644 lib/GHCup/Utils/Version/QQ.hs diff --git a/TODO.md b/TODO.md index 0373d49..c58087d 100644 --- a/TODO.md +++ b/TODO.md @@ -2,20 +2,17 @@ ## Now -* better logs -* better debug-output - -* static builds - +* static builds and host ghcup (and fix BinaryDownloads) * interoperability with old ghcup -* OS faking +* sign the JSON? (Or check gpg keys?) ## Maybe * maybe: download progress * maybe: changelog Show the changelog of a GHC release (online) * maybe: print-system-reqs Print an approximation of system requirements +* OS faking * testing (especially distro detection -> unit tests) @@ -23,6 +20,7 @@ * add support for RC/alpha/HEAD versions * check for updates on start +* use plucky or oops instead of Excepts ## Questions diff --git a/app/ghcup-gen/BinaryDownloads.hs b/app/ghcup-gen/BinaryDownloads.hs index a16156c..0fa393b 100644 --- a/app/ghcup-gen/BinaryDownloads.hs +++ b/app/ghcup-gen/BinaryDownloads.hs @@ -4,9 +4,9 @@ module BinaryDownloads where import GHCup.Types -import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ +import GHCup.Utils.Version.QQ -import Data.String.QQ import HPath import URI.ByteString.QQ @@ -95,7 +95,7 @@ ghc_802_32_deb8 :: DownloadInfo ghc_802_32_deb8 = DownloadInfo [uri|https://downloads.haskell.org/~ghc/8.0.2/ghc-8.0.2-i386-deb8-linux.tar.xz|] (Just ([rel|ghc-8.0.2|] :: Path Rel)) - [s||818621342a2161b8afcc995a0765816bb40aefbfa1db2c8a7d59c04d8b18228a|] + [s|818621342a2161b8afcc995a0765816bb40aefbfa1db2c8a7d59c04d8b18228a|] ghc_802_64_freebsd :: DownloadInfo ghc_802_64_freebsd = DownloadInfo @@ -827,7 +827,8 @@ ghc_883_32_musl :: DownloadInfo ghc_883_32_musl = DownloadInfo [uri|https://github.com/redneb/ghc-alt-libc/releases/download/ghc-8.8.3-musl/ghc-8.8.3-i386-unknown-linux-musl.tar.xz|] (Just ([rel|ghc-8.8.3|] :: Path Rel)) - [s|7a5f41646d06777e75636291a1855d60a0984552bbdf33c3d107565d302f38a4|] + [s|23779adb4cf4b314d0f8c66ee215ba6e74154c0768a573780475943544020bec|] + @@ -900,8 +901,10 @@ cabal_3000_64_darwin = DownloadInfo ghcup_010_64_linux :: DownloadInfo -ghcup_010_64_linux = - DownloadInfo [uri|file:///home/ospa_ju/tmp/ghcup-exe|] Nothing [s||] +ghcup_010_64_linux = DownloadInfo + [uri|file:///home/ospa_ju/tmp/ghcup-exe|] + Nothing + [s|558126339252788a3d44a3f910417277c7ab656f0796b68bdc58afe73296b8cd|] @@ -1023,12 +1026,12 @@ binaryDownloads = M.fromList , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_841_64_fedora)]) , (Linux Fedora , M.fromList [(Nothing, ghc_841_64_fedora)]) - , (Linux Ubuntu, M.fromList [(Nothing, ghc_841_64_fedora)]) - , (Linux Mint , M.fromList [(Nothing, ghc_841_64_fedora)]) - , (Linux Debian, M.fromList [(Nothing, ghc_841_64_deb8)]) - , (Darwin , M.fromList [(Nothing, ghc_841_64_darwin)]) - , (FreeBSD , M.fromList [(Nothing, ghc_841_64_freebsd)]) - , (Linux Alpine, M.fromList [(Nothing, ghc_841_64_musl)]) + , (Linux Ubuntu , M.fromList [(Nothing, ghc_841_64_fedora)]) + , (Linux Mint , M.fromList [(Nothing, ghc_841_64_fedora)]) + , (Linux Debian , M.fromList [(Nothing, ghc_841_64_deb8)]) + , (Darwin , M.fromList [(Nothing, ghc_841_64_darwin)]) + , (FreeBSD , M.fromList [(Nothing, ghc_841_64_freebsd)]) + , (Linux Alpine , M.fromList [(Nothing, ghc_841_64_musl)]) ] ) , ( A_32 @@ -1118,9 +1121,9 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_844_64_fedora)]) - , (Linux CentOS , M.fromList [(Nothing, ghc_844_64_centos)]) - , (Linux AmazonLinux , M.fromList [(Nothing, ghc_844_64_centos)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_844_64_fedora)]) + , (Linux CentOS , M.fromList [(Nothing, ghc_844_64_centos)]) + , (Linux AmazonLinux , M.fromList [(Nothing, ghc_844_64_centos)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_844_64_fedora)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_844_64_fedora) @@ -1156,7 +1159,7 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_861_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_861_64_fedora)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_861_64_fedora)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_861_64_fedora) @@ -1192,7 +1195,7 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_862_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_862_64_fedora)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_862_64_fedora)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_862_64_fedora) @@ -1222,9 +1225,9 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_863_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_863_64_fedora)]) - , (Linux CentOS , M.fromList [(Nothing, ghc_863_64_centos)]) - , (Linux AmazonLinux , M.fromList [(Nothing, ghc_863_64_centos)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_863_64_fedora)]) + , (Linux CentOS , M.fromList [(Nothing, ghc_863_64_centos)]) + , (Linux AmazonLinux , M.fromList [(Nothing, ghc_863_64_centos)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_863_64_fedora) @@ -1260,7 +1263,7 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_864_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_864_64_fedora)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_864_64_fedora)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_864_64_fedora) @@ -1291,13 +1294,13 @@ binaryDownloads = M.fromList ] ) , ( [vver|8.6.5|] - , VersionInfo [] $ M.fromList + , VersionInfo [Recommended] $ M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_865_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_865_64_fedora)]) - , (Linux CentOS , M.fromList [(Nothing, ghc_865_64_centos)]) - , (Linux AmazonLinux , M.fromList [(Nothing, ghc_865_64_centos)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_865_64_fedora)]) + , (Linux CentOS , M.fromList [(Nothing, ghc_865_64_centos)]) + , (Linux AmazonLinux , M.fromList [(Nothing, ghc_865_64_centos)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_865_64_fedora) @@ -1332,9 +1335,9 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_881_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_881_64_fedora)]) - , (Linux CentOS , M.fromList [(Nothing, ghc_881_64_centos)]) - , (Linux AmazonLinux , M.fromList [(Nothing, ghc_881_64_centos)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_881_64_fedora)]) + , (Linux CentOS , M.fromList [(Nothing, ghc_881_64_centos)]) + , (Linux AmazonLinux , M.fromList [(Nothing, ghc_881_64_centos)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_881_64_fedora) @@ -1369,9 +1372,9 @@ binaryDownloads = M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_882_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_882_64_fedora)]) - , (Linux CentOS , M.fromList [(Nothing, ghc_882_64_centos)]) - , (Linux AmazonLinux , M.fromList [(Nothing, ghc_882_64_centos)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_882_64_fedora)]) + , (Linux CentOS , M.fromList [(Nothing, ghc_882_64_centos)]) + , (Linux AmazonLinux , M.fromList [(Nothing, ghc_882_64_centos)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_882_64_fedora) @@ -1402,13 +1405,13 @@ binaryDownloads = M.fromList ] ) , ( [vver|8.8.3|] - , VersionInfo [] $ M.fromList + , VersionInfo [Latest] $ M.fromList [ ( A_64 , M.fromList [ (Linux UnknownLinux, M.fromList [(Nothing, ghc_883_64_fedora)]) - , (Linux Fedora , M.fromList [(Nothing, ghc_883_64_fedora)]) - , (Linux CentOS , M.fromList [(Nothing, ghc_883_64_centos)]) - , (Linux AmazonLinux , M.fromList [(Nothing, ghc_883_64_centos)]) + , (Linux Fedora , M.fromList [(Nothing, ghc_883_64_fedora)]) + , (Linux CentOS , M.fromList [(Nothing, ghc_883_64_centos)]) + , (Linux AmazonLinux , M.fromList [(Nothing, ghc_883_64_centos)]) , ( Linux Ubuntu , M.fromList [ (Nothing , ghc_883_64_fedora) @@ -1443,17 +1446,15 @@ binaryDownloads = M.fromList , ( Cabal , M.fromList [ ( [vver|2.4.1.0|] - , VersionInfo [Recommended, Latest] $ M.fromList + , VersionInfo [] $ M.fromList [ ( A_64 , M.fromList [ ( Linux UnknownLinux , M.fromList [(Nothing, cabal_2410_64_linux)] ) - , ( Linux Alpine - , M.fromList [(Nothing, cabal_2410_64_alpine)] - ) - , (Darwin , M.fromList [(Nothing, cabal_2410_64_darwin)]) - , (FreeBSD, M.fromList [(Nothing, cabal_2410_64_freebsd)]) + , (Linux Alpine, M.fromList [(Nothing, cabal_2410_64_alpine)]) + , (Darwin , M.fromList [(Nothing, cabal_2410_64_darwin)]) + , (FreeBSD , M.fromList [(Nothing, cabal_2410_64_freebsd)]) ] ) , ( A_32 @@ -1489,7 +1490,7 @@ binaryDownloads = M.fromList , ( GHCup , M.fromList [ ( [vver|0.1.0|] - , VersionInfo [Latest] $ M.fromList + , VersionInfo [Recommended, Latest] $ M.fromList [ ( A_64 , M.fromList [(Linux UnknownLinux, M.fromList [(Nothing, ghcup_010_64_linux)])] diff --git a/app/ghcup-gen/Main.hs b/app/ghcup-gen/Main.hs index e340ad8..feab6ec 100644 --- a/app/ghcup-gen/Main.hs +++ b/app/ghcup-gen/Main.hs @@ -21,7 +21,7 @@ import System.Exit import System.IO ( stdout ) import Validate -import qualified Data.ByteString as B +import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as L @@ -31,6 +31,7 @@ data Options = Options data Command = GenJSON GenJSONOpts | ValidateJSON ValidateJSONOpts + | ValidateTarballs ValidateJSONOpts data Output = FileOutput FilePath -- optsparse-applicative doesn't handle ByteString correctly anyway @@ -107,7 +108,16 @@ com = subparser "check" ( ValidateJSON <$> (info (validateJSONOpts <**> helper) - (progDesc "Generate the json downloads file") + (progDesc "Validate the JSON") + ) + ) + ) + <> (command + "check-tarballs" + ( ValidateTarballs + <$> (info + (validateJSONOpts <**> helper) + (progDesc "Validate all tarballs (download and checksum)") ) ) ) @@ -130,16 +140,25 @@ main = do L.writeFile file bs ValidateJSON vopts -> case vopts of ValidateJSONOpts { input = Nothing } -> - L.getContents >>= valAndExit + L.getContents >>= valAndExit validate ValidateJSONOpts { input = Just StdInput } -> - L.getContents >>= valAndExit + L.getContents >>= valAndExit validate ValidateJSONOpts { input = Just (FileInput file) } -> - L.readFile file >>= valAndExit + L.readFile file >>= valAndExit validate + ValidateTarballs vopts -> case vopts of + ValidateJSONOpts { input = Nothing } -> + L.getContents >>= valAndExit validateTarballs + ValidateJSONOpts { input = Just StdInput } -> + L.getContents >>= valAndExit validateTarballs + ValidateJSONOpts { input = Just (FileInput file) } -> + L.readFile file >>= valAndExit validateTarballs pure () where - valAndExit contents = do + valAndExit f contents = do av <- case eitherDecode contents of Right r -> pure r Left e -> die (color Red $ show e) - myLoggerT (LoggerConfig True (B.hPut stdout)) (validate av) >>= exitWith + myLoggerT (LoggerConfig True (B.hPut stdout) (\_ -> pure ())) (f av) + >>= exitWith + diff --git a/app/ghcup-gen/SourceDownloads.hs b/app/ghcup-gen/SourceDownloads.hs index b556a98..7baf872 100644 --- a/app/ghcup-gen/SourceDownloads.hs +++ b/app/ghcup-gen/SourceDownloads.hs @@ -4,9 +4,9 @@ module SourceDownloads where import GHCup.Types -import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ +import GHCup.Utils.Version.QQ -import Data.String.QQ import HPath import URI.ByteString.QQ diff --git a/app/ghcup-gen/Validate.hs b/app/ghcup-gen/Validate.hs index f18d492..a2907e4 100644 --- a/app/ghcup-gen/Validate.hs +++ b/app/ghcup-gen/Validate.hs @@ -5,42 +5,50 @@ module Validate where import GHCup +import GHCup.Download import GHCup.Types +import GHCup.Types.Optics +import GHCup.Utils.Logger -import Control.Monad import Control.Exception.Safe -import Control.Monad.Reader.Class +import Control.Monad import Control.Monad.IO.Class +import Control.Monad.Logger +import Control.Monad.Reader.Class import Control.Monad.Trans.Class ( lift ) import Control.Monad.Trans.Reader ( runReaderT ) +import Control.Monad.Trans.Resource ( runResourceT + , MonadUnliftIO + ) +import Data.IORef import Data.List import Data.String.Interpolate import Data.Versions -import Data.IORef +import Haskus.Utils.Variant.Excepts +import Optics import System.Exit -import Control.Monad.Logger +import System.IO +import qualified Data.ByteString as B import qualified Data.Map.Strict as M --- TODO: improve logging - - data ValidationError = InternalError String deriving Show instance Exception ValidationError --- TODO: test that GHC is in semver --- TODO: check there's LATEST tag for every tool --- TODO: check all tarballs can be downloaded --- AND their checksum --- TODO: check gpg keys of tarballs? -validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m) +addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m () +addError = do + ref <- ask + liftIO $ modifyIORef ref (+ 1) + + +validate :: (Monad m, MonadLogger m, MonadThrow m, MonadIO m, MonadUnliftIO m) => GHCupDownloads -> m ExitCode -validate GHCupDownloads{..} = do +validate dls@GHCupDownloads {..} = do ref <- liftIO $ newIORef 0 -- * verify binary downloads * -- @@ -54,10 +62,16 @@ validate GHCupDownloads{..} = do forM_ (M.toList $ _viArch vi) $ \(arch, pspecs) -> do checkHasRequiredPlatforms t v arch (M.keys pspecs) + checkGHCisSemver + forM_ (M.toList _binaryDownloads) $ \(t, _) -> checkMandatoryTags t -- exit e <- liftIO $ readIORef ref - if e > 0 then pure $ ExitFailure e else pure ExitSuccess + if e > 0 + then pure $ ExitFailure e + else do + lift $ $(logInfo) [i|All good|] + pure ExitSuccess where checkHasRequiredPlatforms t v arch pspecs = do let v' = prettyVer v @@ -65,10 +79,10 @@ validate GHCupDownloads{..} = do lift $ $(logError) [i|Linux UnknownLinux missing for for #{t} #{v'} #{arch}|] addError - when (not $ any (== Darwin) pspecs) $ do + when ((not $ any (== Darwin) pspecs) && arch == A_64) $ do lift $ $(logError) [i|Darwin missing for #{t} #{v'} #{arch}|] addError - when (not $ any (== FreeBSD) pspecs) $ lift $ $(logWarn) + when ((not $ any (== FreeBSD) pspecs) && arch == A_64) $ lift $ $(logWarn) [i|FreeBSD missing for #{t} #{v'} #{arch}|] checkUniqueTags tool = do @@ -89,14 +103,75 @@ validate GHCupDownloads{..} = do case join nonUnique of [] -> pure () xs -> do - lift $ $(logError) [i|Tags not unique: #{xs}|] + lift $ $(logError) [i|Tags not unique for #{tool}: #{xs}|] addError where isUniqueTag Latest = True isUniqueTag Recommended = True + checkGHCisSemver = do + let ghcVers = toListOf (binaryDownloads % ix GHC % to M.keys % folded) dls + forM_ ghcVers $ \v -> case semver (prettyVer v) of + Left _ -> do + lift $ $(logError) [i|GHC version #{v} is not valid semver|] + addError + Right _ -> pure () -addError :: (MonadReader (IORef Int) m, MonadIO m, Monad m) => m () -addError = do - ref <- ask - liftIO $ modifyIORef ref (+ 1) + -- a tool must have at least one of each mandatory tags + checkMandatoryTags tool = do + let allTags = join $ fmap snd $ availableToolVersions _binaryDownloads tool + forM_ [Latest, Recommended] $ \t -> case elem t allTags of + False -> do + lift $ $(logError) [i|Tag #{t} missing from #{tool}|] + addError + True -> pure () + + +validateTarballs :: ( Monad m + , MonadLogger m + , MonadThrow m + , MonadIO m + , MonadUnliftIO m + ) + => GHCupDownloads + -> m ExitCode +validateTarballs GHCupDownloads {..} = do + ref <- liftIO $ newIORef 0 + + flip runReaderT ref $ do + -- download/verify all tarballs + let + dlis = nub $ join $ (M.elems _binaryDownloads) <&> \versions -> + join $ (M.elems versions) <&> \vi -> + join $ (M.elems $ _viArch vi) <&> \pspecs -> + join $ (M.elems pspecs) <&> \pverspecs -> (M.elems pverspecs) + forM_ dlis $ downloadAll + + -- exit + e <- liftIO $ readIORef ref + if e > 0 + then pure $ ExitFailure e + else do + lift $ $(logInfo) [i|All good|] + pure ExitSuccess + + where + downloadAll dli = do + let settings = Settings True GHCupURL False + let runLogger = myLoggerT LoggerConfig { lcPrintDebug = True + , colorOutter = B.hPut stderr + , rawOutter = (\_ -> pure ()) + } + + r <- + runLogger + . flip runReaderT settings + . runResourceT + . runE + $ downloadCached dli Nothing + case r of + VRight _ -> pure () + VLeft e -> do + lift $ $(logError) + [i|Could not download (or verify hash) of #{dli}, Error was: #{e}|] + addError diff --git a/app/ghcup/Main.hs b/app/ghcup/Main.hs index e81675d..c1f94c3 100644 --- a/app/ghcup/Main.hs +++ b/app/ghcup/Main.hs @@ -16,6 +16,7 @@ import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Logger import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ import Control.Monad.Logger import Control.Monad.Reader @@ -25,15 +26,16 @@ import Data.Char import Data.List ( intercalate ) import Data.Semigroup ( (<>) ) import Data.String.Interpolate -import Data.String.QQ import Data.Versions import Haskus.Utils.Variant.Excepts import HPath +import HPath.IO import Options.Applicative hiding ( style ) +import Prelude hiding ( appendFile ) import System.Console.Pretty import System.Environment import System.Exit -import System.IO +import System.IO hiding ( appendFile ) import Text.Read import Text.Layout.Table import URI.ByteString @@ -120,13 +122,15 @@ opts = (option (eitherReader parseUri) (short 's' <> long "url-source" <> metavar "URL" <> help - "Alternative ghcup download info url (default: internal)" + "Alternative ghcup download info url" ) ) ) <*> switch - (short 'n' <> long "no-verify" <> help - "Don't verify sha256 checksums of downloaded tarballs (default: False)" + ( short 'n' + <> long "no-verify" + <> help + "Skip tarball checksum checks (default: False)" ) <*> com where @@ -153,7 +157,10 @@ com = <> command "upgrade" ( Upgrade - <$> (info (upgradeOptsP <**> helper) (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)")) + <$> (info + (upgradeOptsP <**> helper) + (progDesc "Upgrade ghcup (per default in ~/.ghcup/bin/)") + ) ) <> commandGroup "Main commands:" ) @@ -362,10 +369,15 @@ main = do customExecParser (prefs showHelpOnError) (info (opts <**> helper) idm) >>= \opt@Options {..} -> do - let settings = toSettings opt + let settings = toSettings opt -- logger interpreter - let runLogger = myLoggerT (LoggerConfig optVerbose $ B.hPut stderr) + logfile <- initGHCupFileLogging ([rel|ghcup.log|] :: Path Rel) + let runLogger = myLoggerT LoggerConfig + { lcPrintDebug = optVerbose + , colorOutter = B.hPut stderr + , rawOutter = appendFile logfile + } -- wrapper to run effects with settings let runInstTool = @@ -463,8 +475,11 @@ main = do VLeft (V (AlreadyInstalled treq)) -> runLogger $ $(logWarn) (T.pack (show treq) <> [s| already installed|]) - VLeft e -> - runLogger ($(logError) [i|#{e}|]) >> exitFailure + VLeft e -> do + runLogger $ do + $(logError) [i|#{e}|] + $(logError) [i|Also check the logs in ~/.ghcup/logs|] + exitFailure Install (InstallCabal InstallOptions {..}) -> void $ (runInstTool $ do @@ -478,8 +493,11 @@ main = do VLeft (V (AlreadyInstalled treq)) -> runLogger $ $(logWarn) (T.pack (show treq) <> [s| already installed|]) - VLeft e -> - runLogger ($(logError) [i|#{e}|]) >> exitFailure + VLeft e -> do + runLogger $ do + $(logError) [i|#{e}|] + $(logError) [i|Also check the logs in ~/.ghcup/logs|] + exitFailure SetGHC (SetGHCOptions {..}) -> void @@ -550,8 +568,8 @@ main = do pure $ Just p (UpgradeAt p) -> pure $ Just p UpgradeGHCupDir -> do - liftIO $ putStrLn "blah" - pure Nothing + bdir <- liftIO $ ghcupBinDir + pure (Just (bdir ([rel|ghcup|] :: Path Rel))) void $ (runUpgrade $ do @@ -559,9 +577,11 @@ main = do liftE $ upgradeGHCup dls target ) >>= \case - VRight v' -> - runLogger $ $(logInfo) - [i|Successfully upgraded GHCup to version #{v'}|] + VRight v' -> do + let pretty_v = prettyVer v' + runLogger + $ $(logInfo) + [i|Successfully upgraded GHCup to version #{pretty_v}|] VLeft e -> runLogger ($(logError) [i|#{e}|]) >> exitFailure diff --git a/ghcup.cabal b/ghcup.cabal index 8fe8512..cada304 100644 --- a/ghcup.cabal +++ b/ghcup.cabal @@ -58,7 +58,6 @@ common streamly-posix { build-depends: streamly-posix >= 0.1.0.0 } common streamly-bytestring { build-depends: streamly-bytestring >= 0.1.2 } common strict-base { build-depends: strict-base >= 0.4 } common string-interpolate { build-depends: string-interpolate >= 0.2.0.0 } -common string-qq { build-depends: string-qq >= 0.0.4 } common table-layout { build-depends: table-layout >= 0.8 } common tar-bytestring { build-depends: tar-bytestring >= 0.6.2.0 } common template-haskell { build-depends: template-haskell >= 2.7 } @@ -127,7 +126,6 @@ library , streamly-bytestring , strict-base , string-interpolate - , string-qq , tar-bytestring , template-haskell , text @@ -150,9 +148,12 @@ library GHCup.Types.Optics GHCup.Utils GHCup.Utils.Bash + GHCup.Utils.Dirs GHCup.Utils.File GHCup.Utils.Logger GHCup.Utils.Prelude + GHCup.Utils.String.QQ + GHCup.Utils.Version.QQ GHCup.Version -- other-modules: -- other-extensions: @@ -171,9 +172,9 @@ executable ghcup , text , versions , hpath + , hpath-io , pretty-terminal , resourcet - , string-qq , string-interpolate , table-layout , uri-bytestring @@ -203,7 +204,7 @@ executable ghcup-gen , versions , hpath , pretty-terminal - , string-qq + , resourcet , string-interpolate , table-layout , transformers diff --git a/lib/GHCup.hs b/lib/GHCup.hs index 4dd48c4..5ebf74f 100644 --- a/lib/GHCup.hs +++ b/lib/GHCup.hs @@ -21,7 +21,8 @@ import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Prelude -import GHCup.Version +import GHCup.Utils.String.QQ +import GHCup.Utils.Version.QQ import Control.Applicative import Control.Exception.Safe @@ -37,7 +38,6 @@ import Data.Foldable import Data.List import Data.Maybe import Data.String.Interpolate -import Data.String.QQ import Data.Versions import Data.Word8 import GHC.IO.Exception @@ -148,13 +148,19 @@ installGHC :: (MonadLogger m, MonadIO m) -> Path Abs -- ^ Path to install to -> Excepts '[ProcessError] m () installGHC path inst = do - lift $ $(logInfo) [s|Installing GHC|] - lEM $ liftIO $ exec [s|./configure|] - False - [[s|--prefix=|] <> toFilePath inst] - (Just path) - Nothing - lEM $ liftIO $ exec [s|make|] True [[s|install|]] (Just path) Nothing + lift $ $(logInfo) [s|Installing GHC (this may take a while)|] + lEM $ liftIO $ execLogged [s|./configure|] + False + [[s|--prefix=|] <> toFilePath inst] + ([rel|ghc-configure.log|] :: Path Rel) + (Just path) + Nothing + lEM $ liftIO $ execLogged [s|make|] + True + [[s|install|]] + ([rel|ghc-make.log|] :: Path Rel) + (Just path) + Nothing pure () @@ -418,12 +424,12 @@ getDebugInfo = do + --------------- --[ Compile ]-- --------------- --- TODO: build config compileGHC :: ( MonadReader Settings m , MonadThrow m , MonadResource m @@ -544,7 +550,7 @@ upgradeGHCup dls mtarget = do dli <- liftE $ getDownloadInfo dls (ToolRequest GHCup latestVer) Nothing tmp <- lift withGHCupTmpDir let fn = [rel|ghcup|] :: Path Rel - p <- liftE $ download dli tmp (Just fn) + p <- liftE $ download dli tmp (Just fn) case mtarget of Nothing -> do dest <- liftIO $ ghcupBinDir diff --git a/lib/GHCup/Download.hs b/lib/GHCup/Download.hs index dd886e1..cf31d85 100644 --- a/lib/GHCup/Download.hs +++ b/lib/GHCup/Download.hs @@ -17,6 +17,7 @@ import GHCup.Types.Optics import GHCup.Utils import GHCup.Utils.File import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ import Control.Applicative import Control.Exception.Safe @@ -32,7 +33,6 @@ import Data.ByteString.Builder import Data.IORef import Data.Maybe import Data.String.Interpolate -import Data.String.QQ import Data.Versions import GHC.IO.Exception import HPath diff --git a/lib/GHCup/Platform.hs b/lib/GHCup/Platform.hs index 2aed25e..6e14dea 100644 --- a/lib/GHCup/Platform.hs +++ b/lib/GHCup/Platform.hs @@ -13,6 +13,7 @@ import GHCup.Types.JSON ( ) import GHCup.Utils.Bash import GHCup.Utils.File import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ import Control.Applicative import Control.Exception.Safe @@ -23,7 +24,6 @@ import Control.Monad.Trans.Class ( lift ) import Data.Foldable import Data.Maybe import Data.String.Interpolate -import Data.String.QQ import Data.Text ( Text ) import Data.Versions import HPath diff --git a/lib/GHCup/Types/JSON.hs b/lib/GHCup/Types/JSON.hs index 54a6aba..8a901f8 100644 --- a/lib/GHCup/Types/JSON.hs +++ b/lib/GHCup/Types/JSON.hs @@ -12,11 +12,12 @@ module GHCup.Types.JSON where import GHCup.Types +import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ import Data.Aeson import Data.Aeson.TH import Data.Aeson.Types -import Data.String.QQ import Data.Text.Encoding ( decodeUtf8 ) import Data.Text.Encoding as E import Data.Versions @@ -28,20 +29,18 @@ import qualified Data.ByteString as BS import qualified Data.Text as T - - -deriveJSON defaultOptions ''Architecture -deriveJSON defaultOptions ''LinuxDistro -deriveJSON defaultOptions ''Mess -deriveJSON defaultOptions ''Platform -deriveJSON defaultOptions ''SemVer -deriveJSON defaultOptions ''Tool -deriveJSON defaultOptions ''VSep -deriveJSON defaultOptions ''VUnit -deriveJSON defaultOptions ''VersionInfo -deriveJSON defaultOptions ''Tag -deriveJSON defaultOptions ''DownloadInfo -deriveJSON defaultOptions ''GHCupDownloads +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } { fieldLabelModifier = removeLensFieldLabel } ''Architecture +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''LinuxDistro +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Mess +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Platform +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''SemVer +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tool +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VSep +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VUnit +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''VersionInfo +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''Tag +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''DownloadInfo +deriveJSON defaultOptions { fieldLabelModifier = removeLensFieldLabel } ''GHCupDownloads instance ToJSON URI where diff --git a/lib/GHCup/Utils.hs b/lib/GHCup/Utils.hs index 90d4193..a29f60b 100644 --- a/lib/GHCup/Utils.hs +++ b/lib/GHCup/Utils.hs @@ -4,14 +4,20 @@ {-# LANGUAGE TemplateHaskell #-} -module GHCup.Utils where +module GHCup.Utils + ( module GHCup.Utils.Dirs + , module GHCup.Utils + ) +where import GHCup.Errors import GHCup.Types import GHCup.Types.JSON ( ) +import GHCup.Utils.Dirs import GHCup.Utils.File import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ import Control.Applicative import Control.Exception.Safe @@ -25,7 +31,6 @@ import Data.ByteString ( ByteString ) import Data.List import Data.Maybe import Data.String.Interpolate -import Data.String.QQ import Data.Versions import Data.Word8 import GHC.IO.Exception @@ -38,7 +43,6 @@ import Prelude hiding ( abs , writeFile ) import Safe -import System.Posix.Env.ByteString ( getEnv ) import System.Posix.FilePath ( takeFileName ) import System.Posix.Files.ByteString ( readSymbolicLink ) import URI.ByteString @@ -54,27 +58,11 @@ import qualified Data.Text.Encoding as E - ----------------- - --[ Utilities ]-- - ----------------- -ghcupBaseDir :: IO (Path Abs) -ghcupBaseDir = do - getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case - Just r -> parseAbs r - Nothing -> do - home <- liftIO getHomeDirectory - pure (home ([rel|.ghcup|] :: Path Rel)) - -ghcupGHCBaseDir :: IO (Path Abs) -ghcupGHCBaseDir = ghcupBaseDir <&> ( ([rel|ghc|] :: Path Rel)) - -ghcupGHCDir :: Version -> IO (Path Abs) -ghcupGHCDir ver = do - ghcbasedir <- ghcupGHCBaseDir - verdir <- parseRel (verToBS ver) - pure (ghcbasedir verdir) + ------------------------ + --[ Symlink handling ]-- + ------------------------ -- | The symlink destination of a ghc tool. @@ -95,6 +83,13 @@ ghcLinkVersion = either (throwM . ParseError) pure . parseOnly parser Right r -> pure r + + + ----------------------------------- + --[ Set/Installed introspection ]-- + ----------------------------------- + + ghcInstalled :: Version -> IO Bool ghcInstalled ver = do ghcdir <- ghcupGHCDir ver @@ -110,11 +105,6 @@ ghcSet = do link <- readSymbolicLink $ toFilePath ghcBin Just <$> ghcLinkVersion link -ghcupBinDir :: IO (Path Abs) -ghcupBinDir = ghcupBaseDir <&> ( ([rel|bin|] :: Path Rel)) - -ghcupCacheDir :: IO (Path Abs) -ghcupCacheDir = ghcupBaseDir <&> ( ([rel|cache|] :: Path Rel)) cabalInstalled :: Version -> IO Bool cabalInstalled ver = do @@ -132,6 +122,13 @@ cabalSet = do Left e -> throwM e Right r -> pure r + + + ----------------------------------------- + --[ Major version introspection (X.Y) ]-- + ----------------------------------------- + + -- | We assume GHC is in semver format. I hope it is. getGHCMajor :: MonadThrow m => Version -> m (Int, Int) getGHCMajor ver = do @@ -160,10 +157,12 @@ getGHCForMajor major' minor' = do $ semvers -urlBaseName :: MonadThrow m - => ByteString -- ^ the url path (without scheme and host) - -> m (Path Rel) -urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False + + + ----------------- + --[ Unpacking ]-- + ----------------- + -- | Unpack an archive to a temporary directory and return that path. @@ -191,6 +190,55 @@ unpackToDir dest av = do | otherwise -> throwE $ UnknownArchive fn + + + ------------ + --[ Tags ]-- + ------------ + + +-- | Get the tool versions that have this tag. +getTagged :: BinaryDownloads -> Tool -> Tag -> [Version] +getTagged av tool tag = toListOf + ( ix tool + % to (Map.filter (\VersionInfo {..} -> elem tag _viTags)) + % to Map.keys + % folded + ) + av + +getLatest :: BinaryDownloads -> Tool -> Maybe Version +getLatest av tool = headOf folded $ getTagged av tool Latest + +getRecommended :: BinaryDownloads -> Tool -> Maybe Version +getRecommended av tool = headOf folded $ getTagged av tool Recommended + + + + ----------------------- + --[ Settings Getter ]-- + ----------------------- + + +getUrlSource :: MonadReader Settings m => m URLSource +getUrlSource = ask <&> urlSource + +getCache :: MonadReader Settings m => m Bool +getCache = ask <&> cache + + + + ------------- + --[ Other ]-- + ------------- + + +urlBaseName :: MonadThrow m + => ByteString -- ^ the url path (without scheme and host) + -> m (Path Rel) +urlBaseName = parseRel . snd . B.breakEnd (== _slash) . urlDecode False + + -- Get tool files from ~/.ghcup/bin/ghc//bin/* -- while ignoring *- symlinks. ghcToolFiles :: (MonadThrow m, MonadFail m, MonadIO m) @@ -214,27 +262,3 @@ ghcToolFiles ver = do when (B.null symver) (throwIO $ userError $ "Fatal: ghc symlink target is broken") pure $ filter (\x -> not $ symver `B.isSuffixOf` toFilePath x) files - - --- | Get the tool versions that have this tag. -getTagged :: BinaryDownloads -> Tool -> Tag -> [Version] -getTagged av tool tag = toListOf - ( ix tool - % to (Map.filter (\VersionInfo {..} -> elem tag _viTags)) - % to Map.keys - % folded - ) - av - -getLatest :: BinaryDownloads -> Tool -> Maybe Version -getLatest av tool = headOf folded $ getTagged av tool Latest - -getRecommended :: BinaryDownloads -> Tool -> Maybe Version -getRecommended av tool = headOf folded $ getTagged av tool Recommended - - -getUrlSource :: MonadReader Settings m => m URLSource -getUrlSource = ask <&> urlSource - -getCache :: MonadReader Settings m => m Bool -getCache = ask <&> cache diff --git a/lib/GHCup/Utils/Dirs.hs b/lib/GHCup/Utils/Dirs.hs new file mode 100644 index 0000000..c8ddb45 --- /dev/null +++ b/lib/GHCup/Utils/Dirs.hs @@ -0,0 +1,92 @@ +{-# LANGUAGE QuasiQuotes #-} + +module GHCup.Utils.Dirs where + + +import GHCup.Types.JSON ( ) +import GHCup.Utils.Prelude +import GHCup.Utils.String.QQ + +import Control.Applicative +import Control.Exception.Safe +import Control.Monad +import Control.Monad.Reader +import Control.Monad.Trans.Resource +import Data.Maybe +import Data.Versions +import HPath +import HPath.IO +import Optics +import Prelude hiding ( abs + , readFile + , writeFile + ) +import System.Posix.Env.ByteString ( getEnv + , getEnvDefault + ) +import System.Posix.Temp.ByteString ( mkdtemp ) + +import qualified Data.ByteString.UTF8 as UTF8 +import qualified System.Posix.FilePath as FP +import qualified System.Posix.User as PU + + + + ------------------------- + --[ GHCup directories ]-- + ------------------------- + + +ghcupBaseDir :: IO (Path Abs) +ghcupBaseDir = do + getEnv [s|GHCUP_INSTALL_BASE_PREFIX|] >>= \case + Just r -> parseAbs r + Nothing -> do + home <- liftIO getHomeDirectory + pure (home ([rel|.ghcup|] :: Path Rel)) + +ghcupGHCBaseDir :: IO (Path Abs) +ghcupGHCBaseDir = ghcupBaseDir <&> ( ([rel|ghc|] :: Path Rel)) + +ghcupGHCDir :: Version -> IO (Path Abs) +ghcupGHCDir ver = do + ghcbasedir <- ghcupGHCBaseDir + verdir <- parseRel (verToBS ver) + pure (ghcbasedir verdir) + + +ghcupBinDir :: IO (Path Abs) +ghcupBinDir = ghcupBaseDir <&> ( ([rel|bin|] :: Path Rel)) + +ghcupCacheDir :: IO (Path Abs) +ghcupCacheDir = ghcupBaseDir <&> ( ([rel|cache|] :: Path Rel)) + +ghcupLogsDir :: IO (Path Abs) +ghcupLogsDir = ghcupBaseDir <&> ( ([rel|logs|] :: Path Rel)) + + +mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs) +mkGhcupTmpDir = do + tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] + tmp <- liftIO $ mkdtemp $ (tmpdir FP. [s|ghcup-|]) + parseAbs tmp + + +withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs) +withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive + + + + -------------- + --[ Others ]-- + -------------- + + +getHomeDirectory :: IO (Path Abs) +getHomeDirectory = do + e <- getEnv [s|HOME|] + case e of + Just fp -> parseAbs fp + Nothing -> do + h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID) + parseAbs $ UTF8.fromString h -- this is a guess diff --git a/lib/GHCup/Utils/File.hs b/lib/GHCup/Utils/File.hs index 4f1dafa..933acc8 100644 --- a/lib/GHCup/Utils/File.hs +++ b/lib/GHCup/Utils/File.hs @@ -3,19 +3,17 @@ module GHCup.Utils.File where +import GHCup.Utils.Dirs import GHCup.Utils.Prelude import Control.Exception.Safe import Control.Monad -import Control.Monad.IO.Class -import Control.Monad.Trans.Resource import Data.ByteString import Data.ByteString.Unsafe ( unsafeUseAsCStringLen ) import Data.Char import Data.Foldable import Data.Functor import Data.Maybe -import Data.String.QQ import GHC.Foreign ( peekCStringLen ) import GHC.IO.Encoding ( getLocaleEncoding ) import GHC.IO.Exception @@ -27,28 +25,23 @@ import Streamly.External.ByteString import Streamly.External.ByteString.Lazy import System.IO import System.Posix.Directory.ByteString -import System.Posix.Env.ByteString import System.Posix.FD as FD import System.Posix.FilePath hiding ( () ) import System.Posix.Foreign ( oExcl ) import "unix" System.Posix.IO.ByteString hiding ( openFd ) import System.Posix.Process ( ProcessStatus(..) ) -import System.Posix.Temp.ByteString import System.Posix.Types import qualified System.Posix.Process.ByteString as SPPB -import qualified System.Posix.FilePath as FP -import qualified System.Posix.User as PU import Streamly.External.Posix.DirStream import qualified Streamly.Internal.Memory.ArrayStream as AS import qualified Streamly.FileSystem.Handle as FH import qualified Streamly.Internal.Data.Unfold as SU import qualified Streamly.Prelude as S -import qualified Data.ByteString.UTF8 as UTF8 import qualified Data.ByteString.Lazy as L @@ -115,6 +108,36 @@ executeOut path args chdir = captureOutStreams $ do SPPB.executeFile (toFilePath path) True args Nothing +execLogged :: ByteString -- ^ thing to execute + -> Bool -- ^ whether to search PATH for the thing + -> [ByteString] -- ^ args for the thing + -> Path Rel -- ^ log filename + -> Maybe (Path Abs) -- ^ optionally chdir into this + -> Maybe [(ByteString, ByteString)] -- ^ optional environment + -> IO (Either ProcessError ()) +execLogged exe spath args lfile chdir env = do + ldir <- ghcupLogsDir + let logfile = ldir lfile + bracket (createFile (toFilePath logfile) newFilePerms) closeFd action + where + action fd = do + pid <- SPPB.forkProcess $ do + -- dup stdout + void $ dupTo fd stdOutput + + -- dup stderr + void $ dupTo fd stdError + + -- execute the action + maybe (pure ()) (changeWorkingDirectory . toFilePath) chdir + SPPB.executeFile exe spath args env + + + SPPB.getProcessStatus True True pid >>= \case + i@(Just (SPPB.Exited es)) -> pure $ toProcessError exe args i + i -> pure $ toProcessError exe args i + + -- | Capture the stdout and stderr of the given action, which -- is run in a subprocess. Stdin is closed. You might want to -- 'race' this to make sure it terminates. @@ -193,27 +216,6 @@ toProcessError exe args mps = case mps of Nothing -> Left $ NoSuchPid exe args -mkGhcupTmpDir :: (MonadThrow m, MonadIO m) => m (Path Abs) -mkGhcupTmpDir = do - tmpdir <- liftIO $ getEnvDefault [s|TMPDIR|] [s|/tmp|] - tmp <- liftIO $ mkdtemp $ (tmpdir FP. [s|ghcup-|]) - parseAbs tmp - - -withGHCupTmpDir :: (MonadResource m, MonadThrow m, MonadIO m) => m (Path Abs) -withGHCupTmpDir = snd <$> allocate mkGhcupTmpDir deleteDirRecursive - - -getHomeDirectory :: IO (Path Abs) -getHomeDirectory = do - e <- getEnv [s|HOME|] - case e of - Just fp -> parseAbs fp - Nothing -> do - h <- PU.homeDirectory <$> (PU.getEffectiveUserID >>= PU.getUserEntryForID) - parseAbs $ UTF8.fromString h -- this is a guess - - -- | Convert the String to a ByteString with the current -- system encoding. unsafePathToString :: Path b -> IO FilePath diff --git a/lib/GHCup/Utils/Logger.hs b/lib/GHCup/Utils/Logger.hs index d7e7c5a..49af2a4 100644 --- a/lib/GHCup/Utils/Logger.hs +++ b/lib/GHCup/Utils/Logger.hs @@ -1,28 +1,59 @@ +{-# LANGUAGE QuasiQuotes #-} + module GHCup.Utils.Logger where +import GHCup.Utils import Control.Monad.Logger +import HPath +import HPath.IO +import Prelude hiding ( appendFile ) import System.Console.Pretty +import System.IO.Error -import qualified Data.ByteString as B +import qualified Data.ByteString as B -data LoggerConfig = LoggerConfig { - lcPrintDebug :: Bool - , outter :: B.ByteString -> IO () -} +data LoggerConfig = LoggerConfig + { lcPrintDebug :: Bool -- ^ whether to print debug in colorOutter + , colorOutter :: B.ByteString -> IO () -- ^ how to write the color output + , rawOutter :: B.ByteString -> IO () -- ^ how to write the full raw output + } myLoggerT :: LoggerConfig -> LoggingT m a -> m a -myLoggerT LoggerConfig{..} loggingt = runLoggingT loggingt mylogger +myLoggerT LoggerConfig {..} loggingt = runLoggingT loggingt mylogger where mylogger :: Loc -> LogSource -> LogLevel -> LogStr -> IO () mylogger _ _ level str' = do + -- color output let l = case level of - LevelDebug -> if lcPrintDebug then toLogStr (style Bold $ color Blue "[ Debug ]") else mempty - LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]") + LevelDebug -> if lcPrintDebug + then toLogStr (style Bold $ color Blue "[ Debug ]") + else mempty + LevelInfo -> toLogStr (style Bold $ color Green "[ Info ]") LevelWarn -> toLogStr (style Bold $ color Yellow "[ Warn ]") - LevelError -> toLogStr (style Bold $ color Red "[ Error ]") + LevelError -> toLogStr (style Bold $ color Red "[ Error ]") LevelOther t -> toLogStr "[ " <> toLogStr t <> toLogStr " ]" - let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n") - outter out + let out = fromLogStr (l <> toLogStr " " <> str' <> toLogStr "\n") + colorOutter out + + -- raw output + let lr = case level of + LevelDebug -> toLogStr "Debug: " + LevelInfo -> toLogStr "Info:" + LevelWarn -> toLogStr "Warn:" + LevelError -> toLogStr "Error:" + LevelOther t -> toLogStr t <> toLogStr ":" + let outr = fromLogStr (lr <> toLogStr " " <> str' <> toLogStr "\n") + rawOutter outr + + +initGHCupFileLogging :: Path Rel -> IO (Path Abs) +initGHCupFileLogging context = do + logs <- ghcupLogsDir + let logfile = logs context + createDirIfMissing newDirPerms logs + hideError doesNotExistErrorType $ deleteFile logfile + createRegularFile newFilePerms logfile + pure logfile diff --git a/lib/GHCup/Utils/Prelude.hs b/lib/GHCup/Utils/Prelude.hs index 7d6df0d..d5dea54 100644 --- a/lib/GHCup/Utils/Prelude.hs +++ b/lib/GHCup/Utils/Prelude.hs @@ -1,15 +1,10 @@ -{-# OPTIONS_GHC -Wno-orphans #-} {-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE DataKinds #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE DeriveLift #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE StandaloneDeriving #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE AllowAmbiguousTypes #-} {-# LANGUAGE TypeFamilies #-} module GHCup.Utils.Prelude where @@ -21,20 +16,12 @@ import Control.Monad.IO.Class import Control.Monad.Trans.Class ( lift ) import Data.Bifunctor import Data.ByteString ( ByteString ) -import Data.Data import Data.Monoid ( (<>) ) import Data.String import Data.Text ( Text ) import Data.Versions -import GHC.Base import Haskus.Utils.Types.List import Haskus.Utils.Variant.Excepts -import Language.Haskell.TH -import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) -import Language.Haskell.TH.Syntax ( Exp(..) - , Lift - , dataToExpQ - ) import System.IO.Error import qualified Data.ByteString.Lazy as L @@ -45,7 +32,6 @@ import qualified Data.Text.Lazy as TL import qualified Data.Text.Lazy.Builder as B import qualified Data.Text.Lazy.Builder.Int as B import qualified Data.Text.Lazy.Encoding as TLE -import qualified Language.Haskell.TH.Syntax as TH @@ -197,84 +183,20 @@ hideExcept' _ action = catchLiftLeft ((\_ -> pure ()) :: (e -> Excepts es' m ())) action - throwEither :: (Exception a, MonadThrow m) => Either a b -> m b throwEither a = case a of Left e -> throwM e Right r -> pure r - -deriving instance Data Versioning -deriving instance Lift Versioning -deriving instance Data Version -deriving instance Lift Version -deriving instance Data SemVer -deriving instance Lift SemVer -deriving instance Data Mess -deriving instance Lift Mess -deriving instance Data PVP -deriving instance Lift PVP -deriving instance Lift (NonEmpty Word) -deriving instance Lift VSep -deriving instance Data VSep -deriving instance Lift VUnit -deriving instance Data VUnit -instance Lift Text - -qq :: (Text -> Q Exp) -> QuasiQuoter -qq quoteExp' = QuasiQuoter - { quoteExp = (\s -> quoteExp' . T.pack $ s) - , quotePat = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" - , quoteType = \_ -> - fail "illegal QuasiQuote (allowed as expression only, used as a type)" - , quoteDec = \_ -> fail - "illegal QuasiQuote (allowed as expression only, used as a declaration)" - } - -vver :: QuasiQuoter -vver = qq mkV - where - mkV :: Text -> Q Exp - mkV = either (fail . show) liftDataWithText . version - -mver :: QuasiQuoter -mver = qq mkV - where - mkV :: Text -> Q Exp - mkV = either (fail . show) liftDataWithText . mess - -sver :: QuasiQuoter -sver = qq mkV - where - mkV :: Text -> Q Exp - mkV = either (fail . show) liftDataWithText . semver - -vers :: QuasiQuoter -vers = qq mkV - where - mkV :: Text -> Q Exp - mkV = either (fail . show) liftDataWithText . versioning - -pver :: QuasiQuoter -pver = qq mkV - where - mkV :: Text -> Q Exp - mkV = either (fail . show) liftDataWithText . pvp - --- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable -liftText :: T.Text -> Q Exp -liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt) - -liftDataWithText :: Data a => a -> Q Exp -liftDataWithText = dataToExpQ (\a -> liftText <$> cast a) - - verToBS :: Version -> ByteString verToBS = E.encodeUtf8 . prettyVer - intToText :: Integral a => a -> T.Text intToText = TL.toStrict . B.toLazyText . B.decimal + + +removeLensFieldLabel :: String -> String +removeLensFieldLabel str' = + maybe str' T.unpack . T.stripPrefix (T.pack "_") . T.pack $ str' diff --git a/lib/GHCup/Utils/String/QQ.hs b/lib/GHCup/Utils/String/QQ.hs new file mode 100644 index 0000000..c0a1d24 --- /dev/null +++ b/lib/GHCup/Utils/String/QQ.hs @@ -0,0 +1,48 @@ +{-# LANGUAGE TemplateHaskell #-} + +-- | QuasiQuoter for non-interpolated strings, texts and bytestrings. +-- +-- The "s" quoter contains a multi-line string with no interpolation at all, +-- except that the leading newline is trimmed and carriage returns stripped. +-- +-- @ +-- {-\# LANGUAGE QuasiQuotes #-} +-- import Data.Text (Text) +-- import Data.String.QQ +-- foo :: Text -- "String", "ByteString" etc also works +-- foo = [s| +-- Well here is a +-- multi-line string! +-- |] +-- @ +-- +-- Any instance of the IsString type is permitted. +-- +-- (For GHC versions 6, write "[$s||]" instead of "[s||]".) +-- +module GHCup.Utils.String.QQ + ( s + ) +where + + +import Data.Char +import GHC.Exts ( IsString(..) ) +import Language.Haskell.TH.Quote + +-- | QuasiQuoter for a non-interpolating ASCII IsString literal. +-- The pattern portion is undefined. +s :: QuasiQuoter +s = QuasiQuoter + (\s' -> case and $ fmap isAscii s' of + True -> (\a -> [|fromString a|]) . trimLeadingNewline . removeCRs $ s' + False -> fail "Not ascii" + ) + (error "Cannot use q as a pattern") + (error "Cannot use q as a type") + (error "Cannot use q as a dec") + where + removeCRs = filter (/= '\r') + trimLeadingNewline ('\n' : xs) = xs + trimLeadingNewline xs = xs + diff --git a/lib/GHCup/Utils/Version/QQ.hs b/lib/GHCup/Utils/Version/QQ.hs new file mode 100644 index 0000000..e89e459 --- /dev/null +++ b/lib/GHCup/Utils/Version/QQ.hs @@ -0,0 +1,89 @@ +{-# OPTIONS_GHC -Wno-orphans #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE DeriveLift #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE StandaloneDeriving #-} +{-# LANGUAGE TemplateHaskell #-} + + +module GHCup.Utils.Version.QQ where + +import Data.Data +import Data.Text ( Text ) +import Data.Versions +import GHC.Base +import Language.Haskell.TH +import Language.Haskell.TH.Quote ( QuasiQuoter(..) ) +import Language.Haskell.TH.Syntax ( Exp(..) + , Lift + , dataToExpQ + ) +import qualified Data.Text as T +import qualified Language.Haskell.TH.Syntax as TH + + + +deriving instance Data Versioning +deriving instance Lift Versioning +deriving instance Data Version +deriving instance Lift Version +deriving instance Data SemVer +deriving instance Lift SemVer +deriving instance Data Mess +deriving instance Lift Mess +deriving instance Data PVP +deriving instance Lift PVP +deriving instance Lift (NonEmpty Word) +deriving instance Lift VSep +deriving instance Data VSep +deriving instance Lift VUnit +deriving instance Data VUnit +instance Lift Text + +qq :: (Text -> Q Exp) -> QuasiQuoter +qq quoteExp' = QuasiQuoter + { quoteExp = (\s -> quoteExp' . T.pack $ s) + , quotePat = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a pattern)" + , quoteType = \_ -> + fail "illegal QuasiQuote (allowed as expression only, used as a type)" + , quoteDec = \_ -> fail + "illegal QuasiQuote (allowed as expression only, used as a declaration)" + } + +vver :: QuasiQuoter +vver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) liftDataWithText . version + +mver :: QuasiQuoter +mver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) liftDataWithText . mess + +sver :: QuasiQuoter +sver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) liftDataWithText . semver + +vers :: QuasiQuoter +vers = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) liftDataWithText . versioning + +pver :: QuasiQuoter +pver = qq mkV + where + mkV :: Text -> Q Exp + mkV = either (fail . show) liftDataWithText . pvp + +-- https://stackoverflow.com/questions/38143464/cant-find-inerface-file-declaration-for-variable +liftText :: T.Text -> Q Exp +liftText txt = AppE (VarE 'T.pack) <$> TH.lift (T.unpack txt) + +liftDataWithText :: Data a => a -> Q Exp +liftDataWithText = dataToExpQ (\a -> liftText <$> cast a) diff --git a/lib/GHCup/Version.hs b/lib/GHCup/Version.hs index f28925b..a8f7d27 100644 --- a/lib/GHCup/Version.hs +++ b/lib/GHCup/Version.hs @@ -3,8 +3,9 @@ module GHCup.Version where +import GHCup.Utils.Version.QQ + import Data.Versions -import GHCup.Utils.Prelude ghcUpVer :: PVP ghcUpVer = [pver|0.1.0|]