{-# LANGUAGE ExtendedDefaultRules #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-type-defaults #-}

module Update
  ( addPatched,
    assertNotUpdatedOn,
    cveAll,
    cveReport,
    prMessage,
    sourceGithubAll,
    updateAll,
    updatePackage,
  )
where

import CVE (CVE, cveID, cveLI)
import qualified Check
import Control.Concurrent
import qualified Data.ByteString.Lazy.Char8 as BSL
import Data.IORef
import Data.Maybe (fromJust)
import qualified Data.Set as S
import qualified Data.Text as T
import qualified Data.Text.IO as T
import Data.Time.Calendar (showGregorian)
import Data.Time.Clock (UTCTime, getCurrentTime, utctDay)
import qualified GH
import qualified Git
import Language.Haskell.TH.Env (envQ)
import NVD (getCVEs, withVulnDB)
import qualified Nix
import qualified NixpkgsReview
import OurPrelude
import Outpaths
import qualified Rewrite
import qualified Skiplist
import qualified Time
import Utils
  ( Options (..),
    URL,
    UpdateEnv (..),
    Version,
    branchName,
    logDir,
    parseUpdates,
    prTitle,
    whenBatch,
  )
import qualified Version
import Prelude hiding (log)

default (T.Text)

data MergeBaseOutpathsInfo = MergeBaseOutpathsInfo
  { MergeBaseOutpathsInfo -> UTCTime
lastUpdated :: UTCTime,
    MergeBaseOutpathsInfo -> Set ResultLine
mergeBaseOutpaths :: Set ResultLine
  }

log' :: MonadIO m => FilePath -> Text -> m ()
log' :: FilePath -> Text -> m ()
log' FilePath
logFile Text
msg = do
  Text
runDate <- IO Text -> m Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> m Text) -> IO Text -> m Text
forall a b. (a -> b) -> a -> b
$ Sem '[Embed IO] Text -> IO Text
forall (m :: * -> *) a. Monad m => Sem '[Embed m] a -> m a
runM (Sem '[Embed IO] Text -> IO Text)
-> Sem '[Embed IO] Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Sem '[Time, Embed IO] Text -> Sem '[Embed IO] Text
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
Sem (Time : r) a -> Sem r a
Time.runIO Sem '[Time, Embed IO] Text
forall (r :: [(* -> *) -> * -> *]). Member Time r => Sem r Text
Time.runDate
  IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ FilePath -> Text -> IO ()
T.appendFile FilePath
logFile (Text
runDate Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
msg Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n")

logFileName :: IO String
logFileName :: IO FilePath
logFileName = do
  FilePath
lDir <- IO FilePath
logDir
  UTCTime
now <- IO UTCTime
getCurrentTime
  let logFile :: FilePath
logFile = FilePath
lDir FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/" FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> Day -> FilePath
showGregorian (UTCTime -> Day
utctDay UTCTime
now) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
".log"
  FilePath -> IO ()
putStrLn (FilePath
"Using log file: " FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
logFile)
  FilePath -> IO FilePath
forall (m :: * -> *) a. Monad m => a -> m a
return FilePath
logFile

getLog :: Options -> IO (Text -> IO ())
getLog :: Options -> IO (Text -> IO ())
getLog Options
o = do
  if Options -> Bool
batchUpdate Options
o
    then do
      FilePath
logFile <- IO FilePath
logFileName
      let log :: Text -> IO ()
log = FilePath -> Text -> IO ()
forall (m :: * -> *). MonadIO m => FilePath -> Text -> m ()
log' FilePath
logFile
      FilePath -> Text -> IO ()
T.appendFile FilePath
logFile Text
"\n\n"
      (Text -> IO ()) -> IO (Text -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return Text -> IO ()
log
    else (Text -> IO ()) -> IO (Text -> IO ())
forall (m :: * -> *) a. Monad m => a -> m a
return Text -> IO ()
T.putStrLn

notifyOptions :: (Text -> IO ()) -> Options -> IO ()
notifyOptions :: (Text -> IO ()) -> Options -> IO ()
notifyOptions Text -> IO ()
log Options
o = do
  let repr :: (Options -> Bool) -> Text
repr Options -> Bool
f = if Options -> Bool
f Options
o then Text
"YES" else Text
"NO"
  let ghUser :: Text
ghUser = Name Owner -> Text
forall entity. Name entity -> Text
GH.untagName (Name Owner -> Text) -> (Options -> Name Owner) -> Options -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name Owner
githubUser (Options -> Text) -> Options -> Text
forall a b. (a -> b) -> a -> b
$ Options
o
  let pr :: Text
pr = (Options -> Bool) -> Text
repr Options -> Bool
doPR
  let outpaths :: Text
outpaths = (Options -> Bool) -> Text
repr Options -> Bool
calculateOutpaths
  let cve :: Text
cve = (Options -> Bool) -> Text
repr Options -> Bool
makeCVEReport
  let review :: Text
review = (Options -> Bool) -> Text
repr Options -> Bool
runNixpkgsReview
  Text
npDir <- FilePath -> Text
forall a. Show a => a -> Text
tshow (FilePath -> Text) -> IO FilePath -> IO Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO FilePath
Git.nixpkgsDir
  Text -> IO ()
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
    [interpolate|
    Configured Nixpkgs-Update Options:
    ----------------------------------
    GitHub User:                   $ghUser
    Send pull request on success:  $pr
    Calculate Outpaths:            $outpaths
    CVE Security Report:           $cve
    Run nixpkgs-review:            $review
    Nixpkgs Dir:                   $npDir
    ----------------------------------|]

updateAll :: Options -> Text -> IO ()
updateAll :: Options -> Text -> IO ()
updateAll Options
o Text
updates = do
  Text -> IO ()
log <- Options -> IO (Text -> IO ())
getLog Options
o
  Text -> IO ()
log Text
"New run of nixpkgs-update"
  (Text -> IO ()) -> Options -> IO ()
notifyOptions Text -> IO ()
log Options
o
  UTCTime
twoHoursAgo <- Sem '[Embed IO] UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => Sem '[Embed m] a -> m a
runM (Sem '[Embed IO] UTCTime -> IO UTCTime)
-> Sem '[Embed IO] UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ Sem '[Time, Embed IO] UTCTime -> Sem '[Embed IO] UTCTime
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
Sem (Time : r) a -> Sem r a
Time.runIO Sem '[Time, Embed IO] UTCTime
forall (r :: [(* -> *) -> * -> *]). Member Time r => Sem r UTCTime
Time.twoHoursAgo
  IORef MergeBaseOutpathsInfo
mergeBaseOutpathSet <-
    IO (IORef MergeBaseOutpathsInfo)
-> IO (IORef MergeBaseOutpathsInfo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef MergeBaseOutpathsInfo)
 -> IO (IORef MergeBaseOutpathsInfo))
-> IO (IORef MergeBaseOutpathsInfo)
-> IO (IORef MergeBaseOutpathsInfo)
forall a b. (a -> b) -> a -> b
$ MergeBaseOutpathsInfo -> IO (IORef MergeBaseOutpathsInfo)
forall a. a -> IO (IORef a)
newIORef (UTCTime -> Set ResultLine -> MergeBaseOutpathsInfo
MergeBaseOutpathsInfo UTCTime
twoHoursAgo Set ResultLine
forall a. Set a
S.empty)
  Options
-> (Text -> IO ())
-> [Either Text (Text, Text, Text, Maybe Text)]
-> IORef MergeBaseOutpathsInfo
-> IO ()
updateLoop Options
o Text -> IO ()
log (Text -> [Either Text (Text, Text, Text, Maybe Text)]
parseUpdates Text
updates) IORef MergeBaseOutpathsInfo
mergeBaseOutpathSet

cveAll :: Options -> Text -> IO ()
cveAll :: Options -> Text -> IO ()
cveAll Options
o Text
updates = do
  let u' :: [(Text, Text, Text, Maybe Text)]
u' = [Either Text (Text, Text, Text, Maybe Text)]
-> [(Text, Text, Text, Maybe Text)]
forall a b. [Either a b] -> [b]
rights ([Either Text (Text, Text, Text, Maybe Text)]
 -> [(Text, Text, Text, Maybe Text)])
-> [Either Text (Text, Text, Text, Maybe Text)]
-> [(Text, Text, Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ Text -> [Either Text (Text, Text, Text, Maybe Text)]
parseUpdates Text
updates
  [Text]
results <-
    ((Text, Text, Text, Maybe Text) -> IO Text)
-> [(Text, Text, Text, Maybe Text)] -> IO [Text]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM
      ( \(Text
p, Text
oldV, Text
newV, Maybe Text
url) -> do
          Text
r <- UpdateEnv -> IO Text
cveReport (Text -> Text -> Text -> Maybe Text -> Options -> UpdateEnv
UpdateEnv Text
p Text
oldV Text
newV Maybe Text
url Options
o)
          Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return (Text -> IO Text) -> Text -> IO Text
forall a b. (a -> b) -> a -> b
$ Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oldV Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newV Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
r
      )
      [(Text, Text, Text, Maybe Text)]
u'
  Text -> IO ()
T.putStrLn ([Text] -> Text
T.unlines [Text]
results)

sourceGithubAll :: Options -> Text -> IO ()
sourceGithubAll :: Options -> Text -> IO ()
sourceGithubAll Options
o Text
updates = do
  let u' :: [(Text, Text, Text, Maybe Text)]
u' = [Either Text (Text, Text, Text, Maybe Text)]
-> [(Text, Text, Text, Maybe Text)]
forall a b. [Either a b] -> [b]
rights ([Either Text (Text, Text, Text, Maybe Text)]
 -> [(Text, Text, Text, Maybe Text)])
-> [Either Text (Text, Text, Text, Maybe Text)]
-> [(Text, Text, Text, Maybe Text)]
forall a b. (a -> b) -> a -> b
$ Text -> [Either Text (Text, Text, Text, Maybe Text)]
parseUpdates Text
updates
  Either Text ()
_ <-
    ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
      ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => ExceptT Text m ()
Git.fetchIfStale ExceptT Text IO () -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
T.putStrLn Text
"Failed to fetch.")
      Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Git.cleanAndResetTo Text
"master"
  ((Text, Text, Text, Maybe Text) -> IO (Either Text ()))
-> [(Text, Text, Text, Maybe Text)] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_
    ( \(Text
p, Text
oldV, Text
newV, Maybe Text
url) -> do
        let updateEnv :: UpdateEnv
updateEnv = Text -> Text -> Text -> Maybe Text -> Options -> UpdateEnv
UpdateEnv Text
p Text
oldV Text
newV Maybe Text
url Options
o
        ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
          Text
attrPath <- UpdateEnv -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => UpdateEnv -> ExceptT Text m Text
Nix.lookupAttrPath UpdateEnv
updateEnv
          Text
srcUrl <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getSrcUrl Text
attrPath
          Text
v <- UpdateEnv -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> Text -> ExceptT Text m Text
GH.latestVersion UpdateEnv
updateEnv Text
srcUrl
          if Text
v Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
newV
            then
              IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
                Text -> IO ()
T.putStrLn (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$
                  Text
p Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
": " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oldV Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newV Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
v
            else () -> ExceptT Text IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    )
    [(Text, Text, Text, Maybe Text)]
u'

updateLoop ::
  Options ->
  (Text -> IO ()) ->
  [Either Text (Text, Version, Version, Maybe URL)] ->
  IORef MergeBaseOutpathsInfo ->
  IO ()
updateLoop :: Options
-> (Text -> IO ())
-> [Either Text (Text, Text, Text, Maybe Text)]
-> IORef MergeBaseOutpathsInfo
-> IO ()
updateLoop Options
_ Text -> IO ()
log [] IORef MergeBaseOutpathsInfo
_ = Text -> IO ()
log Text
"nixpkgs-update finished"
updateLoop Options
o Text -> IO ()
log (Left Text
e : [Either Text (Text, Text, Text, Maybe Text)]
moreUpdates) IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext = do
  Text -> IO ()
log Text
e
  Options
-> (Text -> IO ())
-> [Either Text (Text, Text, Text, Maybe Text)]
-> IORef MergeBaseOutpathsInfo
-> IO ()
updateLoop Options
o Text -> IO ()
log [Either Text (Text, Text, Text, Maybe Text)]
moreUpdates IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext
updateLoop Options
o Text -> IO ()
log (Right (Text
pName, Text
oldVer, Text
newVer, Maybe Text
url) : [Either Text (Text, Text, Text, Maybe Text)]
moreUpdates) IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext = do
  Text -> IO ()
log (Text
pName Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
oldVer Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" -> " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
newVer Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" ((Text -> Text) -> Maybe Text -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<>) Maybe Text
url))
  let updateEnv :: UpdateEnv
updateEnv = Text -> Text -> Text -> Maybe Text -> Options -> UpdateEnv
UpdateEnv Text
pName Text
oldVer Text
newVer Maybe Text
url Options
o
  Either Text ()
updated <- (Text -> IO ())
-> UpdateEnv -> IORef MergeBaseOutpathsInfo -> IO (Either Text ())
updatePackageBatch Text -> IO ()
log UpdateEnv
updateEnv IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext
  case Either Text ()
updated of
    Left Text
failure -> do
      Text -> IO ()
log (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"FAIL " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
failure
      Either Text ()
cleanupResult <- ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Git.cleanup (UpdateEnv -> Text
branchName UpdateEnv
updateEnv)
      case Either Text ()
cleanupResult of
        Left Text
e -> IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
forall a. Show a => a -> IO ()
print Text
e
        Either Text ()
_ ->
          if Text
".0" Text -> Text -> Bool
`T.isSuffixOf` Text
newVer
            then
              let Just Text
newNewVersion = Text
".0" Text -> Text -> Maybe Text
`T.stripSuffix` Text
newVer
               in Options
-> (Text -> IO ())
-> [Either Text (Text, Text, Text, Maybe Text)]
-> IORef MergeBaseOutpathsInfo
-> IO ()
updateLoop
                    Options
o
                    Text -> IO ()
log
                    ((Text, Text, Text, Maybe Text)
-> Either Text (Text, Text, Text, Maybe Text)
forall a b. b -> Either a b
Right (Text
pName, Text
oldVer, Text
newNewVersion, Maybe Text
url) Either Text (Text, Text, Text, Maybe Text)
-> [Either Text (Text, Text, Text, Maybe Text)]
-> [Either Text (Text, Text, Text, Maybe Text)]
forall a. a -> [a] -> [a]
: [Either Text (Text, Text, Text, Maybe Text)]
moreUpdates)
                    IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext
            else Options
-> (Text -> IO ())
-> [Either Text (Text, Text, Text, Maybe Text)]
-> IORef MergeBaseOutpathsInfo
-> IO ()
updateLoop Options
o Text -> IO ()
log [Either Text (Text, Text, Text, Maybe Text)]
moreUpdates IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext
    Right ()
_ -> do
      Text -> IO ()
log Text
"SUCCESS"
      Options
-> (Text -> IO ())
-> [Either Text (Text, Text, Text, Maybe Text)]
-> IORef MergeBaseOutpathsInfo
-> IO ()
updateLoop Options
o Text -> IO ()
log [Either Text (Text, Text, Text, Maybe Text)]
moreUpdates IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext

-- Arguments this function should have to make it testable:
-- - the merge base commit (should be updated externally to this function)
-- - the merge base context should be updated externally to this function
-- - the commit for branches: master, staging, staging-next
updatePackageBatch ::
  (Text -> IO ()) ->
  UpdateEnv ->
  IORef MergeBaseOutpathsInfo ->
  IO (Either Text ())
updatePackageBatch :: (Text -> IO ())
-> UpdateEnv -> IORef MergeBaseOutpathsInfo -> IO (Either Text ())
updatePackageBatch Text -> IO ()
log updateEnv :: UpdateEnv
updateEnv@UpdateEnv {Maybe Text
Text
Options
options :: UpdateEnv -> Options
sourceURL :: UpdateEnv -> Maybe Text
newVersion :: UpdateEnv -> Text
oldVersion :: UpdateEnv -> Text
packageName :: UpdateEnv -> Text
options :: Options
sourceURL :: Maybe Text
newVersion :: Text
oldVersion :: Text
packageName :: Text
..} IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext =
  ExceptT Text IO () -> IO (Either Text ())
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO () -> IO (Either Text ()))
-> ExceptT Text IO () -> IO (Either Text ())
forall a b. (a -> b) -> a -> b
$ do
    let pr :: Bool
pr = Options -> Bool
doPR Options
options

    -- Filters that don't need git
    UpdateEnv -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => UpdateEnv -> f () -> f ()
whenBatch UpdateEnv
updateEnv do
      Text -> ExceptT Text IO ()
forall (m :: * -> *). TextSkiplister m
Skiplist.packageName Text
packageName
      -- Update our git checkout
      ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => ExceptT Text m ()
Git.fetchIfStale ExceptT Text IO () -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (Text -> IO ()
T.putStrLn Text
"Failed to fetch.")
      Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Git.cleanAndResetTo Text
"master"

    -- Filters: various cases where we shouldn't update the package
    Text
attrPath <- UpdateEnv -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => UpdateEnv -> ExceptT Text m Text
Nix.lookupAttrPath UpdateEnv
updateEnv
    Bool
hasUpdateScript <- Text -> ExceptT Text IO Bool
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Bool
Nix.hasUpdateScript Text
attrPath

    UpdateEnv -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => UpdateEnv -> f () -> f ()
whenBatch UpdateEnv
updateEnv do
      Text -> ExceptT Text IO ()
forall (m :: * -> *). TextSkiplister m
Skiplist.attrPath Text
attrPath
      Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pr do
        Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Git.checkAutoUpdateBranchDoesntExist Text
packageName
        UpdateEnv -> Text -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> Text -> ExceptT Text m ()
GH.checkExistingUpdatePR UpdateEnv
updateEnv Text
attrPath

    Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasUpdateScript do
      UpdateEnv -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => UpdateEnv -> ExceptT Text m ()
Nix.assertNewerVersion UpdateEnv
updateEnv
      UpdateEnv -> Text -> ExceptT Text IO ()
forall (m :: * -> *).
Monad m =>
UpdateEnv -> Text -> ExceptT Text m ()
Version.assertCompatibleWithPathPin UpdateEnv
updateEnv Text
attrPath

    FilePath
derivationFile <- Text -> ExceptT Text IO FilePath
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m FilePath
Nix.getDerivationFile Text
attrPath
    Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasUpdateScript do
      UpdateEnv -> FilePath -> Text -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> FilePath -> Text -> ExceptT Text m ()
assertNotUpdatedOn UpdateEnv
updateEnv FilePath
derivationFile Text
"master"
      UpdateEnv -> FilePath -> Text -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> FilePath -> Text -> ExceptT Text m ()
assertNotUpdatedOn UpdateEnv
updateEnv FilePath
derivationFile Text
"staging"
      UpdateEnv -> FilePath -> Text -> ExceptT Text IO ()
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> FilePath -> Text -> ExceptT Text m ()
assertNotUpdatedOn UpdateEnv
updateEnv FilePath
derivationFile Text
"staging-next"

    -- Calculate output paths for rebuilds and our merge base
    Text
mergeBase <- if Options -> Bool
batchUpdate Options
options
      then Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Git.checkoutAtMergeBase (UpdateEnv -> Text
branchName UpdateEnv
updateEnv)
      else Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
"HEAD"
    let calcOutpaths :: Bool
calcOutpaths = Options -> Bool
calculateOutpaths Options
options
    UTCTime
oneHourAgo <- IO UTCTime -> ExceptT Text IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO UTCTime -> ExceptT Text IO UTCTime)
-> IO UTCTime -> ExceptT Text IO UTCTime
forall a b. (a -> b) -> a -> b
$ Sem '[Embed IO] UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => Sem '[Embed m] a -> m a
runM (Sem '[Embed IO] UTCTime -> IO UTCTime)
-> Sem '[Embed IO] UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ Sem '[Time, Embed IO] UTCTime -> Sem '[Embed IO] UTCTime
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
Sem (Time : r) a -> Sem r a
Time.runIO Sem '[Time, Embed IO] UTCTime
forall (r :: [(* -> *) -> * -> *]). Member Time r => Sem r UTCTime
Time.oneHourAgo
    MergeBaseOutpathsInfo
mergeBaseOutpathsInfo <- IO MergeBaseOutpathsInfo -> ExceptT Text IO MergeBaseOutpathsInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO MergeBaseOutpathsInfo -> ExceptT Text IO MergeBaseOutpathsInfo)
-> IO MergeBaseOutpathsInfo
-> ExceptT Text IO MergeBaseOutpathsInfo
forall a b. (a -> b) -> a -> b
$ IORef MergeBaseOutpathsInfo -> IO MergeBaseOutpathsInfo
forall a. IORef a -> IO a
readIORef IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext
    Set ResultLine
mergeBaseOutpathSet <-
      if Bool
calcOutpaths Bool -> Bool -> Bool
&& MergeBaseOutpathsInfo -> UTCTime
lastUpdated MergeBaseOutpathsInfo
mergeBaseOutpathsInfo UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
< UTCTime
oneHourAgo
        then do
          Set ResultLine
mbos <- ExceptT Text IO (Set ResultLine)
forall (m :: * -> *). MonadIO m => ExceptT Text m (Set ResultLine)
currentOutpathSet
          UTCTime
now <- IO UTCTime -> ExceptT Text IO UTCTime
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO IO UTCTime
getCurrentTime
          IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$
            IORef MergeBaseOutpathsInfo -> MergeBaseOutpathsInfo -> IO ()
forall a. IORef a -> a -> IO ()
writeIORef IORef MergeBaseOutpathsInfo
mergeBaseOutpathsContext (UTCTime -> Set ResultLine -> MergeBaseOutpathsInfo
MergeBaseOutpathsInfo UTCTime
now Set ResultLine
mbos)
          Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall (m :: * -> *) a. Monad m => a -> m a
return Set ResultLine
mbos
        else
          if Bool
calcOutpaths
            then Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set ResultLine -> ExceptT Text IO (Set ResultLine))
-> Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall a b. (a -> b) -> a -> b
$ MergeBaseOutpathsInfo -> Set ResultLine
mergeBaseOutpaths MergeBaseOutpathsInfo
mergeBaseOutpathsInfo
            else Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set ResultLine -> ExceptT Text IO (Set ResultLine))
-> Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall a b. (a -> b) -> a -> b
$ Text -> Set ResultLine
dummyOutpathSetBefore Text
attrPath

    -- Get the original values for diffing purposes
    Text
derivationContents <- IO Text -> ExceptT Text IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Text IO Text)
-> IO Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
derivationFile
    Text
