summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs198
1 files changed, 0 insertions, 198 deletions
diff --git a/kiki.hs b/kiki.hs
index 6b67449..60c0b6b 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -145,9 +145,6 @@ isCertificationSig _ = True
145 145
146issuer (IssuerPacket issuer) = Just issuer 146issuer (IssuerPacket issuer) = Just issuer
147issuer _ = Nothing 147issuer _ = Nothing
148backsig (EmbeddedSignaturePacket s) = Just s
149backsig _ = Nothing
150
151isSubkeySignature (SubkeySignature {}) = True 148isSubkeySignature (SubkeySignature {}) = True
152isSubkeySignature _ = False 149isSubkeySignature _ = False
153 150
@@ -814,85 +811,6 @@ doBTCImport doDecrypt db (ms,subspec,content) = do
814 doImportG doDecrypt db m0 tag "" key 811 doImportG doDecrypt db m0 tag "" key
815-} 812-}
816 813
817-- We return into IO in case we want to make a signature here.
818setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
819setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
820 -- TODO: we are removing the origin from the UID OriginMap,
821 -- when we should be removing origins from the locations
822 -- field of the sig's MappedPacket records.
823 -- Call getHostnames and compare to see if no-op.
824 if not (pred addr) || names0 == names \\ onions
825 then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
826 , " file: "++show (map Char8.unpack names)
827 , " pred: "++show (pred addr)]) -}
828 (return kd)
829 else do
830 -- We should be sure to remove origins so that the data is written
831 -- (but only if something changed).
832 -- Filter all hostnames present in uids
833 -- Write notations into first uid
834 {-
835 trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
836 , " file: "++show (map Char8.unpack names) ]) $ do
837 -}
838 return $ KeyData topmp topsigs uids1 subs
839 where
840 topk = packet topmp
841 addr = fingerdress topk
842 names :: [Char8.ByteString]
843 names = Hosts.namesForAddress addr hosts
844 (_,(onions,names0)) = getHostnames kd
845 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
846 isName (NotationDataPacket True "hostname@" _) = True
847 isName _ = False
848 uids0 = fmap zapIfHasName uids
849 fstuid = head $ do
850 p <- map packet $ flattenAllUids "" True uids
851 guard $ isUserID p
852 return $ uidkey p
853 uids1 = Map.adjust addnames fstuid uids0
854 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
855 where
856 (ss,ts) = splitAt 1 sigs
857 f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
858 else (sig, tm)
859 where p' = (packet sig) { unhashed_subpackets=uh }
860 uh = unhashed_subpackets (packet sig) ++ notations
861 zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin
862 else (sigs,om)
863 where
864 (bs, sigs') = unzip $ map unhash sigs
865
866 unhash (sig,tm) = ( not (null ns)
867 , ( sig { packet = p', locations = Map.empty }
868 , tm ) )
869 where
870 psig = packet sig
871 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
872 else psig
873 uh = unhashed_subpackets $ psig
874 (ns,ps) = partition isName uh
875
876socketFamily (SockAddrInet _ _) = AF_INET
877socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6
878socketFamily (SockAddrUnix _) = AF_UNIX
879
880
881hasFingerDress :: KeyDB -> SockAddr -> Bool
882hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
883hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
884 where
885 (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
886 g' = map toUpper g
887
888fingerdress :: Packet -> SockAddr
889fingerdress topk = maybe zero id $ Hosts.inet_pton addr_str
890 where
891 zero = SockAddrInet 0 0
892 addr_str = colons $ "fd" ++ (drop 10 $ map toLower $ fingerprint topk)
893 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
894 colons xs = xs
895
896 814
897{- 815{-
898onionName :: KeyData -> (SockAddr,L.ByteString) 816onionName :: KeyData -> (SockAddr,L.ByteString)
@@ -901,53 +819,6 @@ onionName kd = (addr,name)
901 (addr,(name:_,_)) = getHostnames kd 819 (addr,(name:_,_)) = getHostnames kd
902-} 820-}
903 821
904getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
905getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
906 where
907 othernames = do
908 mp <- flattenAllUids "" True uids
909 let p = packet mp
910 guard $ isSignaturePacket p
911 uh <- unhashed_subpackets p
912 case uh of
913 NotationDataPacket True "hostname@" v
914 -> return $ Char8.pack v
915 _ -> mzero
916
917 addr = fingerdress topk
918 -- name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key?
919 topk = packet topmp
920 torkeys = do
921 SubKey k sigs <- Map.elems subs
922 let subk = packet k
923 let sigs' = do
924 torsig <- filter (has_tag "tor") $ map (packet . fst) sigs
925 sig <- (signatures $ Message [topk,subk,torsig])
926 let v = verify (Message [topk]) sig
927 -- Require parent's signature
928 guard (not . null $ signatures_over v)
929 let unhashed = unhashed_subpackets torsig
930 subsigs = mapMaybe backsig unhashed
931 -- This should consist only of 0x19 values
932 -- subtypes = map signature_type subsigs
933 sig' <- signatures . Message $ [topk,subk]++subsigs
934 let v' = verify (Message [subk]) sig'
935 -- Require subkey's signature
936 guard . not . null $ signatures_over v'
937 return torsig
938 guard (not $ null sigs')
939 return $ subk
940 has_tag tag p = isSignaturePacket p
941 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
942 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
943 -- subkeyPacket (SubKey k _ ) = k
944 onames :: [L.ByteString]
945 onames = map ( (<> ".onion")
946 . Char8.pack
947 . take 16
948 . torhash )
949 torkeys
950
951whoseKey :: RSAPublicKey -> KeyDB -> [KeyData] 822whoseKey :: RSAPublicKey -> KeyDB -> [KeyData]
952whoseKey rsakey db = filter matchkey (Map.elems db) 823whoseKey rsakey db = filter matchkey (Map.elems db)
953 where 824 where
@@ -1255,75 +1126,6 @@ main = do
1255 Traversable.mapM (signTorIds wkun keys) (rtKeyDB rt) 1126 Traversable.mapM (signTorIds wkun keys) (rtKeyDB rt)
1256 return use_db 1127 return use_db
1257 1128
1258 let doHostNames db = do
1259 let hns = maybe [] id $ Map.lookup "--hosts" margs
1260 hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) hns
1261
1262 let gpgnames = map getHostnames $ Map.elems db
1263 os = do
1264 (addr,(ns,_)) <- gpgnames
1265 n <- ns
1266 return (addr,n)
1267 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
1268 -- we ensure .onion names are set properly
1269 hostdbs = map setOnions hostdbs0
1270 outgoing_names = do
1271 (addr,(_,gns)) <- gpgnames
1272 guard . not $ null gns
1273 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
1274 return addr
1275 -- putStrLn $ "hostdbs = " ++ show hostdbs
1276
1277 -- 1. let U = union all the host dbs
1278 -- preserving whitespace and comments of the first
1279 let u0 = foldl' Hosts.plus Hosts.empty hostdbs
1280 -- we filter U to be only finger-dresses
1281 u1 = Hosts.filterAddrs (hasFingerDress db) u0
1282
1283 -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
1284 {-
1285 putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}"
1286 putStrLn $ "--> " ++ show (nf (head hostdbs))
1287 putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
1288 putStrLn $ "--> " ++ show (nf u0)
1289 putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
1290 putStrLn $ "--> " ++ show (nf u1)
1291 -}
1292
1293 -- 2. replace gpg annotations with those in U
1294 -- forM use_db
1295 db' <- Traversable.mapM (setHostnames (\a -> not $ elem a outgoing_names) u1) db
1296
1297 -- 3. add hostnames from gpg for addresses not in U
1298 let u = foldl' f u1 ans
1299 ans = reverse $ do
1300 (addr,(_,ns)) <- gpgnames
1301 guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
1302 n <- ns
1303 return (addr,n)
1304 f h (addr,n) = Hosts.assignNewName addr n h
1305
1306 {-
1307 putStrLn $ "u = {\n" ++ show u ++ "}"
1308 putStrLn $ "--> " ++ show (nf u)
1309 -}
1310
1311 -- 4. for each host db H, union H with U and write it out as H'
1312 -- only if there is a non-empty diff
1313 forM_ (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do
1314 let h = h1 `Hosts.plus` u
1315 d = Hosts.diff h0 h
1316 fnamecolon = Char8.pack fname <> ": "
1317 {-
1318 putStrLn $ "h = {\n" ++ show h ++ "}"
1319 putStrLn $ "--> " ++ show (nf h)
1320 -}
1321 Char8.hPutStrLn stderr $ Char8.unlines (map (fnamecolon <>) d)
1322 when (not $ null d) $ L.writeFile fname $ Hosts.encode h
1323 return ()
1324
1325 return db'
1326
1327 let homespec = join . take 1 <$> Map.lookup "--homedir" margs 1129 let homespec = join . take 1 <$> Map.lookup "--homedir" margs
1328 passfd = fmap (FileDesc . read) passphrase_fd 1130 passfd = fmap (FileDesc . read) passphrase_fd
1329 pems = flip map keypairs 1131 pems = flip map keypairs