1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
|
{- A remote that provides hooks to run shell commands.
-
- Copyright 2011-2020 Joey Hess <id@joeyh.name>
-
- Licensed under the GNU AGPL version 3 or higher.
-}
{-# LANGUAGE RankNTypes #-}
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 Annex.SpecialRemote.Config
import Remote.Helper.Special
import Remote.Helper.ExportImport
import Utility.Env
import Messages.Progress
import Types.ProposedAccepted
import qualified Data.Map as M
type Action = String
type HookName = String
remote :: RemoteType
remote = specialRemoteType $ RemoteType
{ typename = "hook"
, enumerate = const (findSpecialRemotes "hooktype")
, generate = gen
, configParser = mkRemoteConfigParser
[ optionalStringParser hooktypeField
(FieldDesc "(required) specify collection of hooks to use")
]
, setup = hookSetup
, exportSupported = exportUnsupported
, importSupported = importUnsupported
, thirdPartyPopulated = False
}
hooktypeField :: RemoteConfigField
hooktypeField = Accepted "hooktype"
gen :: Git.Repo -> UUID -> RemoteConfig -> RemoteGitConfig -> RemoteStateHandle -> Annex (Maybe Remote)
gen r u rc gc rs = do
c <- parsedRemoteConfig remote rc
cst <- remoteCost gc c expensiveRemoteCost
return $ Just $ specialRemote c
(store hooktype)
(retrieve hooktype)
(remove hooktype)
(checkKey hooktype)
Remote
{ uuid = u
, cost = cst
, name = Git.repoDescribe r
, storeKey = storeKeyDummy
, retrieveKeyFile = retrieveKeyFileDummy
, retrieveKeyFileInOrder = pure False
, retrieveKeyFileCheap = Nothing
-- 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
, untrustworthy = False
, availability = pure GloballyAvailable
, remotetype = remote
, mkUnavailable = gen r u rc
(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 = maybe (giveup "Specify hooktype=") fromProposedAccepted $
M.lookup hooktypeField 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 (fromOsPath . 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 $ UnquotedString $ "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 ()
runHook hook action k f = lookupHook hook action >>= \case
Just command -> do
showOutput -- make way for hook output
environ <- liftIO (hookEnv action k f)
unlessM (progressCommandEnv "sh" [Param "-c", Param command] environ) $
giveup $ hook ++ " hook exited nonzero!"
Nothing -> giveup $ action ++ " hook misconfigured"
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 $ UnquotedString $ hook ++ " hook exited nonzero!"
return False
)
store :: HookName -> Storer
store h = fileStorer $ \k src _p -> runHook h "store" k (Just (fromOsPath src))
retrieve :: HookName -> Retriever
retrieve h = fileRetriever $ \d k _p ->
unlessM (runHook' h "retrieve" k (Just (fromOsPath d)) $ return True) $
giveup "failed to retrieve content"
remove :: HookName -> Remover
remove h _proof k =
unlessM (runHook' h "remove" k Nothing $ return True) $
giveup "failed to remove content"
checkKey :: HookName -> CheckPresent
checkKey h k = do
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
|