oldHash <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getOldHash Text
attrPath
    Text
oldSrcUrl <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getSrcUrl Text
attrPath
    Maybe Text
oldVerMay <- Either Text Text -> Maybe Text
forall e a. Either e a -> Maybe a
rightMay (Either Text Text -> Maybe Text)
-> ExceptT Text IO (Either Text Text)
-> ExceptT Text IO (Maybe Text)
forall (m :: * -> *) a b l.
Monad m =>
(a -> b) -> ExceptT l m a -> ExceptT l m b
`fmapRT` (IO (Either Text Text) -> ExceptT Text IO (Either Text Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either Text Text) -> ExceptT Text IO (Either Text Text))
-> IO (Either Text Text) -> ExceptT Text IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ ExceptT Text IO Text -> IO (Either Text Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Text -> IO (Either Text Text))
-> ExceptT Text IO Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Raw -> Text -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
Raw -> Text -> Text -> ExceptT Text m Text
Nix.getAttr Raw
Nix.Raw Text
"version" Text
attrPath)

    Text -> Bool -> ExceptT Text IO ()
forall (m :: * -> *) e. Monad m => e -> Bool -> ExceptT e m ()
tryAssert
      Text
"The derivation has no 'version' attribute, so do not know how to figure out the version while doing an updateScript update"
      (Bool -> Bool
not Bool
hasUpdateScript Bool -> Bool -> Bool
|| Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
oldVerMay)

    -- One final filter
    Text -> ExceptT Text IO ()
