diff options
author | Andrew Cady <d@jerkface.net> | 2019-07-16 20:33:23 -0400 |
---|---|---|
committer | Andrew Cady <d@jerkface.net> | 2019-07-16 20:33:23 -0400 |
commit | 8af08303e56fc109135e2ade91299338d03b57b0 (patch) | |
tree | 7131b086733c62c610e667638a3f7893b7304618 /lib/KeyRing/BuildKeyDB.hs | |
parent | 7a94f5103671011295f818bfcf30280423c44042 (diff) |
this compiles
Diffstat (limited to 'lib/KeyRing/BuildKeyDB.hs')
-rw-r--r-- | lib/KeyRing/BuildKeyDB.hs | 23 |
1 files changed, 12 insertions, 11 deletions
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs index 461afa2..510c820 100644 --- a/lib/KeyRing/BuildKeyDB.hs +++ b/lib/KeyRing/BuildKeyDB.hs | |||
@@ -83,9 +83,9 @@ newtype IPsToWriteToHostsFile = IPsToWriteToHostsFile [SockAddr] | |||
83 | -- | 83 | -- |
84 | -- merge all keyrings, PEM files, and wallets into process memory. | 84 | -- merge all keyrings, PEM files, and wallets into process memory. |
85 | -- | 85 | -- |
86 | buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation | 86 | buildKeyDB :: InputFileContext -> Maybe Fingerprint -> KeyRingOperation |
87 | -> IO (KikiCondition (({- db -} KeyDB | 87 | -> IO (KikiCondition (({- db -} KeyDB |
88 | ,{- grip -} Maybe String | 88 | ,{- grip -} Maybe Fingerprint |
89 | ,{- wk -} Maybe MappedPacket | 89 | ,{- wk -} Maybe MappedPacket |
90 | ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], | 90 | ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], |
91 | {- hostdbs -}[Hosts.Hosts], | 91 | {- hostdbs -}[Hosts.Hosts], |
@@ -128,7 +128,8 @@ buildKeyDB ctx grip0 keyring = do | |||
128 | ringPackets <- Map.traverseWithKey readp ringMap | 128 | ringPackets <- Map.traverseWithKey readp ringMap |
129 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) | 129 | let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) |
130 | 130 | ||
131 | let grip = grip0 `mplus` (show . fingerprint <$> fstkey) | 131 | let grip :: Maybe Fingerprint |
132 | grip = grip0 `mplus` (fingerprint <$> fstkey) | ||
132 | where | 133 | where |
133 | fstkey = do | 134 | fstkey = do |
134 | (_,Message ps) <- Map.lookup HomeSec ringPackets | 135 | (_,Message ps) <- Map.lookup HomeSec ringPackets |
@@ -223,7 +224,7 @@ buildKeyDB ctx grip0 keyring = do | |||
223 | guard $ all (==usage) $ drop 1 us | 224 | guard $ all (==usage) $ drop 1 us |
224 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? | 225 | -- TODO: KikiCondition reporting for spill/fill usage mismatch? |
225 | -- TODO: parseSpec3 | 226 | -- TODO: parseSpec3 |
226 | let (topspec,subspec) = parseSpec grip usage | 227 | let (topspec,subspec) = parseSpec (Just grip) usage |
227 | ms = map fst $ filterMatches topspec (kkData db) | 228 | ms = map fst $ filterMatches topspec (kkData db) |
228 | cmd = initializer stream | 229 | cmd = initializer stream |
229 | return (n,subspec,ms,stream, cmd) | 230 | return (n,subspec,ms,stream, cmd) |
@@ -408,16 +409,16 @@ usageFromFilter _ = mzero | |||
408 | 409 | ||
409 | -- | Parse a key specification. | 410 | -- | Parse a key specification. |
410 | -- The first argument is a grip for the default working key. | 411 | -- The first argument is a grip for the default working key. |
411 | parseSpec :: Fingerprint -> String -> (KeySpec,Maybe String) | 412 | parseSpec :: Maybe Fingerprint -> String -> (KeySpec,Maybe String) |
412 | parseSpec wkgrip spec = | 413 | parseSpec wkgrip spec = |
413 | if not slashed | 414 | if not slashed |
414 | then | 415 | then |
415 | case prespec of | 416 | case prespec of |
416 | AnyMatch -> (KeyGrip "", Nothing) | 417 | AnyMatch -> (KeyGrip "", Nothing) |
417 | EmptyMatch -> error "Bad key spec." | 418 | EmptyMatch -> error "Bad key spec." |
418 | WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) | 419 | WorkingKeyMatch -> (KeyGrip $ show wkgrip, Nothing) |
419 | SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) | 420 | SubstringMatch (Just KeyTypeField) tag -> (KeyGrip $ show wkgrip, Just tag) |
420 | SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) | 421 | SubstringMatch Nothing str -> (KeyGrip $ show wkgrip, Just str) |
421 | SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) | 422 | SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) |
422 | FingerprintMatch fp -> (KeyGrip fp, Nothing) | 423 | FingerprintMatch fp -> (KeyGrip fp, Nothing) |
423 | else | 424 | else |
@@ -780,8 +781,8 @@ is40digitHex xs = ys == xs && length ys==40 | |||
780 | 781 | ||
781 | matchSpec :: KeySpec -> KeyData -> Bool | 782 | matchSpec :: KeySpec -> KeyData -> Bool |
782 | matchSpec (KeyGrip grip) (KeyData p _ _ _) | 783 | matchSpec (KeyGrip grip) (KeyData p _ _ _) |
783 | | matchpr grip (packet p)==grip = True | 784 | | matchpr' grip (packet p) = True |
784 | | otherwise = False | 785 | | otherwise = False |
785 | 786 | ||
786 | matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps | 787 | matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps |
787 | where | 788 | where |
@@ -791,7 +792,7 @@ matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps | |||
791 | && has_issuer key p | 792 | && has_issuer key p |
792 | has_issuer key p = isJust $ do | 793 | has_issuer key p = isJust $ do |
793 | issuer <- signature_issuer p | 794 | issuer <- signature_issuer p |
794 | guard $ matchpr issuer key == issuer | 795 | guard $ matchpr' issuer key |
795 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) | 796 | has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) |
796 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) | 797 | || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) |
797 | 798 | ||