summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorGravatar Joey Hess <joey@kitenet.net>2011-04-28 17:21:45 -0400
committerGravatar Joey Hess <joey@kitenet.net>2011-04-28 17:21:45 -0400
commit3ab3f41aea78f6816493d094d2daca7cc0067a91 (patch)
treeb70c38456332a5d4f96160e1a377cea127992dbf
parentb5072b7b4cab21118f60c55a58497f363f749244 (diff)
hook special remote implemented, and tested
-rw-r--r--Remote.hs2
-rw-r--r--Remote/Hook.hs157
-rw-r--r--doc/special_remotes/hook.mdwn3
3 files changed, 161 insertions, 1 deletions
diff --git a/Remote.hs b/Remote.hs
index f47bea560..bbecdb999 100644
--- a/Remote.hs
+++ b/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.
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