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