hook special remote: Added combined hook program support.

Remote/Hook.hs

@@ -23,6 +23,9 @@ import Remote.Helper.Encryptable
 import Crypto
 import Utility.Metered
 
+type Action = String
+type HookName = String
+
 remote :: RemoteType
 remote = RemoteType {
 	typename = "hook",
@@ -67,14 +70,15 @@ hookSetup u c = do
 	gitConfigSpecialRemote u c' "hooktype" hooktype
 	return c'
 
-hookEnv :: Key -> Maybe FilePath -> IO (Maybe [(String, String)])
-hookEnv k f = Just <$> mergeenv (fileenv f ++ keyenv)
+hookEnv :: Action -> Key -> Maybe FilePath -> IO (Maybe [(String, String)])
+hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv)
   where
 	mergeenv l = M.toList . M.union (M.fromList l) 
 		<$> M.fromList <$> getEnvironment
 	env s v = ("ANNEX_" ++ s, v)
 	keyenv = catMaybes
 		[ Just $ env "KEY" (key2file k)
+		, Just $ env "ACTION" action
 		, env "HASH_1" <$> headMaybe hashbits
 		, env "HASH_2" <$> headMaybe (drop 1 hashbits)
 		]
@@ -82,64 +86,70 @@ hookEnv k f = Just <$> mergeenv (fileenv f ++ keyenv)
 	fileenv (Just file) =  [env "FILE" file]
 	hashbits = map takeDirectory $ splitPath $ hashDirMixed k
 
-lookupHook :: String -> String -> Annex (Maybe String)
-lookupHook hooktype hook =do
-	command <- getConfig (annexConfig hookname) ""
+lookupHook :: HookName -> Action -> Annex (Maybe String)
+lookupHook hookname action = do
+	command <- getConfig (annexConfig hook) ""
 	if null command
 		then do
-			warning $ "missing configuration for " ++ hookname
-			return Nothing
+			fallback <- getConfig (annexConfig $ hookfallback) ""
+			if null fallback
+				then do
+					warning $ "missing configuration for " ++ hook ++ " or " ++ hookfallback
+					return Nothing
+				else return $ Just fallback
 		else return $ Just command
   where
-	hookname = hooktype ++ "-" ++ hook ++ "-hook"
+	hook = hookname ++ "-" ++ action ++ "-hook"
+	hookfallback = hookname ++ "-hook"
 
-runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
-runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype hook
+runHook :: HookName -> Action -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
+runHook hook action k f a = maybe (return False) run =<< lookupHook hook action
   where
 	run command = do
 		showOutput -- make way for hook output
-		ifM (liftIO $ boolSystemEnv "sh" [Param "-c", Param command] =<< hookEnv k f)
+		ifM (liftIO $ boolSystemEnv "sh" [Param "-c", Param command] =<< hookEnv action k f)
 			( a
 			, do
 				warning $ hook ++ " hook exited nonzero!"
 				return False
 			)
 
-store :: String -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
+store :: HookName -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
 store h k _f _p = sendAnnex k (void $ remove h k) $ \src ->
 	runHook h "store" k (Just src) $ return True
 
-storeEncrypted :: String -> GpgOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
+storeEncrypted :: HookName -> GpgOpts -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
 storeEncrypted h gpgOpts (cipher, enck) k _p = withTmp enck $ \tmp ->
 	sendAnnex k (void $ remove h enck) $ \src -> do
 		liftIO $ encrypt gpgOpts cipher (feedFile src) $
 			readBytes $ L.writeFile tmp
 		runHook h "store" enck (Just tmp) $ return True
 
-retrieve :: String -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
+retrieve :: HookName -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool
 retrieve h k _f d _p = runHook h "retrieve" k (Just d) $ return True
 
-retrieveCheap :: String -> Key -> FilePath -> Annex Bool
+retrieveCheap :: HookName -> Key -> FilePath -> Annex Bool
 retrieveCheap _ _ _ = return False
 
-retrieveEncrypted :: String -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
+retrieveEncrypted :: HookName -> (Cipher, Key) -> Key -> FilePath -> MeterUpdate -> Annex Bool
 retrieveEncrypted h (cipher, enck) _ f _p = withTmp enck $ \tmp ->
 	runHook h "retrieve" enck (Just tmp) $ liftIO $ catchBoolIO $ do
 		decrypt cipher (feedFile tmp) $
 			readBytes $ L.writeFile f
 		return True
 
-remove :: String -> Key -> Annex Bool
+remove :: HookName -> Key -> Annex Bool
 remove h k = runHook h "remove" k Nothing $ return True
 
-checkPresent :: Git.Repo -> String -> Key -> Annex (Either String Bool)
+checkPresent :: Git.Repo -> HookName -> Key -> Annex (Either String Bool)
 checkPresent r h k = do
 	showAction $ "checking " ++ Git.repoDescribe r
-	v <- lookupHook h "checkpresent"
+	v <- lookupHook h action
 	liftIO $ catchMsgIO $ check v
   where
+  	action = "checkpresent"
 	findkey s = key2file k `elem` lines s
-	check Nothing = error "checkpresent hook misconfigured"
+	check Nothing = error $ action ++ " hook misconfigured"
 	check (Just hook) = do
-		env <- hookEnv k Nothing
+		env <- hookEnv action k Nothing
 		findkey <$> readProcessEnv "sh" ["-c", hook] env