forall (m :: * -> *). TextSkiplister m
Skiplist.content Text
derivationContents

    ----------------------------------------------------------------------------
    -- UPDATES
    --
    -- At this point, we've stashed the old derivation contents and
    -- validated that we actually should be rewriting something. Get
    -- to work processing the various rewrite functions!
    [Text]
rewriteMsgs <- (Text -> IO ()) -> Args -> ExceptT Text IO [Text]
Rewrite.runAll Text -> IO ()
log Args :: UpdateEnv -> Text -> FilePath -> Text -> Bool -> Args
Rewrite.Args {Bool
FilePath
Text
UpdateEnv
hasUpdateScript :: Bool
derivationContents :: Text
derivationFile :: FilePath
attrPath :: Text
updateEnv :: UpdateEnv
derivationContents :: Text
derivationFile :: FilePath
hasUpdateScript :: Bool
attrPath :: Text
updateEnv :: UpdateEnv
..}
    ----------------------------------------------------------------------------

    -- Compute the diff and get updated values
    Text
diffAfterRewrites <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Git.diff Text
mergeBase
    Text -> Bool -> ExceptT Text IO ()
forall (m :: * -> *) e. Monad m => e -> Bool -> ExceptT e m ()
tryAssert
      Text
"The diff was empty after rewrites."
      (Text
diffAfterRewrites Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
T.empty)
    IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ())
