diff options
author | 2013-11-14 17:04:58 -0400 | |
---|---|---|
committer | 2013-11-14 17:04:58 -0400 | |
commit | 521ef9dfebd6a9418a5dce7d1686dbf353ddd0a0 (patch) | |
tree | afe6bb5d52e21a049f04020ae448afb81adc02a7 /Git/GCrypt.hs | |
parent | f4b4f327b69189d24663a7db6407c1f7a6e48fdd (diff) | |
parent | 5c6f6e4d0abb9b4856908a500611044b3b7a48e6 (diff) |
Merge branch 'master' into tasty-tests
Conflicts:
Test.hs
Diffstat (limited to 'Git/GCrypt.hs')
-rw-r--r-- | Git/GCrypt.hs | 103 |
1 files changed, 103 insertions, 0 deletions
diff --git a/Git/GCrypt.hs b/Git/GCrypt.hs new file mode 100644 index 000000000..156441dae --- /dev/null +++ b/Git/GCrypt.hs @@ -0,0 +1,103 @@ +{- git-remote-gcrypt support + - + - https://github.com/blake2-ppc/git-remote-gcrypt + - + - Copyright 2013 Joey Hess <joey@kitenet.net> + - + - Licensed under the GNU GPL version 3 or higher. + -} + +module Git.GCrypt where + +import Common +import Git.Types +import Git.Construct +import qualified Git.Config as Config +import qualified Git.Command as Command +import Utility.Gpg + +urlPrefix :: String +urlPrefix = "gcrypt::" + +isEncrypted :: Repo -> Bool +isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url +isEncrypted _ = False + +{- The first Repo is the git repository that has the second Repo + - as one of its remotes. + - + - When the remote Repo uses gcrypt, returns the actual underlying + - git repository that gcrypt is using to store its data. + - + - Throws an exception if an url is invalid or the repo does not use + - gcrypt. + -} +encryptedRemote :: Repo -> Repo -> IO Repo +encryptedRemote baserepo = go + where + go Repo { location = Url url } + | urlPrefix `isPrefixOf` u = + fromRemoteLocation (drop plen u) baserepo + | otherwise = notencrypted + where + u = show url + plen = length urlPrefix + go _ = notencrypted + notencrypted = error "not a gcrypt encrypted repository" + +data ProbeResult = Decryptable | NotDecryptable | NotEncrypted + +{- Checks if the git repo at a location uses gcrypt. + - + - Rather expensive -- many need to fetch the entire repo contents. + - (Which is fine if the repo is going to be added as a remote..) + -} +probeRepo :: String -> Repo -> IO ProbeResult +probeRepo loc baserepo = do + let p = proc "git" $ toCommand $ Command.gitCommandLine + [ Param "remote-gcrypt" + , Param "--check" + , Param loc + ] baserepo + (_, _, _, pid) <- createProcess p + code <- waitForProcess pid + return $ case code of + ExitSuccess -> Decryptable + ExitFailure 1 -> NotDecryptable + ExitFailure _ -> NotEncrypted + +type GCryptId = String + +{- gcrypt gives each encrypted repository a uique gcrypt-id, + - which is stored in the repository (in encrypted form) + - and cached in a per-remote gcrypt-id configuration setting. -} +remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId +remoteRepoId = getRemoteConfig "gcrypt-id" + +getRemoteConfig :: String -> Repo -> Maybe RemoteName -> Maybe String +getRemoteConfig field repo remotename = do + n <- remotename + Config.getMaybe (remoteConfigKey field n) repo + +{- Gpg keys that the remote is encrypted for. + - If empty, gcrypt uses --default-recipient-self -} +getParticiantList :: Maybe Repo -> Repo -> Maybe RemoteName -> KeyIds +getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust + [ getRemoteConfig "gcrypt-participants" repo remotename + , Config.getMaybe defaultkey repo + , Config.getMaybe defaultkey =<< globalconfigrepo + ] + where + defaultkey = "gcrypt.participants" + parse (Just "simple") = [] + parse (Just l) = words l + parse Nothing = [] + +remoteParticipantConfigKey :: RemoteName -> String +remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants" + +remoteSigningKey :: RemoteName -> String +remoteSigningKey = remoteConfigKey "gcrypt-signingkey" + +remoteConfigKey :: String -> RemoteName -> String +remoteConfigKey key remotename = "remote." ++ remotename ++ "." ++ key |