summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--kiki.hs13
-rw-r--r--lib/KeyRing.hs4
-rw-r--r--lib/KeyRing/BuildKeyDB.hs23
-rw-r--r--lib/Kiki.hs6
4 files changed, 30 insertions, 16 deletions
diff --git a/kiki.hs b/kiki.hs
index 47462a7..cd0f516 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1665,7 +1665,7 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1665 ipsecs = do 1665 ipsecs = do
1666 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt) 1666 (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "ipsec") (rtKeyDB rt)
1667 let kd = (rtKeyDB rt Map.! kk) 1667 let kd = (rtKeyDB rt Map.! kk)
1668 (addr,(onames,ns)) = getHostnames kd 1668 Hostnames addr onames ns _ = getHostnames kd
1669 oname <- onames 1669 oname <- onames
1670 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs) 1670 return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs)
1671 1671
@@ -1698,10 +1698,15 @@ tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
1698 sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd 1698 sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd
1699 ipseckey = do 1699 ipseckey = do
1700 k <- lookupSecret "ipsec" kd 1700 k <- lookupSecret "ipsec" kd
1701 oname <- fst . snd $ getHostnames kd 1701 keyName <- ipsecKeyNames (getHostnames kd)
1702 return $ spem (dir $ "etc/ipsec.d/private/"++Char8.unpack oname++".pem") k 1702 return $ spem (dir $ keyName) k
1703 torkey ++ sshcli ++ sshsvr ++ ipseckey 1703 torkey ++ sshcli ++ sshsvr ++ ipseckey
1704 1704
1705ipsecKeyNames :: Hostnames -> [String]
1706ipsecKeyNames (Hostnames _ onames _ _) = do
1707 oname <- Char8.unpack <$> onames
1708 return $ "etc/ipsec.d/private/"++oname++".pem"
1709
1705tarT :: ([[String]],Map.Map String [String]) -> IO () 1710tarT :: ([[String]],Map.Map String [String]) -> IO ()
1706tarT (sargs,margs) = do 1711tarT (sargs,margs) = do
1707 KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs 1712 KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs
@@ -1747,7 +1752,7 @@ tarC (sargs,margs) = do
1747 knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey) 1752 knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey)
1748 where 1753 where
1749 ns = onames ++ others 1754 ns = onames ++ others
1750 (_,(onames,others)) = getHostnames $ rtKeyDB rt Map.! kk 1755 Hostnames _ onames others _ = getHostnames $ rtKeyDB rt Map.! kk
1751 1756
1752 build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b) 1757 build_secret :: Num t => KeyRingRuntime -> Packet -> (t, Either (IO (Maybe Char8.ByteString)) b)
1753 build_secret rt k = ( fromIntegral $ timestamp k 1758 build_secret rt k = ( fromIntegral $ timestamp k
diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs
index 5cdb30c..8b041f1 100644
--- a/lib/KeyRing.hs
+++ b/lib/KeyRing.hs
@@ -582,7 +582,7 @@ writeHostsFiles
582 -> ([Hosts.Hosts], 582 -> ([Hosts.Hosts],
583 [Hosts.Hosts], 583 [Hosts.Hosts],
584 Hosts.Hosts, 584 Hosts.Hosts,
585 [(SockAddr, (t1, [Char8.ByteString]))], 585 [Hostnames],
586 [SockAddr]) 586 [SockAddr])
587 -> IO [(FilePath, KikiReportAction)] 587 -> IO [(FilePath, KikiReportAction)]
588writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do 588writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
@@ -598,7 +598,7 @@ writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
598 -- 3. add hostnames from gpg for addresses not in U 598 -- 3. add hostnames from gpg for addresses not in U
599 let u = foldl' f u1 ans 599 let u = foldl' f u1 ans
600 ans = reverse $ do 600 ans = reverse $ do
601 (addr,(_,ns)) <- gpgnames 601 Hostnames addr _ ns _ <- gpgnames
602 guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 602 guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
603 n <- ns 603 n <- ns
604 return (addr,n) 604 return (addr,n)
diff --git a/lib/KeyRing/BuildKeyDB.hs b/lib/KeyRing/BuildKeyDB.hs
index 9a806a3..f90f638 100644
--- a/lib/KeyRing/BuildKeyDB.hs
+++ b/lib/KeyRing/BuildKeyDB.hs
@@ -132,7 +132,7 @@ buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
132 ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], 132 ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts],
133 {- hostdbs -}[Hosts.Hosts], 133 {- hostdbs -}[Hosts.Hosts],
134 {- u1 -}Hosts.Hosts, 134 {- u1 -}Hosts.Hosts,
135 {- gpgnames -}[(SockAddr, ([ByteString],[ByteString]))], 135 {- gpgnames -}[Hostnames],
136 {- outgoing_names -}[SockAddr]) 136 {- outgoing_names -}[SockAddr])
137 ,{- accs -} Map.Map InputFile Access 137 ,{- accs -} Map.Map InputFile Access
138 ,{- transcode -} PacketTranscoder 138 ,{- transcode -} PacketTranscoder
@@ -564,7 +564,7 @@ mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
564 , ( [Hosts.Hosts] 564 , ( [Hosts.Hosts]
565 , [Hosts.Hosts] 565 , [Hosts.Hosts]
566 , Hosts.Hosts 566 , Hosts.Hosts
567 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] 567 , [Hostnames]
568 , [SockAddr])) 568 , [SockAddr]))
569 , [(FilePath,KikiReportAction)])) 569 , [(FilePath,KikiReportAction)]))
570mergeHostFiles krd db ctx = do 570mergeHostFiles krd db ctx = do
@@ -586,14 +586,14 @@ mergeHostFiles krd db ctx = do
586 586
587 let gpgnames = map getHostnames $ Map.elems db 587 let gpgnames = map getHostnames $ Map.elems db
588 os = do 588 os = do
589 (addr,(ns,_)) <- gpgnames 589 Hostnames addr ns _ _ <- gpgnames
590 n <- ns 590 n <- ns
591 return (addr,n) 591 return (addr,n)
592 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os 592 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
593 -- we ensure .onion names are set properly 593 -- we ensure .onion names are set properly
594 hostdbs = map setOnions hostdbs0 594 hostdbs = map setOnions hostdbs0
595 outgoing_names = do 595 outgoing_names = do
596 (addr,(_,gns)) <- gpgnames 596 Hostnames addr _ gns _ <- gpgnames
597 guard . not $ null gns 597 guard . not $ null gns
598 guard $ all (null . Hosts.namesForAddress addr) hostdbs0 598 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
599 return addr 599 return addr
@@ -902,13 +902,20 @@ generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do
902 return $ KikiSuccess (kd,report0) 902 return $ KikiSuccess (kd,report0)
903generateSubkey _ kd _ = return kd 903generateSubkey _ kd _ = return kd
904 904
905data Hostnames = Hostnames {
906 gpgipv6addr :: SockAddr,
907 verifiedOnionNames :: [L.ByteString],
908 notationPacketNames :: [L.ByteString],
909 cryptonomicName :: Maybe L.ByteString
910}
911
905-- | 912-- |
906-- Returns (ip6 fingerprint address,(onion names,other host names)) 913-- Returns (ip6 fingerprint address,(onion names,other host names))
907-- 914--
908-- Requires a validly cross-signed tor key for each onion name returned. 915-- Requires a validly cross-signed tor key for each onion name returned.
909-- (Signature checks are performed.) 916-- (Signature checks are performed.)
910getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) 917getHostnames :: KeyData -> Hostnames
911getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) 918getHostnames (KeyData topmp _ uids subs) = Hostnames addr onames othernames Nothing
912 where 919 where
913 othernames = do 920 othernames = do
914 mp <- flattenAllUids "" True uids 921 mp <- flattenAllUids "" True uids
@@ -966,7 +973,9 @@ setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
966 addr = fingerdress topk 973 addr = fingerdress topk
967 names :: [Char8.ByteString] 974 names :: [Char8.ByteString]
968 names = Hosts.namesForAddress addr hosts 975 names = Hosts.namesForAddress addr hosts
969 (_, (gotOnions, gotNonOnions)) = getHostnames kd 976
977 Hostnames _ gotOnions gotNonOnions cryptonomic = getHostnames kd
978
970 namesWithoutGotOnions = names \\ gotOnions 979 namesWithoutGotOnions = names \\ gotOnions
971 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions 980 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions
972 isName (NotationDataPacket True "hostname@" _) = True 981 isName (NotationDataPacket True "hostname@" _) = True
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index ca6e80f..8ceda99 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -431,7 +431,7 @@ generateHostsFile mkpath rt = do
431 KikiResult _ report <- runKeyRing op 431 KikiResult _ report <- runKeyRing op
432 outputReport report 432 outputReport report
433 433
434names :: KeyRingRuntime -> Maybe (SockAddr, ([Char8.ByteString], [Char8.ByteString])) 434names :: KeyRingRuntime -> Maybe Hostnames
435names rt = do wk <- rtWorkingKey rt 435names rt = do wk <- rtWorkingKey rt
436 -- XXX unnecessary signature check 436 -- XXX unnecessary signature check
437 return $ getHostnames (rtKeyDB rt Map.! keykey wk) 437 return $ getHostnames (rtKeyDB rt Map.! keykey wk)
@@ -478,7 +478,7 @@ refreshCache rt rootdir = do
478 (mkpath, commit) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config") 478 (mkpath, commit) <- getMkPathAndCommit (fromMaybe "" rootdir ++ "/var/cache/kiki/config")
479 generateHostsFile mkpath rt 479 generateHostsFile mkpath rt
480 fromMaybe (error "No working key.") $ do 480 fromMaybe (error "No working key.") $ do
481 (wkaddr,(onames,_)) <- names rt 481 Hostnames wkaddr onames _ _ <- names rt
482 Just $ do 482 Just $ do
483 let oname = Char8.concat $ take 1 onames 483 let oname = Char8.concat $ take 1 onames
484 bUnprivileged = False -- TODO 484 bUnprivileged = False -- TODO
@@ -535,7 +535,7 @@ writePublicKeyFiles rt mkpath grip oname wkaddr commit = do
535 namedContact kd = do 535 namedContact kd = do
536 -- The getHostnames command requires a valid cross-signed tor key 536 -- The getHostnames command requires a valid cross-signed tor key
537 -- for each onion name returned in (_,(ns,_)). 537 -- for each onion name returned in (_,(ns,_)).
538 let (addr,(ns,_)) = getHostnames kd 538 let Hostnames addr ns _ _ = getHostnames kd
539 fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. 539 fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name.
540 540
541 known_hosts = L.concat $ map getssh onionkeys 541 known_hosts = L.concat $ map getssh onionkeys