-> (Text -> IO ()) -> Text -> ExceptT Text IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
log (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Diff after rewrites:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
diffAfterRewrites
    Text
updatedDerivationContents <- IO Text -> ExceptT Text IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Text IO Text)
-> IO Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ FilePath -> IO Text
T.readFile FilePath
derivationFile
    Text
newSrcUrl <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getSrcUrl Text
attrPath
    Text
newHash <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getHash Text
attrPath
    Maybe Text
newVerMay <- Either Text Text -> Maybe Text
forall e a. Either e a -> Maybe a
rightMay (Either Text Text -> Maybe Text)
-> ExceptT Text IO (Either Text Text)
-> ExceptT Text IO (Maybe Text)
forall (m :: * -> *) a b l.
Monad m =>
(a -> b) -> ExceptT l m a -> ExceptT l m b
`fmapRT` (IO (Either Text Text) -> ExceptT Text IO (Either Text Text)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO (Either Text Text) -> ExceptT Text IO (Either Text Text))
-> IO (Either Text Text) -> ExceptT Text IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ ExceptT Text IO Text -> IO (Either Text Text)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Text -> IO (Either Text Text))
-> ExceptT Text IO Text -> IO (Either Text Text)
forall a b. (a -> b) -> a -> b
$ Raw -> Text -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
Raw -> Text -> Text -> ExceptT Text m Text
Nix.getAttr Raw
Nix.Raw Text
"version" Text
attrPath)

    Text -> Bool -> ExceptT Text IO ()
forall (m :: * -> *) e. Monad m => e -> Bool -> ExceptT e m ()
tryAssert
      Text
"The derivation has no 'version' attribute, so do not know how to figure out the version while doing an updateScript update"
      (Bool -> Bool
not Bool
hasUpdateScript Bool -> Bool -> Bool
|| Maybe Text -> Bool
forall a. Maybe a -> Bool
isJust Maybe Text
newVerMay)

    -- Sanity checks to make sure the PR is worth opening
    Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
hasUpdateScript do
      Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
derivationContents Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
updatedDerivationContents) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Text
"No rewrites performed on derivation."
      Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
oldSrcUrl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
newSrcUrl) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Text
"Source url did not change. "
      Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
oldHash Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
newHash) (ExceptT Text IO () -> ExceptT Text IO ())
-> ExceptT Text IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Text
"Hashes equal; no update necessary"
    Set ResultLine
editedOutpathSet <- if Bool
calcOutpaths then ExceptT Text IO (Set ResultLine)
forall (m :: * -> *). MonadIO m => ExceptT Text m (Set ResultLine)
currentOutpathSet else Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall (m :: * -> *) a. Monad m => a -> m a
return (Set ResultLine -> ExceptT Text IO (Set ResultLine))
-> Set ResultLine -> ExceptT Text IO (Set ResultLine)
forall a b. (a -> b) -> a -> b
$ Text -> Set ResultLine
dummyOutpathSetAfter Text
attrPath
    let opDiff :: Set ResultLine
opDiff = Set ResultLine -> Set ResultLine -> Set ResultLine
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set ResultLine
mergeBaseOutpathSet Set ResultLine
editedOutpathSet
    let numPRebuilds :: Int
numPRebuilds = Set ResultLine -> Int
numPackageRebuilds Set ResultLine
opDiff
    UpdateEnv -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => UpdateEnv -> f () -> f ()
whenBatch UpdateEnv
updateEnv do
      Int -> Text -> ExceptT Text IO ()
forall (m :: * -> *). Monad m => Int -> Text -> ExceptT Text m ()
Skiplist.python Int
numPRebuilds Text
derivationContents
    Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
numPRebuilds Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0) (Text -> ExceptT Text IO ()
forall (m :: * -> *) e a. Monad m => e -> ExceptT e m a
throwE Text
"Update edits cause no rebuilds.")
    Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Nix.build Text
attrPath
    --
    -- Update updateEnv if using updateScript
    UpdateEnv
updateEnv' <-
      if Bool
hasUpdateScript
        then do
          -- Already checked that these are Just above.
          let Just Text
oldVer = Maybe Text
oldVerMay
          let Just Text
newVer = Maybe Text
newVerMay
          UpdateEnv -> ExceptT Text IO UpdateEnv
forall (m :: * -> *) a. Monad m => a -> m a
return (UpdateEnv -> ExceptT Text IO UpdateEnv)
-> UpdateEnv -> ExceptT Text IO UpdateEnv
forall a b. (a -> b) -> a -> b
$
            Text -> Text -> Text -> Maybe Text -> Options -> UpdateEnv
UpdateEnv
              Text
packageName
              Text
oldVer
              Text
newVer
              (Text -> Maybe Text
forall a. a -> Maybe a
Just Text
"passthru.updateScript")
              Options
options
        else UpdateEnv -> ExceptT Text IO UpdateEnv
