2011-04-28 21:21:45 +00:00
|
|
|
{- A remote that provides hooks to run shell commands.
|
|
|
|
-
|
2015-01-21 16:50:09 +00:00
|
|
|
- Copyright 2011 Joey Hess <id@joeyh.name>
|
2011-04-28 21:21:45 +00:00
|
|
|
-
|
|
|
|
- Licensed under the GNU GPL version 3 or higher.
|
|
|
|
-}
|
|
|
|
|
|
|
|
module Remote.Hook (remote) where
|
|
|
|
|
2016-01-20 20:36:33 +00:00
|
|
|
import Annex.Common
|
2011-06-02 01:56:04 +00:00
|
|
|
import Types.Remote
|
2014-02-11 18:06:50 +00:00
|
|
|
import Types.Creds
|
2011-06-30 17:16:57 +00:00
|
|
|
import qualified Git
|
2011-04-28 21:21:45 +00:00
|
|
|
import Config
|
2013-03-13 20:16:01 +00:00
|
|
|
import Config.Cost
|
2013-09-07 22:38:00 +00:00
|
|
|
import Annex.UUID
|
2011-08-17 00:49:54 +00:00
|
|
|
import Remote.Helper.Special
|
2015-08-17 14:42:14 +00:00
|
|
|
import Remote.Helper.Messages
|
2017-09-01 17:02:07 +00:00
|
|
|
import Remote.Helper.Export
|
2014-01-14 20:42:10 +00:00
|
|
|
import Utility.Env
|
2015-04-04 18:34:03 +00:00
|
|
|
import Messages.Progress
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2015-01-28 19:55:17 +00:00
|
|
|
import qualified Data.Map as M
|
|
|
|
|
2013-05-21 23:19:03 +00:00
|
|
|
type Action = String
|
|
|
|
type HookName = String
|
|
|
|
|
2011-12-31 08:11:39 +00:00
|
|
|
remote :: RemoteType
|
2017-09-07 17:45:31 +00:00
|
|
|
remote = RemoteType
|
|
|
|
{ typename = "hook"
|
|
|
|
, enumerate = const (findSpecialRemotes "hooktype")
|
|
|
|
, generate = gen
|
|
|
|
, setup = hookSetup
|
|
|
|
, exportSupported = exportUnsupported
|
|
|
|
}
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2013-09-12 19:54:35 +00:00
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> Annex (Maybe Remote)
|
2013-01-01 17:52:47 +00:00
|
|
|
gen r u c gc = do
|
|
|
|
cst <- remoteCost gc expensiveRemoteCost
|
2014-08-03 19:35:23 +00:00
|
|
|
return $ Just $ specialRemote c
|
2014-08-02 21:25:16 +00:00
|
|
|
(simplyPrepare $ store hooktype)
|
|
|
|
(simplyPrepare $ retrieve hooktype)
|
run Preparer to get Remover and CheckPresent actions
This will allow special remotes to eg, open a http connection and reuse it,
while checking if chunks are present, or removing chunks.
S3 and WebDAV both need this to support chunks with reasonable speed.
Note that a special remote might want to cache a http connection across
multiple requests. A simple case of this is that CheckPresent is typically
called before Store or Remove. A remote using this interface can certianly
use a Preparer that eg, uses a MVar to cache a http connection.
However, it's up to the remote to then deal with things like stale or
stalled http connections when eg, doing a series of downloads from a remote
and other places. There could be long delays between calls to a remote,
which could lead to eg, http connection stalls; the machine might even
move to a new network, etc.
It might be nice to improve this interface later to allow
the simple case without needing to handle the full complex case.
One way to do it would be to have a `Transaction SpecialRemote cache`,
where SpecialRemote contains methods for Storer, Retriever, Remover, and
CheckPresent, that all expect to be passed a `cache`.
2014-08-06 18:28:36 +00:00
|
|
|
(simplyPrepare $ remove hooktype)
|
|
|
|
(simplyPrepare $ checkKey r hooktype)
|
2014-12-16 19:26:13 +00:00
|
|
|
Remote
|
|
|
|
{ uuid = u
|
|
|
|
, cost = cst
|
|
|
|
, name = Git.repoDescribe r
|
|
|
|
, storeKey = storeKeyDummy
|
|
|
|
, retrieveKeyFile = retreiveKeyFileDummy
|
|
|
|
, retrieveKeyFileCheap = retrieveCheap hooktype
|
2018-06-21 15:35:27 +00:00
|
|
|
-- A hook could use http and be vulnerable to
|
|
|
|
-- redirect to file:// attacks, etc.
|
|
|
|
, retrievalSecurityPolicy = RetrievalVerifiableKeysSecure
|
2014-12-16 19:26:13 +00:00
|
|
|
, removeKey = removeKeyDummy
|
2015-10-08 19:01:38 +00:00
|
|
|
, lockContent = Nothing
|
2014-12-16 19:26:13 +00:00
|
|
|
, checkPresent = checkPresentDummy
|
|
|
|
, checkPresentCheap = False
|
2017-09-01 17:02:07 +00:00
|
|
|
, exportActions = exportUnsupported
|
2014-12-16 19:26:13 +00:00
|
|
|
, whereisKey = Nothing
|
|
|
|
, remoteFsck = Nothing
|
|
|
|
, repairRepo = Nothing
|
|
|
|
, config = c
|
|
|
|
, localpath = Nothing
|
2018-06-04 18:31:55 +00:00
|
|
|
, getRepo = return r
|
2014-12-16 19:26:13 +00:00
|
|
|
, gitconfig = gc
|
|
|
|
, readonly = False
|
|
|
|
, availability = GloballyAvailable
|
|
|
|
, remotetype = remote
|
|
|
|
, mkUnavailable = gen r u c $
|
|
|
|
gc { remoteAnnexHookType = Just "!dne!" }
|
|
|
|
, getInfo = return [("hooktype", hooktype)]
|
|
|
|
, claimUrl = Nothing
|
|
|
|
, checkUrl = Nothing
|
|
|
|
}
|
2013-01-01 17:52:47 +00:00
|
|
|
where
|
2016-11-16 01:29:54 +00:00
|
|
|
hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2017-02-07 18:35:58 +00:00
|
|
|
hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
|
|
|
hookSetup _ mu _ c gc = do
|
2013-09-07 22:38:00 +00:00
|
|
|
u <- maybe (liftIO genUUID) return mu
|
2016-11-16 01:29:54 +00:00
|
|
|
let hooktype = fromMaybe (giveup "Specify hooktype=") $
|
2011-05-15 06:49:43 +00:00
|
|
|
M.lookup "hooktype" c
|
2016-05-23 21:27:15 +00:00
|
|
|
(c', _encsetup) <- encryptionSetup c gc
|
2018-03-27 16:41:57 +00:00
|
|
|
gitConfigSpecialRemote u c' [("hooktype", hooktype)]
|
2013-09-07 22:38:00 +00:00
|
|
|
return (c', u)
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2013-05-21 23:19:03 +00:00
|
|
|
hookEnv :: Action -> Key -> Maybe FilePath -> IO (Maybe [(String, String)])
|
|
|
|
hookEnv action k f = Just <$> mergeenv (fileenv f ++ keyenv)
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
2014-01-14 20:42:10 +00:00
|
|
|
mergeenv l = addEntries l <$> getEnvironment
|
2014-06-10 23:20:14 +00:00
|
|
|
envvar s v = ("ANNEX_" ++ s, v)
|
2012-11-11 04:51:07 +00:00
|
|
|
keyenv = catMaybes
|
2014-06-10 23:20:14 +00:00
|
|
|
[ Just $ envvar "KEY" (key2file k)
|
|
|
|
, Just $ envvar "ACTION" action
|
|
|
|
, envvar "HASH_1" <$> headMaybe hashbits
|
|
|
|
, envvar "HASH_2" <$> headMaybe (drop 1 hashbits)
|
2012-11-11 04:51:07 +00:00
|
|
|
]
|
|
|
|
fileenv Nothing = []
|
2014-06-10 23:20:14 +00:00
|
|
|
fileenv (Just file) = [envvar "FILE" file]
|
2015-01-28 19:55:17 +00:00
|
|
|
hashbits = map takeDirectory $ splitPath $ hashDirMixed def k
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2013-05-21 23:19:03 +00:00
|
|
|
lookupHook :: HookName -> Action -> Annex (Maybe String)
|
|
|
|
lookupHook hookname action = do
|
|
|
|
command <- getConfig (annexConfig hook) ""
|
2011-04-28 21:21:45 +00:00
|
|
|
if null command
|
|
|
|
then do
|
2013-09-26 03:19:01 +00:00
|
|
|
fallback <- getConfig (annexConfig hookfallback) ""
|
2013-05-21 23:19:03 +00:00
|
|
|
if null fallback
|
|
|
|
then do
|
|
|
|
warning $ "missing configuration for " ++ hook ++ " or " ++ hookfallback
|
|
|
|
return Nothing
|
|
|
|
else return $ Just fallback
|
2011-04-28 21:21:45 +00:00
|
|
|
else return $ Just command
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
2013-05-21 23:19:03 +00:00
|
|
|
hook = hookname ++ "-" ++ action ++ "-hook"
|
|
|
|
hookfallback = hookname ++ "-hook"
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2013-05-21 23:19:03 +00:00
|
|
|
runHook :: HookName -> Action -> Key -> Maybe FilePath -> Annex Bool -> Annex Bool
|
|
|
|
runHook hook action k f a = maybe (return False) run =<< lookupHook hook action
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
|
|
|
run command = do
|
|
|
|
showOutput -- make way for hook output
|
2015-04-04 18:34:03 +00:00
|
|
|
ifM (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f))
|
2012-11-11 04:51:07 +00:00
|
|
|
( a
|
|
|
|
, do
|
|
|
|
warning $ hook ++ " hook exited nonzero!"
|
|
|
|
return False
|
|
|
|
)
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2014-08-02 21:25:16 +00:00
|
|
|
store :: HookName -> Storer
|
|
|
|
store h = fileStorer $ \k src _p ->
|
2011-11-08 19:34:10 +00:00
|
|
|
runHook h "store" k (Just src) $ return True
|
2011-04-28 21:21:45 +00:00
|
|
|
|
2014-08-02 21:25:16 +00:00
|
|
|
retrieve :: HookName -> Retriever
|
|
|
|
retrieve h = fileRetriever $ \d k _p ->
|
|
|
|
unlessM (runHook h "retrieve" k (Just d) $ return True) $
|
2016-11-16 01:29:54 +00:00
|
|
|
giveup "failed to retrieve content"
|
2012-01-20 17:23:11 +00:00
|
|
|
|
2015-04-14 20:35:10 +00:00
|
|
|
retrieveCheap :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
|
|
|
retrieveCheap _ _ _ _ = return False
|
2011-04-28 21:21:45 +00:00
|
|
|
|
run Preparer to get Remover and CheckPresent actions
This will allow special remotes to eg, open a http connection and reuse it,
while checking if chunks are present, or removing chunks.
S3 and WebDAV both need this to support chunks with reasonable speed.
Note that a special remote might want to cache a http connection across
multiple requests. A simple case of this is that CheckPresent is typically
called before Store or Remove. A remote using this interface can certianly
use a Preparer that eg, uses a MVar to cache a http connection.
However, it's up to the remote to then deal with things like stale or
stalled http connections when eg, doing a series of downloads from a remote
and other places. There could be long delays between calls to a remote,
which could lead to eg, http connection stalls; the machine might even
move to a new network, etc.
It might be nice to improve this interface later to allow
the simple case without needing to handle the full complex case.
One way to do it would be to have a `Transaction SpecialRemote cache`,
where SpecialRemote contains methods for Storer, Retriever, Remover, and
CheckPresent, that all expect to be passed a `cache`.
2014-08-06 18:28:36 +00:00
|
|
|
remove :: HookName -> Remover
|
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
|
|
|
|
run Preparer to get Remover and CheckPresent actions
This will allow special remotes to eg, open a http connection and reuse it,
while checking if chunks are present, or removing chunks.
S3 and WebDAV both need this to support chunks with reasonable speed.
Note that a special remote might want to cache a http connection across
multiple requests. A simple case of this is that CheckPresent is typically
called before Store or Remove. A remote using this interface can certianly
use a Preparer that eg, uses a MVar to cache a http connection.
However, it's up to the remote to then deal with things like stale or
stalled http connections when eg, doing a series of downloads from a remote
and other places. There could be long delays between calls to a remote,
which could lead to eg, http connection stalls; the machine might even
move to a new network, etc.
It might be nice to improve this interface later to allow
the simple case without needing to handle the full complex case.
One way to do it would be to have a `Transaction SpecialRemote cache`,
where SpecialRemote contains methods for Storer, Retriever, Remover, and
CheckPresent, that all expect to be passed a `cache`.
2014-08-06 18:28:36 +00:00
|
|
|
checkKey :: Git.Repo -> HookName -> CheckPresent
|
2014-08-06 17:45:19 +00:00
|
|
|
checkKey r h k = do
|
2015-08-17 14:42:14 +00:00
|
|
|
showChecking r
|
2013-05-21 23:19:03 +00:00
|
|
|
v <- lookupHook h action
|
2014-08-06 17:45:19 +00:00
|
|
|
liftIO $ check v
|
2012-11-11 04:51:07 +00:00
|
|
|
where
|
2014-10-09 18:53:13 +00:00
|
|
|
action = "checkpresent"
|
2012-11-11 04:51:07 +00:00
|
|
|
findkey s = key2file k `elem` lines s
|
2016-11-16 01:29:54 +00:00
|
|
|
check Nothing = giveup $ action ++ " hook misconfigured"
|
2012-11-11 04:51:07 +00:00
|
|
|
check (Just hook) = do
|
2014-06-10 23:20:14 +00:00
|
|
|
environ <- hookEnv action k Nothing
|
|
|
|
findkey <$> readProcessEnv "sh" ["-c", hook] environ
|