summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.hs11
-rw-r--r--lib/KeyRing.hs101
2 files changed, 80 insertions, 32 deletions
diff --git a/kiki.hs b/kiki.hs
index 325fc7f..eabfbf3 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1000,6 +1000,7 @@ parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd =
1000 homespec = join . take 1 <$> Map.lookup "--homedir" margs 1000 homespec = join . take 1 <$> Map.lookup "--homedir" margs
1001 passfd = fmap (FileDesc . read) passphrase_fd 1001 passfd = fmap (FileDesc . read) passphrase_fd
1002 1002
1003parseKeySpecs :: [String] -> [Maybe (String,String,String)]
1003parseKeySpecs = map $ \specfile -> do 1004parseKeySpecs = map $ \specfile -> do
1004 let (spec,efilecmd) = break (=='=') specfile 1005 let (spec,efilecmd) = break (=='=') specfile
1005 guard $ take 1 efilecmd=="=" 1006 guard $ take 1 efilecmd=="="
@@ -1046,12 +1047,13 @@ sync bExport bImport bSecret cmdarg args_raw = do
1046 -- putStrLn $ "margs = " ++ show (Map.assocs margs) 1047 -- putStrLn $ "margs = " ++ show (Map.assocs margs)
1047 unkeysRef <- newIORef Map.empty 1048 unkeysRef <- newIORef Map.empty
1048 pwRef <- newIORef Nothing 1049 pwRef <- newIORef Nothing
1049 let keypairs0 = parseKeySpecs specs 1050 let keypairs0 = parseKeySpecs specs -- [Maybe (usage,path,cmd)]
1050 specs = fromMaybe [] $ Map.lookup "--pems" margs 1051 specs = fromMaybe [] $ Map.lookup "--pems" margs
1051 keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs 1052 keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs
1052 wallets = fromMaybe [] $ Map.lookup "--wallets" margs 1053 wallets = fromMaybe [] $ Map.lookup "--wallets" margs
1053 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs 1054 passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
1054 1055
1056 -- Report first encountered error in Specs
1055 forM_ (take 1 $ filter (isNothing . fst) 1057 forM_ (take 1 $ filter (isNothing . fst)
1056 $ zip keypairs0 specs ) $ \(_,badspec) -> do 1058 $ zip keypairs0 specs ) $ \(_,badspec) -> do
1057 warn $ "Syntax error in key pair specification " ++ show badspec 1059 warn $ "Syntax error in key pair specification " ++ show badspec
@@ -1064,8 +1066,9 @@ sync bExport bImport bSecret cmdarg args_raw = do
1064 let keypairs = catMaybes keypairs0 1066 let keypairs = catMaybes keypairs0
1065 homespec = join . take 1 <$> Map.lookup "--homedir" margs 1067 homespec = join . take 1 <$> Map.lookup "--homedir" margs
1066 passfd = fmap (FileDesc . read) passphrase_fd 1068 passfd = fmap (FileDesc . read) passphrase_fd
1067 reftyp = if bExport then KF_Subkeys 1069 -- reftyp is used as value for 'fill field' in StreamInfo, walts and rings
1068 else KF_None 1070 reftyp = if bExport then KF_Subkeys -- export to rings when they have master present
1071 else KF_None -- export nothing
1069 pems = flip map keypairs 1072 pems = flip map keypairs
1070 $ \(usage,path,cmd) -> 1073 $ \(usage,path,cmd) ->
1071 let cmd' = mfilter (not . null) (Just cmd) 1074 let cmd' = mfilter (not . null) (Just cmd)
@@ -1092,7 +1095,7 @@ sync bExport bImport bSecret cmdarg args_raw = do
1092 keyrings_ 1095 keyrings_
1093 hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs 1096 hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs
1094 where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) 1097 where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts)
1095 pubfill = maybe KF_Subkeys id 1098 pubfill = maybe KF_Subkeys id -- Note: --import overrides --import-if-authentic
1096 $ mplus import_f importifauth_f 1099 $ mplus import_f importifauth_f
1097 where 1100 where
1098 import_f = fmap (const KF_All) 1101 import_f = fmap (const KF_All)
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--
831matchpr :: String -> Packet -> String 834matchpr :: String -> Packet -> String
832matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp 835matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
833 836
@@ -1578,20 +1581,24 @@ isSecretKey :: Packet -> Bool
1578isSecretKey (SecretKeyPacket {}) = True 1581isSecretKey (SecretKeyPacket {}) = True
1579isSecretKey _ = False 1582isSecretKey _ = False
1580 1583
1584-- | buildKeyDB
1585--
1586-- merge all keyrings, PEM files, and wallets into process memory.
1587--
1581buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation 1588buildKeyDB :: 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)]))
1595buildKeyDB ctx grip0 keyring = do 1602buildKeyDB 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{-
2709interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
2710interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
2711interpretManip 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
2714combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] 2746combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2715combineTransforms trans rt kd = updates 2747combineTransforms 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
2814resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] 2847resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2815resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops 2848resolveTransform 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]
2847resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk 2881resolveTransform (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]
2855resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk 2890resolveTransform (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'.
2864runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) 2899runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
2865runKeyRing operation = do 2900runKeyRing 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
3373data OriginFlags = OriginFlags
3374 { originallyPublic :: Bool
3375 -- ^ false if SecretKeyPacket
3376 , originalNum :: Int
3377 -- ^ packets are numbered, starting from 1..
3378 } deriving Show
3333 3379
3334data OriginFlags = OriginFlags {
3335 originallyPublic :: Bool,
3336 originalNum :: Int
3337 }
3338 deriving Show
3339type OriginMap = Map.Map FilePath OriginFlags 3380type OriginMap = Map.Map FilePath OriginFlags
3381
3340data MappedPacket = MappedPacket 3382data MappedPacket = MappedPacket
3341 { packet :: Packet 3383 { packet :: Packet
3342 , locations :: OriginMap 3384 , locations :: OriginMap
@@ -3346,7 +3388,10 @@ type TrustMap = Map.Map FilePath Packet
3346type SigAndTrust = ( MappedPacket 3388type 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
3349type KeyKey = [ByteString] 3393type KeyKey = [ByteString]
3394
3350data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show 3395data 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