diff --git a/package.yaml b/package.yaml index d1eba45..fa8b232 100644 --- a/package.yaml +++ b/package.yaml @@ -36,6 +36,7 @@ dependencies: - parsers - transformers - lifted-base + - xdg-basedir executables: nixpkgs-update: diff --git a/src/Clean.hs b/src/Clean.hs index c0ddee9..6f128d6 100644 --- a/src/Clean.hs +++ b/src/Clean.hs @@ -20,7 +20,7 @@ import Prelude hiding (FilePath) import Shelly import qualified Text.Regex.Applicative as RE import Text.Regex.Applicative (RE, (=~)) -import Utils (UpdateEnv(..), Version, canFail, setupNixpkgs, succeded) +import Utils (UpdateEnv(..), Version, canFail, succeded) default (T.Text) @@ -33,7 +33,6 @@ archiveRegex version = fixSrcUrl :: UpdateEnv -> FilePath -> Text -> Text -> Sh Text fixSrcUrl updateEnv derivationFile attrPath oldSrcUrl = do - setupNixpkgs oldDerivationName <- T.strip <$> cmd "nix" "eval" "-f" "." "--raw" ("pkgs." <> attrPath <> ".name") diff --git a/src/DeleteMerged.hs b/src/DeleteMerged.hs index 639a2b4..48119f5 100644 --- a/src/DeleteMerged.hs +++ b/src/DeleteMerged.hs @@ -3,8 +3,7 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} module DeleteMerged - ( deleteMerged - , deleteDone + ( deleteDone ) where import Control.Monad (forM_) @@ -17,36 +16,17 @@ import qualified Data.Vector as V import qualified GH import qualified Git import Shelly -import Utils (Options, ourShell, setupNixpkgs) +import Utils (Options, ourShell) +import qualified Data.Vector as V default (T.Text) --- | Delete the already merged branches both from local and remote repository -deleteMerged :: Options -> IO () -deleteMerged o = - ourShell o $ do - setupNixpkgs - Git.fetch - Git.cleanAndResetToMaster - mergedRemoteBranches <- T.lines <$> cmd "git" "branch" "-ra" "--merged" - let mergedRemoteAutoUpdateBranches = - mergedRemoteBranches & filter ("origin/auto-update/" `T.isInfixOf`) & - mapMaybe (T.stripPrefix "remotes/origin/" . T.strip) - forM_ mergedRemoteAutoUpdateBranches $ \branch -> - cmd "git" "push" "origin" (":" <> branch) - mergedBranches <- T.lines <$> cmd "git" "branch" "-a" "--merged" - let mergedAutoUpdateBranches = - mergedBranches & filter ("auto-update/" `T.isInfixOf`) & map T.strip - forM_ mergedAutoUpdateBranches $ \branch -> cmd "git" "branch" "-d" branch - deleteDone :: Options -> IO () -deleteDone o = - ourShell o $ do - setupNixpkgs - Git.fetch - Git.cleanAndResetToMaster - result <- liftIO $ GH.closedAutoUpdateRefs o - case result of - Left error -> liftIO $ T.putStrLn error - Right refs -> - V.sequence_ (fmap (\r -> Git.deleteBranch ("auto-update/" <> r)) refs) +deleteDone o = do + Git.fetch + Git.cleanAndResetToMaster + result <- GH.closedAutoUpdateRefs o + case result of + Left error -> T.putStrLn error + Right refs -> + V.sequence_ (fmap (\r -> Git.deleteBranch ("auto-update/" <> r)) refs) diff --git a/src/Git.hs b/src/Git.hs index 00dd95d..54ca9f4 100644 --- a/src/Git.hs +++ b/src/Git.hs @@ -19,85 +19,86 @@ module Git import Control.Error import Control.Monad.Trans.Class +import Control.Monad.IO.Class import Data.Semigroup ((<>)) import qualified Data.Text as T import Data.Text (Text) import Data.Time.Clock (UTCTime, addUTCTime, diffUTCTime, getCurrentTime) import Shelly import System.Directory (getHomeDirectory, getModificationTime) -import Utils (Options(..), UpdateEnv(..), branchName, canFail) +import Utils (Options(..), UpdateEnv(..), branchName, canFail, shellyET) default (T.Text) -clean :: Sh () -clean = cmd "git" "clean" "-fdx" +clean :: MonadIO m => m () +clean = shelly $ cmd "git" "clean" "-fdx" -cleanAndResetTo :: Text -> Text -> Sh () +cleanAndResetTo :: MonadIO m => Text -> Text -> m () cleanAndResetTo branch target = do - cmd "git" "reset" "--hard" + shelly $ cmd "git" "reset" "--hard" clean - cmd "git" "checkout" "-B" branch target - cmd "git" "reset" "--hard" target + shelly $ cmd "git" "checkout" "-B" branch target + shelly $ cmd "git" "reset" "--hard" target clean -cleanAndResetToMaster :: Sh () +cleanAndResetToMaster :: MonadIO m => m () cleanAndResetToMaster = cleanAndResetTo "master" "upstream/master" -cleanAndResetToStaging :: Sh () +cleanAndResetToStaging :: MonadIO m => m () cleanAndResetToStaging = cleanAndResetTo "staging" "upstream/staging" -cleanup :: Text -> Sh () +cleanup :: MonadIO m => Text -> m () cleanup branchName = do cleanAndResetToMaster - canFail $ cmd "git" "branch" "-D" branchName + shelly $ canFail $ cmd "git" "branch" "-D" branchName -showRef :: Text -> Sh Text -showRef ref = cmd "git" "show-ref" ref +showRef :: MonadIO m => Text -> m Text +showRef ref = shelly $ cmd "git" "show-ref" ref -staleFetchHead :: IO Bool -staleFetchHead = do +staleFetchHead :: MonadIO m => m Bool +staleFetchHead = liftIO $ do home <- getHomeDirectory let fetchHead = home <> "/.cache/nixpkgs/.git/FETCH_HEAD" oneHourAgo <- addUTCTime (fromInteger $ -60 * 60) <$> getCurrentTime fetchedLast <- getModificationTime fetchHead return (fetchedLast < oneHourAgo) -fetchIfStale :: Sh () -fetchIfStale = whenM (liftIO staleFetchHead) fetch +fetchIfStale :: MonadIO m => m () +fetchIfStale = whenM staleFetchHead fetch -fetch :: Sh () +fetch :: MonadIO m => m () fetch = - canFail $ cmd "git" "fetch" "-q" "--prune" "--multiple" "upstream" "origin" + shelly $ canFail $ cmd "git" "fetch" "-q" "--prune" "--multiple" "upstream" "origin" -push :: UpdateEnv -> Sh () +push :: MonadIO m => UpdateEnv -> ExceptT Text m () push updateEnv = - run_ + shellyET $ run_ "git" (["push", "--force", "--set-upstream", "origin", branchName updateEnv] ++ ["--dry-run" | dryRun (options updateEnv)]) -checkoutAtMergeBase :: Text -> Sh () +checkoutAtMergeBase :: MonadIO m => Text -> m () checkoutAtMergeBase branchName = do base <- - T.strip <$> cmd "git" "merge-base" "upstream/master" "upstream/staging" - cmd "git" "checkout" "-B" branchName base + T.strip <$> (shelly $ cmd "git" "merge-base" "upstream/master" "upstream/staging") + shelly $ cmd "git" "checkout" "-B" branchName base -checkAutoUpdateBranchDoesn'tExist :: Text -> ExceptT Text Sh () +checkAutoUpdateBranchDoesn'tExist :: MonadIO m => Text -> ExceptT Text m () checkAutoUpdateBranchDoesn'tExist packageName = do remoteBranches <- - lift $ map T.strip . T.lines <$> (silently $ cmd "git" "branch" "--remote") + lift $ map T.strip . T.lines <$> (shelly $ silently $ cmd "git" "branch" "--remote") when (("origin/auto-update/" <> packageName) `elem` remoteBranches) (throwE "Update branch already on origin.") -commit :: Text -> Sh () -commit = cmd "git" "commit" "-am" +commit :: MonadIO m => Text -> m () +commit ref = shelly $ cmd "git" "commit" "-am" ref -headHash :: Sh Text -headHash = cmd "git" "rev-parse" "HEAD" +headHash :: MonadIO m => m Text +headHash = shelly $ cmd "git" "rev-parse" "HEAD" -deleteBranch :: Text -> Sh () -deleteBranch branchName = do +deleteBranch :: MonadIO m => Text -> m () +deleteBranch branchName = shelly $ do canFail $ do cmd "git" "branch" "-D" branchName cmd "git" "push" "origin" (":" <> branchName) diff --git a/src/Main.hs b/src/Main.hs index 01aa532..1e3b520 100644 --- a/src/Main.hs +++ b/src/Main.hs @@ -14,7 +14,7 @@ import qualified Options.Applicative as Opt import System.Directory (getHomeDirectory) import System.Posix.Env (getEnv) import Update (updateAll) -import Utils (Options(..)) +import Utils (Options(..), setupNixpkgs) default (T.Text) @@ -50,6 +50,7 @@ main :: IO () main = do mode <- Opt.execParser programInfo options <- makeOptions + setupNixpkgs case mode of DeleteDone -> deleteDone options Update -> updateAll options diff --git a/src/Nix.hs b/src/Nix.hs index 1b7539d..30a2402 100644 --- a/src/Nix.hs +++ b/src/Nix.hs @@ -4,7 +4,7 @@ {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Nix - ( nixEvalE + ( nixEvalET , compareVersions , lookupAttrPath , getDerivationFile @@ -27,14 +27,15 @@ import Control.Applicative ((<|>)) import Control.Category ((>>>)) import Control.Error import Control.Monad (void) +import Control.Monad.IO.Class import Data.Bifunctor (second) import Data.Function ((&)) import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (FilePath) -import Shelly (FilePath, Sh, cmd, fromText, run, setStdin, toTextIgnore) -import Utils (UpdateEnv(..), rewriteError, shE, shRE) +import Shelly (FilePath, Sh, cmd, fromText, run, setStdin, shelly, toTextIgnore) +import Utils (UpdateEnv(..), rewriteError, overwriteErrorT, shE, shRE, shellyET) data Raw = Raw @@ -44,32 +45,30 @@ rawOpt :: Raw -> [Text] rawOpt Raw = ["--raw"] rawOpt NoRaw = [] -nixEvalE :: Raw -> Text -> Sh (Either Text Text) -nixEvalE raw expr = - run "nix" (["eval", "-f", "."] <> rawOpt raw <> [expr]) & - (fmap T.strip >>> shE >>> rewriteError ("nix eval failed for " <> expr)) +nixEvalET :: MonadIO m => Raw -> Text -> ExceptT Text m Text +nixEvalET raw expr = + run "nix" (["eval", "-f", "."] <> rawOpt raw <> [expr]) & fmap T.strip & + shellyET & + overwriteErrorT ("nix eval failed for " <> expr) -- Error if the "new version" is actually newer according to nix -compareVersions :: UpdateEnv -> Sh (Either Text ()) +compareVersions :: MonadIO m => UpdateEnv -> ExceptT Text m () compareVersions updateEnv = do versionComparison <- - nixEvalE + nixEvalET NoRaw ("(builtins.compareVersions \"" <> newVersion updateEnv <> "\" \"" <> oldVersion updateEnv <> "\")") - return $ - case versionComparison of - Right "1" -> Right () - Right a -> - Left $ - newVersion updateEnv <> " is not newer than " <> oldVersion updateEnv <> - " according to Nix; versionComparison: " <> - a - Left a -> Left a - -- This is extremely slow but gives us the best results we know of + case versionComparison of + "1" -> return () + a -> throwE ( + newVersion updateEnv <> " is not newer than " <> oldVersion updateEnv <> + " according to Nix; versionComparison: " <> + a) -lookupAttrPath :: UpdateEnv -> Sh (Either Text Text) +-- This is extremely slow but gives us the best results we know of +lookupAttrPath :: MonadIO m => UpdateEnv -> m (Either Text Text) lookupAttrPath updateEnv = cmd "nix-env" @@ -81,91 +80,88 @@ lookupAttrPath updateEnv = "--arg" "config" "{ allowBroken = true; allowUnfree = true; allowAliases = false; }" & - (fmap (head . T.words . head . T.lines) >>> - shE >>> - rewriteError "nix-env -q failed to find package name with old version") + (fmap (T.lines >>> head >>> T.words >>> head)) & + shE & + rewriteError "nix-env -q failed to find package name with old version" & + shelly -getDerivationFile :: UpdateEnv -> Text -> Sh (Either Text FilePath) +getDerivationFile :: MonadIO m => UpdateEnv -> Text -> m (Either Text FilePath) getDerivationFile updateEnv attrPath = - cmd "env" "EDITOR=echo" "nix" "edit" attrPath "-f" "." & - (fmap T.strip >>> - fmap fromText >>> shE >>> rewriteError "Couldn't find derivation file.") + cmd "env" "EDITOR=echo" "nix" "edit" attrPath "-f" "." & fmap T.strip & + fmap fromText & + shE & + rewriteError "Couldn't find derivation file." & + shelly -getHash :: Text -> Sh (Either Text Text) -getHash attrPath = do - e1 <- nixEvalE Raw ("pkgs." <> attrPath <> ".src.drvAttrs.outputHash") - case e1 of - Right _ -> return e1 - Left _ -> nixEvalE Raw ("pkgs." <> attrPath <> ".drvAttrs.outputHash") +getHash :: MonadIO m => Text -> ExceptT Text m Text +getHash attrPath = + (nixEvalET Raw ("pkgs." <> attrPath <> ".src.drvAttrs.outputHash")) <|> + nixEvalET Raw ("pkgs." <> attrPath <> ".drvAttrs.outputHash") -getOldHash :: Text -> Sh (Either Text Text) +getOldHash :: MonadIO m => Text -> ExceptT Text m Text getOldHash attrPath = getHash attrPath & - rewriteError + overwriteErrorT ("Could not find old output hash at " <> attrPath <> ".src.drvAttrs.outputHash or .drvAttrs.outputHash.") -getMaintainers :: Text -> Sh (Either Text Text) +getMaintainers :: MonadIO m => Text -> ExceptT Text m Text getMaintainers attrPath = - nixEvalE + nixEvalET Raw ("(let pkgs = import ./. {}; gh = m : m.github or \"\"; nonempty = s: s != \"\"; addAt = s: \"@\"+s; in builtins.concatStringsSep \" \" (map addAt (builtins.filter nonempty (map gh pkgs." <> attrPath <> ".meta.maintainers or []))))") & - rewriteError ("Could not fetch maintainers for" <> attrPath) + overwriteErrorT ("Could not fetch maintainers for" <> attrPath) -readNixBool :: Either Text Text -> Either Text Bool -readNixBool (Right "true") = Right True -readNixBool (Right "false") = Right False -readNixBool (Right a) = Left ("Failed to convert expected nix boolean " <> a) -readNixBool (Left e) = Left e +readNixBool :: MonadIO m => ExceptT Text m Text -> ExceptT Text m Bool +readNixBool t = do + text <- t + case text of + "true" -> return True + "false" -> return False + a -> throwE ("Failed to read expected nix boolean " <> a) -getIsBroken :: Text -> Sh (Either Text Bool) +getIsBroken :: MonadIO m => Text -> ExceptT Text m Bool getIsBroken attrPath = - nixEvalE + nixEvalET NoRaw ("(let pkgs = import ./. {}; in pkgs." <> attrPath <> ".meta.broken or false)") & - fmap readNixBool & - rewriteError ("Could not get meta.broken for attrpath " <> attrPath) + readNixBool & + overwriteErrorT ("Could not get meta.broken for attrpath " <> attrPath) -getDescription :: Text -> Sh (Either Text Text) +getDescription :: MonadIO m => Text -> ExceptT Text m Text getDescription attrPath = - nixEvalE + nixEvalET NoRaw ("(let pkgs = import ./. {}; in pkgs." <> attrPath <> ".meta.description or \"\")") & - rewriteError ("Could not get meta.description for attrpath " <> attrPath) + overwriteErrorT ("Could not get meta.description for attrpath " <> attrPath) -getSrcUrl :: Text -> Sh (Either Text Text) -getSrcUrl attrPath = do - e1 <- - nixEvalE +getSrcUrl :: MonadIO m => Text -> ExceptT Text m Text +getSrcUrl attrPath = + nixEvalET + Raw + ("(let pkgs = import ./. {}; in builtins.elemAt pkgs." <> attrPath <> + ".src.drvAttrs.urls 0)") <|> + nixEvalET Raw ("(let pkgs = import ./. {}; in builtins.elemAt pkgs." <> attrPath <> - ".src.drvAttrs.urls 0)") - case e1 of - Right _ -> return e1 - Left _ -> - nixEvalE - Raw - ("(let pkgs = import ./. {}; in builtins.elemAt pkgs." <> attrPath <> - ".drvAttrs.urls 0)") + ".drvAttrs.urls 0)") -getSrcAttr :: Text -> Text -> Sh (Either Text Text) +getSrcAttr :: MonadIO m => Text -> Text -> ExceptT Text m Text getSrcAttr attr attrPath = do - e1 <- nixEvalE NoRaw ("pkgs." <> attrPath <> ".src." <> attr) - case e1 of - Right _ -> return e1 - Left _ -> nixEvalE NoRaw ("pkgs." <> attrPath <> "." <> attr) + nixEvalET NoRaw ("pkgs." <> attrPath <> ".src." <> attr) <|> + nixEvalET NoRaw ("pkgs." <> attrPath <> "." <> attr) -getSrcUrls :: Text -> Sh (Either Text Text) +getSrcUrls :: MonadIO m => Text -> ExceptT Text m Text getSrcUrls = getSrcAttr "urls" -buildCmd :: Text -> Sh Text +buildCmd :: Text -> Sh () buildCmd attrPath = cmd - "nix-build" + "nix-build" "--option" "sandbox" "true" @@ -182,17 +178,16 @@ build attrPath = do Right _ -> return $ Right () Left _ -> do buildLogE <- - cmd "nix" "log" "-f" "." attrPath & - (shE >>> - (fmap . fmap) - (T.lines >>> reverse >>> take 30 >>> reverse >>> T.unlines)) + cmd "nix" "log" "-f" "." attrPath & shE & + (fmap . fmap) + (T.lines >>> reverse >>> take 30 >>> reverse >>> T.unlines) return $ case buildLogE of Left t -> Left "nix log failed trying to get build logs" Right buildLog -> Left ("nix build failed.\n" <> buildLog) -cachix :: FilePath -> Sh () -cachix resultPath = do +cachix :: MonadIO m => FilePath -> m () +cachix resultPath = shelly $ do setStdin (toTextIgnore resultPath) void $ shE $ cmd "cachix" "push" "r-ryantm" @@ -202,18 +197,18 @@ numberOfFetchers derivationContents = where count x = T.count x derivationContents -oldVersionOn :: UpdateEnv -> Text -> Text -> Sh (Either Text ()) +oldVersionOn :: MonadIO m => UpdateEnv -> Text -> Text -> m (Either Text ()) oldVersionOn updateEnv branchName contents = pure (assertErr ("Old version not present in " <> branchName <> " derivation file.") (oldVersion updateEnv `T.isInfixOf` contents)) -resultLink :: ExceptT Text Sh FilePath +resultLink :: MonadIO m => ExceptT Text m FilePath resultLink = (T.strip >>> fromText) <$> do - (ExceptT $ shE $ cmd "readlink" "./result") <|> - (ExceptT $ shE $ cmd "readlink" "./result-bin") <|> + (shellyET $ cmd "readlink" "./result") <|> + (shellyET $ cmd "readlink" "./result-bin") <|> throwE "Could not find result link." sha256Zero :: Text diff --git a/src/Outpaths.hs b/src/Outpaths.hs index c3791bd..f784b8a 100644 --- a/src/Outpaths.hs +++ b/src/Outpaths.hs @@ -85,7 +85,6 @@ in outPath :: Sh Text outPath = sub $ do - Utils.setupNixpkgs cmd "curl" "-o" diff --git a/src/Update.hs b/src/Update.hs index abe8981..5faf346 100644 --- a/src/Update.hs +++ b/src/Update.hs @@ -3,6 +3,8 @@ {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# OPTIONS_GHC -fno-warn-type-defaults #-} module Update @@ -13,11 +15,11 @@ import qualified Blacklist import qualified Check import Clean (fixSrcUrl) import Control.Applicative ((<|>)) -import Control.Category ((>>>)) import Control.Error import Control.Exception (SomeException, throw, toException) import Control.Exception.Lifted import Control.Monad (forM_, mplus) +import Control.Monad.Except import Control.Monad.Trans.Class import Data.Function ((&)) import Data.IORef @@ -38,7 +40,7 @@ import NeatInterpolation (text) import qualified Nix import Outpaths import Prelude hiding (FilePath) -import Shelly +import Shelly.Lifted import Utils ( Options(..) , UpdateEnv(..) @@ -51,9 +53,8 @@ import Utils , ourShell , parseUpdates , rewriteError - , setupNixpkgs - , shE , tRead + , shE ) default (T.Text) @@ -103,7 +104,7 @@ updateLoop options log (Right (package, oldVersion, newVersion):moreUpdates) mer updated <- updatePackage log updateEnv mergeBaseOutpathsContext case updated of Left failure -> do - Git.cleanup (branchName updateEnv) + liftIO $ Git.cleanup (branchName updateEnv) log $ "FAIL " <> failure if ".0" `T.isSuffixOf` newVersion then let Just newNewVersion = ".0" `T.stripSuffix` newVersion @@ -125,27 +126,26 @@ updatePackage :: updatePackage log updateEnv mergeBaseOutpathsContext = runExceptT $ do Blacklist.packageName (packageName updateEnv) - lift setupNixpkgs -- Check whether requested version is newer than the current one - ExceptT $ Nix.compareVersions updateEnv - lift Git.fetchIfStale + Nix.compareVersions updateEnv + liftIO $ Git.fetchIfStale Git.checkAutoUpdateBranchDoesn'tExist (packageName updateEnv) - lift Git.cleanAndResetToMaster + liftIO Git.cleanAndResetToMaster attrPath <- ExceptT $ Nix.lookupAttrPath updateEnv ensureVersionCompatibleWithPathPin updateEnv attrPath - srcUrls <- ExceptT $ Nix.getSrcUrls attrPath + srcUrls <- Nix.getSrcUrls attrPath Blacklist.srcUrl srcUrls Blacklist.attrPath attrPath + masterShowRef <- lift $ Git.showRef "master" + lift $ log masterShowRef derivationFile <- ExceptT $ Nix.getDerivationFile updateEnv attrPath flip catches [Handler (\(ex :: SomeException) -> throwE (T.pack (show ex)))] $ -- Make sure it hasn't been updated on master do masterDerivationContents <- lift $ readfile derivationFile - masterShowRef <- lift $ Git.showRef "master" - lift $ log masterShowRef ExceptT $ Nix.oldVersionOn updateEnv "master" masterDerivationContents -- Make sure it hasn't been updated on staging - lift Git.cleanAndResetToStaging + liftIO Git.cleanAndResetToStaging masterShowRef <- lift $ Git.showRef "staging" lift $ log masterShowRef stagingDerivationContents <- lift $ readfile derivationFile @@ -170,14 +170,14 @@ updatePackage log updateEnv mergeBaseOutpathsContext = (Nix.numberOfFetchers derivationContents > 1) (throwE $ "More than one fetcher in " <> toTextIgnore derivationFile) Blacklist.content derivationContents - oldHash <- ExceptT $ Nix.getOldHash attrPath - oldSrcUrl <- ExceptT $ Nix.getSrcUrl attrPath + oldHash <- Nix.getOldHash attrPath + oldSrcUrl <- Nix.getSrcUrl attrPath lift $ File.replace (oldVersion updateEnv) (newVersion updateEnv) derivationFile - newSrcUrl <- ExceptT $ Nix.getSrcUrl attrPath + newSrcUrl <- Nix.getSrcUrl attrPath when (oldSrcUrl == newSrcUrl) $ throwE "Source url did not change." lift $ File.replace oldHash Nix.sha256Zero derivationFile newHash <- Nix.getHashFromBuild (attrPath <> ".src") <|> @@ -216,7 +216,7 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opDiff = do case Blacklist.checkResult (packageName updateEnv) of Right () -> lift $ sub (Check.result updateEnv result) Left msg -> pure msg - d <- ExceptT $ (Nix.getDescription attrPath) + d <- Nix.getDescription attrPath let metaDescription = "\n\nmeta.description for " <> attrPath <> " is: '" <> d <> "'." releaseUrlResult <- liftIO $ GH.releaseUrl newSrcUrl @@ -233,7 +233,7 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opDiff = do lift $ log e return "\n" Right msg -> return ("\n[Compare changes on GitHub](" <> msg <> ")\n\n") - maintainers <- ExceptT $ (Nix.getMaintainers attrPath) + maintainers <- Nix.getMaintainers attrPath let maintainersCc = if not (T.null maintainers) then "\n\ncc " <> maintainers <> " for testing." @@ -242,36 +242,33 @@ publishPackage log updateEnv oldSrcUrl newSrcUrl attrPath result opDiff = do ExceptT $ shE $ Git.commit commitMsg commitHash <- lift $ Git.headHash -- Try to push it three times - ExceptT $ shE - (Git.push updateEnv `orElse` Git.push updateEnv `orElse` Git.push updateEnv) - isBroken <- ExceptT $ (Nix.getIsBroken attrPath) + Git.push updateEnv <|> Git.push updateEnv <|> Git.push updateEnv + isBroken <- Nix.getIsBroken attrPath lift $ untilOfBorgFree let base = if numPackageRebuilds opDiff < 100 then "master" else "staging" - ExceptT $ shE $ - GH.pr - base - (prMessage - updateEnv - isBroken - metaDescription - releaseUrlMessage - compareUrlMessage - resultCheckReport - commitHash - attrPath - maintainersCc - result - (outpathReport opDiff)) - lift $ Git.cleanAndResetToMaster + lift $ GH.pr + base + (prMessage + updateEnv + isBroken + metaDescription + releaseUrlMessage + compareUrlMessage + resultCheckReport + commitHash + attrPath + maintainersCc + result + (outpathReport opDiff)) + liftIO $ Git.cleanAndResetToMaster repologyUrl :: UpdateEnv -> Text repologyUrl updateEnv = [text|https://repology.org/metapackage/$pname/versions|] where - pname = (packageName >>> T.toLower) updateEnv - + pname = updateEnv & packageName & T.toLower commitMessage :: UpdateEnv -> Text -> Text commitMessage updateEnv attrPath = let oV = oldVersion updateEnv diff --git a/src/Utils.hs b/src/Utils.hs index dfab4f8..df5d8ff 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -15,6 +15,8 @@ module Utils , succeded , shE , shRE + , shellyET + , overwriteErrorT , rewriteError , eitherToError , branchName @@ -22,14 +24,19 @@ module Utils , ourSilentShell ) where +import Control.Category ((>>>)) import Control.Error import Control.Exception (Exception) +import Control.Monad.IO.Class import Data.Bifunctor (first) import Data.Semigroup ((<>)) import Data.Text (Text) import qualified Data.Text as T import Prelude hiding (FilePath) -import Shelly +import Shelly.Lifted +import System.Directory +import System.Environment +import System.Environment.XDG.BaseDir default (T.Text) @@ -48,17 +55,18 @@ data UpdateEnv = UpdateEnv , options :: Options } -setupNixpkgs :: Sh () +setupNixpkgs :: IO () setupNixpkgs = do - home <- get_env_text "HOME" - let nixpkgsPath = home ".cache" "nixpkgs" - unlessM (test_e nixpkgsPath) $ do - cmd "hub" "clone" "nixpkgs" nixpkgsPath -- requires that user has forked nixpkgs - cd nixpkgsPath - cmd "git" "remote" "add" "upstream" "https://github.com/NixOS/nixpkgs" - cmd "git" "fetch" "upstream" - cd nixpkgsPath - setenv "NIX_PATH" ("nixpkgs=" <> toTextIgnore nixpkgsPath) + fp <- getUserCacheDir "nixpkgs" + exists <- doesDirectoryExist fp + unless exists $ do + shelly $ run "hub" ["clone", "nixpkgs", T.pack fp] -- requires that user has forked nixpkgs + setCurrentDirectory fp + shelly $ + cmd "git" "remote" "add" "upstream" "https://github.com/NixOS/nixpkgs" + shelly $ cmd "git" "fetch" "upstream" + setCurrentDirectory fp + setEnv "NIX_PATH" ("nixpkgs=" <> fp) -- | Set environment variables needed by various programs setUpEnvironment :: Options -> Sh () @@ -99,6 +107,12 @@ shRE s = do 0 -> return $ Left "" c -> return $ Right stderr +shellyET :: MonadIO m => Sh a -> ExceptT Text m a +shellyET = shE >>> shelly >>> ExceptT + +overwriteErrorT :: MonadIO m => Text -> ExceptT Text m a -> ExceptT Text m a +overwriteErrorT t = fmapLT (const t) + rewriteError :: Text -> Sh (Either Text a) -> Sh (Either Text a) rewriteError t = fmap (first (const t))