forall (m :: * -> *) a. Monad m => a -> m a
return UpdateEnv
updateEnv

    --
    -- Publish the result
    IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO () -> ExceptT Text IO ())
-> (Text -> IO ()) -> Text -> ExceptT Text IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> IO ()
log (Text -> ExceptT Text IO ()) -> Text -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Successfully finished processing"
    Text
result <- ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => ExceptT Text m Text
Nix.resultLink
    (Text -> IO ())
-> UpdateEnv
-> Text
-> Text
-> Text
-> Text
-> Maybe (Set ResultLine)
-> [Text]
-> ExceptT Text IO ()
publishPackage Text -> IO ()
log UpdateEnv
updateEnv' Text
oldSrcUrl Text
newSrcUrl Text
attrPath Text
result (Set ResultLine -> Maybe (Set ResultLine)
forall a. a -> Maybe a
Just Set ResultLine
opDiff) [Text]
rewriteMsgs
    UpdateEnv -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => UpdateEnv -> f () -> f ()
whenBatch UpdateEnv
updateEnv do
      Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Git.cleanAndResetTo Text
"master"

publishPackage ::
  (Text -> IO ()) ->
  UpdateEnv ->
  Text ->
  Text ->
  Text ->
  Text ->
  Maybe (Set ResultLine) ->
  [Text] ->
  ExceptT Text IO ()
publishPackage :: (Text -> IO ())
-> UpdateEnv
-> Text
-> Text
-> Text
-> Text
-> Maybe (Set ResultLine)
-> [Text]
-> ExceptT Text IO ()
publishPackage Text -> IO ()
log UpdateEnv
updateEnv Text
oldSrcUrl Text
newSrcUrl Text
attrPath Text
result Maybe (Set ResultLine)
opDiff [Text]
rewriteMsgs = do
  let prBase :: Text
prBase =
        if (Maybe (Set ResultLine) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Set ResultLine)
opDiff Bool -> Bool -> Bool
|| Set ResultLine -> Int
numPackageRebuilds (Maybe (Set ResultLine) -> Set ResultLine
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Set ResultLine)
opDiff) Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
100)
          then Text
"master"
          else Text
"staging"
  Text
cachixTestInstructions <- (Text -> IO ()) -> UpdateEnv -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
(Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text
doCachix Text -> IO ()
log UpdateEnv
updateEnv Text
result
  Text
resultCheckReport <-
    case Text -> Either Text ()
forall (m :: * -> *). TextSkiplister m
Skiplist.checkResult (UpdateEnv -> Text
packageName UpdateEnv
updateEnv) of
      Right () -> IO Text -> ExceptT Text IO Text
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO Text -> ExceptT Text IO Text)
-> IO Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ UpdateEnv -> FilePath -> IO Text
forall (m :: * -> *). MonadIO m => UpdateEnv -> FilePath -> m Text
Check.result UpdateEnv
updateEnv (Text -> FilePath
T.unpack Text
result)
      Left Text
msg -> Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Applicative f => a -> f a
pure Text
msg
  Text
metaDescription <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getDescription Text
attrPath ExceptT Text IO Text
-> ExceptT Text IO Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> ExceptT Text IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
T.empty
  Text
metaHomepage <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getHomepageET Text
attrPath ExceptT Text IO Text
-> ExceptT Text IO Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> ExceptT Text IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
T.empty
  Text
metaChangelog <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getChangelog Text
attrPath ExceptT Text IO Text
-> ExceptT Text IO Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> ExceptT Text IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
T.empty
  Text
cveRep <- IO Text -> ExceptT Text IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Text IO Text)
-> IO Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ UpdateEnv -> IO Text
cveReport UpdateEnv
updateEnv
  Text
releaseUrl <- UpdateEnv -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> Text -> ExceptT Text m Text
GH.releaseUrl UpdateEnv
updateEnv Text
newSrcUrl ExceptT Text IO Text
-> ExceptT Text IO Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> ExceptT Text IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
  Text
compareUrl <- Text -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> ExceptT Text m Text
GH.compareUrl Text
oldSrcUrl Text
newSrcUrl ExceptT Text IO Text
-> ExceptT Text IO Text -> ExceptT Text IO Text
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Text -> ExceptT Text IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
  Text
maintainers <- Text -> ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Text
Nix.getMaintainers Text
attrPath
  let commitMsg :: Text
commitMsg = UpdateEnv -> Text -> Text
commitMessage UpdateEnv
updateEnv Text
attrPath
  Text -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m ()
Git.commit Text
commitMsg
  Text
commitHash <- ExceptT Text IO Text
forall (m :: * -> *). MonadIO m => ExceptT Text m Text
Git.headHash
  Text
nixpkgsReviewMsg <-
    if Text
prBase Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
"staging" Bool -> Bool -> Bool
&& (Options -> Bool
runNixpkgsReview (Options -> Bool) -> (UpdateEnv -> Options) -> UpdateEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Bool) -> UpdateEnv -> Bool
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv)
      then IO Text -> ExceptT Text IO Text
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Text -> ExceptT Text IO Text)
-> IO Text -> ExceptT Text IO Text
forall a b. (a -> b) -> a -> b
$ (Text -> IO ()) -> Text -> IO Text
NixpkgsReview.runReport Text -> IO ()
log Text
commitHash
      else Text -> ExceptT Text IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
  -- Try to push it three times
  Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Options -> Bool
doPR (Options -> Bool) -> (UpdateEnv -> Options) -> UpdateEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Bool) -> UpdateEnv -> Bool
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv)
    (UpdateEnv -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => UpdateEnv -> ExceptT Text m ()
Git.push UpdateEnv
updateEnv ExceptT Text IO () -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UpdateEnv -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => UpdateEnv -> ExceptT Text m ()
Git.push UpdateEnv
updateEnv ExceptT Text IO () -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> UpdateEnv -> ExceptT Text IO ()
forall (m :: * -> *). MonadIO m => UpdateEnv -> ExceptT Text m ()
Git.push UpdateEnv
updateEnv)
  Bool
isBroken <- Text -> ExceptT Text IO Bool
forall (m :: * -> *). MonadIO m => Text -> ExceptT Text m Bool
Nix.getIsBroken Text
attrPath
  Bool -> ExceptT Text IO () -> ExceptT Text IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
    (Options -> Bool
batchUpdate (Options -> Bool) -> (UpdateEnv -> Options) -> UpdateEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Bool) -> UpdateEnv -> Bool
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv)
    (IO () -> ExceptT Text IO ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift IO ()
forall (m :: * -> *). MonadIO m => m ()
untilOfBorgFree)
  let prMsg :: Text
prMsg =
        UpdateEnv
-> Bool
-> Text
-> Text
-> Text
-> [Text]
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
prMessage
          UpdateEnv
updateEnv
          Bool
isBroken
          Text
metaDescription
          Text
metaHomepage
          Text
metaChangelog
          [Text]
rewriteMsgs
          Text
releaseUrl
          Text
compareUrl
          Text
resultCheckReport
          Text
commitHash
          Text
attrPath
          Text
maintainers
          Text
result
          (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" (Set ResultLine -> Text
outpathReport (Set ResultLine -> Text) -> Maybe (Set ResultLine) -> Maybe Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Set ResultLine)
opDiff))
          Text
cveRep
          Text
cachixTestInstructions
          Text
nixpkgsReviewMsg
  IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
log Text
prMsg
  if (Options -> Bool
doPR (Options -> Bool) -> (UpdateEnv -> Options) -> UpdateEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Bool) -> UpdateEnv -> Bool
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv)
    then do
      let ghUser :: Text
