hopenpgp-tools 0.8 → 0.8.1
raw patch · 2 files changed
+28/−20 lines, 2 filesdep +unordered-containersdep ~hOpenPGP
Dependencies added: unordered-containers
Dependency ranges changed: hOpenPGP
Files
- hkt.hs +25/−18
- hopenpgp-tools.cabal +3/−2
hkt.hs view
@@ -46,8 +46,9 @@ import Data.Graph.Inductive.Query.SP (sp) import Data.GraphViz (graphToDot, nonClusteredParams) import Data.GraphViz.Types (printDotGraph)+import Data.HashMap.Lazy (HashMap)+import qualified Data.HashMap.Lazy as HashMap import Data.List (nub, sort)-import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) import Data.Monoid ((<>)) import Data.Serialize (get, put, runPut)@@ -192,28 +193,35 @@ kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (target1 o) TLIO.putStrLn . printDotGraph $ graphToDot nonClusteredParams (buildKeyGraph ((buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))))) -buildMaps :: [TK] -> (Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int)-buildMaps ks = S.execState (mapM_ mapsInsertions ks) (Map.empty, Map.empty, 0)+buildMaps :: [TK] -> (KeyMaps, Int)+buildMaps ks = S.execState (mapM_ mapsInsertions ks) (KeyMaps HashMap.empty HashMap.empty HashMap.empty, 0) -- FIXME: this presumes no keyID collisions in the input-mapsInsertions :: TK -> S.State (Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int) ()+data KeyMaps = KeyMaps {+ _k2f :: HashMap EightOctetKeyId TwentyOctetFingerprint+ , _f2i :: HashMap TwentyOctetFingerprint Int+ , _i2f :: HashMap Int TwentyOctetFingerprint+}++mapsInsertions :: TK -> S.State (KeyMaps, Int) () mapsInsertions tk = do- (k2f, f2i, i) <- S.get+ (KeyMaps k2f f2i i2f, i) <- S.get let fp = fingerprint (tk^.tkKey._1) keyids = rights . map eightOctetKeyID $ (tk ^.. biplate :: [PKPayload]) i' = i + 1- k2f' = foldr (\k m -> Map.insert k fp m) k2f keyids- f2i' = Map.insert fp i' f2i- S.put (k2f', f2i', i')+ k2f' = foldr (\k m -> HashMap.insert k fp m) k2f keyids+ f2i' = HashMap.insert fp i' f2i+ i2f' = HashMap.insert i' fp i2f+ S.put (KeyMaps k2f' f2i' i2f', i') -buildKeyGraph :: ((Map.Map EightOctetKeyId TwentyOctetFingerprint, Map.Map TwentyOctetFingerprint Int, Int), [TK]) -> Gr TwentyOctetFingerprint HashAlgorithm-buildKeyGraph ((k2f, f2i, _), ks) = mkGraph nodes edges+buildKeyGraph :: ((KeyMaps, Int), [TK]) -> Gr TwentyOctetFingerprint HashAlgorithm+buildKeyGraph ((KeyMaps k2f f2i _, _), ks) = mkGraph nodes edges where- nodes = map swap . Map.toList $ f2i+ nodes = map swap . HashMap.toList $ f2i edges = filter (not . samesies) . nub . sort . concatMap tkToEdges $ ks tkToEdges tk = map (\(ha, i) -> (source i, target tk, ha)) (mapMaybe (fakejoin . (hashAlgo &&& sigissuer)) (sigs tk))- target tk = fromMaybe (error "Epic fail") (Map.lookup (fingerprint (tk^.tkKey._1)) f2i)- source i = fromMaybe (error "Lesser fail") (Map.lookup i k2f >>= flip Map.lookup f2i)+ target tk = fromMaybe (error "Epic fail") (HashMap.lookup (fingerprint (tk^.tkKey._1)) f2i)+ source i = fromMaybe (-1) (HashMap.lookup i k2f >>= flip HashMap.lookup f2i) fakejoin (x, y) = fmap ((,) x) y sigs tk = concat ((tk^..tkUIDs.traverse._2) ++ (tk^..tkUAts.traverse._2)) samesies (x,y,_) = x == y@@ -224,21 +232,20 @@ kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (target1 o) let keys1 = filter (if targetIsFilter o then filterMatch (target2 o) else matchAny (target2 o)) (IxSet.toList kr) keys2 = filter (if targetIsFilter o then filterMatch (target3 o) else matchAny (target3 o)) (IxSet.toList kr)- ((k2f, f2i, i), ks) = (buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr)))- keygraph = buildKeyGraph ((k2f, f2i, i), ks)- keysToIs = mapMaybe (\x -> Map.lookup (fingerprint (x^.tkKey._1)) f2i)+ ((KeyMaps k2f f2i i2f, i), ks) = (buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr)))+ keygraph = buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks)+ keysToIs = mapMaybe (\x -> HashMap.lookup (fingerprint (x^.tkKey._1)) f2i) froms = keysToIs keys1 tos = keysToIs keys2 combos = froms >>= \f -> tos >>= \t -> return (f,t) paths = map (\(x,y) -> sp x y (emap (const (1.0 :: Double)) keygraph)) combos print paths+ putStrLn . unlines $ map (\x -> maybe (show x) show $ HashMap.lookup x i2f >>= \y -> return (x, y)) (nub (sort (concat paths))) where -- FIXME: deduplicate this matchAny srch tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) (efp srch) <|> fmap (keyMatchesEightOctetKeyId True tk . Right) (eeok srch) <|> return (keyMatchesUIDSubString srch tk) filterMatch srch tk = eval pkpEval (either error id (A.parseOnly pPE (T.pack srch))) (tk^.tkKey._1) efp srch = parseFingerprint . T.pack $ srch eeok srch = parseEightOctetKeyId . T.pack $ srch-- -- FIXME: deduplicate the following code eval :: (a -> v -> Bool) -> Expr a -> v -> Bool
hopenpgp-tools.cabal view
@@ -1,5 +1,5 @@ name: hopenpgp-tools-version: 0.8+version: 0.8.1 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools@@ -80,7 +80,7 @@ , directory , fgl , graphviz- , hOpenPGP >= 1.2+ , hOpenPGP >= 1.4 , ixset , lens , optparse-applicative >= 0.5.0@@ -88,6 +88,7 @@ , text , time , transformers+ , unordered-containers default-language: Haskell2010 source-repository head