diff options
-rw-r--r-- | KeyRing.hs | 90 |
1 files changed, 50 insertions, 40 deletions
@@ -19,7 +19,7 @@ import Data.Functor | |||
19 | import Data.Monoid | 19 | import Data.Monoid |
20 | import Data.Tuple ( swap ) | 20 | import Data.Tuple ( swap ) |
21 | import Data.Bits ( (.|.) ) | 21 | import Data.Bits ( (.|.) ) |
22 | import Control.Applicative ( liftA2, (<$>) ) | 22 | import Control.Applicative ( Applicative, pure, liftA2, (<$>), (<*>) ) |
23 | import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) | 23 | import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) |
24 | import Control.Arrow ( first, second ) | 24 | import Control.Arrow ( first, second ) |
25 | import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) | 25 | import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) |
@@ -54,6 +54,7 @@ import Data.Binary ( encode ) | |||
54 | import Data.IORef | 54 | import Data.IORef |
55 | import System.Posix.IO (fdToHandle,fdRead) | 55 | import System.Posix.IO (fdToHandle,fdRead) |
56 | import qualified Data.Traversable as Traversable (mapM,forM,sequence) | 56 | import qualified Data.Traversable as Traversable (mapM,forM,sequence) |
57 | import Data.Traversable ( sequenceA ) | ||
57 | #if ! MIN_VERSION_base(4,6,0) | 58 | #if ! MIN_VERSION_base(4,6,0) |
58 | import GHC.Exts ( Down(..) ) | 59 | import GHC.Exts ( Down(..) ) |
59 | #endif | 60 | #endif |
@@ -292,12 +293,22 @@ data KikiCondition a = KikiSuccess a | |||
292 | | CantFindHome | 293 | | CantFindHome |
293 | | AmbiguousKeySpec FilePath | 294 | | AmbiguousKeySpec FilePath |
294 | | CannotImportMasterKey | 295 | | CannotImportMasterKey |
296 | | NoWorkingKey | ||
295 | deriving ( Functor, Show ) | 297 | deriving ( Functor, Show ) |
296 | 298 | ||
297 | instance FunctorToMaybe KikiCondition where | 299 | instance FunctorToMaybe KikiCondition where |
298 | functorToMaybe (KikiSuccess a) = Just a | 300 | functorToMaybe (KikiSuccess a) = Just a |
299 | functorToMaybe _ = Nothing | 301 | functorToMaybe _ = Nothing |
300 | 302 | ||
303 | instance Applicative KikiCondition where | ||
304 | pure a = KikiSuccess a | ||
305 | f <*> a = | ||
306 | case functorToEither f of | ||
307 | Right f -> case functorToEither a of | ||
308 | Right a -> pure (f a) | ||
309 | Left err -> err | ||
310 | Left err -> err | ||
311 | |||
301 | data KikiReportAction = | 312 | data KikiReportAction = |
302 | NewPacket String | 313 | NewPacket String |
303 | | MissingPacket String | 314 | | MissingPacket String |
@@ -1339,46 +1350,45 @@ performManipulations :: | |||
1339 | -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) | 1350 | -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) |
1340 | performManipulations doDecrypt operation rt wk = do | 1351 | performManipulations doDecrypt operation rt wk = do |
1341 | let db = rtKeyDB rt | 1352 | let db = rtKeyDB rt |
1342 | db <- let perform kd (InducerSignature uid subpaks) = do | 1353 | performAll kd = foldM perform (KikiSuccess kd) $ kManip operation rt kd |
1343 | case wk of | 1354 | r <- Traversable.mapM performAll db |
1344 | Nothing -> error "TODO no working key" -- todo | 1355 | try (sequenceA r) $ \db -> do |
1345 | Just wk' -> do | ||
1346 | wkun' <- doDecrypt wk' | ||
1347 | case functorToEither wkun' of | ||
1348 | Left e -> error "Bad passphrase, todo" | ||
1349 | Right wkun -> do | ||
1350 | let sigOver = makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) subpaks | ||
1351 | sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) | ||
1352 | let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) | ||
1353 | f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x | ||
1354 | , om `Map.union` snd x ) | ||
1355 | om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid | ||
1356 | toMappedPacket om p = (mappedPacket "" p) {locations=om} | ||
1357 | selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard | ||
1358 | . (== keykey whosign) | ||
1359 | . keykey)) vs | ||
1360 | keys = map keyPacket $ Map.elems (rtKeyDB rt) | ||
1361 | overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) | ||
1362 | vs :: [ ( Packet -- signature | ||
1363 | , Maybe SignatureOver -- Nothing means non-verified | ||
1364 | , Packet ) -- key who signed | ||
1365 | ] | ||
1366 | vs = do | ||
1367 | x <- maybeToList $ Map.lookup uid (rentryUids kd) | ||
1368 | sig <- map (packet . fst) (fst x) | ||
1369 | o <- overs sig | ||
1370 | k <- keys | ||
1371 | let ov = verify (Message [k]) $ o | ||
1372 | signatures_over ov | ||
1373 | return (sig,Just ov,k) | ||
1374 | additional new_sig = do | ||
1375 | new_sig <- maybeToList new_sig | ||
1376 | guard (null $ selfsigs) | ||
1377 | signatures_over new_sig | ||
1378 | return kd { rentryUids = Map.adjust f uid (rentryUids kd) } | ||
1379 | in Traversable.mapM (\kd -> foldM perform kd (kManip operation rt kd)) db | ||
1380 | return $ KikiSuccess (rt { rtKeyDB = db },[]) | 1356 | return $ KikiSuccess (rt { rtKeyDB = db },[]) |
1381 | 1357 | where | |
1358 | perform kd (InducerSignature uid subpaks) = do | ||
1359 | try kd $ \kd -> do | ||
1360 | flip (maybe $ return NoWorkingKey) wk $ \wk' -> do | ||
1361 | wkun' <- doDecrypt wk' | ||
1362 | try wkun' $ \wkun -> do | ||
1363 | let sigOver = makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) subpaks | ||
1364 | sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) | ||
1365 | let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) | ||
1366 | f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x | ||
1367 | , om `Map.union` snd x ) | ||
1368 | om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid | ||
1369 | toMappedPacket om p = (mappedPacket "" p) {locations=om} | ||
1370 | selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard | ||
1371 | . (== keykey whosign) | ||
1372 | . keykey)) vs | ||
1373 | keys = map keyPacket $ Map.elems (rtKeyDB rt) | ||
1374 | overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) | ||
1375 | vs :: [ ( Packet -- signature | ||
1376 | , Maybe SignatureOver -- Nothing means non-verified | ||
1377 | , Packet ) -- key who signed | ||
1378 | ] | ||
1379 | vs = do | ||
1380 | x <- maybeToList $ Map.lookup uid (rentryUids kd) | ||
1381 | sig <- map (packet . fst) (fst x) | ||
1382 | o <- overs sig | ||
1383 | k <- keys | ||
1384 | let ov = verify (Message [k]) $ o | ||
1385 | signatures_over ov | ||
1386 | return (sig,Just ov,k) | ||
1387 | additional new_sig = do | ||
1388 | new_sig <- maybeToList new_sig | ||
1389 | guard (null $ selfsigs) | ||
1390 | signatures_over new_sig | ||
1391 | return $ KikiSuccess $ kd { rentryUids = Map.adjust f uid (rentryUids kd) } | ||
1382 | 1392 | ||
1383 | initializeMissingPEMFiles :: | 1393 | initializeMissingPEMFiles :: |
1384 | KeyRingOperation | 1394 | KeyRingOperation |