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