summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
Diffstat
-rw-r--r--cokiki.hs13
-rw-r--r--kiki.cabal14
-rw-r--r--kiki.hs61
-rw-r--r--lib/Base58.hs4
-rw-r--r--lib/GnuPGAgent.hs198
-rw-r--r--lib/KeyRing.hs730
-rw-r--r--lib/Kiki.hs182
-rw-r--r--lib/PEM.hs12
-rw-r--r--lib/PacketTranscoder.hs306
-rw-r--r--lib/SSHKey.hs15
-rw-r--r--lib/TimeUtil.hs2
-rw-r--r--lib/Types.hs298
12 files changed, 1261 insertions, 574 deletions
diff --git a/cokiki.hs b/cokiki.hs
index 8e6ec35..b6d94a0 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -19,6 +19,7 @@ import System.Exit
19import System.IO 19import System.IO
20import System.Posix.User 20import System.Posix.User
21import CommandLine 21import CommandLine
22import Data.OpenPGP (SymmetricAlgorithm(Unencrypted))
22import qualified Hosts 23import qualified Hosts
23 24
24usage = unlines 25usage = unlines
@@ -66,7 +67,7 @@ main = do
66 ["ssh-server"] -> Just $ sshServer uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir 67 ["ssh-server"] -> Just $ sshServer uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
67 ["strongswan"] -> Just $ strongswan uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir 68 ["strongswan"] -> Just $ strongswan uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
68 ["tor"] -> Just $ configureTor uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir 69 ["tor"] -> Just $ configureTor uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
69 ["hosts"] -> Just $ configureHosts uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir 70 ["hosts"] -> Just $ configureHosts uid <$> Kiki.ㄧchroot <*> Kiki.ㄧhomedir
70 _ -> Nothing 71 _ -> Nothing
71 spec = uncurry fancy Kiki.kikiOptions "" 72 spec = uncurry fancy Kiki.kikiOptions ""
72 errorQuit msg = do 73 errorQuit msg = do
@@ -122,7 +123,7 @@ sshClient uid root cmn = whenRoot uid root cmn $ do
122 maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig' 123 maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig'
123 124
124 -- /var/cache/kiki/config/ssh_known_hosts <-- contains known hosts from /root/.gnupg/... 125 -- /var/cache/kiki/config/ssh_known_hosts <-- contains known hosts from /root/.gnupg/...
125 Kiki.importAndRefresh root cmn 126 Kiki.importAndRefresh root cmn Unencrypted
126 127
127sshServer uid root cmn = whenRoot uid root cmn $ do 128sshServer uid root cmn = whenRoot uid root cmn $ do
128 sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/sshd_config") 129 sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/sshd_config")
@@ -135,7 +136,7 @@ sshServer uid root cmn = whenRoot uid root cmn $ do
135 hPutStrLn stderr "adding HostKey directive" 136 hPutStrLn stderr "adding HostKey directive"
136 myWriteFile (root "/etc/ssh/sshd_config") $ unparseSshConfig sshconfig' 137 myWriteFile (root "/etc/ssh/sshd_config") $ unparseSshConfig sshconfig'
137 -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/config/ssh_host_ecdsa_key' etc. 138 -- /etc/ssh/sshd_config <-- 'HostKey /var/cache/kiki/config/ssh_host_ecdsa_key' etc.
138 Kiki.importAndRefresh root cmn 139 Kiki.importAndRefresh root cmn Unencrypted
139 140
140strongswan uid root cmn = whenRoot uid root cmn $ do 141strongswan uid root cmn = whenRoot uid root cmn $ do
141 -- (1) /etc/ipsec.conf <-- 'include /var/cache/kiki/config/ipsec.conf' 142 -- (1) /etc/ipsec.conf <-- 'include /var/cache/kiki/config/ipsec.conf'
@@ -161,7 +162,7 @@ strongswan uid root cmn = whenRoot uid root cmn $ do
161 stmt = ["include", " ", "/var/cache/kiki/config/ipsec.secrets"] 162 stmt = ["include", " ", "/var/cache/kiki/config/ipsec.secrets"]
162 hPutStrLn stderr "adding include directive" 163 hPutStrLn stderr "adding include directive"
163 myWriteFile (root "/etc/ipsec.secrets") $ unparseSshConfig ipsecconf' 164 myWriteFile (root "/etc/ipsec.secrets") $ unparseSshConfig ipsecconf'
164 Kiki.importAndRefresh root cmn 165 Kiki.importAndRefresh root cmn Unencrypted
165 166
166configureTor uid root cmn = whenRoot uid root cmn $ do 167configureTor uid root cmn = whenRoot uid root cmn $ do
167 -- Parsing as if ssh config, that's not right, but good enough for now. 168 -- Parsing as if ssh config, that's not right, but good enough for now.
@@ -215,11 +216,11 @@ configureTor uid root cmn = whenRoot uid root cmn $ do
215 , ["HiddenServicePort"," ","22"," ","127.0.0.1:22"] 216 , ["HiddenServicePort"," ","22"," ","127.0.0.1:22"]
216 , ["HiddenServicePort"," ","25"," ","127.0.0.1:25"] ] 217 , ["HiddenServicePort"," ","25"," ","127.0.0.1:25"] ]
217 myWriteFile (root "/etc/tor/torrc") $ unparseSshConfig torrc' 218 myWriteFile (root "/etc/tor/torrc") $ unparseSshConfig torrc'
218 Kiki.importAndRefresh root cmn 219 Kiki.importAndRefresh root cmn Unencrypted
219 return () 220 return ()
220 221
221configureHosts uid root cmn = whenRoot uid root cmn $ do 222configureHosts uid root cmn = whenRoot uid root cmn $ do
222 Kiki.importAndRefresh root cmn 223 Kiki.importAndRefresh root cmn Unencrypted
223 hosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/etc/hosts") 224 hosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/etc/hosts")
224 kikihosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/var/cache/kiki/config/hosts") 225 kikihosts <- Hosts.decode . fromMaybe "" <$> maybeReadFile (root "/var/cache/kiki/config/hosts")
225 let hosts' = hosts `Hosts.plus` kikihosts 226 let hosts' = hosts `Hosts.plus` kikihosts
diff --git a/kiki.cabal b/kiki.cabal
index 3084908..012bdf9 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -35,7 +35,6 @@ Executable kiki
35 binary, 35 binary,
36 bytestring, 36 bytestring,
37 containers, 37 containers,
38 dataenc,
39 directory, 38 directory,
40 filepath, 39 filepath,
41 tar, 40 tar,
@@ -48,7 +47,7 @@ Executable kiki
48 other-modules: DNSKey 47 other-modules: DNSKey
49 if !flag(cryptonite) 48 if !flag(cryptonite)
50 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any, 49 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any,
51 crypto-pubkey-types -any 50 crypto-pubkey-types -any, dataenc
52 if flag(hourglass) 51 if flag(hourglass)
53 Build-Depends: hourglass -any, x509 >=1.5 && <1.6 52 Build-Depends: hourglass -any, x509 >=1.5 && <1.6
54 else 53 else
@@ -71,6 +70,7 @@ Executable cokiki
71 unix, 70 unix,
72 directory, 71 directory,
73 deepseq, 72 deepseq,
73 openpgp-util,
74 kiki 74 kiki
75 75
76library 76library
@@ -89,11 +89,14 @@ library
89 CommandLine, 89 CommandLine,
90 Numeric.Interval, 90 Numeric.Interval,
91 Numeric.Interval.Bounded, 91 Numeric.Interval.Bounded,
92 SuperOrd 92 SuperOrd,
93 FunctorToMaybe,
94 GnuPGAgent
93 other-modules: TimeUtil, 95 other-modules: TimeUtil,
94 ControlMaybe, 96 ControlMaybe,
95 Compat, 97 Compat,
96 FunctorToMaybe 98 Types,
99 PacketTranscoder
97 100
98 Build-Depends: base >=4.6.0.0, 101 Build-Depends: base >=4.6.0.0,
99 asn1-encoding, 102 asn1-encoding,
@@ -101,7 +104,6 @@ library
101 binary, 104 binary,
102 bytestring, 105 bytestring,
103 containers, 106 containers,
104 dataenc,
105 directory, 107 directory,
106 filepath, 108 filepath,
107 network, 109 network,
@@ -120,7 +122,7 @@ library
120 122
121 if !flag(cryptonite) 123 if !flag(cryptonite)
122 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any, 124 Build-Depends: crypto-pubkey >=0.2.3, cryptohash -any,
123 crypto-pubkey-types -any 125 crypto-pubkey-types -any, dataenc
124 if flag(hourglass) 126 if flag(hourglass)
125 Build-Depends: hourglass -any, x509 >=1.5 && <1.6 127 Build-Depends: hourglass -any, x509 >=1.5 && <1.6
126 else 128 else
diff --git a/kiki.hs b/kiki.hs
index eabfbf3..d3e505a 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -34,7 +34,12 @@ import System.Directory
34import System.Environment 34import System.Environment
35import System.Exit 35import System.Exit
36import System.IO (hPutStrLn,stderr) 36import System.IO (hPutStrLn,stderr)
37#if defined(VERSION_memory)
38import qualified Data.ByteString.Char8 as S8
39import Data.ByteArray.Encoding
40#elif defined(VERSION_dataenc)
37import qualified Codec.Binary.Base64 as Base64 41import qualified Codec.Binary.Base64 as Base64
42#endif
38import qualified Codec.Archive.Tar as Tar 43import qualified Codec.Archive.Tar as Tar
39import qualified Codec.Archive.Tar.Entry as Tar 44import qualified Codec.Archive.Tar.Entry as Tar
40#if !defined(VERSION_cryptonite) 45#if !defined(VERSION_cryptonite)
@@ -69,6 +74,7 @@ import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
69import Kiki 74import Kiki
70import Debug.Trace 75import Debug.Trace
71import Network.Socket (SockAddr) 76import Network.Socket (SockAddr)
77import FunctorToMaybe
72 78
73-- {-# ANN module ("HLint: ignore Eta reduce"::String) #-} 79-- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
74-- {-# ANN module ("HLint: ignore Use camelCase"::String) #-} 80-- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
@@ -194,6 +200,7 @@ listKeysFiltered grips pkts = do
194 , formkind 200 , formkind
195 , " " 201 , " "
196 , fingerprint sub 202 , fingerprint sub
203 , kcipher sub
197 -- , " " ++ (torhash sub) 204 -- , " " ++ (torhash sub)
198 -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub)) 205 -- , " " ++ (concatMap (printf "%02X") $ S.unpack (ecc_curve sub))
199 ] -- ++ ppShow hashed 206 ] -- ++ ppShow hashed
@@ -202,6 +209,8 @@ listKeysFiltered grips pkts = do
202 -- then (" " ++ "BTC " ++ bitcoinAddress sub) : showsigs claimants 209 -- then (" " ++ "BTC " ++ bitcoinAddress sub) : showsigs claimants
203 then (" " ++ "¢ "++kind'++":" ++ bitcoinAddress netid sub) : showsigs claimants 210 then (" " ++ "¢ "++kind'++":" ++ bitcoinAddress netid sub) : showsigs claimants
204 else showsigs claimants 211 else showsigs claimants
212 kcipher k = if isSecretKey k then " " ++ ciphername (symmetric_algorithm k)
213 else ""
205 torkeys = do 214 torkeys = do
206 (code,(top,sub), kind, hashed,claimants) <- subs 215 (code,(top,sub), kind, hashed,claimants) <- subs
207 guard ("tor" `elem` kind) 216 guard ("tor" `elem` kind)
@@ -236,7 +245,7 @@ listKeysFiltered grips pkts = do
236 listToMaybe $ filter match torkeys 245 listToMaybe $ filter match torkeys
237 unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary 246 unlines $ (" " ++ ar ++ "@" ++ " " ++ uid_full parsed) : showsigs secondary
238 -- (_,sigs) = unzip certs 247 -- (_,sigs) = unzip certs
239 "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n" 248 "master-key " ++ fingerprint top ++ kcipher top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n"
240 249
241 250
242{- 251{-
@@ -285,10 +294,22 @@ show_wk secring_file grip db = do
285 Message sec = flattenKeys False sec_db 294 Message sec = flattenKeys False sec_db
286 putStrLn $ listKeysFiltered (maybeToList grip) sec 295 putStrLn $ listKeysFiltered (maybeToList grip) sec
287 296
297debug_dump secring_file grip db = do
298 let sec_db = Map.filter gripmatch db
299 gripmatch (KeyData p _ _ _) =
300 Map.member secring_file (locations p)
301 || Map.member "&secret" (locations p)
302 Message sec = flattenKeys False sec_db
303 mapM_ print sec
304
288show_all db = do 305show_all db = do
289 let Message packets = flattenKeys True db 306 let Message packets = flattenKeys True db
290 putStrLn $ listKeys packets 307 putStrLn $ listKeys packets
291 308
309show_packets puborsec db = do
310 let Message packets = flattenKeys (case puborsec of { "sec":_ -> False; _ -> True }) db
311 forM_ packets $ putStrLn . showPacket
312
292show_whose_key input_key db = 313show_whose_key input_key db =
293 flip (maybe $ return ()) input_key $ \input_key -> do 314 flip (maybe $ return ()) input_key $ \input_key -> do
294 let ks = whoseKey input_key db 315 let ks = whoseKey input_key db
@@ -305,7 +326,11 @@ dnsPresentationFromPacket k = do
305 let RSAKey (MPI n) (MPI e) = fromJust $ rsaKeyFromPacket k 326 let RSAKey (MPI n) (MPI e) = fromJust $ rsaKeyFromPacket k
306 dnskey = DNS.RSA n e 327 dnskey = DNS.RSA n e
307 bin = runPut (DNS.putRSA dnskey) 328 bin = runPut (DNS.putRSA dnskey)
329#if defined(VERSION_memory)
330 qq = S8.unpack $ convertToBase Base64 (L.toStrict bin)
331#elif defined(VERSION_dataenc)
308 qq = Base64.encode (L.unpack bin) 332 qq = Base64.encode (L.unpack bin)
333#endif
309 ttl = 24*60*60 -- 24 hours in seconds 334 ttl = 24*60*60 -- 24 hours in seconds
310 flags = 256 -- (ZONE-key = bit7) TODO: is this a zone key or a key-signing key? 335 flags = 256 -- (ZONE-key = bit7) TODO: is this a zone key or a key-signing key?
311 algo = 8 -- RSASHA256 -- TODO: support other algorithm 336 algo = 8 -- RSASHA256 -- TODO: support other algorithm
@@ -340,7 +365,11 @@ show_wip keyspec wkgrip db = do
340show_torhash pubkey _ = do 365show_torhash pubkey _ = do
341 bs <- Char8.readFile pubkey 366 bs <- Char8.readFile pubkey
342 let parsekey f dta = do 367 let parsekey f dta = do
368#if defined(VERSION_memory)
369 let mdta = fmap L.fromStrict $ functorToMaybe $ convertFromBase Base64 (Char8.toStrict dta)
370#elif defined(VERSION_dataenc)
343 let mdta = L.pack <$> Base64.decode (Char8.unpack dta) 371 let mdta = L.pack <$> Base64.decode (Char8.unpack dta)
372#endif
344 e <- decodeASN1 DER <$> mdta 373 e <- decodeASN1 DER <$> mdta
345 asn1 <- either (const Nothing) (Just) e 374 asn1 <- either (const Nothing) (Just) e
346 k <- either (const Nothing) (Just . fst) (fromASN1 asn1) 375 k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
@@ -370,7 +399,11 @@ show_cert keyspec wkgrip db = do
370 -} 399 -}
371 let cs = mapMaybe x509cert $ (sigs >>= hashed_subpackets) 400 let cs = mapMaybe x509cert $ (sigs >>= hashed_subpackets)
372 ds = map decodeBlob $ map (ParsedCert k (posixSecondsToUTCTime $ fromIntegral $ timestamp k)) cs 401 ds = map decodeBlob $ map (ParsedCert k (posixSecondsToUTCTime $ fromIntegral $ timestamp k)) cs
402#if defined(VERSION_memory)
403 qqs = map (S8.unpack . convertToBase Base64 . L.toStrict) ds
404#elif defined(VERSION_dataenc)
373 qqs = map (Base64.encode . L.unpack) ds 405 qqs = map (Base64.encode . L.unpack) ds
406#endif
374 pems = map (writePEM "CERTIFICATE") qqs 407 pems = map (writePEM "CERTIFICATE") qqs
375 forM_ pems putStrLn 408 forM_ pems putStrLn
376 _ -> void $ warn (keyspec ++ ": ambiguous") 409 _ -> void $ warn (keyspec ++ ": ambiguous")
@@ -528,6 +561,8 @@ kiki_usage bExport bImport bSecret cmd = putStr $
528 ," Outputs tor address and base32 hash of the PEM-format key in" 561 ," Outputs tor address and base32 hash of the PEM-format key in"
529 ," the given file." 562 ," the given file."
530 ,"" 563 ,""
564 ," --dump For debugging, a thorough info dump of your secret keyring."
565 ,""
531 ," --help Shows this help screen." 566 ," --help Shows this help screen."
532 ,"" 567 ,""
533 ] 568 ]
@@ -1115,8 +1150,8 @@ sync bExport bImport bSecret cmdarg args_raw = do
1115 ++ pems 1150 ++ pems
1116 ++ if bSecret then walts else [] 1151 ++ if bSecret then walts else []
1117 ++ hosts 1152 ++ hosts
1118 , opPassphrases = do pfile <- maybeToList passfd 1153 , opPassphrases = withAgent $ do pfile <- maybeToList passfd
1119 return $ PassphraseSpec Nothing Nothing pfile 1154 return $ PassphraseSpec Nothing Nothing pfile
1120 , opTransforms = maybe [] (const [Autosign]) $ Map.lookup "--autosign" margs 1155 , opTransforms = maybe [] (const [Autosign]) $ Map.lookup "--autosign" margs
1121 , opHome = homespec 1156 , opHome = homespec
1122 } 1157 }
@@ -1186,8 +1221,10 @@ kiki "show" [] = kiki "show" ["--working"]
1186kiki "show" args = do 1221kiki "show" args = do
1187 let (sargs,margs) = processArgs sargspec polyVariadicArgs "--show" args 1222 let (sargs,margs) = processArgs sargspec polyVariadicArgs "--show" args
1188 sargspec = [ ("--working",0) --("--show-wk",0) 1223 sargspec = [ ("--working",0) --("--show-wk",0)
1224 , ("--dump",0) --("--show-all",0)
1189 , ("--all",0) --("--show-all",0) 1225 , ("--all",0) --("--show-all",0)
1190 , ("--whose-key",0) 1226 , ("--whose-key",0)
1227 , ("--packets",1)
1191 , ("--key",1) 1228 , ("--key",1)
1192 , ("--pem",1) 1229 , ("--pem",1)
1193 , ("--dns",1) 1230 , ("--dns",1)
@@ -1220,8 +1257,8 @@ kiki "show" args = do
1220 ++ pems 1257 ++ pems
1221 ++ walts 1258 ++ walts
1222 ++ hosts 1259 ++ hosts
1223 , opPassphrases = do pfile <- maybeToList passfd 1260 , opPassphrases = withAgent $ do pfile <- maybeToList passfd
1224 return $ PassphraseSpec Nothing Nothing pfile 1261 return $ PassphraseSpec Nothing Nothing pfile
1225 , opTransforms = [] 1262 , opTransforms = []
1226 , opHome = homespec 1263 , opHome = homespec
1227 } 1264 }
@@ -1239,6 +1276,7 @@ kiki "show" args = do
1239 let shspec = Map.fromList [("--working", const $ show_wk (rtSecring rt) grip) 1276 let shspec = Map.fromList [("--working", const $ show_wk (rtSecring rt) grip)
1240 ,("--all",const show_all) 1277 ,("--all",const show_all)
1241 ,("--whose-key", const $ show_whose_key input_key) 1278 ,("--whose-key", const $ show_whose_key input_key)
1279 ,("--packets", show_packets)
1242 ,("--key",\[x] -> show_id x $ fromMaybe "" grip) 1280 ,("--key",\[x] -> show_id x $ fromMaybe "" grip)
1243 ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip) 1281 ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip)
1244 ,("--dns",\[x] -> show_dns x $ fromMaybe "" grip) 1282 ,("--dns",\[x] -> show_dns x $ fromMaybe "" grip)
@@ -1246,6 +1284,7 @@ kiki "show" args = do
1246 ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip) 1284 ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip)
1247 ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip) 1285 ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip)
1248 ,("--torhash",\[x] -> show_torhash x) 1286 ,("--torhash",\[x] -> show_torhash x)
1287 ,("--dump", const $ debug_dump (rtSecring rt) grip)
1249 ] 1288 ]
1250 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs 1289 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs
1251 1290
@@ -1459,7 +1498,8 @@ kiki "init" args | "--help" `elem` args = do
1459 putStr . unlines $ 1498 putStr . unlines $
1460 [ "kiki init [ --passphrase-fd=FD" 1499 [ "kiki init [ --passphrase-fd=FD"
1461 , " | --homedir[=HOMEDIR]" 1500 , " | --homedir[=HOMEDIR]"
1462 , " | --chroot=ROOTDIR ] ..." 1501 , " | --chroot=ROOTDIR ]"
1502 , " | --cipher="++intercalate "|" (map ciphername ciphers)++" ] ..."
1463 , "" 1503 , ""
1464 , "Modify your GnuPG keyring and update /var/cache/kiki. The following" 1504 , "Modify your GnuPG keyring and update /var/cache/kiki. The following"
1465 , "changes will occur to the keyring:" 1505 , "changes will occur to the keyring:"
@@ -1479,9 +1519,10 @@ kiki "init" args | "--help" `elem` args = do
1479 , " variable is ignored and you must use --homedir to specify" 1519 , " variable is ignored and you must use --homedir to specify"
1480 , " a value other than /root/.gnupg." 1520 , " a value other than /root/.gnupg."
1481 , "" 1521 , ""
1522 , ""
1482 ] ++ documentHomeDir ++ [""] ++ documentPassphraseFDFlag True True True 1523 ] ++ documentHomeDir ++ [""] ++ documentPassphraseFDFlag True True True
1483 1524
1484kiki "init" args = run args $ importAndRefresh <$> ㄧchroot <*> ㄧhomedir 1525kiki "init" args = run args $ importAndRefresh <$> ㄧchroot <*> ㄧhomedir <*> ㄧcipher
1485 1526
1486kiki "delete" args | "--help" `elem` args = do 1527kiki "delete" args | "--help" `elem` args = do
1487 putStr . unlines $ 1528 putStr . unlines $
@@ -1504,8 +1545,8 @@ kiki "delete" args = do
1504 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) 1545 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
1505 , ( HomePub, buildStreamInfo KF_All KeyRingFile ) 1546 , ( HomePub, buildStreamInfo KF_All KeyRingFile )
1506 ] 1547 ]
1507 , opPassphrases = do pfile <- maybeToList passfd 1548 , opPassphrases = withAgent $ do pfile <- maybeToList passfd
1508 return $ PassphraseSpec Nothing Nothing pfile 1549 return $ PassphraseSpec Nothing Nothing pfile
1509 , opTransforms = map DeleteSubkeyByFingerprint fps 1550 , opTransforms = map DeleteSubkeyByFingerprint fps
1510 , opHome = homespec 1551 , opHome = homespec
1511 } 1552 }
@@ -1668,7 +1709,7 @@ tarC (sargs,margs) = do
1668 decrypt :: KeyRingRuntime -> Packet -> IO (Maybe Packet) 1709 decrypt :: KeyRingRuntime -> Packet -> IO (Maybe Packet)
1669 decrypt rt k@SecretKeyPacket { symmetric_algorithm = Unencrypted } = return $ Just k 1710 decrypt rt k@SecretKeyPacket { symmetric_algorithm = Unencrypted } = return $ Just k
1670 decrypt rt k = do 1711 decrypt rt k = do
1671 r <- rtPassphrases rt (MappedPacket k Map.empty) 1712 r <- rtPassphrases rt (Unencrypted,S2K 100 "") (MappedPacket k Map.empty)
1672 case r of 1713 case r of
1673 KikiSuccess p -> return $ Just p 1714 KikiSuccess p -> return $ Just p
1674 _ -> do 1715 _ -> do
diff --git a/lib/Base58.hs b/lib/Base58.hs
index 3c1a113..2de841d 100644
--- a/lib/Base58.hs
+++ b/lib/Base58.hs
@@ -38,11 +38,11 @@ base58_decode str = do
38 hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload 38 hash_result = S.take 4 . SHA256.hash . SHA256.hash . S.pack $ a_payload
39#else 39#else
40 hash_result = S.take 4 . convert $ digest 40 hash_result = S.take 4 . convert $ digest
41 where digest = hash (S.pack a_payload) :: Digest SHA256 41 where digest = hash diges1 :: Digest SHA256
42 diges1 = hash (S.pack a_payload) :: Digest SHA256
42#endif 43#endif
43 expected_hash = S.pack $ reverse rcksum 44 expected_hash = S.pack $ reverse rcksum
44 (network_id,payload) = splitAt 1 a_payload 45 (network_id,payload) = splitAt 1 a_payload
45
46 network_id <- listToMaybe network_id 46 network_id <- listToMaybe network_id
47 guard (hash_result==expected_hash) 47 guard (hash_result==expected_hash)
48 return (network_id,payload) 48 return (network_id,payload)
diff --git a/lib/GnuPGAgent.hs b/lib/GnuPGAgent.hs
new file mode 100644
index 0000000..7161b92
--- /dev/null
+++ b/lib/GnuPGAgent.hs
@@ -0,0 +1,198 @@
1{-# LANGUAGE LambdaCase #-}
2{-# LANGUAGE CPP #-}
3{-# LANGUAGE PatternGuards #-}
4module GnuPGAgent
5 ( session
6 , Query(..)
7 , QueryMode(..)
8 , getPassphrase
9 , clearPassphrase
10 , quit
11 , key_nbits) where
12
13import Debug.Trace
14import Control.Monad
15import Data.Char
16import Data.OpenPGP
17import Data.OpenPGP.Util
18import Network.Socket
19import System.Directory
20import System.Environment
21import System.IO
22import Text.Printf
23#if defined(VERSION_memory)
24import qualified Data.ByteString.Char8 as S8
25import Data.ByteArray.Encoding
26#elif defined(VERSION_dataenc)
27import qualified Codec.Binary.Base16 as Base16
28#endif
29import LengthPrefixedBE
30import qualified Data.ByteString.Lazy as L
31#if defined(VERSION_hourglass)
32import Data.Hourglass
33#else
34import Data.Time.Calendar
35import Data.Time.Clock
36import Data.Time.Clock.POSIX
37#endif
38import Data.Word
39
40data GnuPGAgent = GnuPGAgent { agentHandle :: Handle }
41
42session = do
43 envhomedir Nothing gpgHomeSpec >>= \case
44 Just gpghome -> do
45 sock <- socket AF_UNIX Stream defaultProtocol
46 connect sock (SockAddrUnix (gpghome ++ "/S.gpg-agent"))
47 agent <- socketToHandle sock ReadWriteMode
48 hSetBuffering agent LineBuffering
49 lookupEnv "DISPLAY" >>= \case
50 Just display -> do hPutStrLn agent ("option putenv DISPLAY="++display)
51 _ <- hGetLine agent
52 return ()
53 Nothing -> return ()
54 -- TODO: GPG_TTY
55 return $ Just $ GnuPGAgent agent
56 Nothing -> do
57 hPutStrLn stderr "Unable to find home directory."
58 return Nothing
59
60percentPlusEscape :: String -> String
61percentPlusEscape s = do
62 c <- s
63 case c of
64 ' ' -> "+"
65 '+' -> "%2B"
66 '"' -> "%22"
67 '%' -> "%25"
68 _ | c < ' ' -> printf "%%%02X" (ord c)
69 _ -> return c
70
71clearPassphrase agent key = do
72 let cmd = "clear_passphrase --mode=normal "++fingerprint key
73 hPutStrLn (agentHandle agent) cmd
74
75data Query = Query
76 { queryPacket :: Packet
77 , queryUID :: String
78 , queryMainKey :: Maybe Packet
79 }
80 deriving Show
81
82data QueryMode = AskNot | AskAgain String | AskExisting | AskNew
83 deriving (Show,Eq,Ord)
84
85getPassphrase :: GnuPGAgent -> QueryMode -> Query -> IO (Maybe String)
86getPassphrase agent ask (Query key uid masterkey) = do
87 let (er0,pr,desc) = prompts key uid masterkey
88 (er,askopt) = case ask of
89 AskNot -> (er0,"--no-ask ")
90 AskAgain ermsg -> (ermsg,"")
91 AskExisting -> (er0,"")
92 AskNew -> (er0,"--repeat=1 ")
93 cmd = "get_passphrase "++askopt++fingerprint key++" "++unwords (map percentPlusEscape [er,pr,desc])
94 hPutStrLn stderr $ "gpg-agent <- " ++ cmd
95 hPutStrLn (agentHandle agent) cmd
96 r0 <- hGetLine (agentHandle agent)
97 -- hPutStrLn stderr $ "agent says: " ++ r0
98 case takeWhile (/=' ') r0 of
99 "OK" -> hGetLine (agentHandle agent) >>= unhex . drop 3
100 where
101#if defined(VERSION_memory)
102 unhex hx = case convertFromBase Base16 (S8.pack hx) of
103 Left e -> do
104 -- Useful for debugging but insecure generally ;)
105 -- putStrLn $ "convertFromBase error for input "++show hx++": "++show e
106 return Nothing
107 Right bs -> return $ Just $ S8.unpack bs
108#elif defined(VERSION_dataenc)
109 unhex hx = maybe (return () {- putStrLn $ "dataenc error for input "++show hx -})
110 return
111 $ fmap (map $ chr . fromIntegral) $ Base16.decode hx
112#endif
113 "ERR" -> return Nothing
114
115quit (GnuPGAgent h) = hClose h
116
117prompts :: Packet -> String -> Maybe Packet -> (String,String,String)
118prompts key uid masterkey = ("X","X",atext)
119 where
120 atext = printf (concat [ "Please enter the passphrase to unlock the"
121 , " secret key for the OpenPGP certificate:\n"
122 , "\"%s\"\n"
123 , "%d-bit %s key, ID %s,\n"
124 , "created %s%s.\n"])
125 uid
126 (key_nbits key) algo_name (keystr key)
127 timestr maink
128
129 maink
130 | Just k <- masterkey = printf " (main key ID %s)" (drop 32 $ fingerprint k)
131 | otherwise = ""
132
133 algo_name =
134 case key_algorithm key of
135 a | a `elem` [RSA,RSA_E,RSA_S] -> "RSA"
136 ELGAMAL -> "ELG" -- also PUBKEY_ALGO_ELGAMAL_E
137 DSA -> "DSA"
138 ECDSA -> "ECDSA"
139 ECC -> "ECDH"
140 _ -> "?" -- also "EDDSA";
141
142
143 keystr k = drop 32 $ fingerprint k -- FCD7BFB7
144
145 timestr = timeString $ timestamp key -- 2014-01-04
146
147data HomeDir = HomeDir { homevar :: String, appdir :: String }
148gpgHomeSpec :: HomeDir
149gpgHomeSpec = HomeDir
150 { homevar = "GNUPGHOME"
151 , appdir = ".gnupg"
152 }
153
154envhomedir opt home = do
155 gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
156 homed <- fmap (mfilter (/="") . Just) getHomeDirectory
157 let homegnupg = (++('/':(appdir home))) <$> homed
158 let val = (opt `mplus` gnupghome `mplus` homegnupg)
159 return $ val
160
161
162timeString :: Word32 -> String
163timeString t = printf "%d-%d-%d" year month day
164 where
165#if defined(VERSION_hourglass)
166 Date year m day = timeFromElapsed (Elapsed (Seconds $ fromIntegral t))
167 month = fromEnum m + 1
168#else
169 (year,month,day) = toGregorian . utctDay $ posixSecondsToUTCTime (realToFrac t)
170#endif
171
172key_nbits :: Packet -> Int
173key_nbits p@(SecretKeyPacket {}) = _key_nbits (key_algorithm p) (key p)
174key_nbits p@(PublicKeyPacket {}) = _key_nbits (key_algorithm p) (key p)
175key_nbits _ = 0
176
177_key_nbits :: KeyAlgorithm -> [(Char,MPI)] -> Int
178_key_nbits RSA toks | Just n <- lookup 'n' toks = mpi_nbits n
179_key_nbits DSA toks | Just n <- lookup 'p' toks = mpi_nbits n
180_key_nbits ECDSA toks | Just n <- lookup 'c' toks = curve_oid_nbits n
181_key_nbits ELGAMAL toks | Just n <- lookup 'p' toks = mpi_nbits n
182_key_nbits _ _ = 0
183-- unimplemented: RSA_E RSA_S ECC DH / KeyAlgorithm Word8
184
185curve_oid_nbits :: MPI -> Int
186curve_oid_nbits (MPI 0x2a8648ce3d030107 ) = 256 -- SEC p256r1 ( NIST P-256 )
187curve_oid_nbits (MPI 0x2B81040022 ) = 384 -- SEC p384r1 ( NIST P-384 )
188curve_oid_nbits (MPI 0x2B81040023 ) = 521 -- SEC p521r1 ( NIST P-521 )
189curve_oid_nbits (MPI 0x2b8104000a ) = 256 -- SEC p256k1 ( bitcoin curve )
190curve_oid_nbits n = trace ("Unknown curve: "++ show n) 0
191
192
193mpi_nbits (MPI n) = 8 * fromIntegral len
194 where
195 len = case encode_bigendian n of
196 b | L.head b == 0x0 -> L.length b - 1
197 | otherwise -> L.length b
198
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 2c174b3..5953f12 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -23,6 +23,7 @@
23{-# LANGUAGE DoAndIfThenElse #-} 23{-# LANGUAGE DoAndIfThenElse #-}
24{-# LANGUAGE PatternGuards #-} 24{-# LANGUAGE PatternGuards #-}
25{-# LANGUAGE ForeignFunctionInterface #-} 25{-# LANGUAGE ForeignFunctionInterface #-}
26{-# LANGUAGE LambdaCase #-}
26module KeyRing 27module KeyRing
27 ( 28 (
28 -- * Error Handling 29 -- * Error Handling
@@ -47,13 +48,15 @@ module KeyRing
47 , KeyFilter(..) 48 , KeyFilter(..)
48 -- * Results of a KeyRing Operation 49 -- * Results of a KeyRing Operation
49 , KeyRingRuntime(..) 50 , KeyRingRuntime(..)
50 , MappedPacket(..) 51 , OriginMapped(..)
52 , MappedPacket
51 , KeyDB 53 , KeyDB
52 , KeyData(..) 54 , KeyData(..)
53 , SubKey(..) 55 , SubKey(..)
54 , keyflags 56 , keyflags
55 -- * Miscelaneous Utilities 57 -- * Miscelaneous Utilities
56 , isKey 58 , isKey
59 , isSecretKey
57 , derRSA 60 , derRSA
58 , derToBase32 61 , derToBase32
59 , backsig 62 , backsig
@@ -82,6 +85,7 @@ module KeyRing
82 , accBindings 85 , accBindings
83 , isSubkeySignature 86 , isSubkeySignature
84 , torhash 87 , torhash
88 , torUIDFromKey
85 , ParsedCert(..) 89 , ParsedCert(..)
86 , parseCertBlob 90 , parseCertBlob
87 , packetFromPublicRSAKey 91 , packetFromPublicRSAKey
@@ -109,6 +113,8 @@ module KeyRing
109 , writeKeyToFile 113 , writeKeyToFile
110 , resolveForReport 114 , resolveForReport
111 , KeyKey -- needed for Type sigs 115 , KeyKey -- needed for Type sigs
116 , makeMemoizingDecrypter
117 , showPacket
112 ) where 118 ) where
113 119
114import System.Environment 120import System.Environment
@@ -128,7 +134,7 @@ import Data.Bits ( (.|.), (.&.) )
128import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) 134import Control.Applicative ( Applicative, pure, liftA2, (<*>) )
129import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) 135import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
130import Control.Arrow ( first, second ) 136import Control.Arrow ( first, second )
131import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign, generateKey, GenerateKeyParams(..)) 137import Data.OpenPGP.Util
132import Data.ByteString.Lazy ( ByteString ) 138import Data.ByteString.Lazy ( ByteString )
133import Text.Show.Pretty as PP ( ppShow ) 139import Text.Show.Pretty as PP ( ppShow )
134import Data.Binary {- decode, decodeOrFail -} 140import Data.Binary {- decode, decodeOrFail -}
@@ -143,12 +149,15 @@ import Data.Time.Clock ( UTCTime )
143import Data.Bits ( Bits, shiftR ) 149import Data.Bits ( Bits, shiftR )
144import Data.Text.Encoding ( encodeUtf8 ) 150import Data.Text.Encoding ( encodeUtf8 )
145import qualified Data.Map as Map 151import qualified Data.Map as Map
146import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile 152import qualified Data.ByteString.Lazy as L
147 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt 153import qualified Data.ByteString as S
148 , index, break, pack, empty ) 154#if defined(VERSION_memory)
149import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse ) 155import qualified Data.ByteString.Char8 as S8
156import Data.ByteArray.Encoding
157#elif defined(VERSION_dataenc)
150import qualified Codec.Binary.Base32 as Base32 158import qualified Codec.Binary.Base32 as Base32
151import qualified Codec.Binary.Base64 as Base64 159import qualified Codec.Binary.Base64 as Base64
160#endif
152#if !defined(VERSION_cryptonite) 161#if !defined(VERSION_cryptonite)
153import qualified Crypto.Hash.SHA1 as SHA1 162import qualified Crypto.Hash.SHA1 as SHA1
154import qualified Crypto.Types.PubKey.ECC as ECC 163import qualified Crypto.Types.PubKey.ECC as ECC
@@ -180,7 +189,7 @@ import Foreign.C.Error ( throwErrnoIfMinus1_ )
180import Foreign.Storable 189import Foreign.Storable
181#endif 190#endif
182import System.FilePath ( takeDirectory ) 191import System.FilePath ( takeDirectory )
183import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr) 192import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr, hClose)
184import Data.IORef 193import Data.IORef
185import System.Posix.IO ( fdToHandle ) 194import System.Posix.IO ( fdToHandle )
186import qualified Data.Traversable as Traversable 195import qualified Data.Traversable as Traversable
@@ -204,6 +213,9 @@ import Base58
204import FunctorToMaybe 213import FunctorToMaybe
205import DotLock 214import DotLock
206import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) 215import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
216import GnuPGAgent as Agent
217import Types
218import PacketTranscoder
207 219
208-- DER-encoded elliptic curve ids 220-- DER-encoded elliptic curve ids
209-- nistp256_id = 0x2a8648ce3d030107 221-- nistp256_id = 0x2a8648ce3d030107
@@ -240,114 +252,6 @@ home = HomeDir
240 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] 252 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
241 } 253 }
242 254
243data InputFile = HomeSec
244 -- ^ A file named secring.gpg located in the home directory.
245 -- See 'opHome'.
246 | HomePub
247 -- ^ A file named pubring.gpg located in the home directory.
248 -- See 'opHome'.
249 | ArgFile FilePath
250 -- ^ Contents will be read or written from the specified path.
251 | FileDesc Posix.Fd
252 -- ^ Contents will be read or written from the specified file
253 -- descriptor.
254 | Pipe Posix.Fd Posix.Fd
255 -- ^ Contents will be read from the first descriptor and updated
256 -- content will be writen to the second. Note: Don't use Pipe
257 -- for 'Wallet' files. (TODO: Wallet support)
258 | Generate Int GenerateKeyParams
259 -- ^ New key packets will be generated if there is no
260 -- matching content already in the key pool. The integer is
261 -- a unique id number so that multiple generations can be
262 -- inserted into 'opFiles'
263 deriving (Eq,Ord,Show)
264
265-- type UsageTag = String
266data Initializer = NoCreate | Internal GenerateKeyParams | External String
267 deriving (Eq,Ord,Show)
268
269data FileType = KeyRingFile
270 | PEMFile
271 | WalletFile
272 | DNSPresentation
273 | Hosts
274 deriving (Eq,Ord,Enum,Show)
275
276-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
277-- to contain secret or public PGP key packets. Note that it is not supported
278-- to mix both in the same file and that the secret key packets include all of
279-- the information contained in their corresponding public key packets.
280data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
281 -- (see 'rtRingAccess')
282 | Sec -- ^ secret information
283 | Pub -- ^ public information
284 deriving (Eq,Ord,Show)
285
286-- | Note that the documentation here is intended for when this value is
287-- assigned to 'fill'. For other usage, see 'spill'.
288data KeyFilter = KF_None -- ^ No keys will be imported.
289 | KF_Match String -- ^ Only the key that matches the spec will be imported.
290 | KF_Subkeys -- ^ Subkeys will be imported if their owner key is
291 -- already in the ring. TODO: Even if their signatures
292 -- are bad?
293 | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
294 -- identity (signed or self-authenticating).
295 | KF_All -- ^ All keys will be imported.
296 deriving (Eq,Ord,Show)
297
298-- | This type describes how 'runKeyRing' will treat a file.
299data StreamInfo = StreamInfo
300 { access :: Access
301 -- ^ Indicates whether the file is allowed to contain secret information.
302 , typ :: FileType
303 -- ^ Indicates the format and content type of the file.
304 , fill :: KeyFilter
305 -- ^ This filter controls what packets will be inserted into a file.
306 , spill :: KeyFilter
307 --
308 -- ^ Use this to indicate whether or not a file's contents should be
309 -- available for updating other files. Note that although its type is
310 -- 'KeyFilter', it is usually interpretted as a boolean flag. Details
311 -- depend on 'typ' and are as follows:
312 --
313 -- 'KeyRingFile':
314 --
315 -- * 'KF_None' - The file's contents will not be shared.
316 --
317 -- * otherwise - The file's contents will be shared.
318 --
319 -- 'PEMFile':
320 --
321 -- * 'KF_None' - The file's contents will not be shared.
322 --
323 -- * 'KF_Match' - The file's key will be shared with the specified owner
324 -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be
325 -- equal to this value; changing the usage or owner of a key is not
326 -- supported via the fill/spill mechanism.
327 --
328 -- * otherwise - Unspecified. Do not use.
329 --
330 -- 'WalletFile':
331 --
332 -- * The 'spill' setting is ignored and the file's contents are shared.
333 -- (TODO)
334 --
335 -- 'Hosts':
336 --
337 -- * The 'spill' setting is ignored and the file's contents are shared.
338 -- (TODO)
339 --
340 , initializer :: Initializer
341 -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set,
342 -- then it is interpretted as a shell command that may be used to create
343 -- the key if it does not exist.
344 , transforms :: [Transform]
345 -- ^ Per-file transformations that occur before the contents of a file are
346 -- spilled into the common pool.
347 }
348 deriving (Eq,Show)
349
350
351spillable :: StreamInfo -> Bool 255spillable :: StreamInfo -> Bool
352spillable (spill -> KF_None) = False 256spillable (spill -> KF_None) = False
353spillable _ = True 257spillable _ = True
@@ -379,6 +283,7 @@ usageFromFilter :: MonadPlus m => KeyFilter -> m String
379usageFromFilter (KF_Match usage) = return usage 283usageFromFilter (KF_Match usage) = return usage
380usageFromFilter _ = mzero 284usageFromFilter _ = mzero
381 285
286
382data KeyRingRuntime = KeyRingRuntime 287data KeyRingRuntime = KeyRingRuntime
383 { rtPubring :: FilePath 288 { rtPubring :: FilePath
384 -- ^ Path to the file represented by 'HomePub' 289 -- ^ Path to the file represented by 'HomePub'
@@ -399,90 +304,13 @@ data KeyRingRuntime = KeyRingRuntime
399 -- 'KeyRingFile'. If 'AutoAccess' was specified 304 -- 'KeyRingFile'. If 'AutoAccess' was specified
400 -- for a file, this 'Map.Map' will indicate the 305 -- for a file, this 'Map.Map' will indicate the
401 -- detected value that was used by the algorithm. 306 -- detected value that was used by the algorithm.
402 , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet) 307 , rtPassphrases :: PacketTranscoder
403 } 308 }
404 309
405-- | Roster-entry level actions 310-- | Roster-entry level actions
406data PacketUpdate = InducerSignature String [SignatureSubpacket] 311data PacketUpdate = InducerSignature String [SignatureSubpacket]
407 | SubKeyDeletion KeyKey KeyKey 312 | SubKeyDeletion KeyKey KeyKey
408 313
409-- | This type is used to indicate where to obtain passphrases.
410data PassphraseSpec = PassphraseSpec
411 { passSpecRingFile :: Maybe FilePath
412 -- ^ If not Nothing, the passphrase is to be used for packets
413 -- from this file.
414 , passSpecKeySpec :: Maybe String
415 -- ^ Non-Nothing value reserved for future use.
416 -- (TODO: Use this to implement per-key passphrase associations).
417 , passSpecPassFile :: InputFile
418 -- ^ The passphrase will be read from this file or file descriptor.
419 }
420 -- | Use this to carry pasphrases from a previous run.
421 | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))
422
423instance Show PassphraseSpec where
424 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
425 show (PassphraseMemoizer _) = "PassphraseMemoizer"
426instance Eq PassphraseSpec where
427 PassphraseSpec a b c == PassphraseSpec d e f
428 = and [a==d,b==e,c==f]
429 _ == _
430 = False
431
432
433
434data Transform =
435 Autosign
436 -- ^ This operation will make signatures for any tor-style UID
437 -- that matches a tor subkey and thus can be authenticated without
438 -- requring the judgement of a human user.
439 --
440 -- A tor-style UID is one of the following form:
441 --
442 -- > Anonymous <root@HOSTNAME.onion>
443 | DeleteSubkeyByFingerprint String
444 -- ^ Delete the subkey specified by the given fingerprint and any
445 -- associated signatures on that key.
446 | DeleteSubkeyByUsage String
447 -- ^ Delete the subkey specified by the given fingerprint and any
448 -- associated signatures on that key.
449 deriving (Eq,Ord,Show)
450
451-- | This type describes an idempotent transformation (merge or import) on a
452-- set of GnuPG keyrings and other key files.
453data KeyRingOperation = KeyRingOperation
454 { opFiles :: Map.Map InputFile StreamInfo
455 -- ^ Indicates files to be read or updated.
456 , opPassphrases :: [PassphraseSpec]
457 -- ^ Indicates files or file descriptors where passphrases can be found.
458 , opTransforms :: [Transform]
459 -- ^ Transformations to be performed on the key pool after all files have
460 -- been read and before any have been written.
461 , opHome :: Maybe FilePath
462 -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
463 -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted
464 -- and if that is not set, it falls back to $HOME/.gnupg.
465 }
466 deriving (Eq,Show)
467
468resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
469resolveInputFile ctx = resolve
470 where
471 resolve HomeSec = return (homesecPath ctx)
472 resolve HomePub = return (homepubPath ctx)
473 resolve (ArgFile f) = return f
474 resolve _ = []
475
476resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
477resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
478 where str = case (fdr,fdw) of
479 (0,1) -> "-"
480 _ -> "&pipe" ++ show (fdr,fdw)
481resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
482 where str = "&" ++ show fd
483resolveForReport mctx f = concat $ resolveInputFile ctx f
484 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
485
486filesToLock :: 314filesToLock ::
487 KeyRingOperation -> InputFileContext -> [FilePath] 315 KeyRingOperation -> InputFileContext -> [FilePath]
488filesToLock k ctx = do 316filesToLock k ctx = do
@@ -622,33 +450,6 @@ instance ASN1Object RSAPrivateKey where
622 450
623 451
624 452
625-- | This type is used to indicate success or failure
626-- and in the case of success, return the computed object.
627-- The 'FunctorToMaybe' class is implemented to facilitate
628-- branching on failture.
629data KikiCondition a = KikiSuccess a
630 | FailedToLock [FilePath]
631 | BadPassphrase
632 | FailedToMakeSignature
633 | CantFindHome
634 | AmbiguousKeySpec FilePath
635 | CannotImportMasterKey
636 | NoWorkingKey
637 deriving ( Functor, Show )
638
639instance FunctorToMaybe KikiCondition where
640 functorToMaybe (KikiSuccess a) = Just a
641 functorToMaybe _ = Nothing
642
643instance Applicative KikiCondition where
644 pure a = KikiSuccess a
645 f <*> a =
646 case functorToEither f of
647 Right f -> case functorToEither a of
648 Right a -> pure (f a)
649 Left err -> err
650 Left err -> err
651
652-- | This type is used to describe events triggered by 'runKeyRing'. In 453-- | This type is used to describe events triggered by 'runKeyRing'. In
653-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate 454-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
654-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a 455-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a
@@ -785,21 +586,21 @@ keyflags _ = Nothing
785 586
786data PGPKeyFlags = 587data PGPKeyFlags =
787 Special 588 Special
788 | Vouch -- Signkey 589 | Vouch -- 0001 C -- Signkey
789 | Sign 590 | Sign -- 0010 S
790 | VouchSign 591 | VouchSign -- 0011
791 | Communication 592 | Communication -- 0100 E
792 | VouchCommunication 593 | VouchCommunication -- 0101
793 | SignCommunication 594 | SignCommunication -- 0110
794 | VouchSignCommunication 595 | VouchSignCommunication -- 0111
795 | Storage 596 | Storage -- 1000 E
796 | VouchStorage 597 | VouchStorage -- 1001
797 | SignStorage 598 | SignStorage -- 1010
798 | VouchSignStorage 599 | VouchSignStorage -- 1011
799 | Encrypt 600 | Encrypt -- 1100 E
800 | VouchEncrypt 601 | VouchEncrypt -- 1101
801 | SignEncrypt 602 | SignEncrypt -- 1110
802 | VouchSignEncrypt 603 | VouchSignEncrypt -- 1111
803 deriving (Eq,Show,Read,Enum) 604 deriving (Eq,Show,Read,Enum)
804 605
805 606
@@ -826,14 +627,6 @@ usageString flgs =
826 627
827 628
828 629
829-- matchpr computes the fingerprint of the given key truncated to
830-- be the same lenght as the given fingerprint for comparison.
831--
832-- matchpr fp = Data.List.Extra.takeEnd (length fp)
833--
834matchpr :: String -> Packet -> String
835matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
836
837keyFlags :: t -> [Packet] -> [SignatureSubpacket] 630keyFlags :: t -> [Packet] -> [SignatureSubpacket]
838keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) 631keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
839 632
@@ -1336,18 +1129,6 @@ seek_key (KeyUidMatch pat) ps
1336 uidStr _ = "" 1129 uidStr _ = ""
1337 1130
1338 1131
1339data InputFileContext = InputFileContext
1340 { homesecPath :: FilePath
1341 , homepubPath :: FilePath
1342 }
1343
1344readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
1345readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
1346readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
1347readInputFileS ctx inp = do
1348 let fname = resolveInputFile ctx inp
1349 fmap S.concat $ mapM S.readFile fname
1350
1351readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString 1132readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
1352readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents 1133readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents
1353readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents 1134readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
@@ -1395,7 +1176,7 @@ writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeF
1395-} 1176-}
1396 1177
1397writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () 1178writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
1398writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str 1179writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either (\h x-> hPutStr h x >> hClose h) writeFile) str
1399 1180
1400getInputFileTime :: InputFileContext -> InputFile -> IO CTime 1181getInputFileTime :: InputFileContext -> InputFile -> IO CTime
1401getInputFileTime ctx (Pipe fdr fdw) = do 1182getInputFileTime ctx (Pipe fdr fdw) = do
@@ -1423,30 +1204,12 @@ doesInputFileExist ctx f = do
1423-} 1204-}
1424 1205
1425 1206
1426cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
1427cachedContents maybePrompt ctx fd = do
1428 ref <- newIORef Nothing
1429 return $ get maybePrompt ref fd
1430 where
1431 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
1432
1433 get maybePrompt ref fd = do
1434 pw <- readIORef ref
1435 flip (flip maybe return) pw $ do
1436 if fd == FileDesc 0 then case maybePrompt of
1437 Just prompt -> S.hPutStr stderr prompt
1438 Nothing -> return ()
1439 else return ()
1440 pw <- fmap trimCR $ readInputFileS ctx fd
1441 writeIORef ref (Just pw)
1442 return pw
1443
1444generateSubkey :: 1207generateSubkey ::
1445 (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ 1208 PacketTranscoder
1446 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db 1209 -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db
1447 -> (GenerateKeyParams, StreamInfo) 1210 -> (GenerateKeyParams, StreamInfo)
1448 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) 1211 -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)]))
1449generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do 1212generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1450 try kd' $ \(kd,report0) -> do 1213 try kd' $ \(kd,report0) -> do
1451 let subs = do 1214 let subs = do
1452 SubKey p sigs <- Map.elems $ keySubKeys kd 1215 SubKey p sigs <- Map.elems $ keySubKeys kd
@@ -1454,7 +1217,7 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1454 if null subs 1217 if null subs
1455 then do 1218 then do
1456 newkey <- generateKey genparam 1219 newkey <- generateKey genparam
1457 kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey 1220 kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey
1458 try kdr $ \(newkd,report) -> do 1221 try kdr $ \(newkd,report) -> do
1459 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) 1222 return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)])
1460 else do 1223 else do
@@ -1462,14 +1225,14 @@ generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
1462generateSubkey _ kd _ = return kd 1225generateSubkey _ kd _ = return kd
1463 1226
1464importSecretKey :: 1227importSecretKey ::
1465 (MappedPacket -> IO (KikiCondition Packet)) 1228 (PacketTranscoder)
1466 -> KikiCondition 1229 -> KikiCondition
1467 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) 1230 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
1468 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 1231 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
1469 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 1232 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1470importSecretKey doDecrypt db' tup = do 1233importSecretKey transcode db' tup = do
1471 try db' $ \(db',report0) -> do 1234 try db' $ \(db',report0) -> do
1472 r <- doImport doDecrypt 1235 r <- doImport transcode
1473 db' 1236 db'
1474 tup 1237 tup
1475 try r $ \(db'',report) -> do 1238 try r $ \(db'',report) -> do
@@ -1577,10 +1340,6 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
1577 return $ map (first $ resolveForReport $ Just ctx) rs 1340 return $ map (first $ resolveForReport $ Just ctx) rs
1578 return $ concat rss 1341 return $ concat rss
1579 1342
1580isSecretKey :: Packet -> Bool
1581isSecretKey (SecretKeyPacket {}) = True
1582isSecretKey _ = False
1583
1584-- | buildKeyDB 1343-- | buildKeyDB
1585-- 1344--
1586-- merge all keyrings, PEM files, and wallets into process memory. 1345-- merge all keyrings, PEM files, and wallets into process memory.
@@ -1595,16 +1354,15 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1595 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], 1354 {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))],
1596 {- outgoing_names -}[SockAddr]) 1355 {- outgoing_names -}[SockAddr])
1597 ,{- accs -} Map.Map InputFile Access 1356 ,{- accs -} Map.Map InputFile Access
1598 ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) 1357 ,{- doDecrypt -} PacketTranscoder
1599 ,{- unspilled -} Map.Map InputFile Message 1358 ,{- unspilled -} Map.Map InputFile Message
1600 ) 1359 )
1601 ,{- report_imports -} [(FilePath,KikiReportAction)])) 1360 ,{- report_imports -} [(FilePath,KikiReportAction)]))
1602buildKeyDB ctx grip0 keyring = do 1361buildKeyDB ctx grip0 keyring = do
1603 let 1362 let files istyp = do
1604 files istyp = do
1605 (f,stream) <- Map.toList (opFiles keyring) 1363 (f,stream) <- Map.toList (opFiles keyring)
1606 guard (istyp $ typ stream) 1364 guard (istyp $ typ stream)
1607 resolveInputFile ctx f 1365 return f -- resolveInputFile ctx f
1608 1366
1609 ringMap0 = Map.filter (isring . typ) $ opFiles keyring 1367 ringMap0 = Map.filter (isring . typ) $ opFiles keyring
1610 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 1368 (genMap,ringMap) = Map.partitionWithKey isgen ringMap0
@@ -1624,10 +1382,10 @@ buildKeyDB ctx grip0 keyring = do
1624 _ -> AutoAccess 1382 _ -> AutoAccess
1625 acc -> acc 1383 acc -> acc
1626 1384
1627 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) 1385 readw wk n = fmap (n,) (readPacketsFromWallet wk n)
1628 1386
1629 -- KeyRings (todo: KikiCondition reporting?) 1387 -- KeyRings (todo: KikiCondition reporting?)
1630 (spilled,mwk,grip,accs,keys,unspilled) <- do 1388 (spilled,mwk,grip,accs,keyqs,unspilled) <- do
1631#if MIN_VERSION_containers(0,5,0) 1389#if MIN_VERSION_containers(0,5,0)
1632 ringPackets <- Map.traverseWithKey readp ringMap 1390 ringPackets <- Map.traverseWithKey readp ringMap
1633#else 1391#else
@@ -1650,32 +1408,18 @@ buildKeyDB ctx grip0 keyring = do
1650 -- | keys 1408 -- | keys
1651 -- process ringPackets, and get a map of fingerprint info to 1409 -- process ringPackets, and get a map of fingerprint info to
1652 -- to a packet, remembering it's original file, access. 1410 -- to a packet, remembering it's original file, access.
1653 keys :: Map.Map KeyKey MappedPacket 1411 keys :: Map.Map KeyKey (OriginMapped Query)
1654 keys = Map.foldl slurpkeys Map.empty
1655 $ Map.mapWithKey filterSecrets ringPackets
1656 where
1657 filterSecrets f (_,Message ps) =
1658 filter (isSecretKey . packet)
1659 $ zipWith (mappedPacketWithHint fname) ps [1..]
1660 where fname = resolveForReport (Just ctx) f
1661 slurpkeys m ps = m `Map.union` Map.fromList ps'
1662 where ps' = zip (map (keykey . packet) ps) ps
1663 -- | mwk
1664 -- first master key matching the provided grip
1665 -- (the m is for "MappedPacket", wk for working key)
1666 mwk :: Maybe MappedPacket 1412 mwk :: Maybe MappedPacket
1667 mwk = listToMaybe $ do 1413 (mwk, keys) = keyQueries grip ringPackets
1668 fp <- maybeToList grip 1414
1669 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
1670 where p = packet mp
1671 Map.elems $ Map.filter matchfp keys
1672 -- | accs 1415 -- | accs
1673 -- file access(Sec | Pub) lookup table 1416 -- file access(Sec | Pub) lookup table
1674 accs :: Map.Map InputFile Access 1417 accs :: Map.Map InputFile Access
1675 accs = fmap (access . fst) ringPackets 1418 accs = fmap (access . fst) ringPackets
1676 return (spilled,mwk,grip,accs,keys,fmap snd unspilled) 1419 return (spilled,mwk,grip,accs,keys,fmap snd unspilled)
1677 1420
1678 doDecrypt <- makeMemoizingDecrypter keyring ctx keys 1421 transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs)
1422 let doDecrypt = transcode (Unencrypted,S2K 100 "")
1679 1423
1680 let wk = fmap packet mwk 1424 let wk = fmap packet mwk
1681 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx 1425 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
@@ -1684,7 +1428,7 @@ buildKeyDB ctx grip0 keyring = do
1684 , rtWorkingKey = wk 1428 , rtWorkingKey = wk
1685 , rtRingAccess = accs 1429 , rtRingAccess = accs
1686 , rtKeyDB = Map.empty 1430 , rtKeyDB = Map.empty
1687 , rtPassphrases = doDecrypt 1431 , rtPassphrases = transcode
1688 } 1432 }
1689 -- autosigns and deletes 1433 -- autosigns and deletes
1690 transformed0 <- 1434 transformed0 <-
@@ -1696,6 +1440,9 @@ buildKeyDB ctx grip0 keyring = do
1696 r <- performManipulations doDecrypt rt1 mwk manip 1440 r <- performManipulations doDecrypt rt1 mwk manip
1697 try r $ \(rt2,report) -> do 1441 try r $ \(rt2,report) -> do
1698 return $ KikiSuccess (report,rtKeyDB rt2) 1442 return $ KikiSuccess (report,rtKeyDB rt2)
1443 -- XXX: Unspilled keys are not obtainable from rtKeyDB.
1444 -- If the working key is marked non spillable, then how
1445 -- would we look up it's UID and such?
1699#if MIN_VERSION_containers(0,5,0) 1446#if MIN_VERSION_containers(0,5,0)
1700 in fmap sequenceA $ Map.traverseWithKey trans spilled 1447 in fmap sequenceA $ Map.traverseWithKey trans spilled
1701#else 1448#else
@@ -1715,7 +1462,7 @@ buildKeyDB ctx grip0 keyring = do
1715 -- Wallets 1462 -- Wallets
1716 let importWalletKey wk db' (top,fname,sub,tag) = do 1463 let importWalletKey wk db' (top,fname,sub,tag) = do
1717 try db' $ \(db',report0) -> do 1464 try db' $ \(db',report0) -> do
1718 r <- doImportG doDecrypt 1465 r <- doImportG transcode
1719 db' 1466 db'
1720 (fmap keykey $ maybeToList wk) 1467 (fmap keykey $ maybeToList wk)
1721 [mkUsage tag] 1468 [mkUsage tag]
@@ -1731,6 +1478,7 @@ buildKeyDB ctx grip0 keyring = do
1731 (_,sub,(_,m)) <- xs 1478 (_,sub,(_,m)) <- xs
1732 (tag,top) <- Map.toList m 1479 (tag,top) <- Map.toList m
1733 return (top,fname,sub,tag) 1480 return (top,fname,sub,tag)
1481
1734 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys 1482 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
1735 try db $ \(db,reportWallets) -> do 1483 try db $ \(db,reportWallets) -> do
1736 1484
@@ -1738,7 +1486,6 @@ buildKeyDB ctx grip0 keyring = do
1738 let pems = do 1486 let pems = do
1739 (n,stream) <- Map.toList $ opFiles keyring 1487 (n,stream) <- Map.toList $ opFiles keyring
1740 grip <- maybeToList grip 1488 grip <- maybeToList grip
1741 n <- resolveInputFile ctx n
1742 guard $ spillable stream && isSecretKeyFile (typ stream) 1489 guard $ spillable stream && isSecretKeyFile (typ stream)
1743 let us = mapMaybe usageFromFilter [fill stream,spill stream] 1490 let us = mapMaybe usageFromFilter [fill stream,spill stream]
1744 usage <- take 1 us 1491 usage <- take 1 us
@@ -1749,8 +1496,11 @@ buildKeyDB ctx grip0 keyring = do
1749 ms = map fst $ filterMatches topspec (Map.toList db) 1496 ms = map fst $ filterMatches topspec (Map.toList db)
1750 cmd = initializer stream 1497 cmd = initializer stream
1751 return (n,subspec,ms,stream, cmd) 1498 return (n,subspec,ms,stream, cmd)
1752 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems 1499
1753 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports 1500 imports <- filterM (\case (ArgFile n,_,_,_,_) -> doesFileExist n
1501 _ -> return True)
1502 pems
1503 db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports
1754 try db $ \(db,reportPEMs) -> do 1504 try db $ \(db,reportPEMs) -> do
1755 1505
1756 -- generate keys 1506 -- generate keys
@@ -1758,25 +1508,25 @@ buildKeyDB ctx grip0 keyring = do
1758 where g (Generate _ params,v) = Just (params,v) 1508 where g (Generate _ params,v) = Just (params,v)
1759 g _ = Nothing 1509 g _ = Nothing
1760 1510
1761 db <- generateInternals doDecrypt mwk db gens 1511 db <- generateInternals transcode mwk db gens
1762 try db $ \(db,reportGens) -> do 1512 try db $ \(db,reportGens) -> do
1763 1513
1764 r <- mergeHostFiles keyring db ctx 1514 r <- mergeHostFiles keyring db ctx
1765 try r $ \((db,hs),reportHosts) -> do 1515 try r $ \((db,hs),reportHosts) -> do
1766 1516
1767 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) 1517 return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled)
1768 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) 1518 , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts )
1769 1519
1770generateInternals :: 1520generateInternals ::
1771 (MappedPacket -> IO (KikiCondition Packet)) 1521 PacketTranscoder
1772 -> Maybe MappedPacket 1522 -> Maybe MappedPacket
1773 -> Map.Map KeyKey KeyData 1523 -> Map.Map KeyKey KeyData
1774 -> [(GenerateKeyParams,StreamInfo)] 1524 -> [(GenerateKeyParams,StreamInfo)]
1775 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) 1525 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1776generateInternals doDecrypt mwk db gens = do 1526generateInternals transcode mwk db gens = do
1777 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of 1527 case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of
1778 Just kd0 -> do 1528 Just kd0 -> do
1779 kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens 1529 kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens
1780 try kd $ \(kd,reportGens) -> do 1530 try kd $ \(kd,reportGens) -> do
1781 let kk = keykey $ packet $ fromJust mwk 1531 let kk = keykey $ packet $ fromJust mwk
1782 return $ KikiSuccess (Map.insert kk kd db,reportGens) 1532 return $ KikiSuccess (Map.insert kk kd db,reportGens)
@@ -1785,15 +1535,23 @@ generateInternals doDecrypt mwk db gens = do
1785torhash :: Packet -> String 1535torhash :: Packet -> String
1786torhash key = fromMaybe "" $ derToBase32 <$> derRSA key 1536torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1787 1537
1538torUIDFromKey :: Packet -> String
1539torUIDFromKey key = "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
1540
1788derToBase32 :: ByteString -> String 1541derToBase32 :: ByteString -> String
1789#if !defined(VERSION_cryptonite) 1542derToBase32 = map toLower . base32 . sha1
1790derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
1791#else
1792derToBase32 = map toLower . Base32.encode . S.unpack . sha1
1793 where 1543 where
1794 sha1 :: L.ByteString -> S.ByteString 1544 sha1 :: L.ByteString -> S.ByteString
1545#if !defined(VERSION_cryptonite)
1546 sha1 = SHA1.hashlazy
1547#else
1795 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) 1548 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1796#endif 1549#endif
1550#if defined(VERSION_memory)
1551 base32 = S8.unpack . convertToBase Base32
1552#elif defined(VERSION_dataenc)
1553 base32 = Base32.encode . S.unpack
1554#endif
1797 1555
1798derRSA :: Packet -> Maybe ByteString 1556derRSA :: Packet -> Maybe ByteString
1799derRSA rsa = do 1557derRSA rsa = do
@@ -1921,11 +1679,18 @@ extractRSAKeyFields kvs = do
1921 , rsaCoefficient = u } 1679 , rsaCoefficient = u }
1922 where 1680 where
1923 parseField blob = MPI <$> m 1681 parseField blob = MPI <$> m
1682#if defined(VERSION_memory)
1683 where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob)
1684 bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1685 where
1686 nlen = S.length bs
1687#elif defined(VERSION_dataenc)
1924 where m = bigendian <$> Base64.decode (Char8.unpack blob) 1688 where m = bigendian <$> Base64.decode (Char8.unpack blob)
1925
1926 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs 1689 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1927 where 1690 where
1928 nlen = length bs 1691 nlen = length bs
1692#endif
1693
1929 1694
1930rsaToPGP stamp rsa = SecretKeyPacket 1695rsaToPGP stamp rsa = SecretKeyPacket
1931 { version = 4 1696 { version = 4
@@ -2003,21 +1768,21 @@ readSecretPEMFile fname = do
2003 return $ dta 1768 return $ dta
2004 1769
2005doImport 1770doImport
2006 :: (MappedPacket -> IO (KikiCondition Packet)) 1771 :: PacketTranscoder
2007 -> Map.Map KeyKey KeyData 1772 -> Map.Map KeyKey KeyData
2008 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) 1773 -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t)
2009 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 1774 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
2010doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do 1775doImport transcode db (fname,subspec,ms,typ -> typ,_) = do
2011 flip (maybe $ return CannotImportMasterKey) 1776 flip (maybe $ return CannotImportMasterKey)
2012 subspec $ \tag -> do 1777 subspec $ \tag -> do
2013 (certs,keys) <- case typ of 1778 (certs,keys) <- case typ of
2014 PEMFile -> do 1779 PEMFile -> do
2015 ps <- readSecretPEMFile (ArgFile fname) 1780 ps <- readSecretPEMFile fname
2016 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) 1781 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
2017 = partition (isJust . spemCert) ps 1782 = partition (isJust . spemCert) ps
2018 return (certs,keys) 1783 return (certs,keys)
2019 DNSPresentation -> do 1784 DNSPresentation -> do
2020 p <- readSecretDNSFile (ArgFile fname) 1785 p <- readSecretDNSFile fname
2021 return ([],[p]) 1786 return ([],[p])
2022 -- TODO Probably we need to move to a new design where signature 1787 -- TODO Probably we need to move to a new design where signature
2023 -- packets are merged into the database in one phase with null 1788 -- packets are merged into the database in one phase with null
@@ -2030,7 +1795,7 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
2030 try prior $ \(db,report) -> do 1795 try prior $ \(db,report) -> do
2031 let (m0,tailms) = splitAt 1 ms 1796 let (m0,tailms) = splitAt 1 ms
2032 if (not (null tailms) || null m0) 1797 if (not (null tailms) || null m0)
2033 then return $ AmbiguousKeySpec fname 1798 then return $ AmbiguousKeySpec (resolveForReport Nothing fname)
2034 else do 1799 else do
2035 let kk = keykey key 1800 let kk = keykey key
2036 cs = filter (\c -> kk==keykey (pcertKey c)) certs 1801 cs = filter (\c -> kk==keykey (pcertKey c)) certs
@@ -2041,42 +1806,54 @@ doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
2041 , notation_value = Char8.unpack bs } 1806 , notation_value = Char8.unpack bs }
2042 datedKey = key { timestamp = fromTime $ minimum dates } 1807 datedKey = key { timestamp = fromTime $ minimum dates }
2043 dates = fromTime (timestamp key) : map pcertTimestamp certs 1808 dates = fromTime (timestamp key) : map pcertTimestamp certs
2044 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey 1809 r <- doImportG transcode db m0 (mkUsage tag:blobs) fname datedKey
2045 try r $ \(db',report') -> do 1810 try r $ \(db',report') -> do
2046 return $ KikiSuccess (db',report++report') 1811 return $ KikiSuccess (db',report++report')
2047 1812
2048doImportG 1813doImportG
2049 :: (MappedPacket -> IO (KikiCondition Packet)) 1814 :: PacketTranscoder
2050 -> Map.Map KeyKey KeyData 1815 -> Map.Map KeyKey KeyData
2051 -> [KeyKey] -- m0, only head is used 1816 -> [KeyKey] -- m0, only head is used
2052 -> [SignatureSubpacket] -- tags 1817 -> [SignatureSubpacket] -- tags
2053 -> FilePath 1818 -> InputFile
2054 -> Packet 1819 -> Packet
2055 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) 1820 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)]))
2056doImportG doDecrypt db m0 tags fname key = do 1821doImportG transcode db m0 tags fname key = do
2057 let kk = head m0 1822 let kk = head m0
2058 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db 1823 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db
2059 kdr <- insertSubkey doDecrypt kk kd tags fname key 1824 kdr <- insertSubkey transcode kk kd tags fname key
2060 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 1825 try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs)
2061 1826
2062insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do 1827insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do
2063 let subkk = keykey key 1828 let topcipher = symmetric_algorithm $ packet top
2064 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) 1829 tops2k = s2k $ packet top
2065 []) 1830 doDecrypt = transcode (Unencrypted,S2K 100 "")
2066 ( (False,) . addOrigin ) 1831 fname = resolveForReport Nothing inputfile
2067 (Map.lookup subkk subs) 1832 subkk = keykey key0
2068 where 1833 istor = do
2069 addOrigin (SubKey mp sigs) = 1834 guard ("tor" `elem` mapMaybe usage tags)
1835 return $ torUIDFromKey key0
1836 addOrigin (SubKey mp sigs) =
2070 let mp' = mp 1837 let mp' = mp
2071 { locations = Map.insert fname 1838 { locations = Map.insert fname
2072 (origin (packet mp) (-1)) 1839 (origin (packet mp) (-1))
2073 (locations mp) } 1840 (locations mp) }
2074 in SubKey mp' sigs 1841 in SubKey mp' sigs
2075 subs' = Map.insert subkk subkey subs
2076 1842
2077 istor = do 1843 subkey_result <- do
2078 guard ("tor" `elem` mapMaybe usage tags) 1844 case Map.lookup subkk subs of
2079 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>" 1845 Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing)
1846 Nothing -> do
1847 wkun' <- doDecrypt top
1848 try wkun' $ \wkun -> do
1849 key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0
1850 try key' $ \key -> do
1851 return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key))
1852
1853
1854 try subkey_result $ \(is_new,subkey,decrypted) -> do
1855
1856 let subs' = Map.insert subkk subkey subs
2080 1857
2081 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do 1858 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
2082 let has_torid = do 1859 let has_torid = do
@@ -2086,14 +1863,13 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
2086 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) 1863 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
2087 signatures_over $ verify (Message [packet top]) s 1864 signatures_over $ verify (Message [packet top]) s
2088 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do 1865 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
2089 wkun <- doDecrypt top
2090
2091 try wkun $ \wkun -> do
2092 1866
2093 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) 1867 let keyflags = keyFlags (error "dummy argument (insertSubkey)") (map packet $ flattenAllUids fname True uids)
2094 uid = UserIDPacket idstr 1868 uid = UserIDPacket idstr
2095 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags 1869 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
2096 tor_ov = makeInducerSig (packet top) wkun uid keyflags 1870 tor_ov = makeInducerSig (packet top) (packet top) uid keyflags
1871 wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted
1872 try wkun' $ \wkun -> do
2097 sig_ov <- pgpSign (Message [wkun]) 1873 sig_ov <- pgpSign (Message [wkun])
2098 tor_ov 1874 tor_ov
2099 SHA1 1875 SHA1
@@ -2112,10 +1888,12 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
2112 1888
2113 let SubKey subkey_p subsigs = subkey 1889 let SubKey subkey_p subsigs = subkey
2114 wk = packet top 1890 wk = packet top
2115 (xs',minsig,ys') = findTag tags wk key subsigs 1891 (xs',minsig,ys') = findTag tags wk key0 subsigs
2116 doInsert mbsig = do 1892 doInsert mbsig = do
2117 -- NEW SUBKEY BINDING SIGNATURE 1893 -- NEW SUBKEY BINDING SIGNATURE
2118 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig 1894 -- XXX: Here I assume that key0 is the unencrypted version
1895 -- of subkey_p. TODO: Check this assumption.
1896 sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} tags mbsig
2119 try sig' $ \(sig',report) -> do 1897 try sig' $ \(sig',report) -> do
2120 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] 1898 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
2121 let subs' = Map.insert subkk 1899 let subs' = Map.insert subkk
@@ -2126,7 +1904,7 @@ insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do
2126 1904
2127 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) 1905 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
2128 else id 1906 else id
2129 s = show (fmap fst minsig,fingerprint key) 1907 s = show (fmap fst minsig,fingerprint key0)
2130 in return (f report) 1908 in return (f report)
2131 1909
2132 case minsig of 1910 case minsig of
@@ -2211,11 +1989,33 @@ ifSecret _ t f = f
2211showPacket :: Packet -> String 1989showPacket :: Packet -> String
2212showPacket p | isKey p = (if is_subkey p 1990showPacket p | isKey p = (if is_subkey p
2213 then showPacket0 p 1991 then showPacket0 p
2214 else ifSecret p "----Secret-----" "----Public-----") 1992 else ifSecret p "---Secret" "---Public")
2215 ++ " "++show (key_algorithm p)++" "++fingerprint p 1993 ++ " "++fingerprint p
2216 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) 1994 ++ " "++show (key_algorithm p)
2217 | otherwise = showPacket0 p 1995 ++ case key_nbits p of { 0 -> ""; n -> "("++show n++")" }
2218showPacket0 p = concat . take 1 $ words (show p) 1996 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1997 -- | isSignaturePacket p = showPacket0 p ++ maybe "" ((++) (" ^ signed"++sigusage p++": ")) (signature_issuer p)
1998 | isSignaturePacket p = showPacket0 p ++ maybe "" (" ^ signed: "++) (signature_issuer p) ++ sigusage p
1999 | otherwise = showPacket0 p
2000 where
2001 sigusage p =
2002 case take 1 (tagStrings p) of
2003 [] -> ""
2004 tag:_ -> " "++show tag -- "("++tag++")"
2005 where
2006 tagStrings p = usage_tags ++ flags
2007 where
2008 usage_tags = mapMaybe usage xs
2009 flags = mapMaybe (fmap usageString . keyflags) xs
2010 xs = hashed_subpackets p
2011
2012
2013showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
2014 where
2015 dropSuffix :: String -> String -> String
2016 dropSuffix _ [] = ""
2017 dropSuffix suff (x:xs) | (x:xs)==suff = ""
2018 | otherwise = x:dropSuffix suff xs
2219 2019
2220 2020
2221-- | returns Just True so as to indicate that 2021-- | returns Just True so as to indicate that
@@ -2406,7 +2206,11 @@ pemFromPacket Sec packet =
2406 rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey 2206 rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey
2407 let asn1 = toASN1 rsa [] 2207 let asn1 = toASN1 rsa []
2408 bs = encodeASN1 DER asn1 2208 bs = encodeASN1 DER asn1
2209#if defined(VERSION_memory)
2210 dta = S8.unpack $ convertToBase Base64 (L.toStrict bs)
2211#elif defined(VERSION_dataenc)
2409 dta = Base64.encode (L.unpack bs) 2212 dta = Base64.encode (L.unpack bs)
2213#endif
2410 output = writePEM "RSA PRIVATE KEY" dta 2214 output = writePEM "RSA PRIVATE KEY" dta
2411 Just output 2215 Just output
2412 algo -> Nothing 2216 algo -> Nothing
@@ -2416,7 +2220,11 @@ pemFromPacket Pub packet =
2416 rsa <- rsaKeyFromPacket packet 2220 rsa <- rsaKeyFromPacket packet
2417 let asn1 = toASN1 (pkcs8 rsa) [] 2221 let asn1 = toASN1 (pkcs8 rsa) []
2418 bs = encodeASN1 DER asn1 2222 bs = encodeASN1 DER asn1
2223#if defined(VERSION_memory)
2224 dta = S8.unpack $ convertToBase Base64 (L.toStrict bs)
2225#elif defined(VERSION_dataenc)
2419 dta = Base64.encode (L.unpack bs) 2226 dta = Base64.encode (L.unpack bs)
2227#endif
2420 output = writePEM "PUBLIC KEY" dta 2228 output = writePEM "PUBLIC KEY" dta
2421 Just output 2229 Just output
2422 algo -> Nothing 2230 algo -> Nothing
@@ -2448,7 +2256,11 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do
2448 let -- asn1 = toASN1 rsa [] 2256 let -- asn1 = toASN1 rsa []
2449 -- bs = encodeASN1 DER asn1 2257 -- bs = encodeASN1 DER asn1
2450 -- dta = Base64.encode (L.unpack bs) 2258 -- dta = Base64.encode (L.unpack bs)
2259#if defined(VERSION_memory)
2260 b64 ac rsa = S8.unpack $ convertToBase Base64 $ i2bs_unsized i
2261#elif defined(VERSION_dataenc)
2451 b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i) 2262 b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
2263#endif
2452 where 2264 where
2453 MPI i = ac rsa 2265 MPI i = ac rsa
2454 i2bs_unsized :: Integer -> S.ByteString 2266 i2bs_unsized :: Integer -> S.ByteString
@@ -2478,7 +2290,7 @@ writeKeyToFile StreamInfo { typ = DNSPresentation } fname packet = do
2478 return [(fname, ExportedSubkey)] 2290 return [(fname, ExportedSubkey)]
2479 algo -> return [(fname, UnableToExport algo $ fingerprint packet)] 2291 algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
2480 2292
2481writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) 2293writePEMKeys :: (PacketDecrypter)
2482 -> KeyDB 2294 -> KeyDB
2483 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)] 2295 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
2484 -> IO (KikiCondition [(FilePath,KikiReportAction)]) 2296 -> IO (KikiCondition [(FilePath,KikiReportAction)])
@@ -2500,81 +2312,8 @@ writePEMKeys doDecrypt db exports = do
2500 try pun $ \pun -> do 2312 try pun $ \pun -> do
2501 return $ KikiSuccess (fname,stream,pun) 2313 return $ KikiSuccess (fname,stream,pun)
2502 2314
2503makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
2504 -> Map.Map KeyKey MappedPacket
2505 -> IO (MappedPacket -> IO (KikiCondition Packet))
2506makeMemoizingDecrypter operation ctx keys =
2507 if null chains then do
2508 -- (*) Notice we do not pass ctx to resolveForReport.
2509 -- This is because the merge function does not currently use a context
2510 -- and the pws map keys must match the MappedPacket locations.
2511 -- TODO: Perhaps these should both be of type InputFile rather than
2512 -- FilePath?
2513 -- pws :: Map.Map FilePath (IO S.ByteString)
2514 {-
2515 pws <-
2516 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
2517 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
2518 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
2519 -}
2520 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
2521 pws2 <-
2522 Traversable.mapM (cachedContents prompt ctx)
2523 $ Map.fromList $ mapMaybe
2524 (\spec -> (,passSpecPassFile spec) `fmap` do
2525 guard $ isNothing $ passSpecKeySpec spec
2526 passSpecRingFile spec)
2527 passspecs
2528 defpw <- do
2529 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
2530 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
2531 && isNothing (passSpecKeySpec sp))
2532 $ opPassphrases operation
2533 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
2534 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
2535 else let PassphraseMemoizer f = head chains
2536 in return f
2537 where
2538 (chains,passspecs) = partition isChain $ opPassphrases operation
2539 where isChain (PassphraseMemoizer {}) = True
2540 isChain _ = False
2541 doDecrypt :: IORef (Map.Map KeyKey Packet)
2542 -> Map.Map FilePath (IO S.ByteString)
2543 -> Maybe (IO S.ByteString)
2544 -> MappedPacket
2545 -> IO (KikiCondition Packet)
2546 doDecrypt unkeysRef pws defpw mp0 = do
2547 unkeys <- readIORef unkeysRef
2548 let mp = fromMaybe mp0 $ do
2549 k <- Map.lookup kk keys
2550 return $ mergeKeyPacket "decrypt" mp0 k
2551 wk = packet mp0
2552 kk = keykey wk
2553 fs = Map.keys $ locations mp
2554
2555 decryptIt [] = return BadPassphrase
2556 decryptIt (getpw:getpws) = do
2557 -- TODO: This function should use mergeKeyPacket to
2558 -- combine the packet with it's unspilled version before
2559 -- attempting to decrypt it.
2560 pw <- getpw
2561 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
2562 case symmetric_algorithm wkun of
2563 Unencrypted -> do
2564 writeIORef unkeysRef (Map.insert kk wkun unkeys)
2565 return $ KikiSuccess wkun
2566 _ -> decryptIt getpws
2567
2568 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
2569
2570 case symmetric_algorithm wk of
2571 Unencrypted -> return (KikiSuccess wk)
2572 _ -> maybe (decryptIt getpws)
2573 (return . KikiSuccess)
2574 $ Map.lookup kk unkeys
2575
2576performManipulations :: 2315performManipulations ::
2577 (MappedPacket -> IO (KikiCondition Packet)) 2316 (PacketDecrypter)
2578 -> KeyRingRuntime 2317 -> KeyRingRuntime
2579 -> Maybe MappedPacket 2318 -> Maybe MappedPacket
2580 -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) 2319 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
@@ -2647,20 +2386,25 @@ initializeMissingPEMFiles ::
2647 -> InputFileContext 2386 -> InputFileContext
2648 -> Maybe String 2387 -> Maybe String
2649 -> Maybe MappedPacket 2388 -> Maybe MappedPacket
2650 -> (MappedPacket -> IO (KikiCondition Packet)) 2389 -> PacketTranscoder
2651 -> KeyDB 2390 -> KeyDB
2652 -> IO (KikiCondition ( (KeyDB,[( FilePath 2391 -> IO (KikiCondition ( (KeyDB,[( FilePath
2653 , Maybe String 2392 , Maybe String
2654 , [MappedPacket] 2393 , [MappedPacket]
2655 , StreamInfo )]) 2394 , StreamInfo )])
2656 , [(FilePath,KikiReportAction)])) 2395 , [(FilePath,KikiReportAction)]))
2657initializeMissingPEMFiles operation ctx grip mwk decrypt db = do 2396initializeMissingPEMFiles operation ctx grip mwk transcode db = do
2397 let decrypt = transcode (Unencrypted,S2K 100 "")
2398
2399 -- nonexistants - files missing from disk.
2658 nonexistents <- 2400 nonexistents <-
2659 filterM (fmap not . doesFileExist . fst) 2401 filterM (fmap not . doesFileExist . fst)
2660 $ do (f,t) <- Map.toList (opFiles operation) 2402 $ do (f,t) <- Map.toList (opFiles operation)
2661 f <- resolveInputFile ctx f 2403 f <- resolveInputFile ctx f
2662 return (f,t) 2404 return (f,t)
2663 2405
2406 -- missing - mutable files not in the keyring and not on disk
2407 -- notmissing - mutable keys in the keyring, but not on disk
2664 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do 2408 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
2665 (fname,stream) <- nonexistents 2409 (fname,stream) <- nonexistents
2666 let mutableTag 2410 let mutableTag
@@ -2707,23 +2451,31 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do
2707 ExitFailure num -> return (tup,FailedExternal num) 2451 ExitFailure num -> return (tup,FailedExternal num)
2708 ExitSuccess -> return (tup,ExternallyGeneratedFile) 2452 ExitSuccess -> return (tup,ExternallyGeneratedFile)
2709 2453
2710 v <- foldM (importSecretKey decrypt) 2454 v <- foldM (importSecretKey transcode)
2711 (KikiSuccess (db,[])) $ do 2455 (KikiSuccess (db,[])) $ do
2712 ((f,subspec,ms,stream,cmd),r) <- rs 2456 ((f,subspec,ms,stream,cmd),r) <- rs
2713 guard $ case r of 2457 guard $ case r of
2714 ExternallyGeneratedFile -> True 2458 ExternallyGeneratedFile -> True
2715 _ -> False 2459 _ -> False
2716 return (f,subspec,map fst ms,stream,cmd) 2460 return (ArgFile f,subspec,map fst ms,stream,cmd)
2717 2461
2718 try v $ \(db,import_rs) -> do 2462 try v $ \(db,import_rs) -> do
2719 2463
2720 -- generateInternals 2464 -- generateInternals
2721 let internals = mapMaybe getParams nonexistents 2465 let internals = mapMaybe getParams $ do
2466 (f,stream) <- nonexistents
2467 usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream]
2468 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
2469 guard $ null $ do
2470 (kk,kd) <- filterMatches topspec $ Map.toList db
2471 subkeysForExport subspec kd
2472 return (f,stream)
2722 where 2473 where
2723 getParams (fname,stream) = 2474 getParams (fname,stream) =
2724 case initializer stream of 2475 case initializer stream of
2725 Internal p -> do _ <- internalInitializer stream 2476 Internal p -> do _ <- internalInitializer stream
2726 Just (p, stream) 2477 Just $ Right (p, stream)
2478 WarnMissing warning -> Just $ Left warning
2727 _ -> Nothing 2479 _ -> Nothing
2728 2480
2729 internalInitializer StreamInfo 2481 internalInitializer StreamInfo
@@ -2731,7 +2483,8 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do
2731 , spill = KF_Match tag } = Just tag 2483 , spill = KF_Match tag } = Just tag
2732 internalInitializer _ = Nothing 2484 internalInitializer _ = Nothing
2733 2485
2734 v <- generateInternals decrypt mwk db internals 2486 mapM_ (hPutStrLn stderr) (lefts internals)
2487 v <- generateInternals transcode mwk db (rights internals)
2735 2488
2736 try v $ \(db,internals_rs) -> do 2489 try v $ \(db,internals_rs) -> do
2737 2490
@@ -2916,6 +2669,7 @@ runKeyRing operation = do
2916 secring <- return Nothing 2669 secring <- return Nothing
2917 pubring <- return Nothing 2670 pubring <- return Nothing
2918 lks <- forM tolocks $ \f -> do 2671 lks <- forM tolocks $ \f -> do
2672 createDirectoryIfMissing True $ takeDirectory f
2919 lk <- dotlock_create f 0 2673 lk <- dotlock_create f 0
2920 v <- flip (maybe $ return Nothing) lk $ \lk -> do 2674 v <- flip (maybe $ return Nothing) lk $ \lk -> do
2921 e <- dotlock_take lk (-1) 2675 e <- dotlock_take lk (-1)
@@ -2930,24 +2684,25 @@ runKeyRing operation = do
2930 2684
2931 -- merge all keyrings, PEM files, and wallets 2685 -- merge all keyrings, PEM files, and wallets
2932 bresult <- buildKeyDB ctx grip0 operation 2686 bresult <- buildKeyDB ctx grip0 operation
2933 try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do 2687 try' bresult $ \((db,grip,wk,hs,accs,transcode,unspilled),report_imports) -> do
2934 2688
2935 externals_ret <- initializeMissingPEMFiles operation 2689 externals_ret <- initializeMissingPEMFiles operation
2936 ctx 2690 ctx
2937 grip 2691 grip
2938 wk 2692 wk
2939 decrypt 2693 transcode
2940 db 2694 db
2941 try' externals_ret $ \((db,exports),report_externals) -> do 2695 try' externals_ret $ \((db,exports),report_externals) -> do
2942 2696
2943 let rt = KeyRingRuntime 2697 let decrypt = transcode (Unencrypted,S2K 100 "")
2698 rt = KeyRingRuntime
2944 { rtPubring = homepubPath ctx 2699 { rtPubring = homepubPath ctx
2945 , rtSecring = homesecPath ctx 2700 , rtSecring = homesecPath ctx
2946 , rtGrip = grip 2701 , rtGrip = grip
2947 , rtWorkingKey = fmap packet wk 2702 , rtWorkingKey = fmap packet wk
2948 , rtKeyDB = db 2703 , rtKeyDB = db
2949 , rtRingAccess = accs 2704 , rtRingAccess = accs
2950 , rtPassphrases = decrypt 2705 , rtPassphrases = transcode
2951 } 2706 }
2952 2707
2953 -- Maybe add signatures, delete subkeys 2708 -- Maybe add signatures, delete subkeys
@@ -3035,19 +2790,6 @@ lookupEnv var =
3035 handleIO_ (return Nothing) $ fmap Just (getEnv var) 2790 handleIO_ (return Nothing) $ fmap Just (getEnv var)
3036#endif 2791#endif
3037 2792
3038isKey :: Packet -> Bool
3039isKey (PublicKeyPacket {}) = True
3040isKey (SecretKeyPacket {}) = True
3041isKey _ = False
3042
3043isUserID :: Packet -> Bool
3044isUserID (UserIDPacket {}) = True
3045isUserID _ = False
3046
3047isTrust :: Packet -> Bool
3048isTrust (TrustPacket {}) = True
3049isTrust _ = False
3050
3051sigpackets :: 2793sigpackets ::
3052 Monad m => 2794 Monad m =>
3053 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet 2795 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
@@ -3154,11 +2896,12 @@ readPacketsFromWallet wk fname = do
3154 timestamp <- getInputFileTime ctx fname 2896 timestamp <- getInputFileTime ctx fname
3155 input <- readInputFileL ctx fname 2897 input <- readInputFileL ctx fname
3156 let (ks,_) = slurpWIPKeys timestamp input 2898 let (ks,_) = slurpWIPKeys timestamp input
2899 {-
3157 unless (null ks) $ do 2900 unless (null ks) $ do
3158 -- decrypt wk 2901 -- decrypt wk
3159 -- create sigs 2902 -- create sigs
3160 -- return key/sig pairs 2903 -- return key/sig pairs
3161 return () 2904 return () -}
3162 return $ do 2905 return $ do
3163 wk <- maybeToList wk 2906 wk <- maybeToList wk
3164 guard (not $ null ks) 2907 guard (not $ null ks)
@@ -3276,7 +3019,7 @@ mkUsage tag = NotationDataPacket
3276 } 3019 }
3277 3020
3278makeSig :: 3021makeSig ::
3279 (MappedPacket -> IO (KikiCondition Packet)) 3022 (PacketDecrypter)
3280 -> MappedPacket 3023 -> MappedPacket
3281 -> [Char] 3024 -> [Char]
3282 -> MappedPacket 3025 -> MappedPacket
@@ -3369,29 +3112,10 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do
3369 return $ fmap (,[]) newsig 3112 return $ fmap (,[]) newsig
3370 3113
3371 3114
3372-- | The position and acces a packet had before the operation
3373data OriginFlags = OriginFlags
3374 { originallyPublic :: Bool
3375 -- ^ false if SecretKeyPacket
3376 , originalNum :: Int
3377 -- ^ packets are numbered, starting from 1..
3378 } deriving Show
3379
3380type OriginMap = Map.Map FilePath OriginFlags
3381
3382data MappedPacket = MappedPacket
3383 { packet :: Packet
3384 , locations :: OriginMap
3385 } deriving Show
3386
3387type TrustMap = Map.Map FilePath Packet 3115type TrustMap = Map.Map FilePath Packet
3388type SigAndTrust = ( MappedPacket 3116type SigAndTrust = ( MappedPacket
3389 , TrustMap ) -- trust packets 3117 , TrustMap ) -- trust packets
3390 3118
3391-- | The 'KeyKey'-type is used to store the information of a key
3392-- which is used for finger-printing
3393type KeyKey = [ByteString]
3394
3395data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show 3119data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
3396 3120
3397-- | This is a GPG Identity which includes a master key and all its UIDs and 3121-- | This is a GPG Identity which includes a master key and all its UIDs and
@@ -3404,34 +3128,6 @@ data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key
3404 3128
3405type KeyDB = Map.Map KeyKey KeyData 3129type KeyDB = Map.Map KeyKey KeyData
3406 3130
3407origin :: Packet -> Int -> OriginFlags
3408origin p n = OriginFlags ispub n
3409 where
3410 ispub = case p of
3411 SecretKeyPacket {} -> False
3412 _ -> True
3413
3414mappedPacket :: FilePath -> Packet -> MappedPacket
3415mappedPacket filename p = MappedPacket
3416 { packet = p
3417 , locations = Map.singleton filename (origin p (-1))
3418 }
3419
3420mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
3421mappedPacketWithHint filename p hint = MappedPacket
3422 { packet = p
3423 , locations = Map.singleton filename (origin p hint)
3424 }
3425
3426keykey :: Packet -> KeyKey
3427keykey key =
3428 -- Note: The key's timestamp is normally included in it's fingerprint.
3429 -- This is undesirable for kiki because it causes the same
3430 -- key to be imported multiple times and show as apparently
3431 -- distinct keys with different fingerprints.
3432 -- Thus, we will remove the timestamp.
3433 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
3434
3435uidkey :: Packet -> String 3131uidkey :: Packet -> String
3436uidkey (UserIDPacket str) = str 3132uidkey (UserIDPacket str) = str
3437 3133
@@ -3466,22 +3162,6 @@ onionName kd = (addr,name)
3466 where 3162 where
3467 (addr,(name:_,_)) = getHostnames kd 3163 (addr,(name:_,_)) = getHostnames kd
3468-} 3164-}
3469keyCompare :: String -> Packet -> Packet -> Ordering
3470keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
3471keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
3472keyCompare what a b | keykey a==keykey b = EQ
3473keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
3474 , fingerprint a
3475 , PP.ppShow a
3476 , fingerprint b
3477 , PP.ppShow b
3478 ]
3479
3480mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
3481mergeKeyPacket what key p =
3482 key { packet = minimumBy (keyCompare what) [packet key,packet p]
3483 , locations = Map.union (locations key) (locations p)
3484 }
3485 3165
3486 3166
3487merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] 3167merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index f5490e0..468394f 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -2,14 +2,16 @@
2{-# LANGUAGE OverloadedStrings #-} 2{-# LANGUAGE OverloadedStrings #-}
3module Kiki where 3module Kiki where
4 4
5import Control.Exception
6import Control.Applicative 5import Control.Applicative
7import Control.Arrow 6import Control.Arrow
7import Control.Concurrent
8import Control.Exception
8import Control.Monad 9import Control.Monad
9import Data.ASN1.BinaryEncoding 10import Data.ASN1.BinaryEncoding
10import Data.ASN1.Encoding 11import Data.ASN1.Encoding
11import Data.ASN1.Types 12import Data.ASN1.Types
12import Data.Binary 13import Data.Binary
14import Data.Char
13import Data.List 15import Data.List
14import Data.Maybe 16import Data.Maybe
15import Data.Monoid 17import Data.Monoid
@@ -21,11 +23,17 @@ import System.FilePath.Posix as FilePath
21import System.IO 23import System.IO
22import System.IO.Temp 24import System.IO.Temp
23import System.IO.Error 25import System.IO.Error
26import System.Posix.IO as Posix (createPipe)
24import System.Posix.User 27import System.Posix.User
25import System.Process 28import System.Process
26import System.Posix.Files 29import System.Posix.Files
27import qualified Data.Traversable as T (mapM) 30import qualified Data.Traversable as T (mapM)
31#if defined(VERSION_memory)
32import qualified Data.ByteString.Char8 as S8
33import Data.ByteArray.Encoding
34#elif defined(VERSION_dataenc)
28import qualified Codec.Binary.Base64 as Base64 35import qualified Codec.Binary.Base64 as Base64
36#endif
29import qualified Data.ByteString.Lazy as L 37import qualified Data.ByteString.Lazy as L
30import qualified Data.ByteString.Lazy.Char8 as Char8 38import qualified Data.ByteString.Lazy.Char8 as Char8
31import qualified Data.Map.Strict as Map 39import qualified Data.Map.Strict as Map
@@ -33,10 +41,50 @@ import qualified SSHKey as SSH
33import Network.Socket -- (SockAddr) 41import Network.Socket -- (SockAddr)
34import ProcessUtils 42import ProcessUtils
35 43
44import GnuPGAgent (Query(..))
36import CommandLine 45import CommandLine
37import KeyRing 46import KeyRing
38import DotLock 47import DotLock
39 48
49withAgent :: [PassphraseSpec] -> [PassphraseSpec]
50withAgent [] = [PassphraseAgent]
51withAgent ps = ps
52
53ciphername Unencrypted = "-"
54ciphername TripleDES = "3des"
55ciphername (SymmetricAlgorithm w8) = "cipher-"++show w8
56ciphername c = map toLower $ show c
57
58cipherFromString "clear" = Unencrypted
59cipherFromString "unencrypted" = Unencrypted
60cipherFromString s =
61 case filter ( (== s) . ciphername) ciphers of
62 x:_ -> x
63 -- _ | all isHexDigit s -> unhex s
64 _ -> error $ "known ciphers: "++unwords (map ciphername ciphers)
65 {-
66 where
67#if defined(VERSION_memory)
68 unhex hx = case convertFromBase Base16 (S8.pack hx) of
69 Left e -> do
70 -- Useful for debugging but insecure generally ;)
71 -- putStrLn $ "convertFromBase error for input "++show hx++": "++show e
72 return Nothing
73 Right bs -> return $ Just $ S8.unpack bs
74#elif defined(VERSION_dataenc)
75 unhex hx = maybe (return () {- putStrLn $ "dataenc error for input "++show hx -})
76 return
77 $ fmap (map $ chr . fromIntegral) $ Base16.decode hx
78#endif
79-}
80
81
82ciphers :: [SymmetricAlgorithm]
83ciphers = takeWhile notFallback $ map toEnum $ [0..4]++[7..]
84 where
85 notFallback (SymmetricAlgorithm _) = False
86 notFallback _ = True
87
40-- | 88-- |
41-- Regenerate /var/cache/kiki 89-- Regenerate /var/cache/kiki
42refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO () 90refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
@@ -78,8 +126,8 @@ minimalOp cap = op
78 [ ( HomeSec, streaminfo { access = Sec }) 126 [ ( HomeSec, streaminfo { access = Sec })
79 , ( HomePub, streaminfo { access = Pub }) 127 , ( HomePub, streaminfo { access = Pub })
80 ] 128 ]
81 , opPassphrases = do pfile <- maybeToList (cap_passfd cap) 129 , opPassphrases = withAgent $ do pfile <- maybeToList (cap_passfd cap)
82 return $ PassphraseSpec Nothing Nothing pfile 130 return $ PassphraseSpec Nothing Nothing pfile
83 , opTransforms = [] 131 , opTransforms = []
84 , opHome = cap_homespec cap 132 , opHome = cap_homespec cap
85 } 133 }
@@ -95,8 +143,8 @@ outputReport report = do
95 forM_ report $ \(fname,act) -> do 143 forM_ report $ \(fname,act) -> do
96 putStrLn $ fname ++ ": " ++ reportString act 144 putStrLn $ fname ++ ": " ++ reportString act
97 145
98importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO () 146importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO ()
99importAndRefresh root cmn = do 147importAndRefresh root cmn cipher = do
100 let rootdir = do guard (root "x" /= "x") 148 let rootdir = do guard (root "x" /= "x")
101 Just $ root "" 149 Just $ root ""
102 150
@@ -122,7 +170,13 @@ importAndRefresh root cmn = do
122 old_umask <- setFileCreationMask(0o077); 170 old_umask <- setFileCreationMask(0o077);
123 -- Generate secring.gpg if it does not exist... 171 -- Generate secring.gpg if it does not exist...
124 gotsec <- doesFileExist secring 172 gotsec <- doesFileExist secring
125 when (not gotsec) $ do 173
174 let passfd = cap_passfd cmn
175
176 (torgen,pwds) <-
177 if gotsec
178 then return (Generate 0 $ GenRSA $ 1024 `div` 8, [])
179 else do
126 {- ssh-keygen to create master key... 180 {- ssh-keygen to create master key...
127 let mkpath = home ++ "/master-key" 181 let mkpath = home ++ "/master-key"
128 mkdirFor mkpath 182 mkdirFor mkpath
@@ -135,12 +189,46 @@ importAndRefresh root cmn = do
135 HomeSec 189 HomeSec
136 ( encode $ Message [mk { is_subkey = False }] ) 190 ( encode $ Message [mk { is_subkey = False }] )
137 -} 191 -}
138 master <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 ) 192 master_un <- (\k -> MappedPacket (k { is_subkey = False }) Map.empty) <$> generateKey (GenRSA $ 4096 `div` 8 )
139 mkdirFor secring 193 tor_un <- generateKey (GenRSA $ 1024 `div` 8 )
140 writeInputFileL (InputFileContext secring pubring) 194 (read_tor,write_tor) <- Posix.createPipe
141 HomeSec 195 do rs <- writeKeyToFile (streaminfo { typ = PEMFile, access = Sec, spill = KF_Match "tor", fill = KF_All }) (FileDesc write_tor) tor_un
142 $ encode $ Message [master { is_subkey = False}] 196 -- outputReport $ map (first show) rs
143 197 return ()
198 let cipher's2k = (cipher {- AES128 -}, IteratedSaltedS2K SHA1 4073382889203176146 7864320)
199 ctx = InputFileContext secring pubring
200 main_passwds = withAgent $ do pfd <- maybeToList passfd
201 return $ PassphraseSpec Nothing Nothing pfd
202 passwordop = KeyRingOperation
203 { opFiles = Map.empty
204 , opPassphrases = main_passwds
205 , opHome = homespec
206 , opTransforms = []
207 }
208 let uidentry = Map.singleton (keykey $ packet master_un)
209 $ master_un { packet = Query (packet master_un)
210 (torUIDFromKey tor_un)
211 Nothing
212 }
213 transcoder <- makeMemoizingDecrypter passwordop ctx (Just master_un, uidentry)
214 master0 <- transcoder cipher's2k master_un
215 case master0 of
216 KikiSuccess master -> do
217 mkdirFor secring
218 writeInputFileL ctx
219 HomeSec
220 $ encode $ Message [master]
221 putStrLn "Wrote master key"
222 return (FileDesc read_tor, [PassphraseMemoizer transcoder])
223 er -> do
224 hPutStrLn stderr ("warning: " ++ errorString er)
225 hPutStrLn stderr "warning: keys will not be encrypted.";
226 mkdirFor secring
227 writeInputFileL ctx
228 HomeSec
229 $ encode $ Message [packet master_un]
230 putStrLn "Wrote master key"
231 return (Generate 0 (GenRSA $ 1024 `div` 8 ), [])
144 gotpub <- doesFileExist pubring 232 gotpub <- doesFileExist pubring
145 when (not gotpub) $ do 233 when (not gotpub) $ do
146 mkdirFor pubring 234 mkdirFor pubring
@@ -164,8 +252,7 @@ importAndRefresh root cmn = do
164 252
165 -- First, we ensure that the tor key exists and is imported 253 -- First, we ensure that the tor key exists and is imported
166 -- so that we know where to put the strongswan key. 254 -- so that we know where to put the strongswan key.
167 let passfd = cap_passfd cmn 255 let strm = StreamInfo { typ = KeyRingFile
168 strm = StreamInfo { typ = KeyRingFile
169 , fill = KF_None 256 , fill = KF_None
170 , spill = KF_All 257 , spill = KF_All
171 , access = AutoAccess 258 , access = AutoAccess
@@ -191,21 +278,30 @@ importAndRefresh root cmn = do
191 { opFiles = Map.fromList $ 278 { opFiles = Map.fromList $
192 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile ) 279 [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
193 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } ) 280 , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
194 , ( Generate 0 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "tor" }) 281 , ( torgen , case torgen of
195 , ( Generate 1 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "ipsec" }) 282 FileDesc _ -> StreamInfo { typ = PEMFile
283 , fill = KF_Match "tor"
284 , spill = KF_Match "tor"
285 , access = Sec
286 , initializer = NoCreate
287 , transforms = [] }
288 _ -> strm { spill = KF_Match "tor" })
289 , ( Generate 1 (GenRSA (2048 `div` 8)), strm { spill = KF_Match "ipsec" })
196 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") ) 290 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
197 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") ) 291 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
292 , ( Generate 2 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "encrypt" })
293 , ( Generate 3 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "sign" })
198 ] 294 ]
199 , opPassphrases = do pfd <- maybeToList passfd 295 , opPassphrases = withAgent $ pwds ++ do pfd <- maybeToList passfd
200 return $ PassphraseSpec Nothing Nothing pfd 296 return $ PassphraseSpec Nothing Nothing pfd
201 , opHome = homespec 297 , opHome = homespec
202 , opTransforms = [] 298 , opTransforms = []
203 } 299 }
204 -- doNothing = return () 300 -- doNothing = return ()
205 nop = KeyRingOperation 301 nop = KeyRingOperation
206 { opFiles = Map.empty 302 { opFiles = Map.empty
207 , opPassphrases = do pfd <- maybeToList passfd 303 , opPassphrases = withAgent $ do pfd <- maybeToList passfd
208 return $ PassphraseSpec Nothing Nothing pfd 304 return $ PassphraseSpec Nothing Nothing pfd
209 , opHome=homespec, opTransforms = [] 305 , opHome=homespec, opTransforms = []
210 } 306 }
211 -- if bUnprivileged then doNothing else mkdirFor torpath 307 -- if bUnprivileged then doNothing else mkdirFor torpath
@@ -299,12 +395,39 @@ refreshCache rt rootdir = do
299 wkkd = rtKeyDB rt Map.! keykey wk 395 wkkd = rtKeyDB rt Map.! keykey wk
300 getSecret tag = sortOn (Down . timestamp) 396 getSecret tag = sortOn (Down . timestamp)
301 $ getSubkeys Unsigned wk (keySubKeys wkkd) tag 397 $ getSubkeys Unsigned wk (keySubKeys wkkd) tag
302 398 exportOp = withOutgoing $ minimalOp (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt)
399 Nothing)
400 where
401 withOutgoing op = op
402 { opFiles = opFiles op `Map.union` Map.fromList outgoing_secrets
403 , opPassphrases = [PassphraseMemoizer (rtPassphrases rt)]
404 }
405 outgoing_secrets =
406 [ send "ipsec" (mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem") "missing ipsec key?"
407 , send "ssh-client" (mkpath "root/.ssh/id_rsa") "missing ssh-client key?"
408 , send "ssh-server" (mkpath "ssh_host_rsa_key") "missing ssh host key?"
409 , send "tor" (mkpath "tor/private_key") "missing tor key?"
410 ]
411 send usage path warning =
412 ( ArgFile path, StreamInfo { typ = PEMFile
413 , fill = KF_Match usage
414 , spill = KF_None
415 , access = Sec
416 , initializer = WarnMissing warning
417 , transforms = []
418 })
419 KikiResult rt' report <- runKeyRing exportOp
420
421 {-
303 let writeSecret tag path warning = do 422 let writeSecret tag path warning = do
304 let my_ks :: [Packet] 423 let my_ks :: [Packet]
305 my_ks = getSecret "ipsec" 424 my_ks = getSecret tag
306 case my_ks of 425 case my_ks of
307 sec:_ -> do report <- writeKeyToFile streaminfo { typ = PEMFile 426 se0:_ -> do sc1 <- rtPassphrases rt (Unencrypted,S2K 100 "") $ MappedPacket se0 Map.empty
427 let sec = case sc1 of
428 KikiSuccess s -> s
429 _ -> se0
430 report <- writeKeyToFile streaminfo { typ = PEMFile
308 , access = Sec 431 , access = Sec
309 , spill = KF_All 432 , spill = KF_All
310 } 433 }
@@ -335,6 +458,7 @@ refreshCache rt rootdir = do
335 writeSecret "tor" 458 writeSecret "tor"
336 (mkpath "tor/private_key") 459 (mkpath "tor/private_key")
337 "missing tor key?" 460 "missing tor key?"
461 -}
338 462
339 -- Finally, export public keys if they do not exist. 463 -- Finally, export public keys if they do not exist.
340 either warn (write $ mkpath "root/.ssh/id_rsa.pub") 464 either warn (write $ mkpath "root/.ssh/id_rsa.pub")
@@ -364,6 +488,7 @@ refreshCache rt rootdir = do
364 ipsecs :: [Packet] 488 ipsecs :: [Packet]
365 ipsecs = sortOn (Down . timestamp) 489 ipsecs = sortOn (Down . timestamp)
366 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec" 490 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
491 -- ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan"
367 sshs :: [Packet] 492 sshs :: [Packet]
368 sshs = sortOn (Down . timestamp) 493 sshs = sortOn (Down . timestamp)
369 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" 494 $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
@@ -449,7 +574,11 @@ sortOn f =
449pemFromPacket k = do 574pemFromPacket k = do
450 let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k 575 let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
451 der = encodeASN1 DER (toASN1 rsa []) 576 der = encodeASN1 DER (toASN1 rsa [])
577#if defined(VERSION_memory)
578 qq = S8.unpack $ convertToBase Base64 (L.toStrict der)
579#elif defined(VERSION_dataenc)
452 qq = Base64.encode (L.unpack der) 580 qq = Base64.encode (L.unpack der)
581#endif
453 return $ 582 return $
454 writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec) 583 writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)
455 584
@@ -491,6 +620,7 @@ sshblobFromPacketL k = do
491 RSAKey (MPI n) (MPI e) <- rsaKeyFromPacket k 620 RSAKey (MPI n) (MPI e) <- rsaKeyFromPacket k
492 return $ SSH.keyblob (n,e) 621 return $ SSH.keyblob (n,e)
493 622
623{-
494replaceSshServerKeys root cmn = do 624replaceSshServerKeys root cmn = do
495 let homepass' = cmn { cap_homespec = fmap root (cap_homespec cmn) } 625 let homepass' = cmn { cap_homespec = fmap root (cap_homespec cmn) }
496 replaceSSH op = op { opFiles = files } 626 replaceSSH op = op { opFiles = files }
@@ -508,6 +638,7 @@ replaceSshServerKeys root cmn = do
508 "" -> Nothing 638 "" -> Nothing
509 pth -> Just pth 639 pth -> Just pth
510 err -> hPutStrLn stderr $ errorString err 640 err -> hPutStrLn stderr $ errorString err
641-}
511 642
512slash :: String -> String -> String 643slash :: String -> String -> String
513slash "/" ('/':xs) = '/':xs 644slash "/" ('/':xs) = '/':xs
@@ -523,8 +654,11 @@ slash (y:ys) xs = y:slash ys xs
523 <$> optional (arg "--homedir") 654 <$> optional (arg "--homedir")
524 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd") 655 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
525 656
657ㄧcipher :: Args SymmetricAlgorithm
658ㄧcipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher")
659
526kikiOptions :: ( [(String,Int)], [String] ) 660kikiOptions :: ( [(String,Int)], [String] )
527kikiOptions = ( ss, ps ) 661kikiOptions = ( ss, ps )
528 where 662 where
529 ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1)] 663 ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1),("--cipher",1)]
530 ps = [] 664 ps = []
diff --git a/lib/PEM.hs b/lib/PEM.hs
index e07b3d4..fd2fe98 100644
--- a/lib/PEM.hs
+++ b/lib/PEM.hs
@@ -1,4 +1,5 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE CPP #-}
2module PEM where 3module PEM where
3 4
4import Data.Monoid 5import Data.Monoid
@@ -6,9 +7,14 @@ import qualified Data.ByteString.Lazy as LW
6import qualified Data.ByteString.Lazy.Char8 as L 7import qualified Data.ByteString.Lazy.Char8 as L
7import Control.Monad 8import Control.Monad
8import Control.Applicative 9import Control.Applicative
10#if defined(VERSION_memory)
11import qualified Data.ByteString.Char8 as S8
12import Data.ByteArray.Encoding
13#elif defined(VERSION_dataenc)
9import qualified Codec.Binary.Base64 as Base64 14import qualified Codec.Binary.Base64 as Base64
15#endif
10import ScanningParser 16import ScanningParser
11 17import FunctorToMaybe
12data PEMBlob = PEMBlob { pemType :: L.ByteString 18data PEMBlob = PEMBlob { pemType :: L.ByteString
13 , pemBlob :: L.ByteString 19 , pemBlob :: L.ByteString
14 } 20 }
@@ -28,7 +34,11 @@ pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
28 pbdy typ xs = (mblob, drop 1 rs) 34 pbdy typ xs = (mblob, drop 1 rs)
29 where 35 where
30 (ys,rs) = span (/="-----END " <> typ <> "-----") xs 36 (ys,rs) = span (/="-----END " <> typ <> "-----") xs
37#if defined(VERSION_memory)
38 mblob = PEMBlob typ <$> LW.fromStrict <$> (functorToMaybe $ convertFromBase Base64 $ L.toStrict dta)
39#elif defined(VERSION_dataenc)
31 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta) 40 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
41#endif
32 dta = case ys of 42 dta = case ys of
33 [] -> "" 43 [] -> ""
34 dta_lines -> L.concat dta_lines 44 dta_lines -> L.concat dta_lines
diff --git a/lib/PacketTranscoder.hs b/lib/PacketTranscoder.hs
new file mode 100644
index 0000000..f4b4cce
--- /dev/null
+++ b/lib/PacketTranscoder.hs
@@ -0,0 +1,306 @@
1{-# LANGUAGE TupleSections #-}
2{-# LANGUAGE OverloadedStrings #-}
3{-# LANGUAGE PatternGuards #-}
4module PacketTranscoder where
5
6import GHC.Stack
7import Control.Monad
8import Data.IORef
9import Data.List
10import Data.Maybe
11import Data.OpenPGP
12import Data.OpenPGP.Util
13import GnuPGAgent
14import qualified Data.ByteString as S
15import qualified Data.ByteString.Char8 as S8
16import Data.Map as Map (Map)
17import qualified Data.Map as Map
18import qualified Data.Traversable as Traversable
19import System.IO ( stderr)
20import System.Posix.IO ( fdToHandle )
21import Text.Show.Pretty as PP ( ppShow )
22import Types
23import ControlMaybe (handleIO_)
24
25-- | Merge two representations of the same key, prefering secret version
26-- because they have more information.
27mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
28mergeKeyPacket what key p =
29 key { packet = minimumBy (keyCompare what) [packet key,packet p]
30 , locations = Map.union (locations key) (locations p)
31 }
32
33-- | Compare different versions if the same key pair. Public versions
34-- are considered greater. If the two packets do not represent the same
35-- key or the packets are not keys at all, an error will result that
36-- includes the context provided as the first argument.
37keyCompare :: String -> Packet -> Packet -> Ordering
38keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
39keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
40keyCompare what a b | keykey a==keykey b = EQ
41keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
42 , if isKey a then fingerprint a else ""
43 , PP.ppShow a
44 , if isKey b then fingerprint b else ""
45 , PP.ppShow b
46 ]
47
48resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
49resolveInputFile ctx = resolve
50 where
51 resolve HomeSec = return (homesecPath ctx)
52 resolve HomePub = return (homepubPath ctx)
53 resolve (ArgFile f) = return f
54 resolve _ = []
55
56resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
57resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
58 where str = case (fdr,fdw) of
59 (0,1) -> "-"
60 _ -> "&pipe" ++ show (fdr,fdw)
61resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
62 where str = "&" ++ show fd
63resolveForReport mctx f = concat $ resolveInputFile ctx f
64 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
65
66readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
67readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
68readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
69readInputFileS ctx inp = do
70 let fname = resolveInputFile ctx inp
71 fmap S.concat $ mapM S.readFile fname
72
73
74
75-- | Reads contents of an 'InputFile' or returns the cached content from a prior call.
76-- An optional prompt is provided and will be printed on stdout only in the case that
77-- the provided 'InputFile' is 'FileDesc' 0 (i.e. stdin).
78cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
79cachedContents maybePrompt ctx fd = do
80 ref <- newIORef Nothing
81 return $ get maybePrompt ref fd
82 where
83 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
84
85 get maybePrompt ref fd = do
86 pw <- readIORef ref
87 flip (flip maybe return) pw $ do
88 if fd == FileDesc 0 then case maybePrompt of
89 Just prompt -> S.hPutStr stderr prompt
90 Nothing -> return ()
91 else return ()
92 pw <- fmap trimCR $ readInputFileS ctx fd
93 writeIORef ref (Just pw)
94 return pw
95
96
97
98makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
99 -> (Maybe MappedPacket, Map.Map KeyKey (OriginMapped Query))
100 -> IO PacketTranscoder
101makeMemoizingDecrypter operation ctx (workingkey,keys) = do
102 if null chains then do
103 -- (*) Notice we do not pass ctx to resolveForReport.
104 -- This is because the merge function does not currently use a context
105 -- and the pws map keys must match the MappedPacket locations.
106 -- TODO: Perhaps these should both be of type InputFile rather than
107 -- FilePath?
108 -- pws :: Map.Map FilePath (IO S.ByteString)
109 {-
110 -- This disabled code obtained password sources from StreamInfo records.
111 pws <-
112 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
113 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
114 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
115 -}
116 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
117 -- List of file-specific password sources.
118 pws2 <-
119 Traversable.mapM (cachedContents prompt ctx)
120 $ Map.fromList $ mapMaybe
121 (\spec -> (,passSpecPassFile spec) `fmap` do
122 guard $ isNothing $ passSpecKeySpec spec
123 passSpecRingFile spec)
124 passspecs
125 -- List of general password sources.
126 defpw <- do
127 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
128 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
129 && isNothing (passSpecKeySpec sp))
130 $ passspecs
131 unkeysRef <- newIORef (Map.empty :: Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet)
132 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw (not $ null agentspec)
133 else let PassphraseMemoizer f = head chains
134 in return f
135 where
136 (chains,passspecs0) = partition isChain $ opPassphrases operation
137 where isChain (PassphraseMemoizer {}) = True
138 isChain _ = False
139 (agentspec,passspecs) = partition isAgent passspecs0
140 where isAgent PassphraseAgent = True
141 isAgent _ = False
142 doDecrypt :: IORef (Map.Map (KeyKey,SymmetricAlgorithm,S2K) Packet)
143 -> Map.Map FilePath (IO S.ByteString)
144 -> Maybe (IO S.ByteString)
145 -> Bool
146 -> (SymmetricAlgorithm,S2K)
147 -> MappedPacket
148 -> IO (KikiCondition Packet)
149 doDecrypt unkeysRef pws defpw agent_requested (dest_alg,dest_s2k) mp0 = do
150 unkeys <- readIORef unkeysRef
151 let (mp,qry) = fromMaybe (mp0,Query (packet mp0) "anonymous2" Nothing)
152 $ mplus (do k <- Map.lookup kk keys
153 return (mergeKeyPacket "decrypt" mp0 (fmap queryPacket k), packet k))
154 (do guard $ is_subkey (packet mp0)
155 working <- fmap packet workingkey
156 q <- fmap packet $ Map.lookup (keykey working) keys
157 return (mp0, Query (packet mp0) (queryUID q) (Just working)))
158
159 dest_s2k' | dest_alg==Unencrypted = S2K 100 ""
160 | otherwise = dest_s2k
161
162 wk = packet mp0
163 kk = keykey wk
164 fs = Map.keys $ locations mp
165
166 decryptIt [] = return BadPassphrase
167 decryptIt (getpw:getpws) = tries 1 getpw (decryptIt getpws)
168 where
169 tries count getpw recurse = do
170 -- TODO: This function should use mergeKeyPacket to
171 -- combine the packet with it's unspilled version before
172 -- attempting to decrypt it. Note: We are uninterested
173 -- in the 'locations' field, so this would effectively
174 -- allow you to run 'decryptIt' on an unencrypted public key
175 -- to obtain it's secret key.
176 handleIO_ (decryptIt []) $ do
177 (pw,wants_retry) <- getpw (count,qry)
178 let wkun = fromMaybe wk $ do
179 guard $ symmetric_algorithm (packet mp) /= Unencrypted
180 decryptSecretKey pw (packet mp)
181
182 retryOrFail
183 | Just clear <- wants_retry = if count < 4
184 then tries (count+1) getpw recurse
185 else clear >> recurse
186 | otherwise = recurse
187
188 case symmetric_algorithm wkun of
189
190 Unencrypted -> do
191 writeIORef unkeysRef (Map.insert (kk,Unencrypted,S2K 100 "") wkun unkeys)
192 ek <- case dest_alg of
193 Unencrypted -> return $ Just wkun
194 _ -> encryptSecretKey pw dest_s2k' dest_alg wkun
195
196 case ek of
197 Nothing -> retryOrFail
198 Just wken -> do
199 modifyIORef unkeysRef (Map.insert (kk,dest_alg,dest_s2k') wken)
200 return $ KikiSuccess wken
201
202 _ -> retryOrFail
203
204 getpws = (map (const . fmap (,Nothing)) $ mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw) ++ [ agentpw | agent_requested ]
205
206 agentpw (count,qry) = do
207 s <- session
208 fromMaybe (return ("",Nothing)) $ do
209 s <- s
210 Just $ do
211 let (firsttime,maink) | Just k <- (queryMainKey qry) = (2,k)
212 | otherwise = (1,error "bug in makeMemoizingDecrypter")
213
214 alg = symmetric_algorithm (queryPacket qry)
215
216 ask | count<firsttime = AskNot
217 | count>firsttime = AskAgain "Bad passphrase"
218 | count==firsttime = initial_ask
219 where
220 initial_ask | Unencrypted <- alg = AskNew
221 | otherwise = AskExisting
222
223 actual_qry | count<firsttime = qry { queryPacket = maink, queryMainKey = Nothing }
224 | otherwise = qry
225
226 let clear | count > firsttime = clearPassphrase s (queryPacket qry)
227 | otherwise = return ()
228 clear
229 let sanitizeQry qry = (fingerprint $ queryPacket qry, queryUID qry, fmap fingerprint $ queryMainKey qry)
230 -- putStrLn $ "(count,firsttime,ask,qry,actual_qry)="++show (count,firsttime,ask,sanitizeQry qry, sanitizeQry actual_qry)
231 mbpw <- getPassphrase s ask actual_qry
232 quit s
233 return ( maybe "" S8.pack mbpw, guard (ask /= AskNew) >> Just clear )
234
235 calls <- currentCallStack
236 putStrLn $ concat [fingerprint wk," ", show (symmetric_algorithm wk,s2k wk)," --> ",show (dest_alg,dest_s2k)]
237 mapM_ putStrLn calls
238 if symmetric_algorithm wk == dest_alg && s2k wk == dest_s2k'
239 then return (KikiSuccess wk)
240 else maybe (decryptIt getpws)
241 (return . KikiSuccess)
242 $ Map.lookup (kk,dest_alg,dest_s2k') unkeys
243
244keyQueries :: Maybe String -> Map InputFile (StreamInfo,Message) -> (Maybe MappedPacket, Map KeyKey (OriginMapped Query))
245keyQueries grip ringPackets = (mwk, fmap makeQuery keys)
246 where
247 makeQuery (maink,mp,us) = mp { packet = q }
248 where q = Query { queryPacket = packet mp
249 , queryUID = concat $ take 1 $ Map.keys $ Map.union us (getUIDS maink)
250 , queryMainKey = if is_subkey (packet mp)
251 then maink `mplus` fmap packet mwk
252 else Nothing
253 }
254
255 getUIDS maink = fromMaybe Map.empty $ do
256 k <- maink
257 (_,_,mus) <- Map.lookup (keykey k) keys
258 return mus
259
260 -- | mwk
261 -- first master key matching the provided grip
262 -- (the m is for "MappedPacket", wk for working key)
263 mwk :: Maybe MappedPacket
264 mwk = listToMaybe $ do
265 fp <- maybeToList grip
266 let matchfp mp
267 | not (is_subkey p) && matchpr fp p == fp = Just mp
268 | otherwise = Nothing
269 where p = packet mp
270 Map.elems $ Map.mapMaybe matchfp $ fmap (\(_,p,_) -> p) $ keys
271
272 keys = Map.foldl slurpkeys Map.empty
273 $ Map.mapWithKey filterSecrets ringPackets
274 where
275 filterSecrets :: InputFile -> (a,Message) -> [[MappedPacket]]
276 filterSecrets f (_,Message ps) = keygroups
277 -- filter (isSecretKey . packet) mps
278 where
279 mps = zipWith (mappedPacketWithHint fname) ps [1..]
280 fname = resolveForReport Nothing f -- (Just ctx) f
281 keygroups = dropWhile (not . isSecretKey . packet . head)
282 $ groupBy (const $ not . isSecretKey . packet) mps
283 slurpkeys :: (Map KeyKey (Maybe Packet,MappedPacket,Map String [Packet]))
284 -> [[MappedPacket]]
285 -> (Map KeyKey (Maybe Packet, MappedPacket,Map String [Packet]))
286 slurpkeys m pss = Map.unionWith combineKeyKey m m2
287 where
288
289 m2 :: Map.Map KeyKey (Maybe Packet, MappedPacket, (Map.Map String [Packet]))
290 m2 = Map.fromList
291 $ drop 1
292 $ scanl' build ([],(Nothing,error "bug in PacketTranscoder (1)", error "bug in PacketTranscoder (2)")) pss
293 where
294 build (_,(main0,_,_)) ps = (kk,(main,kp,uidmap ps'))
295 where
296 main | is_subkey (packet kp) = main0
297 | otherwise = Just $ packet kp
298 (kpkt,ps') = splitAt 1 ps
299 kp = head kpkt
300 kk = keykey . packet $ kp
301 combineKeyKey (master1,mp,um) (master2,mp2,um2) = (master1 `mplus` master2,mp,Map.unionWith (++) um um2)
302 uidmap ps = um2
303 where
304 ugs = dropWhile (not . isUserID . packet .head) $ groupBy (const $ not . isUserID . packet) ps
305 um2 = Map.fromList
306 $ map (\(MappedPacket (UserIDPacket s) _:sigs)->(s,takeWhile isSignaturePacket $ map packet sigs)) ugs
diff --git a/lib/SSHKey.hs b/lib/SSHKey.hs
index 488f55f..bd47169 100644
--- a/lib/SSHKey.hs
+++ b/lib/SSHKey.hs
@@ -1,9 +1,16 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2{-# LANGUAGE CPP #-}
2module SSHKey where 3module SSHKey where
3 4
4import qualified Data.ByteString.Lazy.Char8 as L8 5import qualified Data.ByteString.Lazy.Char8 as L8
5import qualified Data.ByteString.Lazy as L 6import qualified Data.ByteString.Lazy as L
7#if defined(VERSION_memory)
8import qualified Data.ByteString.Char8 as S8
9import Data.ByteArray.Encoding
10import FunctorToMaybe
11#elif defined(VERSION_dataenc)
6import qualified Codec.Binary.Base64 as Base64 12import qualified Codec.Binary.Base64 as Base64
13#endif
7import Data.Binary.Get ( runGet ) 14import Data.Binary.Get ( runGet )
8import Data.Binary.Put ( putWord32be, runPut, putByteString ) 15import Data.Binary.Put ( putWord32be, runPut, putByteString )
9import Data.Binary ( get, put ) 16import Data.Binary ( get, put )
@@ -19,7 +26,11 @@ keyblob :: Key -> L.ByteString
19keyblob (n,e) = "ssh-rsa " <> blob 26keyblob (n,e) = "ssh-rsa " <> blob
20 where 27 where
21 bs = sshrsa e n 28 bs = sshrsa e n
29#if defined(VERSION_memory)
30 blob = L.fromStrict $ convertToBase Base64 (L.toStrict bs)
31#elif defined(VERSION_dataenc)
22 blob = L8.pack $ Base64.encode (L.unpack bs) 32 blob = L8.pack $ Base64.encode (L.unpack bs)
33#endif
23 34
24 sshrsa :: Integer -> Integer -> L.ByteString 35 sshrsa :: Integer -> Integer -> L.ByteString
25 sshrsa e n = runPut $ do 36 sshrsa e n = runPut $ do
@@ -35,7 +46,11 @@ blobkey bs = do
35 let (sp,bs2) = L8.span isSpace bs1 46 let (sp,bs2) = L8.span isSpace bs1
36 guard $ not (L8.null sp) 47 guard $ not (L8.null sp)
37 bs3 <- listToMaybe $ L8.words bs2 48 bs3 <- listToMaybe $ L8.words bs2
49#if defined(VERSION_memory)
50 qq <- fmap L.fromStrict $ functorToMaybe $ convertFromBase Base64 $ L.toStrict bs3
51#elif defined(VERSION_dataenc)
38 qq <- L.pack `fmap` Base64.decode (L8.unpack bs3) 52 qq <- L.pack `fmap` Base64.decode (L8.unpack bs3)
53#endif
39 decode_sshrsa qq 54 decode_sshrsa qq
40 where 55 where
41 decode_sshrsa :: L8.ByteString -> Maybe Key 56 decode_sshrsa :: L8.ByteString -> Maybe Key
diff --git a/lib/TimeUtil.hs b/lib/TimeUtil.hs
index 879bc32..b678d5f 100644
--- a/lib/TimeUtil.hs
+++ b/lib/TimeUtil.hs
@@ -11,6 +11,8 @@ module TimeUtil
11 , dateParser 11 , dateParser
12 ) where 12 ) where
13 13
14-- TODO: switch to hourglass package
15
14import Data.Time.LocalTime 16import Data.Time.LocalTime
15import Data.Time.Format 17import Data.Time.Format
16import Data.Time.Clock 18import Data.Time.Clock
diff --git a/lib/Types.hs b/lib/Types.hs
new file mode 100644
index 0000000..86836e0
--- /dev/null
+++ b/lib/Types.hs
@@ -0,0 +1,298 @@
1{-# LANGUAGE DeriveFunctor #-}
2module Types where
3
4import Data.Map as Map (Map)
5import qualified Data.Map as Map
6import Data.OpenPGP
7import Data.OpenPGP.Util
8import FunctorToMaybe
9import qualified Data.ByteString.Lazy as L
10import qualified System.Posix.Types as Posix
11
12-- | This type describes an idempotent transformation (merge or import) on a
13-- set of GnuPG keyrings and other key files.
14data KeyRingOperation = KeyRingOperation
15 { opFiles :: Map InputFile StreamInfo
16 -- ^ Indicates files to be read or updated.
17 , opPassphrases :: [PassphraseSpec]
18 -- ^ Indicates files or file descriptors where passphrases can be found.
19 , opTransforms :: [Transform]
20 -- ^ Transformations to be performed on the key pool after all files have
21 -- been read and before any have been written.
22 , opHome :: Maybe FilePath
23 -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
24 -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted
25 -- and if that is not set, it falls back to $HOME/.gnupg.
26 }
27 deriving (Eq,Show)
28
29data InputFile = HomeSec
30 -- ^ A file named secring.gpg located in the home directory.
31 -- See 'opHome'.
32 | HomePub
33 -- ^ A file named pubring.gpg located in the home directory.
34 -- See 'opHome'.
35 | ArgFile FilePath
36 -- ^ Contents will be read or written from the specified path.
37 | FileDesc Posix.Fd
38 -- ^ Contents will be read or written from the specified file
39 -- descriptor.
40 | Pipe Posix.Fd Posix.Fd
41 -- ^ Contents will be read from the first descriptor and updated
42 -- content will be writen to the second. Note: Don't use Pipe
43 -- for 'Wallet' files. (TODO: Wallet support)
44 | Generate Int GenerateKeyParams
45 -- ^ New key packets will be generated if there is no
46 -- matching content already in the key pool. The integer is
47 -- a unique id number so that multiple generations can be
48 -- inserted into 'opFiles'
49 deriving (Eq,Ord,Show)
50
51-- | This type describes how 'runKeyRing' will treat a file.
52data StreamInfo = StreamInfo
53 { access :: Access
54 -- ^ Indicates whether the file is allowed to contain secret information.
55 , typ :: FileType
56 -- ^ Indicates the format and content type of the file.
57 , fill :: KeyFilter
58 -- ^ This filter controls what packets will be inserted into a file.
59 , spill :: KeyFilter
60 --
61 -- ^ Use this to indicate whether or not a file's contents should be
62 -- available for updating other files. Note that although its type is
63 -- 'KeyFilter', it is usually interpretted as a boolean flag. Details
64 -- depend on 'typ' and are as follows:
65 --
66 -- 'KeyRingFile':
67 --
68 -- * 'KF_None' - The file's contents will not be shared.
69 --
70 -- * otherwise - The file's contents will be shared.
71 --
72 -- 'PEMFile':
73 --
74 -- * 'KF_None' - The file's contents will not be shared.
75 --
76 -- * 'KF_Match' - The file's key will be shared with the specified owner
77 -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be
78 -- equal to this value; changing the usage or owner of a key is not
79 -- supported via the fill/spill mechanism.
80 --
81 -- * otherwise - Unspecified. Do not use.
82 --
83 -- 'WalletFile':
84 --
85 -- * The 'spill' setting is ignored and the file's contents are shared.
86 -- (TODO)
87 --
88 -- 'Hosts':
89 --
90 -- * The 'spill' setting is ignored and the file's contents are shared.
91 -- (TODO)
92 --
93 , initializer :: Initializer
94 -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set,
95 -- then it is interpretted as a shell command that may be used to create
96 -- the key if it does not exist.
97 , transforms :: [Transform]
98 -- ^ Per-file transformations that occur before the contents of a file are
99 -- spilled into the common pool.
100 }
101 deriving (Eq,Show)
102
103
104-- | This type is used to indicate where to obtain passphrases.
105data PassphraseSpec = PassphraseSpec
106 { passSpecRingFile :: Maybe FilePath
107 -- ^ If not Nothing, the passphrase is to be used for packets
108 -- from this file.
109 , passSpecKeySpec :: Maybe String
110 -- ^ Non-Nothing value reserved for future use.
111 -- (TODO: Use this to implement per-key passphrase associations).
112 , passSpecPassFile :: InputFile
113 -- ^ The passphrase will be read from this file or file descriptor.
114 }
115 -- | Use this to carry pasphrases from a previous run.
116 | PassphraseMemoizer PacketTranscoder
117 | PassphraseAgent
118
119instance Show PassphraseSpec where
120 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
121 show (PassphraseMemoizer _) = "PassphraseMemoizer"
122instance Eq PassphraseSpec where
123 PassphraseSpec a b c == PassphraseSpec d e f
124 = and [a==d,b==e,c==f]
125 _ == _
126 = False
127
128
129
130data Transform =
131 Autosign
132 -- ^ This operation will make signatures for any tor-style UID
133 -- that matches a tor subkey and thus can be authenticated without
134 -- requring the judgement of a human user.
135 --
136 -- A tor-style UID is one of the following form:
137 --
138 -- > Anonymous <root@HOSTNAME.onion>
139 | DeleteSubkeyByFingerprint String
140 -- ^ Delete the subkey specified by the given fingerprint and any
141 -- associated signatures on that key.
142 | DeleteSubkeyByUsage String
143 -- ^ Delete the subkey specified by the given fingerprint and any
144 -- associated signatures on that key.
145 deriving (Eq,Ord,Show)
146
147-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
148-- to contain secret or public PGP key packets. Note that it is not supported
149-- to mix both in the same file and that the secret key packets include all of
150-- the information contained in their corresponding public key packets.
151data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
152 -- (see 'rtRingAccess')
153 | Sec -- ^ secret information
154 | Pub -- ^ public information
155 deriving (Eq,Ord,Show)
156
157data FileType = KeyRingFile
158 | PEMFile
159 | WalletFile
160 | DNSPresentation
161 | Hosts
162 | SshFile
163 deriving (Eq,Ord,Enum,Show)
164
165-- type UsageTag = String
166data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String
167 deriving (Eq,Ord,Show)
168
169
170
171type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet)
172type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet)
173
174-- | Note that the documentation here is intended for when this value is
175-- assigned to 'fill'. For other usage, see 'spill'.
176data KeyFilter = KF_None -- ^ No keys will be imported.
177 | KF_Match String -- ^ Only the key that matches the spec will be imported.
178 | KF_Subkeys -- ^ Subkeys will be imported if their owner key is
179 -- already in the ring. TODO: Even if their signatures
180 -- are bad?
181 | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
182 -- identity (signed or self-authenticating).
183 | KF_All -- ^ All keys will be imported.
184 deriving (Eq,Ord,Show)
185
186-- | The position and acces a packet had before the operation
187data OriginFlags = OriginFlags
188 { originallyPublic :: Bool
189 -- ^ false if SecretKeyPacket
190 , originalNum :: Int
191 -- ^ packets are numbered, starting from 1..
192 } deriving Show
193
194type OriginMap = Map FilePath OriginFlags
195
196type MappedPacket = OriginMapped Packet
197data OriginMapped a = MappedPacket
198 { packet :: a
199 , locations :: OriginMap
200 } deriving Show
201instance Functor OriginMapped where
202 fmap f (MappedPacket x ls) = MappedPacket (f x) ls
203
204origin :: Packet -> Int -> OriginFlags
205origin p n = OriginFlags ispub n
206 where
207 ispub = case p of
208 SecretKeyPacket {} -> False
209 _ -> True
210
211mappedPacket :: FilePath -> Packet -> MappedPacket
212mappedPacket filename p = MappedPacket
213 { packet = p
214 , locations = Map.singleton filename (origin p (-1))
215 }
216
217mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
218mappedPacketWithHint filename p hint = MappedPacket
219 { packet = p
220 , locations = Map.singleton filename (origin p hint)
221 }
222
223
224-- | This type is used to indicate success or failure
225-- and in the case of success, return the computed object.
226-- The 'FunctorToMaybe' class is implemented to facilitate
227-- branching on failture.
228data KikiCondition a = KikiSuccess a
229 | FailedToLock [FilePath]
230 | BadPassphrase
231 | FailedToMakeSignature
232 | CantFindHome
233 | AmbiguousKeySpec FilePath
234 | CannotImportMasterKey
235 | NoWorkingKey
236 deriving ( Functor, Show )
237
238instance FunctorToMaybe KikiCondition where
239 functorToMaybe (KikiSuccess a) = Just a
240 functorToMaybe _ = Nothing
241
242instance Applicative KikiCondition where
243 pure a = KikiSuccess a
244 f <*> a =
245 case functorToEither f of
246 Right f -> case functorToEither a of
247 Right a -> pure (f a)
248 Left err -> err
249 Left err -> err
250
251data InputFileContext = InputFileContext
252 { homesecPath :: FilePath
253 , homepubPath :: FilePath
254 }
255
256
257-- | The 'KeyKey'-type is used to store the information of a key
258-- which is used for finger-printing and as a lookup key into
259-- maps. This type may be changed to an actual fingerprint in
260-- in the future.
261type KeyKey = [L.ByteString]
262
263keykey :: Packet -> KeyKey
264keykey key =
265 -- Note: The key's timestamp is normally included in it's fingerprint.
266 -- This is undesirable for kiki because it causes the same
267 -- key to be imported multiple times and show as apparently
268 -- distinct keys with different fingerprints.
269 -- Thus, we will remove the timestamp.
270 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
271
272isKey :: Packet -> Bool
273isKey (PublicKeyPacket {}) = True
274isKey (SecretKeyPacket {}) = True
275isKey _ = False
276
277isSecretKey :: Packet -> Bool
278isSecretKey (SecretKeyPacket {}) = True
279isSecretKey _ = False
280
281
282isUserID :: Packet -> Bool
283isUserID (UserIDPacket {}) = True
284isUserID _ = False
285
286isTrust :: Packet -> Bool
287isTrust (TrustPacket {}) = True
288isTrust _ = False
289
290-- matchpr computes the fingerprint of the given key truncated to
291-- be the same lenght as the given fingerprint for comparison.
292--
293-- matchpr fp = Data.List.Extra.takeEnd (length fp)
294--
295matchpr :: String -> Packet -> String
296matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
297
298
generated by cgit v1.2.3 (git 2.39.1) at 2024-09-16 02:30:37 +0000