hook special remote implemented, and tested

Remote.hs

@@ -49,6 +49,7 @@ import qualified Remote.S3
 import qualified Remote.Bup
 import qualified Remote.Directory
 import qualified Remote.Rsync
+import qualified Remote.Hook
 
 remoteTypes :: [RemoteType Annex]
 remoteTypes =
@@ -57,6 +58,7 @@ remoteTypes =
 	, Remote.Bup.remote
 	, Remote.Directory.remote
 	, Remote.Rsync.remote
+	, Remote.Hook.remote
 	]
 
 {- Builds a list of all available Remotes.

Remote/Hook.hs

@@ -0,0 +1,157 @@
+{- A remote that provides hooks to run shell commands.
+ -
+ - Copyright 2011 Joey Hess <joey@kitenet.net>
+ -
+ - Licensed under the GNU GPL version 3 or higher.
+ -}
+
+module Remote.Hook (remote) where
+
+import qualified Data.ByteString.Lazy.Char8 as L
+import Control.Exception.Extensible (IOException)
+import qualified Data.Map as M
+import Control.Monad.State (liftIO)
+import System.FilePath
+import System.Posix.Process
+import System.Posix.IO
+import System.IO
+import System.IO.Error (try)
+import System.Exit
+
+import RemoteClass
+import Types
+import qualified GitRepo as Git
+import qualified Annex
+import UUID
+import Locations
+import Config
+import Content
+import Utility
+import Remote.Special
+import Remote.Encryptable
+import Crypto
+import Messages
+
+remote :: RemoteType Annex
+remote = RemoteType {
+	typename = "hook",
+	enumerate = findSpecialRemotes "hooktype",
+	generate = gen,
+	setup = hookSetup
+}
+
+gen :: Git.Repo -> UUID -> Maybe RemoteConfig -> Annex (Remote Annex)
+gen r u c = do
+	hooktype <- getConfig r "hooktype" (error "missing hooktype")
+	cst <- remoteCost r expensiveRemoteCost
+	return $ encryptableRemote c
+		(storeEncrypted hooktype)
+		(retrieveEncrypted hooktype)
+		Remote {
+			uuid = u,
+			cost = cst,
+			name = Git.repoDescribe r,
+ 			storeKey = store hooktype,
+			retrieveKeyFile = retrieve hooktype,
+			removeKey = remove hooktype,
+			hasKey = checkPresent r hooktype,
+			hasKeyCheap = False,
+			config = Nothing
+		}
+
+hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
+hookSetup u c = do
+	let hooktype = case M.lookup "hooktype" c of
+		Nothing -> error "Specify hooktype="
+		Just r -> r
+	c' <- encryptionSetup c
+	gitConfigSpecialRemote u c' "hooktype" hooktype
+	return c'
+
+hookEnv :: Key -> Maybe FilePath -> Maybe [(String, String)]
+hookEnv k f = Just $ keyenv : fileenv f
+	where
+		env s v = ("ANNEX_" ++ s, v)
+		keyenv = env "KEY" (show k)
+		fileenv Nothing = []
+		fileenv (Just file) = 
+			[ env "FILE" file
+			, env "HASH_1" (hashbits !! 0)
+			, env "HASH_2" (hashbits !! 1)
+			]
+		hashbits = map takeDirectory $ splitPath $ hashDirMixed k
+
+lookupHook :: String -> String -> Annex (Maybe String)
+lookupHook hooktype hook =do
+	g <- Annex.gitRepo
+	command <- getConfig g hookname ""
+	if null command
+		then do
+			warning $ "missing configuration for " ++ hookname
+			return Nothing
+		else return $ Just command
+	where
+		hookname =  hooktype ++ "-" ++ hook ++ "-hook"
+
+runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
+runHook hooktype hook k f a = do
+	command <- lookupHook hooktype hook
+	case command of
+		Nothing -> return False
+		Just c -> do
+			showProgress -- make way for hook output
+			res <- liftIO $ boolSystemEnv
+				"sh" [Param "-c", Param c] $ hookEnv k f
+			if res
+				then a
+				else do
+					warning $ hook ++ " hook exited nonzero!"
+					return res
+
+store :: String -> Key -> Annex Bool
+store h k = do
+	g <- Annex.gitRepo
+	runHook h "store" k (Just $ gitAnnexLocation g k) $ return True
+
+storeEncrypted :: String -> (Cipher, Key) -> Key -> Annex Bool
+storeEncrypted h (cipher, enck) k = withTmp enck $ \tmp -> do
+	g <- Annex.gitRepo
+	let f = gitAnnexLocation g k
+	liftIO $ withEncryptedContent cipher (L.readFile f) $ \s -> L.writeFile tmp s
+	runHook h "store" enck (Just tmp) $ return True
+
+retrieve :: String -> Key -> FilePath -> Annex Bool
+retrieve h k f = runHook h "retrieve" k (Just f) $ return True
+
+retrieveEncrypted :: String -> (Cipher, Key) -> FilePath -> Annex Bool
+retrieveEncrypted h (cipher, enck) f = withTmp enck $ \tmp ->
+	runHook h "retrieve" enck (Just tmp) $ liftIO $ catchBool $ do
+		withDecryptedContent cipher (L.readFile tmp) $ L.writeFile f
+		return True
+
+remove :: String -> Key -> Annex Bool
+remove h k = runHook h "remove" k Nothing $ do return True
+
+checkPresent :: Git.Repo -> String -> Key -> Annex (Either IOException Bool)
+checkPresent r h k = do
+	showNote ("checking " ++ Git.repoDescribe r ++ "...")
+	v <- lookupHook h "checkpresent"
+	liftIO (try (check v) ::IO (Either IOException Bool))
+	where
+		findkey s = (show k) `elem` (lines s)
+		env = hookEnv k Nothing
+		check Nothing = error "checkpresent hook misconfigured"
+		check (Just hook) = do
+			(frompipe, topipe) <- createPipe
+			pid <- forkProcess $ do
+				_ <- dupTo topipe stdOutput
+				closeFd frompipe
+				executeFile "sh" True ["-c", hook] env
+			closeFd topipe
+			fromh <- fdToHandle frompipe
+			reply <- hGetContentsStrict fromh
+			hClose fromh
+			s <- getProcessStatus True False pid
+			case s of
+				Just (Exited (ExitSuccess)) -> return $ findkey reply
+				_ -> error "checkpresent hook failed"

doc/special_remotes/hook.mdwn

@@ -1,4 +1,5 @@
-This special remote type runs hooks that you configure to store content.
+This special remote lets you store content in a remote of your own
+devising.
 
 It's not recommended to use this remote type when another like [[rsync]]
 or [[directory]] will do. If your hooks are not carefully written, data