diff options
author | James Crayne <jim.crayne@gmail.com> | 2016-04-30 02:58:04 -0400 |
---|---|---|
committer | James Crayne <jim.crayne@gmail.com> | 2016-04-30 02:58:04 -0400 |
commit | e69a1a1f1991c2ce879aaba187002a7b5a5f6827 (patch) | |
tree | f5e47fdf81e6a4dcafb7e9a54bb528f2c784f3a0 /lib/KeyRing.hs | |
parent | c2cf1002fa6f48cc699f6c5925272a2ddb28bd64 (diff) |
comments and type signatures
Diffstat (limited to 'lib/KeyRing.hs')
-rw-r--r-- | lib/KeyRing.hs | 101 |
1 files changed, 73 insertions, 28 deletions
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs index 77d6973..2c174b3 100644 --- a/lib/KeyRing.hs +++ b/lib/KeyRing.hs | |||
@@ -828,6 +828,9 @@ usageString flgs = | |||
828 | 828 | ||
829 | -- matchpr computes the fingerprint of the given key truncated to | 829 | -- matchpr computes the fingerprint of the given key truncated to |
830 | -- be the same lenght as the given fingerprint for comparison. | 830 | -- be the same lenght as the given fingerprint for comparison. |
831 | -- | ||
832 | -- matchpr fp = Data.List.Extra.takeEnd (length fp) | ||
833 | -- | ||
831 | matchpr :: String -> Packet -> String | 834 | matchpr :: String -> Packet -> String |
832 | matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp | 835 | matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp |
833 | 836 | ||
@@ -1578,20 +1581,24 @@ isSecretKey :: Packet -> Bool | |||
1578 | isSecretKey (SecretKeyPacket {}) = True | 1581 | isSecretKey (SecretKeyPacket {}) = True |
1579 | isSecretKey _ = False | 1582 | isSecretKey _ = False |
1580 | 1583 | ||
1584 | -- | buildKeyDB | ||
1585 | -- | ||
1586 | -- merge all keyrings, PEM files, and wallets into process memory. | ||
1587 | -- | ||
1581 | buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation | 1588 | buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation |
1582 | -> IO (KikiCondition ((KeyDB | 1589 | -> IO (KikiCondition (({- db -} KeyDB |
1583 | ,Maybe String | 1590 | ,{- grip -} Maybe String |
1584 | ,Maybe MappedPacket | 1591 | ,{- wk -} Maybe MappedPacket |
1585 | ,([Hosts.Hosts], | 1592 | ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], |
1586 | [Hosts.Hosts], | 1593 | {- hostdbs -}[Hosts.Hosts], |
1587 | Hosts.Hosts, | 1594 | {- u1 -}Hosts.Hosts, |
1588 | [(SockAddr, (KeyKey, KeyKey))], | 1595 | {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], |
1589 | [SockAddr]) | 1596 | {- outgoing_names -}[SockAddr]) |
1590 | ,Map.Map InputFile Access | 1597 | ,{- accs -} Map.Map InputFile Access |
1591 | ,MappedPacket -> IO (KikiCondition Packet) | 1598 | ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) |
1592 | ,Map.Map InputFile Message | 1599 | ,{- unspilled -} Map.Map InputFile Message |
1593 | ) | 1600 | ) |
1594 | ,[(FilePath,KikiReportAction)])) | 1601 | ,{- report_imports -} [(FilePath,KikiReportAction)])) |
1595 | buildKeyDB ctx grip0 keyring = do | 1602 | buildKeyDB ctx grip0 keyring = do |
1596 | let | 1603 | let |
1597 | files istyp = do | 1604 | files istyp = do |
@@ -1633,7 +1640,16 @@ buildKeyDB ctx grip0 keyring = do | |||
1633 | fstkey = do | 1640 | fstkey = do |
1634 | (_,Message ps) <- Map.lookup HomeSec ringPackets | 1641 | (_,Message ps) <- Map.lookup HomeSec ringPackets |
1635 | listToMaybe ps | 1642 | listToMaybe ps |
1643 | |||
1644 | -- | spilled | ||
1645 | -- ring packets with info available for export | ||
1646 | -- | unspilled | ||
1647 | -- the rest | ||
1636 | (spilled,unspilled) = Map.partition (spillable . fst) ringPackets | 1648 | (spilled,unspilled) = Map.partition (spillable . fst) ringPackets |
1649 | |||
1650 | -- | keys | ||
1651 | -- process ringPackets, and get a map of fingerprint info to | ||
1652 | -- to a packet, remembering it's original file, access. | ||
1637 | keys :: Map.Map KeyKey MappedPacket | 1653 | keys :: Map.Map KeyKey MappedPacket |
1638 | keys = Map.foldl slurpkeys Map.empty | 1654 | keys = Map.foldl slurpkeys Map.empty |
1639 | $ Map.mapWithKey filterSecrets ringPackets | 1655 | $ Map.mapWithKey filterSecrets ringPackets |
@@ -1644,13 +1660,20 @@ buildKeyDB ctx grip0 keyring = do | |||
1644 | where fname = resolveForReport (Just ctx) f | 1660 | where fname = resolveForReport (Just ctx) f |
1645 | slurpkeys m ps = m `Map.union` Map.fromList ps' | 1661 | slurpkeys m ps = m `Map.union` Map.fromList ps' |
1646 | where ps' = zip (map (keykey . packet) ps) ps | 1662 | where ps' = zip (map (keykey . packet) ps) ps |
1647 | wk = listToMaybe $ do | 1663 | -- | mwk |
1664 | -- first master key matching the provided grip | ||
1665 | -- (the m is for "MappedPacket", wk for working key) | ||
1666 | mwk :: Maybe MappedPacket | ||
1667 | mwk = listToMaybe $ do | ||
1648 | fp <- maybeToList grip | 1668 | fp <- maybeToList grip |
1649 | let matchfp mp = not (is_subkey p) && matchpr fp p == fp | 1669 | let matchfp mp = not (is_subkey p) && matchpr fp p == fp |
1650 | where p = packet mp | 1670 | where p = packet mp |
1651 | Map.elems $ Map.filter matchfp keys | 1671 | Map.elems $ Map.filter matchfp keys |
1672 | -- | accs | ||
1673 | -- file access(Sec | Pub) lookup table | ||
1674 | accs :: Map.Map InputFile Access | ||
1652 | accs = fmap (access . fst) ringPackets | 1675 | accs = fmap (access . fst) ringPackets |
1653 | return (spilled,wk,grip,accs,keys,fmap snd unspilled) | 1676 | return (spilled,mwk,grip,accs,keys,fmap snd unspilled) |
1654 | 1677 | ||
1655 | doDecrypt <- makeMemoizingDecrypter keyring ctx keys | 1678 | doDecrypt <- makeMemoizingDecrypter keyring ctx keys |
1656 | 1679 | ||
@@ -1663,8 +1686,10 @@ buildKeyDB ctx grip0 keyring = do | |||
1663 | , rtKeyDB = Map.empty | 1686 | , rtKeyDB = Map.empty |
1664 | , rtPassphrases = doDecrypt | 1687 | , rtPassphrases = doDecrypt |
1665 | } | 1688 | } |
1689 | -- autosigns and deletes | ||
1666 | transformed0 <- | 1690 | transformed0 <- |
1667 | let trans f (info,ps) = do | 1691 | let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) |
1692 | trans f (info,ps) = do | ||
1668 | let manip = combineTransforms (transforms info) | 1693 | let manip = combineTransforms (transforms info) |
1669 | rt1 = rt0 { rtKeyDB = merge Map.empty f ps } | 1694 | rt1 = rt0 { rtKeyDB = merge Map.empty f ps } |
1670 | acc = Just Sec /= Map.lookup f accs | 1695 | acc = Just Sec /= Map.lookup f accs |
@@ -1677,9 +1702,14 @@ buildKeyDB ctx grip0 keyring = do | |||
1677 | in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled | 1702 | in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled |
1678 | #endif | 1703 | #endif |
1679 | try transformed0 $ \transformed -> do | 1704 | try transformed0 $ \transformed -> do |
1680 | let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed | 1705 | let -- | db_rings - all keyrings combined into one |
1706 | db_rings :: Map.Map KeyKey KeyData | ||
1707 | db_rings = Map.foldlWithKey' mergeIt Map.empty transformed | ||
1681 | where | 1708 | where |
1682 | mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans | 1709 | mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans |
1710 | -- | reportTrans | ||
1711 | -- events, indexed by file | ||
1712 | reportTrans :: [(FilePath, KikiReportAction)] | ||
1683 | reportTrans = concat $ Map.elems $ fmap fst transformed | 1713 | reportTrans = concat $ Map.elems $ fmap fst transformed |
1684 | 1714 | ||
1685 | -- Wallets | 1715 | -- Wallets |
@@ -1714,6 +1744,7 @@ buildKeyDB ctx grip0 keyring = do | |||
1714 | usage <- take 1 us | 1744 | usage <- take 1 us |
1715 | guard $ all (==usage) $ drop 1 us | 1745 | guard $ all (==usage) $ drop 1 us |
1716 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? | 1746 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? |
1747 | -- TODO: parseSpec3 | ||
1717 | let (topspec,subspec) = parseSpec grip usage | 1748 | let (topspec,subspec) = parseSpec grip usage |
1718 | ms = map fst $ filterMatches topspec (Map.toList db) | 1749 | ms = map fst $ filterMatches topspec (Map.toList db) |
1719 | cmd = initializer stream | 1750 | cmd = initializer stream |
@@ -2270,7 +2301,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do | |||
2270 | case fill stream of | 2301 | case fill stream of |
2271 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt | 2302 | KF_Match usage -> do grip <- maybeToList $ rtGrip rt |
2272 | flattenTop f only_public | 2303 | flattenTop f only_public |
2273 | $ filterNewSubs f (parseSpec grip usage) d | 2304 | $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3 |
2274 | _ -> flattenTop f only_public d | 2305 | _ -> flattenTop f only_public d |
2275 | new_packets = filter isnew x | 2306 | new_packets = filter isnew x |
2276 | where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) | 2307 | where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) |
@@ -2636,6 +2667,7 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do | |||
2636 | | isMutable stream = usageFromFilter (fill stream) | 2667 | | isMutable stream = usageFromFilter (fill stream) |
2637 | | otherwise = Nothing | 2668 | | otherwise = Nothing |
2638 | usage <- maybeToList mutableTag | 2669 | usage <- maybeToList mutableTag |
2670 | -- TODO: Use parseSpec3 | ||
2639 | -- TODO: Report error if generating without specifying usage tag. | 2671 | -- TODO: Report error if generating without specifying usage tag. |
2640 | let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage | 2672 | let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage |
2641 | -- ms will contain duplicates if a top key has multiple matching | 2673 | -- ms will contain duplicates if a top key has multiple matching |
@@ -2705,12 +2737,12 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do | |||
2705 | 2737 | ||
2706 | return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs | 2738 | return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs |
2707 | ++ import_rs ++ internals_rs) | 2739 | ++ import_rs ++ internals_rs) |
2708 | {- | ||
2709 | interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData | ||
2710 | interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" | ||
2711 | interpretManip kd manip = return kd | ||
2712 | -} | ||
2713 | 2740 | ||
2741 | -- | combineTransforms | ||
2742 | -- remove rundant transforms, and compile the rest to PacketUpdate(s) | ||
2743 | -- | ||
2744 | -- eqivalent to: | ||
2745 | -- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd | ||
2714 | combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] | 2746 | combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] |
2715 | combineTransforms trans rt kd = updates | 2747 | combineTransforms trans rt kd = updates |
2716 | where | 2748 | where |
@@ -2811,6 +2843,7 @@ getBindings pkts = (sigs,bindings) | |||
2811 | kind = guard (code==1) >> hashed >>= maybeToList . usage | 2843 | kind = guard (code==1) >> hashed >>= maybeToList . usage |
2812 | return (code,(topkey b,subkey b), kind, hashed,claimants) | 2844 | return (code,(topkey b,subkey b), kind, hashed,claimants) |
2813 | 2845 | ||
2846 | -- | resolveTransform | ||
2814 | resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | 2847 | resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] |
2815 | resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops | 2848 | resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops |
2816 | where | 2849 | where |
@@ -2844,6 +2877,7 @@ resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops | |||
2844 | gs = groupBy sameMaster (sortBy (comparing code) bindings') | 2877 | gs = groupBy sameMaster (sortBy (comparing code) bindings') |
2845 | 2878 | ||
2846 | 2879 | ||
2880 | -- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | ||
2847 | resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk | 2881 | resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk |
2848 | where | 2882 | where |
2849 | topk = keykey $ packet k -- key to master of key to be deleted | 2883 | topk = keykey $ packet k -- key to master of key to be deleted |
@@ -2852,6 +2886,7 @@ resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap subm | |||
2852 | guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) | 2886 | guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) |
2853 | return k | 2887 | return k |
2854 | 2888 | ||
2889 | -- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] | ||
2855 | resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk | 2890 | resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk |
2856 | where | 2891 | where |
2857 | topk = keykey $ packet k -- key to master of key to be deleted | 2892 | topk = keykey $ packet k -- key to master of key to be deleted |
@@ -2863,7 +2898,9 @@ resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = | |||
2863 | -- | Load and update key files according to the specified 'KeyRingOperation'. | 2898 | -- | Load and update key files according to the specified 'KeyRingOperation'. |
2864 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) | 2899 | runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) |
2865 | runKeyRing operation = do | 2900 | runKeyRing operation = do |
2866 | homedir <- getHomeDir (opHome operation) | 2901 | -- get homedir and keyring files + fingerprint for working key |
2902 | homedir <- getHomeDir (opHome operation) | ||
2903 | |||
2867 | let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) | 2904 | let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) |
2868 | -- FIXME: try' should probably accept a list of KikiReportActions. | 2905 | -- FIXME: try' should probably accept a list of KikiReportActions. |
2869 | -- This would be useful for reporting on disk writes that have already | 2906 | -- This would be useful for reporting on disk writes that have already |
@@ -2872,6 +2909,7 @@ runKeyRing operation = do | |||
2872 | case functorToEither v of | 2909 | case functorToEither v of |
2873 | Left e -> return $ KikiResult e [] | 2910 | Left e -> return $ KikiResult e [] |
2874 | Right wkun -> body wkun | 2911 | Right wkun -> body wkun |
2912 | |||
2875 | try' homedir $ \(homedir,secring,pubring,grip0) -> do | 2913 | try' homedir $ \(homedir,secring,pubring,grip0) -> do |
2876 | let ctx = InputFileContext secring pubring | 2914 | let ctx = InputFileContext secring pubring |
2877 | tolocks = filesToLock operation ctx | 2915 | tolocks = filesToLock operation ctx |
@@ -2912,6 +2950,7 @@ runKeyRing operation = do | |||
2912 | , rtPassphrases = decrypt | 2950 | , rtPassphrases = decrypt |
2913 | } | 2951 | } |
2914 | 2952 | ||
2953 | -- Maybe add signatures, delete subkeys | ||
2915 | r <- performManipulations decrypt | 2954 | r <- performManipulations decrypt |
2916 | rt | 2955 | rt |
2917 | wk | 2956 | wk |
@@ -3330,13 +3369,16 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do | |||
3330 | return $ fmap (,[]) newsig | 3369 | return $ fmap (,[]) newsig |
3331 | 3370 | ||
3332 | 3371 | ||
3372 | -- | The position and acces a packet had before the operation | ||
3373 | data OriginFlags = OriginFlags | ||
3374 | { originallyPublic :: Bool | ||
3375 | -- ^ false if SecretKeyPacket | ||
3376 | , originalNum :: Int | ||
3377 | -- ^ packets are numbered, starting from 1.. | ||
3378 | } deriving Show | ||
3333 | 3379 | ||
3334 | data OriginFlags = OriginFlags { | ||
3335 | originallyPublic :: Bool, | ||
3336 | originalNum :: Int | ||
3337 | } | ||
3338 | deriving Show | ||
3339 | type OriginMap = Map.Map FilePath OriginFlags | 3380 | type OriginMap = Map.Map FilePath OriginFlags |
3381 | |||
3340 | data MappedPacket = MappedPacket | 3382 | data MappedPacket = MappedPacket |
3341 | { packet :: Packet | 3383 | { packet :: Packet |
3342 | , locations :: OriginMap | 3384 | , locations :: OriginMap |
@@ -3346,7 +3388,10 @@ type TrustMap = Map.Map FilePath Packet | |||
3346 | type SigAndTrust = ( MappedPacket | 3388 | type SigAndTrust = ( MappedPacket |
3347 | , TrustMap ) -- trust packets | 3389 | , TrustMap ) -- trust packets |
3348 | 3390 | ||
3391 | -- | The 'KeyKey'-type is used to store the information of a key | ||
3392 | -- which is used for finger-printing | ||
3349 | type KeyKey = [ByteString] | 3393 | type KeyKey = [ByteString] |
3394 | |||
3350 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show | 3395 | data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show |
3351 | 3396 | ||
3352 | -- | This is a GPG Identity which includes a master key and all its UIDs and | 3397 | -- | This is a GPG Identity which includes a master key and all its UIDs and |