2011-04-28 21:21:45 +00:00
|
|
|
|
{- 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
|
|
|
|
|
|
2012-06-20 17:13:40 +00:00
|
|
|
|
import qualified Data.ByteString.Lazy as L
|
2011-04-28 21:21:45 +00:00
|
|
|
|
import qualified Data.Map as M
|
2012-06-05 01:52:36 +00:00
|
|
|
|
import System.Environment
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
2011-10-05 20:02:51 +00:00
|
|
|
|
import Common.Annex
|
2011-06-02 01:56:04 +00:00
|
|
|
|
import Types.Remote
|
2012-08-08 20:06:01 +00:00
|
|
|
|
import Types.Key
|
2011-06-30 17:16:57 +00:00
|
|
|
|
import qualified Git
|
2011-04-28 21:21:45 +00:00
|
|
|
|
import Config
|
2011-10-04 04:40:47 +00:00
|
|
|
|
import Annex.Content
|
2011-08-17 00:49:54 +00:00
|
|
|
|
import Remote.Helper.Special
|
|
|
|
|
import Remote.Helper.Encryptable
|
2011-04-28 21:21:45 +00:00
|
|
|
|
import Crypto
|
|
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
|
remote :: RemoteType
|
2011-04-28 21:21:45 +00:00
|
|
|
|
remote = RemoteType {
|
|
|
|
|
typename = "hook",
|
|
|
|
|
enumerate = findSpecialRemotes "hooktype",
|
|
|
|
|
generate = gen,
|
|
|
|
|
setup = hookSetup
|
|
|
|
|
}
|
|
|
|
|
|
2012-11-30 04:55:59 +00:00
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> Annex Remote
|
2011-04-28 21:21:45 +00:00
|
|
|
|
gen r u c = do
|
2012-03-22 03:41:01 +00:00
|
|
|
|
hooktype <- getRemoteConfig r "hooktype" (error "missing hooktype")
|
2011-04-28 21:21:45 +00:00
|
|
|
|
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,
|
2012-01-20 17:23:11 +00:00
|
|
|
|
retrieveKeyFileCheap = retrieveCheap hooktype,
|
2011-04-28 21:21:45 +00:00
|
|
|
|
removeKey = remove hooktype,
|
|
|
|
|
hasKey = checkPresent r hooktype,
|
|
|
|
|
hasKeyCheap = False,
|
2012-02-14 07:49:48 +00:00
|
|
|
|
whereisKey = Nothing,
|
2012-11-30 04:55:59 +00:00
|
|
|
|
config = M.empty,
|
2012-08-26 18:26:43 +00:00
|
|
|
|
localpath = Nothing,
|
2011-12-31 07:27:37 +00:00
|
|
|
|
repo = r,
|
2012-08-26 19:39:02 +00:00
|
|
|
|
readonly = False,
|
2011-12-31 07:27:37 +00:00
|
|
|
|
remotetype = remote
|
2011-04-28 21:21:45 +00:00
|
|
|
|
}
|
|
|
|
|
|
|
|
|
|
hookSetup :: UUID -> RemoteConfig -> Annex RemoteConfig
|
|
|
|
|
hookSetup u c = do
|
2011-07-15 16:47:14 +00:00
|
|
|
|
let hooktype = fromMaybe (error "Specify hooktype=") $
|
2011-05-15 06:49:43 +00:00
|
|
|
|
M.lookup "hooktype" c
|
2011-04-28 21:21:45 +00:00
|
|
|
|
c' <- encryptionSetup c
|
|
|
|
|
gitConfigSpecialRemote u c' "hooktype" hooktype
|
|
|
|
|
return c'
|
|
|
|
|
|
2012-06-05 01:52:36 +00:00
|
|
|
|
hookEnv :: Key -> Maybe FilePath -> IO (Maybe [(String, String)])
|
|
|
|
|
hookEnv k f = Just <$> mergeenv (fileenv f ++ keyenv)
|
2012-11-11 04:51:07 +00:00
|
|
|
|
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)
|
|
|
|
|
, 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
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
|
|
|
|
lookupHook :: String -> String -> Annex (Maybe String)
|
|
|
|
|
lookupHook hooktype hook =do
|
2012-05-06 00:15:32 +00:00
|
|
|
|
command <- getConfig (annexConfig hookname) ""
|
2011-04-28 21:21:45 +00:00
|
|
|
|
if null command
|
|
|
|
|
then do
|
|
|
|
|
warning $ "missing configuration for " ++ hookname
|
|
|
|
|
return Nothing
|
|
|
|
|
else return $ Just command
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
hookname = hooktype ++ "-" ++ hook ++ "-hook"
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
|
|
|
|
runHook :: String -> String -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
|
2011-05-15 06:49:43 +00:00
|
|
|
|
runHook hooktype hook k f a = maybe (return False) run =<< lookupHook hooktype hook
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
run command = do
|
|
|
|
|
showOutput -- make way for hook output
|
|
|
|
|
ifM (liftIO $ boolSystemEnv "sh" [Param "-c", Param command] =<< hookEnv k f)
|
|
|
|
|
( a
|
|
|
|
|
, do
|
|
|
|
|
warning $ hook ++ " hook exited nonzero!"
|
|
|
|
|
return False
|
|
|
|
|
)
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
2012-09-21 18:50:14 +00:00
|
|
|
|
store :: String -> Key -> AssociatedFile -> MeterUpdate -> Annex Bool
|
2012-09-19 20:08:37 +00:00
|
|
|
|
store h k _f _p = do
|
2011-11-29 02:43:51 +00:00
|
|
|
|
src <- inRepo $ gitAnnexLocation k
|
2011-11-08 19:34:10 +00:00
|
|
|
|
runHook h "store" k (Just src) $ return True
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
2012-09-21 18:50:14 +00:00
|
|
|
|
storeEncrypted :: String -> (Cipher, Key) -> Key -> MeterUpdate -> Annex Bool
|
2012-09-19 20:08:37 +00:00
|
|
|
|
storeEncrypted h (cipher, enck) k _p = withTmp enck $ \tmp -> do
|
2011-11-29 02:43:51 +00:00
|
|
|
|
src <- inRepo $ gitAnnexLocation k
|
2012-11-18 19:27:44 +00:00
|
|
|
|
liftIO $ encrypt cipher (feedFile src) $
|
|
|
|
|
readBytes $ L.writeFile tmp
|
2011-04-28 21:21:45 +00:00
|
|
|
|
runHook h "store" enck (Just tmp) $ return True
|
|
|
|
|
|
2012-07-01 20:59:54 +00:00
|
|
|
|
retrieve :: String -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
|
|
|
|
retrieve h k _f d = runHook h "retrieve" k (Just d) $ return True
|
2012-01-20 17:23:11 +00:00
|
|
|
|
|
|
|
|
|
retrieveCheap :: String -> Key -> FilePath -> Annex Bool
|
|
|
|
|
retrieveCheap _ _ _ = return False
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
2012-03-04 07:36:39 +00:00
|
|
|
|
retrieveEncrypted :: String -> (Cipher, Key) -> Key -> FilePath -> Annex Bool
|
|
|
|
|
retrieveEncrypted h (cipher, enck) _ f = withTmp enck $ \tmp ->
|
2011-11-11 00:24:24 +00:00
|
|
|
|
runHook h "retrieve" enck (Just tmp) $ liftIO $ catchBoolIO $ do
|
2012-11-18 19:27:44 +00:00
|
|
|
|
decrypt cipher (feedFile tmp) $
|
|
|
|
|
readBytes $ L.writeFile f
|
2011-04-28 21:21:45 +00:00
|
|
|
|
return True
|
|
|
|
|
|
|
|
|
|
remove :: String -> Key -> Annex Bool
|
2011-07-15 16:47:14 +00:00
|
|
|
|
remove h k = runHook h "remove" k Nothing $ return True
|
2011-04-28 21:21:45 +00:00
|
|
|
|
|
2011-11-09 22:33:15 +00:00
|
|
|
|
checkPresent :: Git.Repo -> String -> Key -> Annex (Either String Bool)
|
2011-04-28 21:21:45 +00:00
|
|
|
|
checkPresent r h k = do
|
2011-07-19 18:07:23 +00:00
|
|
|
|
showAction $ "checking " ++ Git.repoDescribe r
|
2011-04-28 21:21:45 +00:00
|
|
|
|
v <- lookupHook h "checkpresent"
|
2011-11-11 00:24:24 +00:00
|
|
|
|
liftIO $ catchMsgIO $ check v
|
2012-11-11 04:51:07 +00:00
|
|
|
|
where
|
|
|
|
|
findkey s = key2file k `elem` lines s
|
|
|
|
|
check Nothing = error "checkpresent hook misconfigured"
|
|
|
|
|
check (Just hook) = do
|
|
|
|
|
env <- hookEnv k Nothing
|
|
|
|
|
findkey <$> readProcessEnv "sh" ["-c", hook] env
|