diff options
Diffstat (limited to 'Remote/Helper')
| -rw-r--r-- | Remote/Helper/Encryptable.hs | 72 | ||||
| -rw-r--r-- | Remote/Helper/Hooks.hs | 103 | ||||
| -rw-r--r-- | Remote/Helper/Special.hs | 18 | ||||
| -rw-r--r-- | Remote/Helper/Ssh.hs | 34 |
4 files changed, 113 insertions, 114 deletions
diff --git a/Remote/Helper/Encryptable.hs b/Remote/Helper/Encryptable.hs index 8ed2fed63..12c7d37e9 100644 --- a/Remote/Helper/Encryptable.hs +++ b/Remote/Helper/Encryptable.hs @@ -32,12 +32,12 @@ encryptionSetup c = case (M.lookup "encryption" c, extractCipher c) of (Just "shared", Nothing) -> use "encryption setup" $ genSharedCipher (Just keyid, Nothing) -> use "encryption setup" $ genEncryptedCipher keyid (Just keyid, Just v) -> use "encryption updated" $ updateEncryptedCipher keyid v - where - cannotchange = error "Cannot change encryption type of existing remote." - use m a = do - cipher <- liftIO a - showNote $ m ++ " " ++ describeCipher cipher - return $ M.delete "encryption" $ storeCipher c cipher + where + cannotchange = error "Cannot change encryption type of existing remote." + use m a = do + cipher <- liftIO a + showNote $ m ++ " " ++ describeCipher cipher + return $ M.delete "encryption" $ storeCipher c cipher {- Modifies a Remote to support encryption. - @@ -58,35 +58,35 @@ encryptableRemote c storeKeyEncrypted retrieveKeyFileEncrypted r = hasKey = withkey $ hasKey r, cost = cost r + encryptedRemoteCostAdj } - where - store k f p = cip k >>= maybe - (storeKey r k f p) - (\enck -> storeKeyEncrypted enck k p) - retrieve k f d = cip k >>= maybe - (retrieveKeyFile r k f d) - (\enck -> retrieveKeyFileEncrypted enck k d) - retrieveCheap k d = cip k >>= maybe - (retrieveKeyFileCheap r k d) - (\_ -> return False) - withkey a k = cip k >>= maybe (a k) (a . snd) - cip = cipherKey c + where + store k f p = cip k >>= maybe + (storeKey r k f p) + (\enck -> storeKeyEncrypted enck k p) + retrieve k f d = cip k >>= maybe + (retrieveKeyFile r k f d) + (\enck -> retrieveKeyFileEncrypted enck k d) + retrieveCheap k d = cip k >>= maybe + (retrieveKeyFileCheap r k d) + (\_ -> return False) + withkey a k = cip k >>= maybe (a k) (a . snd) + cip = cipherKey c {- Gets encryption Cipher. The decrypted Ciphers are cached in the Annex - state. -} remoteCipher :: RemoteConfig -> Annex (Maybe Cipher) remoteCipher c = go $ extractCipher c - where - go Nothing = return Nothing - go (Just encipher) = do - cache <- Annex.getState Annex.ciphers - case M.lookup encipher cache of - Just cipher -> return $ Just cipher - Nothing -> decrypt encipher cache - decrypt encipher cache = do - showNote "gpg" - cipher <- liftIO $ decryptCipher encipher - Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache }) - return $ Just cipher + where + go Nothing = return Nothing + go (Just encipher) = do + cache <- Annex.getState Annex.ciphers + case M.lookup encipher cache of + Just cipher -> return $ Just cipher + Nothing -> decrypt encipher cache + decrypt encipher cache = do + showNote "gpg" + cipher <- liftIO $ decryptCipher encipher + Annex.changeState (\s -> s { Annex.ciphers = M.insert encipher cipher cache }) + return $ Just cipher {- Checks if there is a trusted (non-shared) cipher. -} isTrustedCipher :: RemoteConfig -> Bool @@ -97,16 +97,16 @@ isTrustedCipher c = cipherKey :: Maybe RemoteConfig -> Key -> Annex (Maybe (Cipher, Key)) cipherKey Nothing _ = return Nothing cipherKey (Just c) k = maybe Nothing encrypt <$> remoteCipher c - where - encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k) + where + encrypt ciphertext = Just (ciphertext, encryptKey ciphertext k) {- Stores an StorableCipher in a remote's configuration. -} storeCipher :: RemoteConfig -> StorableCipher -> RemoteConfig storeCipher c (SharedCipher t) = M.insert "cipher" (toB64 t) c storeCipher c (EncryptedCipher t ks) = M.insert "cipher" (toB64 t) $ M.insert "cipherkeys" (showkeys ks) c - where - showkeys (KeyIds l) = join "," l + where + showkeys (KeyIds l) = join "," l {- Extracts an StorableCipher from a remote's configuration. -} extractCipher :: RemoteConfig -> Maybe StorableCipher @@ -115,5 +115,5 @@ extractCipher c = (Just t, Just ks) -> Just $ EncryptedCipher (fromB64 t) (readkeys ks) (Just t, Nothing) -> Just $ SharedCipher (fromB64 t) _ -> Nothing - where - readkeys = KeyIds . split "," + where + readkeys = KeyIds . split "," diff --git a/Remote/Helper/Hooks.hs b/Remote/Helper/Hooks.hs index eb788bc3e..91190d841 100644 --- a/Remote/Helper/Hooks.hs +++ b/Remote/Helper/Hooks.hs @@ -25,16 +25,16 @@ addHooks r = addHooks' r <$> lookupHook r "start" <*> lookupHook r "stop" addHooks' :: Remote -> Maybe String -> Maybe String -> Remote addHooks' r Nothing Nothing = r addHooks' r starthook stophook = r' - where - r' = r - { storeKey = \k f p -> wrapper $ storeKey r k f p - , retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d - , retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f - , removeKey = \k -> wrapper $ removeKey r k - , hasKey = \k -> wrapper $ hasKey r k - } - where - wrapper = runHooks r' starthook stophook + where + r' = r + { storeKey = \k f p -> wrapper $ storeKey r k f p + , retrieveKeyFile = \k f d -> wrapper $ retrieveKeyFile r k f d + , retrieveKeyFileCheap = \k f -> wrapper $ retrieveKeyFileCheap r k f + , removeKey = \k -> wrapper $ removeKey r k + , hasKey = \k -> wrapper $ hasKey r k + } + where + wrapper = runHooks r' starthook stophook runHooks :: Remote -> Maybe String -> Maybe String -> Annex a -> Annex a runHooks r starthook stophook a = do @@ -44,50 +44,49 @@ runHooks r starthook stophook a = do liftIO $ createDirectoryIfMissing True dir firstrun lck a - where - remoteid = show (uuid r) - run Nothing = noop - run (Just command) = void $ liftIO $ - boolSystem "sh" [Param "-c", Param command] - firstrun lck = do - -- Take a shared lock; This indicates that git-annex - -- is using the remote, and prevents other instances - -- of it from running the stophook. If another - -- instance is shutting down right now, this - -- will block waiting for its exclusive lock to clear. - lockFile lck + where + remoteid = show (uuid r) + run Nothing = noop + run (Just command) = void $ liftIO $ + boolSystem "sh" [Param "-c", Param command] + firstrun lck = do + -- Take a shared lock; This indicates that git-annex + -- is using the remote, and prevents other instances + -- of it from running the stophook. If another + -- instance is shutting down right now, this + -- will block waiting for its exclusive lock to clear. + lockFile lck - -- The starthook is run even if some other git-annex - -- is already running, and ran it before. - -- It would be difficult to use locking to ensure - -- it's only run once, and it's also possible for - -- git-annex to be interrupted before it can run the - -- stophook, in which case the starthook - -- would be run again by the next git-annex. - -- So, requiring idempotency is the right approach. - run starthook + -- The starthook is run even if some other git-annex + -- is already running, and ran it before. + -- It would be difficult to use locking to ensure + -- it's only run once, and it's also possible for + -- git-annex to be interrupted before it can run the + -- stophook, in which case the starthook + -- would be run again by the next git-annex. + -- So, requiring idempotency is the right approach. + run starthook - Annex.addCleanup (remoteid ++ "-stop-command") $ - runstop lck - runstop lck = do - -- Drop any shared lock we have, and take an - -- exclusive lock, without blocking. If the lock - -- succeeds, we're the only process using this remote, - -- so can stop it. - unlockFile lck - mode <- annexFileMode - fd <- liftIO $ noUmask mode $ - openFd lck ReadWrite (Just mode) defaultFileFlags - v <- liftIO $ tryIO $ - setLock fd (WriteLock, AbsoluteSeek, 0, 0) - case v of - Left _ -> noop - Right _ -> run stophook - liftIO $ closeFd fd + Annex.addCleanup (remoteid ++ "-stop-command") $ runstop lck + runstop lck = do + -- Drop any shared lock we have, and take an + -- exclusive lock, without blocking. If the lock + -- succeeds, we're the only process using this remote, + -- so can stop it. + unlockFile lck + mode <- annexFileMode + fd <- liftIO $ noUmask mode $ + openFd lck ReadWrite (Just mode) defaultFileFlags + v <- liftIO $ tryIO $ + setLock fd (WriteLock, AbsoluteSeek, 0, 0) + case v of + Left _ -> noop + Right _ -> run stophook + liftIO $ closeFd fd lookupHook :: Remote -> String -> Annex (Maybe String) lookupHook r n = go =<< getRemoteConfig (repo r) hookname "" - where - go "" = return Nothing - go command = return $ Just command - hookname = n ++ "-command" + where + go "" = return Nothing + go command = return $ Just command + hookname = n ++ "-command" diff --git a/Remote/Helper/Special.hs b/Remote/Helper/Special.hs index 3f6c9c155..f25ee8ee0 100644 --- a/Remote/Helper/Special.hs +++ b/Remote/Helper/Special.hs @@ -23,18 +23,18 @@ findSpecialRemotes :: String -> Annex [Git.Repo] findSpecialRemotes s = do m <- fromRepo Git.config liftIO $ mapM construct $ remotepairs m - where - remotepairs = M.toList . M.filterWithKey match - construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown - match k _ = startswith "remote." k && endswith (".annex-"++s) k + where + remotepairs = M.toList . M.filterWithKey match + construct (k,_) = Git.Construct.remoteNamedFromKey k Git.Construct.fromUnknown + match k _ = startswith "remote." k && endswith (".annex-"++s) k {- Sets up configuration for a special remote in .git/config. -} gitConfigSpecialRemote :: UUID -> RemoteConfig -> String -> String -> Annex () gitConfigSpecialRemote u c k v = do set ("annex-"++k) v set ("annex-uuid") (fromUUID u) - where - set a b = inRepo $ Git.Command.run "config" - [Param (configsetting a), Param b] - remotename = fromJust (M.lookup "name" c) - configsetting s = "remote." ++ remotename ++ "." ++ s + where + set a b = inRepo $ Git.Command.run "config" + [Param (configsetting a), Param b] + remotename = fromJust (M.lookup "name" c) + configsetting s = "remote." ++ remotename ++ "." ++ s diff --git a/Remote/Helper/Ssh.hs b/Remote/Helper/Ssh.hs index 4434bc65d..b6da80ec6 100644 --- a/Remote/Helper/Ssh.hs +++ b/Remote/Helper/Ssh.hs @@ -1,6 +1,6 @@ {- git-annex remote access with ssh - - - Copyright 2011.2012 Joey Hess <joey@kitenet.net> + - Copyright 2011,2012 Joey Hess <joey@kitenet.net> - - Licensed under the GNU GPL version 3 or higher. -} @@ -34,22 +34,22 @@ git_annex_shell r command params fields sshparams <- sshToRepo r [Param $ sshcmd uuid ] return $ Just ("ssh", sshparams) | otherwise = return Nothing - where - dir = Git.repoPath r - shellcmd = "git-annex-shell" - shellopts = Param command : File dir : params - sshcmd uuid = unwords $ - shellcmd : map shellEscape (toCommand shellopts) ++ - uuidcheck uuid ++ - map shellEscape (toCommand fieldopts) - uuidcheck NoUUID = [] - uuidcheck (UUID u) = ["--uuid", u] - fieldopts - | null fields = [] - | otherwise = fieldsep : map fieldopt fields ++ [fieldsep] - fieldsep = Param "--" - fieldopt (field, value) = Param $ - fieldName field ++ "=" ++ value + where + dir = Git.repoPath r + shellcmd = "git-annex-shell" + shellopts = Param command : File dir : params + sshcmd uuid = unwords $ + shellcmd : map shellEscape (toCommand shellopts) ++ + uuidcheck uuid ++ + map shellEscape (toCommand fieldopts) + uuidcheck NoUUID = [] + uuidcheck (UUID u) = ["--uuid", u] + fieldopts + | null fields = [] + | otherwise = fieldsep : map fieldopt fields ++ [fieldsep] + fieldsep = Param "--" + fieldopt (field, value) = Param $ + fieldName field ++ "=" ++ value {- Uses a supplied function (such as boolSystem) to run a git-annex-shell - command on a remote. |