163 lines
5 KiB
Haskell
163 lines
5 KiB
Haskell
{- A remote that provides hooks to run shell commands.
|
|
-
|
|
- Copyright 2011 Joey Hess <id@joeyh.name>
|
|
-
|
|
- Licensed under the GNU AGPL version 3 or higher.
|
|
-}
|
|
|
|
module Remote.Hook (remote) where
|
|
|
|
import Annex.Common
|
|
import Types.Remote
|
|
import Types.Creds
|
|
import qualified Git
|
|
import Git.Types (fromConfigKey, fromConfigValue)
|
|
import Config
|
|
import Config.Cost
|
|
import Annex.UUID
|
|
import Remote.Helper.Special
|
|
import Remote.Helper.Messages
|
|
import Remote.Helper.ExportImport
|
|
import Utility.Env
|
|
import Messages.Progress
|
|
|
|
import qualified Data.Map as M
|
|
|
|
type Action = String
|
|
type HookName = String
|
|
|
|
remote :: RemoteType
|
|
remote = RemoteType
|
|
{ typename = "hook"
|
|
, enumerate = const (findSpecialRemotes "hooktype")
|
|
, generate = gen
|
|
, setup = hookSetup
|
|
, exportSupported = exportUnsupported
|
|
, importSupported = importUnsupported
|
|
}
|
|
|
|
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
|
|
gen r u c gc rs = do
|
|
cst <- remoteCost gc expensiveRemoteCost
|
|
return $ Just $ specialRemote c
|
|
(simplyPrepare $ store hooktype)
|
|
(simplyPrepare $ retrieve hooktype)
|
|
(simplyPrepare $ remove hooktype)
|
|
(simplyPrepare $ checkKey r hooktype)
|
|
Remote
|
|
{ uuid = u
|
|
, cost = cst
|
|
, name = Git.repoDescribe r
|
|
, storeKey = storeKeyDummy
|
|
, retrieveKeyFile = retreiveKeyFileDummy
|
|
, retrieveKeyFileCheap = retrieveCheap hooktype
|
|
-- A hook could use http and be vulnerable to
|
|
-- redirect to file:// attacks, etc.
|
|
, retrievalSecurityPolicy = mkRetrievalVerifiableKeysSecure gc
|
|
, removeKey = removeKeyDummy
|
|
, lockContent = Nothing
|
|
, checkPresent = checkPresentDummy
|
|
, checkPresentCheap = False
|
|
, exportActions = exportUnsupported
|
|
, importActions = importUnsupported
|
|
, whereisKey = Nothing
|
|
, remoteFsck = Nothing
|
|
, repairRepo = Nothing
|
|
, config = c
|
|
, localpath = Nothing
|
|
, getRepo = return r
|
|
, gitconfig = gc
|
|
, readonly = False
|
|
, appendonly = False
|
|
, availability = GloballyAvailable
|
|
, remotetype = remote
|
|
, mkUnavailable = gen r u c
|
|
(gc { remoteAnnexHookType = Just "!dne!" })
|
|
rs
|
|
, getInfo = return [("hooktype", hooktype)]
|
|
, claimUrl = Nothing
|
|
, checkUrl = Nothing
|
|
, remoteStateHandle = rs
|
|
}
|
|
where
|
|
hooktype = fromMaybe (giveup "missing hooktype") $ remoteAnnexHookType gc
|
|
|
|
hookSetup :: SetupStage -> Maybe UUID -> Maybe CredPair -> RemoteConfig -> RemoteGitConfig -> Annex (RemoteConfig, UUID)
|
|
hookSetup _ mu _ c gc = do
|
|
u <- maybe (liftIO genUUID) return mu
|
|
let hooktype = fromMaybe (giveup "Specify hooktype=") $
|
|
M.lookup "hooktype" c
|
|
(c', _encsetup) <- encryptionSetup c gc
|
|
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
|
|
envvar s v = ("ANNEX_" ++ s, v)
|
|
keyenv = catMaybes
|
|
[ Just $ envvar "KEY" (serializeKey k)
|
|
, Just $ envvar "ACTION" action
|
|
, envvar "HASH_1" <$> headMaybe hashbits
|
|
, envvar "HASH_2" <$> headMaybe (drop 1 hashbits)
|
|
]
|
|
fileenv Nothing = []
|
|
fileenv (Just file) = [envvar "FILE" file]
|
|
hashbits = map takeDirectory $ splitPath $ hashDirMixed def k
|
|
|
|
lookupHook :: HookName -> Action -> Annex (Maybe String)
|
|
lookupHook hookname action = do
|
|
command <- fromConfigValue <$> getConfig hook mempty
|
|
if null command
|
|
then do
|
|
fallback <- fromConfigValue <$> getConfig hookfallback mempty
|
|
if null fallback
|
|
then do
|
|
warning $ "missing configuration for " ++ fromConfigKey hook ++ " or " ++ fromConfigKey hookfallback
|
|
return Nothing
|
|
else return $ Just fallback
|
|
else return $ Just command
|
|
where
|
|
hook = annexConfig $ encodeBS' $ hookname ++ "-" ++ action ++ "-hook"
|
|
hookfallback = annexConfig $ encodeBS' $ 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 (progressCommandEnv "sh" [Param "-c", Param command] =<< liftIO (hookEnv action k f))
|
|
( a
|
|
, do
|
|
warning $ hook ++ " hook exited nonzero!"
|
|
return False
|
|
)
|
|
|
|
store :: HookName -> Storer
|
|
store h = fileStorer $ \k src _p ->
|
|
runHook h "store" k (Just src) $ return True
|
|
|
|
retrieve :: HookName -> Retriever
|
|
retrieve h = fileRetriever $ \d k _p ->
|
|
unlessM (runHook h "retrieve" k (Just d) $ return True) $
|
|
giveup "failed to retrieve content"
|
|
|
|
retrieveCheap :: HookName -> Key -> AssociatedFile -> FilePath -> Annex Bool
|
|
retrieveCheap _ _ _ _ = return False
|
|
|
|
remove :: HookName -> Remover
|
|
remove h k = runHook h "remove" k Nothing $ return True
|
|
|
|
checkKey :: Git.Repo -> HookName -> CheckPresent
|
|
checkKey r h k = do
|
|
showChecking r
|
|
v <- lookupHook h action
|
|
liftIO $ check v
|
|
where
|
|
action = "checkpresent"
|
|
findkey s = serializeKey k `elem` lines s
|
|
check Nothing = giveup $ action ++ " hook misconfigured"
|
|
check (Just hook) = do
|
|
environ <- hookEnv action k Nothing
|
|
findkey <$> readProcessEnv "sh" ["-c", hook] environ
|