summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.hs111
1 files changed, 87 insertions, 24 deletions
diff --git a/kiki.hs b/kiki.hs
index 171319a..b5f87cd 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1679,6 +1679,26 @@ main = do
1679 use_db <- foldM (doImport decrypt) use_db0 (map snd imports) 1679 use_db <- foldM (doImport decrypt) use_db0 (map snd imports)
1680 (ret_db,_) <- foldM (doExport decrypt) (Just use_db,use_db) (map snd exports) 1680 (ret_db,_) <- foldM (doExport decrypt) (Just use_db,use_db) (map snd exports)
1681 1681
1682 use_db <-
1683 flip (maybe $ return use_db)
1684 (lookup "--autosign" $ map (\(x:xs)->(x,xs)) sargs)
1685 $ \_ -> do
1686 let keys = map undata $ Map.elems use_db
1687 wk = listToMaybe $ do
1688 fp <- maybeToList grip
1689 elm <- Map.toList use_db
1690 guard $ matchSpec (KeyGrip fp) elm
1691 return $ undata (snd elm)
1692
1693 undata (KeyData p _ _ _) = packet p
1694 g <- newGenIO
1695 stamp <- now
1696 wkun <- flip (maybe $ return Nothing) wk $ \wk -> do
1697 wkun <- decrypt wk
1698 maybe (error $ "Bad passphrase?") (return . Just) wkun
1699 return . snd $ Map.mapAccum (signTorIds stamp wkun keys) g use_db
1700 ret_db <- return $ fmap (const use_db) ret_db
1701
1682 flip (maybe $ return ()) ret_db . const $ do 1702 flip (maybe $ return ()) ret_db . const $ do
1683 -- On last pass, interpret --show-* commands. 1703 -- On last pass, interpret --show-* commands.
1684 let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip) 1704 let shspec = Map.fromList [("--show-wk", const $ show_wk secfile grip)
@@ -1759,36 +1779,79 @@ main = do
1759 where 1779 where
1760 w0:ws = pub 1780 w0:ws = pub
1761 1781
1782 signTorIds timestamp selfkey keys
1783 g kd@(KeyData k ksigs umap submap) = (g', KeyData k ksigs umap' submap)
1784 where
1785 _ = g :: SystemRandom
1786 mkey = packet k
1787 (g',umap') = Map.mapAccumWithKey signIfTor g umap
1788 signIfTor g str ps = if isTorID str then {- trace (unlines
1789 [ "Found tor id: "
1790 ++show (str,fmap fingerprint selfkey)
1791 , "additional = " ++ intercalate "," (map showPacket additional)
1792 ]) -}
1793 (g',ps')
1794 else (g,ps)
1795 where
1796 uidxs0 = map packet $ flattenUid "" True (str,ps)
1797 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket str
1798 tmap = Map.empty
1799 ps' = ( map ( (,tmap) . flip MappedPacket om) additional
1800 ++ fst ps
1801 , Map.union om (snd ps) )
1802
1803 (uidxs, additional, xs'',g') = signSelfAuthTorKeys' selfkey g keys grip timestamp mkey uidxs0
1804 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
1805 isTorID str = and [ uid_topdomain parsed == "onion"
1806 , uid_realname parsed `elem` ["","Anonymous"]
1807 , uid_user parsed == "root"
1808 , fmap (match . fst) (lookup mkey torbindings)
1809 == Just True ]
1810 where parsed = parseUID str
1811 match = ( (==subdom) . take (fromIntegral len))
1812 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
1813 subdom = Char8.unpack subdom0
1814 len = T.length (uid_subdomain parsed)
1815
1762 signSelfAuthTorKeys selfkey g sec grip timestamp xs = ys 1816 signSelfAuthTorKeys selfkey g sec grip timestamp xs = ys
1763 where 1817 where
1764 keys = filter isKey sec 1818 keys = filter isKey sec
1765 mainpubkey = fst (head xs) 1819 mainpubkey = fst (head xs)
1766 uid:xs' = map snd xs 1820 uidxs0 = map snd xs
1821 (uidxs, additional, xs'',g') = signSelfAuthTorKeys' selfkey g keys grip timestamp mainpubkey uidxs0
1822 ys = uidxs++ additional++xs''
1823
1824 signSelfAuthTorKeys' selfkey g keys grip timestamp mainpubkey (uid:xs') = (uid:sigs,additional,xs'',g')
1825 where
1767 (sigs, xs'') = span isSignaturePacket xs' 1826 (sigs, xs'') = span isSignaturePacket xs'
1768 overs sig = signatures $ Message (keys++[uid,sig]) 1827 overs sig = signatures $ Message (keys++[mainpubkey,uid,sig])
1769 vs :: [ ( Packet -- signature 1828 vs :: [ ( Packet -- signature
1770 , Maybe SignatureOver) -- Nothing means non-verified 1829 , Maybe SignatureOver -- Nothing means non-verified
1830 , Packet ) -- key who signed
1771 ] 1831 ]
1772 vs = do 1832 vs = do
1773 sig <- sigs 1833 sig <- sigs
1774 let vs = overs sig >>= return . verify (Message keys) 1834 o <- overs sig
1775 ws = filter (not . null . signatures_over) vs 1835 k <- keys
1776 ws' = if null ws then [Nothing] else map Just ws 1836 let ov = verify (Message [k]) $ o
1777 v <- ws' 1837 signatures_over ov
1778 return (sig,v) 1838 return (sig,Just ov,k)
1779 selfsigs = filter (\(sig,v) -> fmap topkey v == selfkey) vs 1839 {-
1780 has_self = not . null $ selfsigs 1840 mainsigs = filter (\(sig,v,whosign) -> isJust (v >> Just mainpubkey >>= guard
1781 sigs' = if has_self 1841 . (== keykey whosign)
1782 then sigs 1842 . keykey))
1783 {- 1843 vs
1784 else trace ( "key params: "++params (fromJust selfkey)++"\n" 1844 -}
1785 ++traceSig (topkey new_sig) 1845 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> selfkey >>= guard
1786 (user_id new_sig) 1846 . (== keykey whosign)
1787 (signatures_over new_sig)) 1847 . keykey))
1788 sigs 1848 vs
1789 ++ {- map modsig -} (signatures_over new_sig) 1849 additional = do
1790 -} 1850 guard $ {- trace (unlines $ [ "selfsigs = "++show (map ((\(_,_,k)->fingerprint k)) selfsigs)
1791 else sigs ++ signatures_over new_sig 1851 , " for mainkey = "++fingerprint mainpubkey] )
1852 -}
1853 (null $ selfsigs)
1854 signatures_over new_sig
1792 modsig sig = sig { signature = map id (signature sig) } 1855 modsig sig = sig { signature = map id (signature sig) }
1793 where plus1 (MPI x) = MPI (x+1) 1856 where plus1 (MPI x) = MPI (x+1)
1794 params newtop = public ++ map fst (key newtop) ++ "}" 1857 params newtop = public ++ map fst (key newtop) ++ "}"
@@ -1812,11 +1875,11 @@ main = do
1812 ,"issuer = " ++ show (map signature_issuer new_sig) 1875 ,"issuer = " ++ show (map signature_issuer new_sig)
1813 ]) 1876 ])
1814 flgs = if keykey mainpubkey == keykey (fromJust selfkey) 1877 flgs = if keykey mainpubkey == keykey (fromJust selfkey)
1815 then keyFlags0 mainpubkey (map fst selfsigs) 1878 then keyFlags0 mainpubkey (map (\(x,_,_)->x) selfsigs)
1816 else [] 1879 else []
1817 new_sig = fst $ torsig g mainpubkey (fromJust selfkey) uid timestamp flgs 1880 (new_sig,g') = torsig g mainpubkey (fromJust selfkey) uid timestamp flgs
1818 1881
1819 ys = uid:sigs'++xs'' 1882 -- ys = uid:sigs++ additional++xs''
1820 1883
1821 {- 1884 {-
1822 doCmd cmd@(List {}) = do 1885 doCmd cmd@(List {}) = do