1{- git-remote-gcrypt support 2 - 3 - https://spwhitton.name/tech/code/git-remote-gcrypt/ 4 - 5 - Copyright 2013 Joey Hess <id@joeyh.name> 6 - 7 - Licensed under the GNU AGPL version 3 or higher. 8 -} 9 10{-# LANGUAGE OverloadedStrings #-} 11 12module Git.GCrypt where 13 14import Common 15import Git.Types 16import Git.Construct 17import qualified Git.Config as Config 18import qualified Git.Command as Command 19import Utility.Gpg 20 21import qualified Data.ByteString as S 22import qualified Network.URI 23 24urlScheme :: String 25urlScheme = "gcrypt:" 26 27urlPrefix :: String 28urlPrefix = urlScheme ++ ":" 29 30isEncrypted :: Repo -> Bool 31isEncrypted Repo { location = Url url } = urlPrefix `isPrefixOf` show url 32isEncrypted Repo { location = UnparseableUrl url } = urlPrefix `isPrefixOf` url 33isEncrypted _ = False 34 35{- The first Repo is the git repository that has the second Repo 36 - as one of its remotes. 37 - 38 - When the remote Repo uses gcrypt, returns the actual underlying 39 - git repository that gcrypt is using to store its data. 40 - 41 - Throws an exception if the repo does not use gcrypt. 42 -} 43encryptedRemote :: Repo -> Repo -> IO Repo 44encryptedRemote baserepo = go 45 where 46 go Repo { location = Url url } = go' (show url) 47 go Repo { location = UnparseableUrl url } = go' url 48 go _ = notencrypted 49 50 go' u 51 | urlPrefix `isPrefixOf` u = 52 let l = drop plen u 53 -- Git.Construct.fromUrl escapes characters 54 -- that are not allowed in URIs (though git 55 -- allows them); need to de-escape any such 56 -- to get back the path to the repository. 57 l' = Network.URI.unEscapeString l 58 in fromRemoteLocation l' baserepo 59 | otherwise = notencrypted 60 61 notencrypted = giveup "not a gcrypt encrypted repository" 62 63 plen = length urlPrefix 64 65data ProbeResult = Decryptable | NotDecryptable | NotEncrypted 66 67{- Checks if the git repo at a location uses gcrypt. 68 - 69 - Rather expensive -- many need to fetch the entire repo contents. 70 - (Which is fine if the repo is going to be added as a remote..) 71 -} 72probeRepo :: String -> Repo -> IO ProbeResult 73probeRepo loc baserepo = do 74 let p = proc "git" $ toCommand $ Command.gitCommandLine 75 [ Param "remote-gcrypt" 76 , Param "--check" 77 , Param loc 78 ] baserepo 79 withCreateProcess p $ \_ _ _ pid -> do 80 code <- waitForProcess pid 81 return $ case code of 82 ExitSuccess -> Decryptable 83 ExitFailure 1 -> NotDecryptable 84 ExitFailure _ -> NotEncrypted 85 86type GCryptId = String 87 88{- gcrypt gives each encrypted repository a uique gcrypt-id, 89 - which is stored in the repository (in encrypted form) 90 - and cached in a per-remote gcrypt-id configuration setting. -} 91remoteRepoId :: Repo -> Maybe RemoteName -> Maybe GCryptId 92remoteRepoId r n = fromConfigValue <$> getRemoteConfig "gcrypt-id" r n 93 94getRemoteConfig :: S.ByteString -> Repo -> Maybe RemoteName -> Maybe ConfigValue 95getRemoteConfig field repo remotename = do 96 n <- remotename 97 Config.getMaybe (remoteConfigKey field n) repo 98 99{- Gpg keys that the remote is encrypted for. 100 - If empty, gcrypt uses --default-recipient-self -} 101getParticiantList :: Maybe Repo -> Repo -> Maybe RemoteName -> KeyIds 102getParticiantList globalconfigrepo repo remotename = KeyIds $ parse $ firstJust 103 [ getRemoteConfig "gcrypt-participants" repo remotename 104 , Config.getMaybe defaultkey repo 105 , Config.getMaybe defaultkey =<< globalconfigrepo 106 ] 107 where 108 defaultkey = "gcrypt.participants" 109 parse (Just (ConfigValue "simple")) = [] 110 parse (Just (ConfigValue b)) = words (decodeBS b) 111 parse (Just NoConfigValue) = [] 112 parse Nothing = [] 113 114remoteParticipantConfigKey :: RemoteName -> ConfigKey 115remoteParticipantConfigKey = remoteConfigKey "gcrypt-participants" 116 117remotePublishParticipantConfigKey :: RemoteName -> ConfigKey 118remotePublishParticipantConfigKey = remoteConfigKey "gcrypt-publish-participants" 119 120remoteSigningKey :: RemoteName -> ConfigKey 121remoteSigningKey = remoteConfigKey "gcrypt-signingkey" 122 123remoteConfigKey :: S.ByteString -> RemoteName -> ConfigKey 124remoteConfigKey key remotename = ConfigKey $ 125 "remote." <> encodeBS remotename <> "." <> key 126