diff options
Diffstat (limited to 'Remote/Hook.hs')
| -rw-r--r-- | Remote/Hook.hs | 159 |
1 files changed, 159 insertions, 0 deletions
diff --git a/Remote/Hook.hs b/Remote/Hook.hs new file mode 100644 index 000000000..3735c228c --- /dev/null +++ b/Remote/Hook.hs @@ -0,0 +1,159 @@ +{- 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 as L +import qualified Data.Map as M + +import Common.Annex +import Types.Remote +import Types.Key +import Types.Creds +import qualified Git +import Config +import Config.Cost +import Annex.Content +import Annex.UUID +import Remote.Helper.Special +import Remote.Helper.Encryptable +import Crypto +import Utility.Metered +import Utility.Env + +type Action = String +type HookName = String + +remote :: RemoteType +remote = RemoteType { + typename = "hook", + enumerate = findSpecialRemotes "hooktype", + generate = gen, + setup = hookSetup +} + +gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote) +gen r u c gc = do + cst <- remoteCost gc expensiveRemoteCost + return $ Just $ encryptableRemote c + (storeEncrypted hooktype $ getGpgEncParams (c,gc)) + (retrieveEncrypted hooktype) + Remote { + uuid = u, + cost = cst, + name = Git.repoDescribe r, + storeKey = store hooktype, + retrieveKeyFile = retrieve hooktype, + retrieveKeyFileCheap = retrieveCheap hooktype, + removeKey = remove hooktype, + hasKey = checkPresent r hooktype, + hasKeyCheap = False, + whereisKey = Nothing, + remoteFsck = Nothing, + repairRepo = Nothing, + config = c, + localpath = Nothing, + repo = r, + gitconfig = gc, + readonly = False, + availability = GloballyAvailable, + remotetype = remote + } + where + hooktype = fromMaybe (error "missing hooktype") $ remoteAnnexHookType gc + +hookSetup :: Maybe UUID -> Maybe CredPair -> RemoteConfig -> Annex (RemoteConfig, UUID) +hookSetup mu _ c = do + u <- maybe (liftIO genUUID) return mu + let hooktype = fromMaybe (error "Specify hooktype=") $ + M.lookup "hooktype" c + c' <- encryptionSetup c + gitConfigSpecialRemote u c' "hooktype" hooktype + return (c', u) + +hookEnv :: Action -> Key -> Maybe FilePath -> IO (Maybe [(String, String)]) +hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv) + where + mergeenv l = addEntries l <$> 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) + ] + fileenv Nothing = [] + fileenv (Just file) = [env "FILE" file] + hashbits = map takeDirectory $ splitPath $ hashDirMixed k + +lookupHook :: HookName -> Action -> Annex (Maybe String) +lookupHook hookname action = do + command <- getConfig (annexConfig hook) "" + if null command + then do + 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 + hook = hookname ++ "-" ++ action ++ "-hook" + hookfallback = hookname ++ "-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 action k f) + ( a + , do + warning $ hook ++ " hook exited nonzero!" + return False + ) + +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 :: HookName -> [CommandParam] -> (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 :: HookName -> Key -> AssociatedFile -> FilePath -> MeterUpdate -> Annex Bool +retrieve h k _f d _p = runHook h "retrieve" k (Just d) $ return True + +retrieveCheap :: HookName -> Key -> FilePath -> Annex Bool +retrieveCheap _ _ _ = return False + +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 :: HookName -> Key -> Annex Bool +remove h k = runHook h "remove" k Nothing $ return True + +checkPresent :: Git.Repo -> HookName -> Key -> Annex (Either String Bool) +checkPresent r h k = do + showAction $ "checking " ++ Git.repoDescribe r + v <- lookupHook h action + liftIO $ catchMsgIO $ check v + where + action = "checkpresent" + findkey s = key2file k `elem` lines s + check Nothing = error $ action ++ " hook misconfigured" + check (Just hook) = do + env <- hookEnv action k Nothing + findkey <$> readProcessEnv "sh" ["-c", hook] env |