1{- git-annex actions 2 - 3 - Copyright 2010-2020 Joey Hess <id@joeyh.name> 4 - 5 - Licensed under the GNU AGPL version 3 or higher. 6 -} 7 8{-# LANGUAGE CPP #-} 9 10module Annex.Action ( 11 action, 12 verifiedAction, 13 startup, 14 shutdown, 15 stopCoProcesses, 16 stopNonConcurrentSafeCoProcesses, 17) where 18 19import qualified Data.Map as M 20 21import Annex.Common 22import qualified Annex 23import Annex.Content 24import Annex.CatFile 25import Annex.CheckAttr 26import Annex.HashObject 27import Annex.CheckIgnore 28import Annex.TransferrerPool 29 30import Control.Concurrent.STM 31#ifndef mingw32_HOST_OS 32import System.Posix.Signals 33#endif 34 35{- Runs an action that may throw exceptions, catching and displaying them. -} 36action :: Annex () -> Annex Bool 37action a = tryNonAsync a >>= \case 38 Right () -> return True 39 Left e -> do 40 warning (show e) 41 return False 42 43verifiedAction :: Annex Verification -> Annex (Bool, Verification) 44verifiedAction a = tryNonAsync a >>= \case 45 Right v -> return (True, v) 46 Left e -> do 47 warning (show e) 48 return (False, UnVerified) 49 50 51{- Actions to perform each time ran. -} 52startup :: Annex () 53startup = do 54#ifndef mingw32_HOST_OS 55 av <- Annex.getRead Annex.signalactions 56 let propagate sig = liftIO $ installhandleronce sig av 57 propagate sigINT 58 propagate sigQUIT 59 propagate sigTERM 60 propagate sigTSTP 61 propagate sigCONT 62 propagate sigHUP 63 -- sigWINCH is not propagated; it should not be needed, 64 -- and the concurrent-output library installs its own signal 65 -- handler for it. 66 -- sigSTOP and sigKILL cannot be caught, so will not be propagated. 67 where 68 installhandleronce sig av = void $ 69 installHandler sig (CatchOnce (gotsignal sig av)) Nothing 70 gotsignal sig av = do 71 mapM_ (\a -> a (fromIntegral sig)) =<< atomically (readTVar av) 72 raiseSignal sig 73 installhandleronce sig av 74#else 75 return () 76#endif 77 78{- Cleanup actions. -} 79shutdown :: Bool -> Annex () 80shutdown nocommit = do 81 saveState nocommit 82 sequence_ =<< M.elems <$> Annex.getState Annex.cleanupactions 83 stopCoProcesses 84 85{- Stops all long-running child processes, including git query processes. -} 86stopCoProcesses :: Annex () 87stopCoProcesses = do 88 stopNonConcurrentSafeCoProcesses 89 emptyTransferrerPool 90 91{- Stops long-running child processes that use handles that are not safe 92 - for multiple threads to access at the same time. -} 93stopNonConcurrentSafeCoProcesses :: Annex () 94stopNonConcurrentSafeCoProcesses = do 95 catFileStop 96 checkAttrStop 97 hashObjectStop 98 checkIgnoreStop 99