Skip to content

Add Rollback protection #405

New issue

Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.

Sign up for GitHub

By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.

Already on GitHub? Sign in to your account

Open
flandweber wants to merge 2 commits into
base: master
Choose a base branch
from
Open

Add Rollback protection #405

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
2 commits
Select commit Hold shift + click to select a range
6cf78a4
implemented maybeLoad and loadDefault in Niv.Update
flandweber Jun 18, 2024
b004911
implemented rollback-protection in git fetcher
flandweber Jun 18, 2024
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
1 change: 1 addition & 0 deletions package.yaml
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -36,6 +36,7 @@
"profunctors",
"pureMD5",
"string-qq",
"temporary",
"text",
"unliftio",
"unordered-containers"
Expand Down
60 changes: 46 additions & 14 deletions src/Niv/Git/Cmd.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -8,6 +8,7 @@ module Niv.Git.Cmd where

import Control.Applicative
import Control.Arrow
import Control.Monad (void)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
Expand All @@ -24,6 +25,7 @@ import Niv.Update
import qualified Options.Applicative as Opts
import qualified Options.Applicative.Help.Pretty as Opts
import System.Exit (ExitCode (ExitSuccess))
import System.IO.Temp (withSystemTempDirectory)
import System.Process (readProcessWithExitCode)

gitCmd :: Cmd
Expand Down Expand Up @@ -77,7 +79,7 @@ parseGitShortcut txt'@(T.dropWhileEnd (== '/') -> txt) =
parseGitPackageSpec :: Opts.Parser PackageSpec
parseGitPackageSpec =
PackageSpec . KM.fromList
<$> many (parseRepo <|> parseBranch <|> parseRev <|> parseAttr <|> parseSAttr)
<$> many (parseRepo <|> parseBranch <|> parseRev <|> parseRollback <|> parseAttr <|> parseSAttr)
where
parseRepo =
("repo",) . Aeson.String
Expand All @@ -98,6 +100,13 @@ parseGitPackageSpec =
<> Opts.short 'b'
<> Opts.metavar "BRANCH"
)
parseRollback =
("rollback-protection",) . Aeson.Bool
<$> Opts.flag'
True
Comment thread
flandweber marked this conversation as resolved.
( Opts.long "rollback-protection"
<> Opts.help "Prevent updates to all revisions that are not ancestors of the current revision. May increase update times."
)
parseAttr =
Opts.option
(Opts.maybeReader parseKeyValJSON)
Expand Down Expand Up @@ -150,20 +159,28 @@ gitUpdate ::
(T.Text -> IO (T.Text, T.Text)) ->
Update () ()
gitUpdate latestRev' defaultBranchAndRev' = proc () -> do
useOrSet "type" -< ("git" :: Box T.Text)
useOrSet "type" -< pure "git" :: Box T.Text
rp <- loadDefault "rollback-protection" -< pure False
oldRev <- maybeLoad "rev" -< ()
repository <- load "repo" -< ()
discoverRev <+> discoverRefAndRev -< repository
newRev <- discoverRev <+> discoverRefAndRev -< repository
newRev' <- run ifEnsureAncestor -< (,,,) <$> rp <*> repository <*> oldRev <*> newRev
update "rev" -< newRev'
returnA -< ()
where
discoverRefAndRev = proc repository -> do
branchAndRev <- run defaultBranchAndRev' -< repository
update "branch" -< fst <$> branchAndRev
update "rev" -< snd <$> branchAndRev
returnA -< ()
returnA -< snd <$> branchAndRev
discoverRev = proc repository -> do
branch <- load "branch" -< ()
rev <- run' (uncurry latestRev') -< (,) <$> repository <*> branch
update "rev" -< rev
returnA -< ()
run' (uncurry latestRev') -< (,) <$> repository <*> branch
ifEnsureAncestor (rp, repository, oldRev, newRev) =
if rp
then case oldRev of
Nothing -> return newRev -- no old revision to test against (first update)
Just oldRev' -> ensureAncestor repository oldRev' newRev
else return newRev -- rollback protection disabled

-- | The "real" (IO) update
gitUpdate' :: Update () ()
Expand All @@ -177,7 +194,7 @@ latestRev ::
IO T.Text
latestRev repo branch = do
let gitArgs = ["ls-remote", repo, "refs/heads/" <> branch]
sout <- runGit gitArgs
sout <- runGit abortGitBug gitArgs
case sout of
ls@(_ : _ : _) -> abortTooMuchOutput gitArgs ls
[l1] -> parseRev gitArgs l1
Expand All @@ -200,7 +217,7 @@ defaultBranchAndRev ::
T.Text ->
IO (T.Text, T.Text)
defaultBranchAndRev repo = do
sout <- runGit args
sout <- runGit abortGitBug args
case sout of
(l1 : l2 : _) -> (,) <$> parseBranch l1 <*> parseRev l2
_ ->
Expand All @@ -226,14 +243,29 @@ abortNoRev args l = abortGitBug args $ "Could not read revision from: " <> l
abortNoRef :: [T.Text] -> T.Text -> IO a
abortNoRef args l = abortGitBug args $ "Could not read reference from: " <> l

