summaryrefslogtreecommitdiff
path: root/lib
diff options
context:
space:
mode:
Diffstat (limited to 'lib')
-rw-r--r--lib/Transforms.hs60
1 files changed, 32 insertions, 28 deletions
diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 7750ec5..9571e7e 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -751,39 +751,43 @@ parseUID str = UserIDRecord {
751 T.reverse . T.drop 1 -> subdomain) 751 T.reverse . T.drop 1 -> subdomain)
752 = T.break (=='.') . T.reverse $ hostname 752 = T.break (=='.') . T.reverse $ hostname
753 753
754selfAuthenticated :: OriginMapped Packet -> KeyData -> UidString -> Bool
755selfAuthenticated k kd (UidString str) =
756 and [ uid_topdomain parsed == "onion"
757 , uid_realname parsed `elem` ["","Anonymous"]
758 , uid_user parsed == "root"
759 , fmap (match . fst) (lookup (packet k) torbindings) == Just True
760 ]
761 where
762 parsed = parseUID str
763 match = (==subdom) . take (fromIntegral len)
764 len = T.length (uid_subdomain parsed)
765 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
766 subdom = Char8.unpack subdom0
767 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
768
769getTorKeys :: [Packet] -> [(Packet, (String, Packet))]
770getTorKeys pub = do
771 xs <- groupBindings pub
772 (_,(top,sub),us,_,_) <- xs
773 guard ("tor" `elem` us)
774 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
775 return (top,(torhash,sub))
776
777groupBindings :: [Packet] -> [[(Word8, (Packet, Packet), [String], [SignatureSubpacket], [Packet])]]
778groupBindings (accBindings . snd . getBindings -> bindings) = gs
779 where
780 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
781 ownerkey (_,(a,_),_,_,_) = a
782 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
783 gs = groupBy sameMaster (sortBy (comparing code) bindings)
784
754-- | resolveTransform 785-- | resolveTransform
755resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] 786resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
756resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops 787resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
757 where 788 where
758 ops = map (\(UidString u) -> InducerSignature u []) us 789 ops = map (\(UidString u) -> InducerSignature u []) us
759 us = filter torStyle $ Map.keys umap 790 us = filter (selfAuthenticated k kd) $ Map.keys umap
760 torStyle (UidString str) = and [ uid_topdomain parsed == "onion"
761 , uid_realname parsed `elem` ["","Anonymous"]
762 , uid_user parsed == "root"
763 , fmap (match . fst) (lookup (packet k) torbindings)
764 == Just True ]
765 where parsed = parseUID str
766 match = (==subdom) . take (fromIntegral len)
767 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
768 subdom = Char8.unpack subdom0
769 len = T.length (uid_subdomain parsed)
770 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
771 getTorKeys pub = do
772 xs <- groupBindings pub
773 (_,(top,sub),us,_,_) <- xs
774 guard ("tor" `elem` us)
775 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
776 return (top,(torhash,sub))
777
778 groupBindings pub = gs
779 where (_,bindings) = getBindings pub
780 bindings' = accBindings bindings
781 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
782 ownerkey (_,(a,_),_,_,_) = a
783 sameMaster (ownerkey->a) (ownerkey->b)
784 = fingerprint_material a==fingerprint_material b
785 gs = groupBy sameMaster (sortBy (comparing code) bindings')
786
787 791
788-- (2 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] 792-- (2 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
789resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk 793resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk