From e69a1a1f1991c2ce879aaba187002a7b5a5f6827 Mon Sep 17 00:00:00 2001 From: James Crayne Date: Sat, 30 Apr 2016 02:58:04 -0400 Subject: comments and type signatures --- kiki.hs | 11 ++++--- lib/KeyRing.hs | 101 +++++++++++++++++++++++++++++++++++++++++---------------- 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 = homespec = join . take 1 <$> Map.lookup "--homedir" margs passfd = fmap (FileDesc . read) passphrase_fd +parseKeySpecs :: [String] -> [Maybe (String,String,String)] parseKeySpecs = map $ \specfile -> do let (spec,efilecmd) = break (=='=') specfile guard $ take 1 efilecmd=="=" @@ -1046,12 +1047,13 @@ sync bExport bImport bSecret cmdarg args_raw = do -- putStrLn $ "margs = " ++ show (Map.assocs margs) unkeysRef <- newIORef Map.empty pwRef <- newIORef Nothing - let keypairs0 = parseKeySpecs specs + let keypairs0 = parseKeySpecs specs -- [Maybe (usage,path,cmd)] specs = fromMaybe [] $ Map.lookup "--pems" margs keyrings_ = fromMaybe [] $ Map.lookup "--keyrings" margs wallets = fromMaybe [] $ Map.lookup "--wallets" margs passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs + -- Report first encountered error in Specs forM_ (take 1 $ filter (isNothing . fst) $ zip keypairs0 specs ) $ \(_,badspec) -> do warn $ "Syntax error in key pair specification " ++ show badspec @@ -1064,8 +1066,9 @@ sync bExport bImport bSecret cmdarg args_raw = do let keypairs = catMaybes keypairs0 homespec = join . take 1 <$> Map.lookup "--homedir" margs passfd = fmap (FileDesc . read) passphrase_fd - reftyp = if bExport then KF_Subkeys - else KF_None + -- reftyp is used as value for 'fill field' in StreamInfo, walts and rings + reftyp = if bExport then KF_Subkeys -- export to rings when they have master present + else KF_None -- export nothing pems = flip map keypairs $ \(usage,path,cmd) -> let cmd' = mfilter (not . null) (Just cmd) @@ -1092,7 +1095,7 @@ sync bExport bImport bSecret cmdarg args_raw = do keyrings_ hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts) - pubfill = maybe KF_Subkeys id + pubfill = maybe KF_Subkeys id -- Note: --import overrides --import-if-authentic $ mplus import_f importifauth_f where 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 = -- matchpr computes the fingerprint of the given key truncated to -- be the same lenght as the given fingerprint for comparison. +-- +-- matchpr fp = Data.List.Extra.takeEnd (length fp) +-- matchpr :: String -> Packet -> String matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp @@ -1578,20 +1581,24 @@ isSecretKey :: Packet -> Bool isSecretKey (SecretKeyPacket {}) = True isSecretKey _ = False +-- | buildKeyDB +-- +-- merge all keyrings, PEM files, and wallets into process memory. +-- buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation - -> IO (KikiCondition ((KeyDB - ,Maybe String - ,Maybe MappedPacket - ,([Hosts.Hosts], - [Hosts.Hosts], - Hosts.Hosts, - [(SockAddr, (KeyKey, KeyKey))], - [SockAddr]) - ,Map.Map InputFile Access - ,MappedPacket -> IO (KikiCondition Packet) - ,Map.Map InputFile Message + -> IO (KikiCondition (({- db -} KeyDB + ,{- grip -} Maybe String + ,{- wk -} Maybe MappedPacket + ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], + {- hostdbs -}[Hosts.Hosts], + {- u1 -}Hosts.Hosts, + {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], + {- outgoing_names -}[SockAddr]) + ,{- accs -} Map.Map InputFile Access + ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) + ,{- unspilled -} Map.Map InputFile Message ) - ,[(FilePath,KikiReportAction)])) + ,{- report_imports -} [(FilePath,KikiReportAction)])) buildKeyDB ctx grip0 keyring = do let files istyp = do @@ -1633,7 +1640,16 @@ buildKeyDB ctx grip0 keyring = do fstkey = do (_,Message ps) <- Map.lookup HomeSec ringPackets listToMaybe ps + + -- | spilled + -- ring packets with info available for export + -- | unspilled + -- the rest (spilled,unspilled) = Map.partition (spillable . fst) ringPackets + + -- | keys + -- process ringPackets, and get a map of fingerprint info to + -- to a packet, remembering it's original file, access. keys :: Map.Map KeyKey MappedPacket keys = Map.foldl slurpkeys Map.empty $ Map.mapWithKey filterSecrets ringPackets @@ -1644,13 +1660,20 @@ buildKeyDB ctx grip0 keyring = do where fname = resolveForReport (Just ctx) f slurpkeys m ps = m `Map.union` Map.fromList ps' where ps' = zip (map (keykey . packet) ps) ps - wk = listToMaybe $ do + -- | mwk + -- first master key matching the provided grip + -- (the m is for "MappedPacket", wk for working key) + mwk :: Maybe MappedPacket + mwk = listToMaybe $ do fp <- maybeToList grip let matchfp mp = not (is_subkey p) && matchpr fp p == fp where p = packet mp Map.elems $ Map.filter matchfp keys + -- | accs + -- file access(Sec | Pub) lookup table + accs :: Map.Map InputFile Access accs = fmap (access . fst) ringPackets - return (spilled,wk,grip,accs,keys,fmap snd unspilled) + return (spilled,mwk,grip,accs,keys,fmap snd unspilled) doDecrypt <- makeMemoizingDecrypter keyring ctx keys @@ -1663,8 +1686,10 @@ buildKeyDB ctx grip0 keyring = do , rtKeyDB = Map.empty , rtPassphrases = doDecrypt } + -- autosigns and deletes transformed0 <- - let trans f (info,ps) = do + let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) + trans f (info,ps) = do let manip = combineTransforms (transforms info) rt1 = rt0 { rtKeyDB = merge Map.empty f ps } acc = Just Sec /= Map.lookup f accs @@ -1677,9 +1702,14 @@ buildKeyDB ctx grip0 keyring = do in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled #endif try transformed0 $ \transformed -> do - let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed + let -- | db_rings - all keyrings combined into one + db_rings :: Map.Map KeyKey KeyData + db_rings = Map.foldlWithKey' mergeIt Map.empty transformed where mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans + -- | reportTrans + -- events, indexed by file + reportTrans :: [(FilePath, KikiReportAction)] reportTrans = concat $ Map.elems $ fmap fst transformed -- Wallets @@ -1714,6 +1744,7 @@ buildKeyDB ctx grip0 keyring = do usage <- take 1 us guard $ all (==usage) $ drop 1 us -- TODO: KikiCondition reporting for spill/fill usage mismatch? + -- TODO: parseSpec3 let (topspec,subspec) = parseSpec grip usage ms = map fst $ filterMatches topspec (Map.toList db) cmd = initializer stream @@ -2270,7 +2301,7 @@ writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do case fill stream of KF_Match usage -> do grip <- maybeToList $ rtGrip rt flattenTop f only_public - $ filterNewSubs f (parseSpec grip usage) d + $ filterNewSubs f (parseSpec grip usage) d -- TODO: parseSpec3 _ -> flattenTop f only_public d new_packets = filter isnew x where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) @@ -2636,6 +2667,7 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do | isMutable stream = usageFromFilter (fill stream) | otherwise = Nothing usage <- maybeToList mutableTag + -- TODO: Use parseSpec3 -- TODO: Report error if generating without specifying usage tag. let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage -- ms will contain duplicates if a top key has multiple matching @@ -2705,12 +2737,12 @@ initializeMissingPEMFiles operation ctx grip mwk decrypt db = do return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs ++ internals_rs) -{- -interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData -interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" -interpretManip kd manip = return kd --} +-- | combineTransforms +-- remove rundant transforms, and compile the rest to PacketUpdate(s) +-- +-- eqivalent to: +-- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] combineTransforms trans rt kd = updates where @@ -2811,6 +2843,7 @@ getBindings pkts = (sigs,bindings) kind = guard (code==1) >> hashed >>= maybeToList . usage return (code,(topkey b,subkey b), kind, hashed,claimants) +-- | resolveTransform resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops where @@ -2844,6 +2877,7 @@ resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops gs = groupBy sameMaster (sortBy (comparing code) bindings') +-- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk where 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 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) return k +-- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk where 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) = -- | Load and update key files according to the specified 'KeyRingOperation'. runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) runKeyRing operation = do - homedir <- getHomeDir (opHome operation) + -- get homedir and keyring files + fingerprint for working key + homedir <- getHomeDir (opHome operation) + let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) -- FIXME: try' should probably accept a list of KikiReportActions. -- This would be useful for reporting on disk writes that have already @@ -2872,6 +2909,7 @@ runKeyRing operation = do case functorToEither v of Left e -> return $ KikiResult e [] Right wkun -> body wkun + try' homedir $ \(homedir,secring,pubring,grip0) -> do let ctx = InputFileContext secring pubring tolocks = filesToLock operation ctx @@ -2912,6 +2950,7 @@ runKeyRing operation = do , rtPassphrases = decrypt } + -- Maybe add signatures, delete subkeys r <- performManipulations decrypt rt wk @@ -3330,13 +3369,16 @@ makeSig doDecrypt top fname subkey_p tags mbsig = do return $ fmap (,[]) newsig +-- | The position and acces a packet had before the operation +data OriginFlags = OriginFlags + { originallyPublic :: Bool + -- ^ false if SecretKeyPacket + , originalNum :: Int + -- ^ packets are numbered, starting from 1.. + } deriving Show -data OriginFlags = OriginFlags { - originallyPublic :: Bool, - originalNum :: Int - } - deriving Show type OriginMap = Map.Map FilePath OriginFlags + data MappedPacket = MappedPacket { packet :: Packet , locations :: OriginMap @@ -3346,7 +3388,10 @@ type TrustMap = Map.Map FilePath Packet type SigAndTrust = ( MappedPacket , TrustMap ) -- trust packets +-- | The 'KeyKey'-type is used to store the information of a key +-- which is used for finger-printing type KeyKey = [ByteString] + data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show -- | This is a GPG Identity which includes a master key and all its UIDs and -- cgit v1.2.3