ghUser = Name Owner -> Text
forall entity. Name entity -> Text
GH.untagName (Name Owner -> Text)
-> (UpdateEnv -> Name Owner) -> UpdateEnv -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name Owner
githubUser (Options -> Name Owner)
-> (UpdateEnv -> Options) -> UpdateEnv -> Name Owner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Text) -> UpdateEnv -> Text
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv
      Text
pullRequestUrl <- UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text IO Text
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> Text -> Text -> Text -> Text -> ExceptT Text m Text
GH.pr UpdateEnv
updateEnv (UpdateEnv -> Text -> Text
prTitle UpdateEnv
updateEnv Text
attrPath) Text
prMsg (Text
ghUser Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (UpdateEnv -> Text
branchName UpdateEnv
updateEnv)) Text
prBase
      IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
log Text
pullRequestUrl
    else IO () -> ExceptT Text IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> ExceptT Text IO ()) -> IO () -> ExceptT Text IO ()
forall a b. (a -> b) -> a -> b
$ Text -> IO ()
T.putStrLn Text
prMsg

commitMessage :: UpdateEnv -> Text -> Text
commitMessage :: UpdateEnv -> Text -> Text
commitMessage UpdateEnv
updateEnv Text
attrPath = UpdateEnv -> Text -> Text
prTitle UpdateEnv
updateEnv Text
attrPath

brokenWarning :: Bool -> Text
brokenWarning :: Bool -> Text
brokenWarning Bool
False = Text
""
brokenWarning Bool
True =
  Text
"- WARNING: Package has meta.broken=true; Please manually test this package update and remove the broken attribute."

prMessage ::
  UpdateEnv ->
  Bool ->
  Text ->
  Text ->
  Text ->
  [Text] ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text ->
  Text
prMessage :: UpdateEnv
-> Bool
-> Text
-> Text
-> Text
-> [Text]
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
-> Text
prMessage UpdateEnv
updateEnv Bool
isBroken Text
metaDescription Text
metaHomepage Text
metaChangelog [Text]
rewriteMsgs Text
releaseUrl Text
compareUrl Text
resultCheckReport Text
commitHash Text
attrPath Text
maintainers Text
resultPath Text
opReport Text
cveRep Text
cachixTestInstructions Text
nixpkgsReviewMsg =
  -- Some components of the PR description are pre-generated prior to calling
  -- because they require IO, but in general try to put as much as possible for
  -- the formatting into the pure function so that we can control the body
  -- formatting in one place and unit test it.
  let brokenMsg :: Text
brokenMsg = Bool -> Text
brokenWarning Bool
isBroken
      metaHomepageLine :: Text
metaHomepageLine =
        if Text
metaHomepage Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
          then Text
""
          else Text
"meta.homepage for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metaHomepage
      metaDescriptionLine :: Text
metaDescriptionLine =
        if Text
metaDescription Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
          then Text
""
          else Text
"meta.description for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metaDescription
      metaChangelogLine :: Text
metaChangelogLine =
        if Text
metaDescription Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
          then Text
""
          else Text
"meta.changelog for " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" is: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
metaChangelog
      rewriteMsgsLine :: Text
rewriteMsgsLine = (Text -> Text -> Text) -> Text -> [Text] -> Text
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\Text
ms Text
m -> Text
ms Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> FilePath -> Text
T.pack FilePath
"\n- " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
m) Text
"\n###### Updates performed" [Text]
rewriteMsgs
      maintainersCc :: Text
maintainersCc =
        if Bool -> Bool
not (Text -> Bool
T.null Text
maintainers)
          then Text
"cc " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
maintainers Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" for [testing](https://github.com/ryantm/nixpkgs-update/blob/master/doc/nixpkgs-maintainer-faq.md#r-ryantm-opened-a-pr-for-my-package-what-do-i-do)."
          else Text
""
      releaseUrlMessage :: Text
releaseUrlMessage =
        if Text
releaseUrl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
          then Text
""
          else Text
"- [Release on GitHub](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
releaseUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      compareUrlMessage :: Text
compareUrlMessage =
        if Text
compareUrl Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
          then Text
""
          else Text
"- [Compare changes on GitHub](" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
compareUrl Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
")"
      nixpkgsReviewSection :: Text
nixpkgsReviewSection =
        if Text
nixpkgsReviewMsg Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
          then Text
"NixPkgs review skipped"
          else
            [interpolate|
            We have automatically built all packages that will get rebuilt due to
            this change.

            This gives evidence on whether the upgrade will break dependent packages.
            Note sometimes packages show up as _failed to build_ independent of the
            change, simply because they are already broken on the target branch.

            $nixpkgsReviewMsg
            |]
      pat :: Text -> Text
pat Text
link = [interpolate|This update was made based on information from $link.|]
      sourceLinkInfo :: Text
sourceLinkInfo = Text -> (Text -> Text) -> Maybe Text -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" Text -> Text
pat (Maybe Text -> Text) -> Maybe Text -> Text
forall a b. (a -> b) -> a -> b
$ UpdateEnv -> Maybe Text
sourceURL UpdateEnv
updateEnv
      ghUser :: Text
ghUser = Name Owner -> Text
forall entity. Name entity -> Text
GH.untagName (Name Owner -> Text)
-> (UpdateEnv -> Name Owner) -> UpdateEnv -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Options -> Name Owner
githubUser (Options -> Name Owner)
-> (UpdateEnv -> Options) -> UpdateEnv -> Name Owner
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Text) -> UpdateEnv -> Text
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv
      batch :: Bool
batch = Options -> Bool
batchUpdate (Options -> Bool) -> (UpdateEnv -> Options) -> UpdateEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Bool) -> UpdateEnv -> Bool
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv
      automatic :: Text
automatic = if Bool
batch then Text
"Automatic" else Text
"Semi-automatic"
   in [interpolate|
       $automatic update generated by [nixpkgs-update](https://github.com/ryantm/nixpkgs-update) tools. $sourceLinkInfo
       $brokenMsg

       $metaDescriptionLine

       $metaHomepageLine

       $metaChangelogLine

       $rewriteMsgsLine

       ###### To inspect upstream changes

       $releaseUrlMessage

       $compareUrlMessage

       ###### Impact

       <details>
       <summary>
       <b>Checks done</b> (click to expand)
       </summary>

       ---

       - built on NixOS
       $resultCheckReport

       ---

       </details>
       <details>
       <summary>
       <b>Rebuild report</b> (if merged into master) (click to expand)
       </summary>

       ```
       $opReport
       ```

       </details>

       <details>
       <summary>
       <b>Instructions to test this update</b> (click to expand)
       </summary>

       ---

       $cachixTestInstructions
       ```
       nix-build -A $attrPath https://github.com/$ghUser/nixpkgs/archive/$commitHash.tar.gz
       ```

       After you've downloaded or built it, look at the files and if there are any, run the binaries:
       ```
       ls -la $resultPath
       ls -la $resultPath/bin
       ```

       ---

       </details>
       <br/>

       $cveRep

       ### Pre-merge build results

       $nixpkgsReviewSection

       ---

       ###### Maintainer pings

       $maintainersCc
    |]

jqBin :: String
jqBin :: FilePath
jqBin = Maybe FilePath -> FilePath
forall a. HasCallStack => Maybe a -> a
fromJust ($$(envQ "JQ") :: Maybe String) FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
"/bin/jq"

untilOfBorgFree :: MonadIO m => m ()
untilOfBorgFree :: m ()
untilOfBorgFree = do
  ByteString
stats <-
    FilePath -> ProcessConfig () () ()
shell FilePath
"curl -s https://events.nix.ci/stats.php" ProcessConfig () () ()
-> (ProcessConfig () () () -> m ByteString) -> m ByteString
forall a b. a -> (a -> b) -> b
& ProcessConfig () () () -> m ByteString
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored -> m ByteString
readProcessInterleaved_
  Int
waiting <-
    FilePath -> ProcessConfig () () ()
shell (FilePath
jqBin FilePath -> FilePath -> FilePath
forall a. Semigroup a => a -> a -> a
<> FilePath
" .evaluator.messages.waiting") ProcessConfig () () ()
-> (ProcessConfig () () () -> ProcessConfig () () ())
-> ProcessConfig () () ()
forall a b. a -> (a -> b) -> b
& StreamSpec 'STInput ()
-> ProcessConfig () () () -> ProcessConfig () () ()
forall stdin stdin0 stdout stderr.
StreamSpec 'STInput stdin
-> ProcessConfig stdin0 stdout stderr
-> ProcessConfig stdin stdout stderr
setStdin (ByteString -> StreamSpec 'STInput ()
byteStringInput ByteString
stats)
      ProcessConfig () () ()
-> (ProcessConfig () () () -> m ByteString) -> m ByteString
forall a b. a -> (a -> b) -> b
& ProcessConfig () () () -> m ByteString
forall (m :: * -> *) stdin stdoutIgnored stderrIgnored.
MonadIO m =>
ProcessConfig stdin stdoutIgnored stderrIgnored -> m ByteString
readProcessInterleaved_
      m ByteString -> (m ByteString -> m Int) -> m Int
forall a b. a -> (a -> b) -> b
& (ByteString -> Int) -> m ByteString -> m Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ByteString -> Maybe (Int, ByteString)
BSL.readInt (ByteString -> Maybe (Int, ByteString))
-> (Maybe (Int, ByteString) -> Int) -> ByteString -> Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> ((Int, ByteString) -> Int) -> Maybe (Int, ByteString) -> Maybe Int
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, ByteString) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, ByteString) -> Maybe Int)
-> (Maybe Int -> Int) -> Maybe (Int, ByteString) -> Int
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
0)
  Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
