diff options
author | Joey Hess <joey@kitenet.net> | 2011-04-28 17:21:45 -0400 |
---|---|---|
committer | Joey Hess <joey@kitenet.net> | 2011-04-28 17:21:45 -0400 |
commit | 3ab3f41aea78f6816493d094d2daca7cc0067a91 (patch) | |
tree | b70c38456332a5d4f96160e1a377cea127992dbf | |
parent | b5072b7b4cab21118f60c55a58497f363f749244 (diff) |
hook special remote implemented, and tested
-rw-r--r-- | Remote.hs | 2 | ||||
-rw-r--r-- | Remote/Hook.hs | 157 | ||||
-rw-r--r-- | doc/special_remotes/hook.mdwn | 3 |
3 files changed, 161 insertions, 1 deletions
@@ -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. diff --git a/Remote/Hook.hs b/Remote/Hook.hs new file mode 100644 index 000000000..2613fda7a --- /dev/null +++ b/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" diff --git a/doc/special_remotes/hook.mdwn b/doc/special_remotes/hook.mdwn index 7bdd317b9..74c4029cd 100644 --- a/doc/special_remotes/hook.mdwn +++ b/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 |