summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs139
1 files changed, 121 insertions, 18 deletions
diff --git a/kiki.hs b/kiki.hs
index 58806cb..c616445 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1124,7 +1124,8 @@ main = do
1124 ws' = if null ws then [Nothing] else map Just ws 1124 ws' = if null ws then [Nothing] else map Just ws
1125 v <- ws' 1125 v <- ws'
1126 return (sig,v) 1126 return (sig,v)
1127 has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs 1127 selfsigs = filter (\(sig,v) -> fmap topkey v == selfkey) vs
1128 has_self = not . null $ selfsigs
1128 sigs' = if has_self 1129 sigs' = if has_self
1129 then sigs 1130 then sigs
1130 {- 1131 {-
@@ -1158,7 +1159,10 @@ main = do
1158 ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig) 1159 ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig)
1159 ,"issuer = " ++ show (map signature_issuer new_sig) 1160 ,"issuer = " ++ show (map signature_issuer new_sig)
1160 ]) 1161 ])
1161 new_sig = fst $ torsig g mainpubkey (fromJust selfkey) uid timestamp 1162 flgs = if keykey mainpubkey == keykey (fromJust selfkey)
1163 then keyFlags0 mainpubkey (map fst selfsigs)
1164 else []
1165 new_sig = fst $ torsig g mainpubkey (fromJust selfkey) uid timestamp flgs
1162 1166
1163 ys = uid:sigs'++xs'' 1167 ys = uid:sigs'++xs''
1164 1168
@@ -1385,7 +1389,12 @@ main = do
1385 torkey <- parsedkey 1389 torkey <- parsedkey
1386 if key_usage cmd /= "tor" 1390 if key_usage cmd /= "tor"
1387 then uids 1391 then uids
1388 else let ps = makeTorUID (g::SystemRandom) timestamp wkun wk torkey 1392 else let ps = makeTorUID (g::SystemRandom)
1393 timestamp
1394 wkun
1395 (keyFlags wkun uids)
1396 wk
1397 torkey
1389 toruid = head ps 1398 toruid = head ps
1390 in if toruid `elem` uids then uids else uids ++ ps 1399 in if toruid `elem` uids then uids else uids ++ ps
1391 if not (null pks) 1400 if not (null pks)
@@ -1518,16 +1527,6 @@ newKey wkun wk parsedkey tag pre uids subkeys output_file grip = do
1518 grip 1527 grip
1519 timestamp 1528 timestamp
1520 (g::SystemRandom) 1529 (g::SystemRandom)
1521 sigpackets typ hashed unhashed = return $
1522 signaturePacket
1523 4 -- version
1524 typ -- 0x18 subkey binding sig, or 0x19 back-signature
1525 RSA
1526 SHA1
1527 hashed
1528 unhashed
1529 0 -- Word16 -- Left 16 bits of the signed hash value
1530 [] -- [MPI]
1531 1530
1532 hashed0 = 1531 hashed0 =
1533 [ KeyFlagsPacket 1532 [ KeyFlagsPacket
@@ -1638,19 +1637,123 @@ seek_key (KeyUidMatch pat) ps = if null bs
1638groupTops ps = groupBy (\_ b -> not (isTopKey b)) ps 1637groupTops ps = groupBy (\_ b -> not (isTopKey b)) ps
1639 1638
1640 1639
1641makeTorUID g timestamp wkun topkey torkey = uid:signatures_over sig 1640makeTorUID g timestamp wkun keyflags topkey torkey = uid:signatures_over sig
1642 where 1641 where
1643 torhash sub = maybe "" id $ derToBase32 <$> derRSA sub 1642 torhash sub = maybe "" id $ derToBase32 <$> derRSA sub
1644 s = "Anonymous <root@" ++ take 16 (torhash torkey) ++ ".onion>" 1643 s = "Anonymous <root@" ++ take 16 (torhash torkey) ++ ".onion>"
1645 uid = UserIDPacket $ trace ("UID: "++s) s 1644 uid = UserIDPacket s
1646 sig = fst $ torsig g topkey wkun uid timestamp 1645 sig = fst $ torsig g topkey wkun uid timestamp keyflags
1647 1646
1648torsig g topk wkun uid timestamp 1647torsig g topk wkun uid timestamp extras
1649 = sign (Message [wkun]) 1648 = sign (Message [wkun])
1650 (CertificationSignature (secretToPublic topk) 1649 (CertificationSignature (secretToPublic topk)
1651 uid 1650 uid
1652 []) --fromJust wkun, uid]) 1651 (sigpackets 0x13
1652 subpackets
1653 subpackets_unh))
1653 SHA1 1654 SHA1
1654 (fingerprint wkun) {- (fromJust wkgrip) -} 1655 (fingerprint wkun) {- (fromJust wkgrip) -}
1655 timestamp 1656 timestamp
1656 g 1657 g
1658 where
1659 subpackets = [ SignatureCreationTimePacket (fromIntegral timestamp)
1660 , TrustSignaturePacket 1 60
1661 , RegularExpressionPacket regex]
1662 ++ extras
1663 subpackets_unh = [IssuerPacket (fingerprint wkun)]
1664 -- <[^>]+[@.]asdf\.nowhere>$
1665 regex = "<[^>]+[@.]"++hostname++">$"
1666 -- regex = username ++ "@" ++ hostname
1667 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
1668 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
1669 pu = parseUID uidstr where UserIDPacket uidstr = uid
1670 subdomain' = escape . T.unpack . uid_subdomain
1671 topdomain' = escape . T.unpack . uid_topdomain
1672 escape s = concatMap echar s
1673 where
1674 echar '|' = "\\|"
1675 echar '*' = "\\*"
1676 echar '+' = "\\+"
1677 echar '?' = "\\?"
1678 echar '.' = "\\."
1679 echar '^' = "\\^"
1680 echar '$' = "\\$"
1681 echar '\\' = "\\\\"
1682 echar '[' = "\\["
1683 echar ']' = "\\]"
1684 echar c = [c]
1685
1686sigpackets typ hashed unhashed = return $
1687 signaturePacket
1688 4 -- version
1689 typ -- 0x18 subkey binding sig, or 0x19 back-signature
1690 RSA
1691 SHA1
1692 hashed
1693 unhashed
1694 0 -- Word16 -- Left 16 bits of the signed hash value
1695 [] -- [MPI]
1696
1697keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
1698 where
1699 vs = map (verify (Message [wkun])) (signatures (Message (wkun:uids)))
1700 ws = map signatures_over vs
1701 xs = filter null ws
1702
1703keyFlags0 wkun uidsigs = concat
1704 [ keyflags
1705 , preferredsym
1706 , preferredhash
1707 , preferredcomp
1708 , features ]
1709
1710 where
1711 subs = concatMap hashed_subpackets uidsigs
1712 keyflags = filterOr isflags subs $
1713 KeyFlagsPacket { certify_keys = True
1714 , sign_data = True
1715 , encrypt_communication = False
1716 , encrypt_storage = False
1717 , split_key = False
1718 , authentication = False
1719 , group_key = False
1720 }
1721 preferredsym = filterOr ispreferedsym subs $
1722 PreferredSymmetricAlgorithmsPacket
1723 [ AES256
1724 , AES192
1725 , AES128
1726 , CAST5
1727 , TripleDES
1728 ]
1729 preferredhash = filterOr ispreferedhash subs $
1730 PreferredHashAlgorithmsPacket
1731 [ SHA256
1732 , SHA1
1733 , SHA384
1734 , SHA512
1735 , SHA224
1736 ]
1737 preferredcomp = filterOr ispreferedcomp subs $
1738 PreferredCompressionAlgorithmsPacket
1739 [ ZLIB
1740 , BZip2
1741 , ZIP
1742 ]
1743 features = filterOr isfeatures subs $
1744 FeaturesPacket { supports_mdc = True
1745 }
1746
1747 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
1748
1749 isflags (KeyFlagsPacket {}) = True
1750 isflags _ = False
1751 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
1752 ispreferedsym _ = False
1753 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
1754 ispreferedhash _ = False
1755 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
1756 ispreferedcomp _ = False
1757 isfeatures (FeaturesPacket {}) = True
1758 isfeatures _ = False
1759