waiting Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
2) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
    IO () -> m ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> m ()) -> IO () -> m ()
forall a b. (a -> b) -> a -> b
$ Int -> IO ()
threadDelay Int
60000000
    m ()
forall (m :: * -> *). MonadIO m => m ()
untilOfBorgFree

assertNotUpdatedOn ::
  MonadIO m => UpdateEnv -> FilePath -> Text -> ExceptT Text m ()
assertNotUpdatedOn :: UpdateEnv -> FilePath -> Text -> ExceptT Text m ()
assertNotUpdatedOn UpdateEnv
updateEnv FilePath
derivationFile Text
branch = do
  FilePath
npDir <- IO FilePath -> ExceptT Text m FilePath
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO FilePath -> ExceptT Text m FilePath)
-> IO FilePath -> ExceptT Text m FilePath
forall a b. (a -> b) -> a -> b
$ IO FilePath
Git.nixpkgsDir
  let Just Text
file = Text -> Text -> Maybe Text
T.stripPrefix (FilePath -> Text
T.pack FilePath
npDir Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/") (FilePath -> Text
T.pack FilePath
derivationFile)
  Text
derivationContents <- Text -> Text -> ExceptT Text m Text
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> ExceptT Text m Text
Git.show Text
branch Text
file
  UpdateEnv -> Text -> Text -> ExceptT Text m ()
forall (m :: * -> *).
MonadIO m =>
UpdateEnv -> Text -> Text -> ExceptT Text m ()
Nix.assertOldVersionOn UpdateEnv
updateEnv Text
branch Text
derivationContents

addPatched :: Text -> Set CVE -> IO [(CVE, Bool)]
addPatched :: Text -> Set CVE -> IO [(CVE, Bool)]
addPatched Text
attrPath Set CVE
set = do
  let list :: [CVE]
list = Set CVE -> [CVE]
forall a. Set a -> [a]
S.toList Set CVE
set
  [CVE] -> (CVE -> IO (CVE, Bool)) -> IO [(CVE, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM
    [CVE]
list
    ( \CVE
cve -> do
        Either Text Bool
patched <- ExceptT Text IO Bool -> IO (Either Text Bool)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT Text IO Bool -> IO (Either Text Bool))
-> ExceptT Text IO Bool -> IO (Either Text Bool)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> ExceptT Text IO Bool
forall (m :: * -> *).
MonadIO m =>
Text -> Text -> ExceptT Text m Bool
Nix.hasPatchNamed Text
attrPath (CVE -> Text
cveID CVE
cve)
        let p :: Bool
p =
              case Either Text Bool
patched of
                Left Text
_ -> Bool
False
                Right Bool
r -> Bool
r
        (CVE, Bool) -> IO (CVE, Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (CVE
cve, Bool
p)
    )

cveReport :: UpdateEnv -> IO Text
cveReport :: UpdateEnv -> IO Text
cveReport UpdateEnv
updateEnv =
  if Bool -> Bool
not (Options -> Bool
makeCVEReport (Options -> Bool) -> (UpdateEnv -> Options) -> UpdateEnv -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UpdateEnv -> Options
options (UpdateEnv -> Bool) -> UpdateEnv -> Bool
forall a b. (a -> b) -> a -> b
$ UpdateEnv
updateEnv)
    then Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
    else (Connection -> IO Text) -> IO Text
forall a. (Connection -> IO a) -> IO a
withVulnDB ((Connection -> IO Text) -> IO Text)
-> (Connection -> IO Text) -> IO Text
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
      let pname1 :: Text
pname1 = UpdateEnv -> Text
packageName UpdateEnv
updateEnv
      let pname2 :: Text
pname2 = Text -> Text -> Text -> Text
T.replace Text
"-" Text
"_" Text
pname1
      [CVE]
oldCVEs1 <- Connection -> Text -> Text -> IO [CVE]
getCVEs Connection
conn Text
pname1 (UpdateEnv -> Text
oldVersion UpdateEnv
updateEnv)
      [CVE]
oldCVEs2 <- Connection -> Text -> Text -> IO [CVE]
getCVEs Connection
conn Text
pname2 (UpdateEnv -> Text
oldVersion UpdateEnv
updateEnv)
      let oldCVEs :: Set CVE
oldCVEs = [CVE] -> Set CVE
forall a. Ord a => [a] -> Set a
S.fromList ([CVE]
oldCVEs1 [CVE] -> [CVE] -> [CVE]
forall a. [a] -> [a] -> [a]
++ [CVE]
oldCVEs2)
      [CVE]
newCVEs1 <- Connection -> Text -> Text -> IO [CVE]
getCVEs Connection
conn Text
pname1 (UpdateEnv -> Text
newVersion UpdateEnv
updateEnv)
      [CVE]
newCVEs2 <- Connection -> Text -> Text -> IO [CVE]
getCVEs Connection
conn Text
pname2 (UpdateEnv -> Text
newVersion UpdateEnv
updateEnv)
      let newCVEs :: Set CVE
newCVEs = [CVE] -> Set CVE
forall a. Ord a => [a] -> Set a
S.fromList ([CVE]
newCVEs1 [CVE] -> [CVE] -> [CVE]
forall a. [a] -> [a] -> [a]
++ [CVE]
newCVEs2)
      let inOldButNotNew :: Set CVE
inOldButNotNew = Set CVE -> Set CVE -> Set CVE
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set CVE
oldCVEs Set CVE
newCVEs
          inNewButNotOld :: Set CVE
inNewButNotOld = Set CVE -> Set CVE -> Set CVE
forall a. Ord a => Set a -> Set a -> Set a
S.difference Set CVE
newCVEs Set CVE
oldCVEs
          inBoth :: Set CVE
inBoth = Set CVE -> Set CVE -> Set CVE
forall a. Ord a => Set a -> Set a -> Set a
S.intersection Set CVE
oldCVEs Set CVE
newCVEs
          ifEmptyNone :: Text -> Text
ifEmptyNone Text
t =
            if Text
t Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
T.empty
              then Text
"none"
              else Text
t
      [(CVE, Bool)]
inOldButNotNew' <- Text -> Set CVE -> IO [(CVE, Bool)]
addPatched (UpdateEnv -> Text
packageName UpdateEnv
updateEnv) Set CVE
inOldButNotNew
      [(CVE, Bool)]
inNewButNotOld' <- Text -> Set CVE -> IO [(CVE, Bool)]
addPatched (UpdateEnv -> Text
packageName UpdateEnv
updateEnv) Set CVE
inNewButNotOld
      [(CVE, Bool)]
inBoth' <- Text -> Set CVE -> IO [(CVE, Bool)]
addPatched (UpdateEnv -> Text
packageName UpdateEnv
updateEnv) Set CVE
inBoth
      let toMkdownList :: [(CVE, Bool)] -> Text
toMkdownList = ((CVE, Bool) -> Text) -> [(CVE, Bool)] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CVE -> Bool -> Text) -> (CVE, Bool) -> Text
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry CVE -> Bool -> Text
cveLI) ([(CVE, Bool)] -> [Text])
-> ([Text] -> Text) -> [(CVE, Bool)] -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> [Text] -> Text
T.unlines ([Text] -> Text) -> (Text -> Text) -> [Text] -> Text
forall k (cat :: k -> k -> *) (a :: k) (b :: k) (c :: k).
Category cat =>
cat a b -> cat b c -> cat a c
>>> Text -> Text
ifEmptyNone
          fixedList :: Text
