7225c2bfc0
In order to record a semi-useful filename associated with the key, this required plumbing the filename all the way through to the remotes' storeKey and retrieveKeyFile. Note that there is potential for deadlock here, narrowly avoided. Suppose the repos are A and B. A sends file foo to B, and at the same time, B gets file foo from A. So, A locks its upload transfer info file, and then locks B's download transfer info file. At the same time, B is taking the two locks in the opposite order. This is only not a deadlock because the lock code does not wait, and aborts. So one of A or B's transfers will be aborted and the other transfer will continue. Whew!
93 lines
3 KiB
Haskell
93 lines
3 KiB
Haskell
{- Adds hooks to remotes.
|
|
-
|
|
- Copyright 2012 Joey Hess <joey@kitenet.net>
|
|
-
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
-}
|
|
|
|
module Remote.Helper.Hooks (addHooks) where
|
|
|
|
import qualified Data.Map as M
|
|
|
|
import Common.Annex
|
|
import Types.Remote
|
|
import qualified Annex
|
|
import Annex.LockPool
|
|
import Config
|
|
import Annex.Perms
|
|
|
|
{- Modifies a remote's access functions to first run the
|
|
- annex-start-command hook, and trigger annex-stop-command on shutdown.
|
|
- This way, the hooks are only run when a remote is actively being used.
|
|
-}
|
|
addHooks :: Remote -> Annex Remote
|
|
addHooks r = addHooks' r <$> lookupHook r "start" <*> lookupHook r "stop"
|
|
addHooks' :: Remote -> Maybe String -> Maybe String -> Remote
|
|
addHooks' r Nothing Nothing = r
|
|
addHooks' r starthook stophook = r'
|
|
where
|
|
r' = r
|
|
{ storeKey = \k f -> wrapper $ storeKey r k f
|
|
, retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d
|
|
, retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f
|
|
, removeKey = \k -> wrapper $ removeKey r k
|
|
, hasKey = \k -> wrapper $ hasKey r k
|
|
}
|
|
where
|
|
wrapper = runHooks r' starthook stophook
|
|
|
|
runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a
|
|
runHooks r starthook stophook a = do
|
|
dir <- fromRepo gitAnnexRemotesDir
|
|
let lck = dir </> remoteid ++ ".lck"
|
|
whenM (not . any (== lck) . M.keys <$> getPool) $ do
|
|
liftIO $ createDirectoryIfMissing True dir
|
|
firstrun lck
|
|
a
|
|
where
|
|
remoteid = show (uuid r)
|
|
run Nothing = noop
|
|
run (Just command) = void $ liftIO $
|
|
boolSystem "sh" [Param "-c", Param command]
|
|
firstrun lck = do
|
|
-- Take a shared lock; This indicates that git-annex
|
|
-- is using the remote, and prevents other instances
|
|
-- of it from running the stophook. If another
|
|
-- instance is shutting down right now, this
|
|
-- will block waiting for its exclusive lock to clear.
|
|
lockFile lck
|
|
|
|
-- The starthook is run even if some other git-annex
|
|
-- is already running, and ran it before.
|
|
-- It would be difficult to use locking to ensure
|
|
-- it's only run once, and it's also possible for
|
|
-- git-annex to be interrupted before it can run the
|
|
-- stophook, in which case the starthook
|
|
-- would be run again by the next git-annex.
|
|
-- So, requiring idempotency is the right approach.
|
|
run starthook
|
|
|
|
Annex.addCleanup (remoteid ++ "-stop-command") $
|
|
runstop lck
|
|
runstop lck = do
|
|
-- Drop any shared lock we have, and take an
|
|
-- exclusive lock, without blocking. If the lock
|
|
-- succeeds, we're the only process using this remote,
|
|
-- so can stop it.
|
|
unlockFile lck
|
|
mode <- annexFileMode
|
|
fd <- liftIO $ noUmask mode $
|
|
openFd lck ReadWrite (Just mode) defaultFileFlags
|
|
v <- liftIO $ tryIO $
|
|
setLock fd (WriteLock, AbsoluteSeek, 0, 0)
|
|
case v of
|
|
Left _ -> noop
|
|
Right _ -> run stophook
|
|
liftIO $ closeFd fd
|
|
|
|
lookupHook :: Remote -> String -> Annex (Maybe String)
|
|
lookupHook r n = go =<< getRemoteConfig (repo r) hookname ""
|
|
where
|
|
go "" = return Nothing
|
|
go command = return $ Just command
|
|
hookname = n ++ "-command"
|