-- | Run the "git" executable
runGit :: [T.Text] -> IO [T.Text]
runGit args = do
-- TODO: only clone shallow repository and fetch needed commits to speed up verification
ensureAncestor :: T.Text -> T.Text -> T.Text -> IO T.Text

@nmattia nmattia Jun 24, 2024

Copy link
Copy Markdown
Owner

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I'm trying to wrap my head around what's happening here. If I understand --rollback-protection correctly, the goal is to prevent rolling back to an ancestor. So here you ensure that the old rev is an ancestor of the new rev.

Wouldn't that prevent a user from changing branches?

         o---o---o---B
        /
---o---o---o---A

If the user was on revision A, and changed the branch to B, wouldn't this implementation throw an error?

Would it make sense to invert the check and do something like this?

ensureNotAncestor ... = 
  exitCode <- readProcessWithExitCode' "git" ["merge-base", "--is-ancestor", newRev, oldRev]
  case ExitCode
    ExitSuccess -> fail "new rev should not be an ancestor"
    _ -> pure ()

@flandweber flandweber Jun 24, 2024

Copy link
Copy Markdown
Contributor Author

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Yes, it would prevent branch changes iff the new branch head is not an ancestor of the old rev.
I see that this might be surprising for users that 'just' want to switch branches.
Maybe an additional update flag --ignore-rollback-protection would make sense in these cases?

Could you give an example for when the inverted check would be sensible?
`ensureNotAncestor could for example succeed if I switched from a recent state to an old branch-off, but fail if the old rev was before the branching:

         o---o---o---C
        /
---A---o---o---o---B

niv update dep # A -> B
niv modify -b fork
niv update dep # B -> C, succeeds

niv modify -b fork
niv update dep # A -> C, fails

ensureAncestor repository oldRev newRev = withSystemTempDirectory "ensure-ancestor" $ \(T.pack -> dir) -> do
void $ runGit abortGitBug ["clone", "--bare", repository, dir]
let runGit' f args = void $ runGit f $ ["-C", dir] <> args -- run git on new repository and discard output
runGit' abortAncestor ["merge-base", "--is-ancestor", oldRev, newRev]
return newRev
where
abortAncestor args msg =
abort $
T.unlines
[ T.unwords $ "Revision" : oldRev : "is not an ancestor of" : newRev : "." : [],
T.unwords $ "command:" : "git" : args,
msg
]

runGit :: ([T.Text] -> T.Text -> IO [T.Text]) -> [T.Text] -> IO [T.Text]
runGit abortFunction args = do
(exitCode, sout, serr) <- readProcessWithExitCode "git" (T.unpack <$> args) ""
case (exitCode, lines sout) of
(ExitSuccess, ls) -> pure $ T.pack <$> ls
_ ->
abortGitBug args $
abortFunction args $
T.unlines
[ T.unwords ["stdout:", T.pack sout],
T.unwords ["stderr:", T.pack serr]
Expand Down
13 changes: 9 additions & 4 deletions src/Niv/Update.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -200,10 +200,9 @@ runUpdate' attrs = \case
UpdateReady res -> pure res
UpdateNeedMore next' -> next' v
Load k -> pure $
UpdateReady $ do
case HMS.lookup k attrs of
Just (_, v') -> UpdateSuccess attrs v'
Nothing -> UpdateFailed $ FailNoSuchKey k
UpdateReady $ case HMS.lookup k attrs of
Nothing -> UpdateFailed $ FailNoSuchKey k
Just (_, v) -> UpdateSuccess attrs v
First a -> do
runUpdate' attrs a >>= \case
UpdateReady (UpdateFailed e) -> pure $ UpdateReady $ UpdateFailed e
Expand Down Expand Up @@ -316,6 +315,12 @@ check = Check
load :: (FromJSON a) => T.Text -> Update () (Box a)
load k = Load k >>> arr (decodeBox $ "When loading key " <> k)

maybeLoad :: (FromJSON a) => T.Text -> Update () (Box (Maybe a))
maybeLoad k = Plus (load k) $ arr $ const $ pure Nothing

loadDefault :: (FromJSON a) => T.Text -> Update (Box a) (Box a)
loadDefault k = Plus ((arr $ const ()) >>> load k) Id

-- TODO: should input really be Box?
useOrSet :: (JSON a) => T.Text -> Update (Box a) (Box a)
useOrSet k =
Expand Down