fixedList = [(CVE, Bool)] -> Text
toMkdownList [(CVE, Bool)]
inOldButNotNew'
          newList :: Text
newList = [(CVE, Bool)] -> Text
toMkdownList [(CVE, Bool)]
inNewButNotOld'
          unresolvedList :: Text
unresolvedList = [(CVE, Bool)] -> Text
toMkdownList [(CVE, Bool)]
inBoth'
      if Text
fixedList Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none" Bool -> Bool -> Bool
&& Text
unresolvedList Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none" Bool -> Bool -> Bool
&& Text
newList Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"none"
        then Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
""
        else
          Text -> IO Text
forall (m :: * -> *) a. Monad m => a -> m a
return
            [interpolate|
      ###### Security vulnerability report

      <details>
      <summary>
      Security report (click to expand)
      </summary>

      CVEs resolved by this update:
      $fixedList

      CVEs introduced by this update:
      $newList

      CVEs present in both versions:
      $unresolvedList


       </details>
       <br/>
      |]

doCachix :: MonadIO m => (Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text
doCachix :: (Text -> m ()) -> UpdateEnv -> Text -> ExceptT Text m Text
doCachix Text -> m ()
log UpdateEnv
updateEnv Text
resultPath =
  let o :: Options
o = UpdateEnv -> Options
options UpdateEnv
updateEnv
  in
    if Options -> Bool
batchUpdate Options
o Bool -> Bool -> Bool
&& Text
"r-ryantm" Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== (Name Owner -> Text
forall entity. Name entity -> Text
GH.untagName (Name Owner -> Text) -> Name Owner -> Text
forall a b. (a -> b) -> a -> b
$ Options -> Name Owner
githubUser Options
o)
    then do
      Text -> ExceptT Text m Text
forall (m :: * -> *) a. Monad m => a -> m a
return
        [interpolate|
       Either **download from Cachix**:
       ```
       nix-store -r $resultPath \
         --option binary-caches 'https://cache.nixos.org/ https://nix-community.cachix.org/' \
         --option trusted-public-keys '
         nix-community.cachix.org-1:mB9FSh9qf2dCimDSUo8Zy7bkq5CX+/rkCWyvRCYg3Fs=
         cache.nixos.org-1:6NCHdD59X431o0gWypbMrAURkbJ16ZPMQFGspcDShjY=
         '
       ```
       (The Cachix cache is only trusted for this store-path realization.)
       For the Cachix download to work, your user must be in the `trusted-users` list or you can use `sudo` since root is effectively trusted.

       Or, **build yourself**:
       |]
    else do
      m () -> ExceptT Text m ()
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m () -> ExceptT Text m ()) -> m () -> ExceptT Text m ()
forall a b. (a -> b) -> a -> b
$ Text -> m ()
log Text
"skipping cachix"
      Text -> ExceptT Text m Text
forall (m :: * -> *) a. Monad m => a -> m a
return Text
"Build yourself:"

updatePackage ::
  Options ->
  Text ->
  IO (Either Text ())
updatePackage :: Options -> Text -> IO (Either Text ())
updatePackage Options
o Text
updateInfo = do
  let (Text
p, Text
oldV, Text
newV, Maybe Text
url) = [(Text, Text, Text, Maybe Text)] -> (Text, Text, Text, Maybe Text)
forall a. [a] -> a
head ([Either Text (Text, Text, Text, Maybe Text)]
-> [(Text, Text, Text, Maybe Text)]
forall a b. [Either a b] -> [b]
rights (Text -> [Either Text (Text, Text, Text, Maybe Text)]
parseUpdates Text
updateInfo))
  let updateEnv :: UpdateEnv
updateEnv = Text -> Text -> Text -> Maybe Text -> Options -> UpdateEnv
UpdateEnv Text
p Text
oldV Text
newV Maybe Text
url Options
o
  let log :: Text -> IO ()
log = Text -> IO ()
T.putStrLn
  IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ (Text -> IO ()) -> Options -> IO ()
notifyOptions Text -> IO ()
log Options
o
  UTCTime
twoHoursAgo <- Sem '[Embed IO] UTCTime -> IO UTCTime
forall (m :: * -> *) a. Monad m => Sem '[Embed m] a -> m a
runM (Sem '[Embed IO] UTCTime -> IO UTCTime)
-> Sem '[Embed IO] UTCTime -> IO UTCTime
forall a b. (a -> b) -> a -> b
$ Sem '[Time, Embed IO] UTCTime -> Sem '[Embed IO] UTCTime
forall (r :: [(* -> *) -> * -> *]) a.
Member (Embed IO) r =>
Sem (Time : r) a -> Sem r a
Time.runIO Sem '[Time, Embed IO] UTCTime
forall (r :: [(* -> *) -> * -> *]). Member Time r => Sem r UTCTime
Time.twoHoursAgo
  IORef MergeBaseOutpathsInfo
mergeBaseOutpathSet <-
    IO (IORef MergeBaseOutpathsInfo)
-> IO (IORef MergeBaseOutpathsInfo)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (IORef MergeBaseOutpathsInfo)
 -> IO (IORef MergeBaseOutpathsInfo))
-> IO (IORef MergeBaseOutpathsInfo)
-> IO (IORef MergeBaseOutpathsInfo)
forall a b. (a -> b) -> a -> b
$ MergeBaseOutpathsInfo -> IO (IORef MergeBaseOutpathsInfo)
forall a. a -> IO (IORef a)
newIORef (UTCTime -> Set ResultLine -> MergeBaseOutpathsInfo
MergeBaseOutpathsInfo UTCTime
twoHoursAgo Set ResultLine
forall a. Set a
S.empty)
  (Text -> IO ())
-> UpdateEnv -> IORef MergeBaseOutpathsInfo -> IO (Either Text ())
updatePackageBatch Text -> IO ()
log UpdateEnv
updateEnv IORef MergeBaseOutpathsInfo
mergeBaseOutpathSet