git-annex-shell: Added lockcontent command, to prevent dropping of key's content.
This commit is contained in:
parent
4d50958ed7
commit
5240a9f315
4 changed files with 60 additions and 0 deletions
45
Command/LockContent.hs
Normal file
45
Command/LockContent.hs
Normal file
|
@ -0,0 +1,45 @@
|
|||
{- git-annex-shell command
|
||||
-
|
||||
- Copyright 2015 Joey Hess <id@joeyh.name>
|
||||
-
|
||||
- Licensed under the GNU GPL version 3 or higher.
|
||||
-}
|
||||
|
||||
module Command.LockContent where
|
||||
|
||||
import Common.Annex
|
||||
import Command
|
||||
import Annex.Content
|
||||
import Types.Key
|
||||
|
||||
cmd :: Command
|
||||
cmd = noCommit $
|
||||
command "lockcontent" SectionPlumbing
|
||||
"locks key's content in the annex, preventing it being dropped"
|
||||
paramKey
|
||||
(withParams seek)
|
||||
|
||||
seek :: CmdParams -> CommandSeek
|
||||
seek = withWords start
|
||||
|
||||
-- First, lock the content. Then, make sure the content is actually
|
||||
-- present, and print out a "1". Wait for the caller to send a line before
|
||||
-- dropping the lock.
|
||||
start :: [String] -> CommandStart
|
||||
start [ks] = do
|
||||
ok <- lockContentShared k locksuccess
|
||||
`catchNonAsync` (const $ return False)
|
||||
liftIO $ if ok
|
||||
then exitSuccess
|
||||
else exitFailure
|
||||
where
|
||||
k = fromMaybe (error "bad key") (file2key ks)
|
||||
locksuccess = ifM (inAnnex k)
|
||||
( liftIO $ do
|
||||
putStrLn "OK"
|
||||
hFlush stdout
|
||||
_ <- getLine
|
||||
return True
|
||||
, return False
|
||||
)
|
||||
start _ = error "Specify exactly 1 key."
|
Loading…
Add table
Add a link
Reference in a new issue