diff options
Diffstat (limited to 'Remote/Helper/Hooks.hs')
| -rw-r--r-- | Remote/Helper/Hooks.hs | 103 |
1 files changed, 51 insertions, 52 deletions
diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index eb788bc3e..91190d841 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -25,16 +25,16 @@ 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 p -> wrapper $ storeKey r k f p - , 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 + where + r' = r + { storeKey = \k f p -> wrapper $ storeKey r k f p + , 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 @@ -44,50 +44,49 @@ runHooks r starthook stophook a = 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 + 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 + -- 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 + 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" + where + go "" = return Nothing + go command = return $ Just command + hookname = n ++ "-command" |