From db7738d3d3ea80011fdf6f355d1f06009214e032 Mon Sep 17 00:00:00 2001 From: Andrew Cady Date: Fri, 12 Jul 2019 21:29:58 -0400 Subject: further clarification of types --- lib/Kiki.hs | 132 ++++++++++++++++++++++++++++++++---------------------------- 1 file changed, 71 insertions(+), 61 deletions(-) diff --git a/lib/Kiki.hs b/lib/Kiki.hs index 32add1b..4659e95 100644 --- a/lib/Kiki.hs +++ b/lib/Kiki.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE CPP #-} @@ -17,6 +18,7 @@ import Data.ASN1.Encoding import Data.ASN1.Types import Data.Binary import Data.Bool +import Data.Coerce import Data.Char import Data.Functor import Data.List @@ -332,28 +334,26 @@ importAndRefresh root cmn cipher = do -- Finally, we update /var/cache/kiki. when (not bUnprivileged) $ refreshCache rt rootdir -data IpsecPeerConfig = IpsecPeerConfig +data Peer = Peer { contactname :: UidHostname , addr :: SockAddr , kd :: KeyData } +newtype IpsecPeerConfig = IpsecPeerConfig Char8.ByteString -- Installs the cert file for the peer to the filesystem, and returns an -- ipsec.conf snippet configuring the peer and referencing the installed cert -- file. -installIpsecPeerCertificate - :: FileWriter - -> IpsecPeerConfig - -> IO Char8.ByteString -installIpsecPeerCertificate fw IpsecPeerConfig{..} = +installIpsecPeerCertificate :: FileWriter -> Peer -> IO IpsecPeerConfig +installIpsecPeerCertificate fw p@Peer{kd} = IpsecPeerConfig <$> fromMaybe "" <$> do forM (listToMaybe ipsecs) $ \k -> do flip (either warn') (pemFromPacket k :: Either String String) $ \pem -> do case sshs of (sshkey:_) -> do theirHostname <- ResolvableHostname <$> sshKeyToHostname sshkey - write fw (ipsecCertPath contactname) pem - return $ strongswanPeerConfiguration addr contactname theirHostname + write fw (peerCertPath p) pem + return $ strongswanPeerConfiguration p theirHostname _ -> error "fuck." where warn' x = warn x >> return Char8.empty @@ -370,14 +370,17 @@ installIpsecPeerCertificate fw IpsecPeerConfig{..} = sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" -ipsecPath :: String -> UidHostname -> String -ipsecPath theDirName (UidHostname theBaseName) = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" +ipsecPath :: String -> Char8.ByteString -> String +ipsecPath theDirName theBaseName = "ipsec.d/" ++ theDirName ++ "/" ++ Char8.unpack theBaseName ++ ".pem" -ipsecKeyPath :: UidHostname -> FilePath -ipsecKeyPath = ipsecPath "private" +ipsecKeyPath :: MyIdentity -> FilePath +ipsecKeyPath (MyIdentity _ theBaseName) = ipsecPath "private" theBaseName -ipsecCertPath :: UidHostname -> FilePath -ipsecCertPath = ipsecPath "certs" +ipsecCertPath :: MyIdentity -> FilePath +ipsecCertPath (MyIdentity _ theBaseName) = ipsecPath "certs" theBaseName + +peerCertPath :: Peer -> FilePath +peerCertPath (Peer (UidHostname theBaseName) _ _) = ipsecPath "certs" theBaseName makeFileWriter :: (FilePath -> FilePath) -> (IO ()) -> FileWriter makeFileWriter p c = @@ -453,25 +456,23 @@ generateHostsFile fw rt = do KikiResult _ report <- runKeyRing op outputReport report -getssh :: (Char8.ByteString, SockAddr, KeyData) -> Char8.ByteString -getssh (contactname,_addr,kd) = do - let their_master = packet $ keyMappedPacket kd - sshs :: [Packet] - sshs = sortOn (Down . timestamp) - $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" - blobs = mapMaybe sshblobFromPacketL sshs - taggedblobs = map (\b -> contactname <> " " <> b) blobs - Char8.unlines taggedblobs - -data IpsecConfig = IpsecConfig { - ourGpgAddress :: SockAddr, - ourSigKey :: (), - peers :: [IpsecPeerConfig] +getssh :: Peer -> Char8.ByteString +getssh (Peer (UidHostname contactname) _ kd) = Char8.unlines taggedblobs + where + their_master = packet $ keyMappedPacket kd + sshs :: [Packet] + sshs = sortOn (Down . timestamp) $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server" + blobs = mapMaybe sshblobFromPacketL sshs + taggedblobs = map ((contactname <> " ") <>) blobs + +data MyIdentity = MyIdentity { + myGpgAddress :: SockAddr, + myCertificateBasename :: Char8.ByteString } -installIpsecConf :: FileWriter -> SockAddr -> Char8.ByteString -> [IpsecPeerConfig] -> IO () -installIpsecConf fw wkaddr certBasename cs = do - snippets <- mapM (installIpsecPeerCertificate fw) cs +installIpsecConf :: FileWriter -> MyIdentity -> [Peer] -> IO () +installIpsecConf fw (MyIdentity wkaddr certBasename) cs = do + snippets <- mapM (coerce . installIpsecPeerCertificate fw) cs writeL fw "ipsec.conf" . Char8.unlines $ [ "conn %default" , " ikelifetime=60m" @@ -503,9 +504,8 @@ refreshCache rt rootdir = do wk <- rtWorkingKey rt Hostnames wkaddr onames _ _ <- Just $ getHostnames (byKeyKey (rtKeyDB rt) Map.! keykey wk) Just $ do - let oname = UidHostname $ Char8.concat $ take 1 onames - - -- if (oname == "") then error "Missing tor key" else do + let oname = Char8.concat $ take 1 onames + if (oname == "") then error "Missing tor key" else do -- sshcpathpub0 = fromMaybe "" rootdir ++ osHomeDir ".ssh" "id_rsa.pub" -- sshspathpub0 = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key.pub" -- contactipsec0 = fromMaybe "" rootdir ++ "/etc/ipsec.d/certs/%(onion).pem" @@ -513,6 +513,7 @@ refreshCache rt rootdir = do flip (maybe $ warn "missing working key?") (rtWorkingKey rt) $ \wk -> do let grip = fingerprint wk + myId = MyIdentity wkaddr oname exportOp = passphrases <> pemSecrets <> minimalOp False (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt) @@ -520,7 +521,7 @@ refreshCache rt rootdir = do where passphrases = mempty { opPassphrases = [PassphraseMemoizer (rtPassphrases rt)] } pemSecrets = mempty { opFiles = Map.fromList - [ send "ipsec" (ipsecKeyPath oname) "missing ipsec key?" + [ send "ipsec" (ipsecKeyPath myId) "missing ipsec key?" , send "ssh-client" ("root/.ssh/id_rsa") "missing ssh-client key?" , send "ssh-server" ("ssh_host_rsa_key") "missing ssh host key?" , send "tor" ("tor/private_key") "missing tor key?" @@ -538,7 +539,7 @@ refreshCache rt rootdir = do outputReport report -- outputReport $ map (first $ resolveForReport ctx) $ filter ((/=ExportedSubkey) . snd) report rt'' <- rethrowKikiErrors rt' - writePublicKeyFiles rt'' fw grip oname wkaddr + writePublicKeyFiles rt'' fw grip myId rethrowKikiErrors :: KikiCondition a -> IO a rethrowKikiErrors BadPassphrase = @@ -548,31 +549,32 @@ rethrowKikiErrors rt = unconditionally $ return rt newtype UidHostname = UidHostname Char8.ByteString newtype ResolvableHostname = ResolvableHostname Char8.ByteString -writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> UidHostname -> SockAddr -> IO () -writePublicKeyFiles rt fw grip oname wkaddr = do - - -- Finally, export public keys if they do not exist. - either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) - either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) - either warn (write fw $ ipsecCertPath oname) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket - - let onionkeys = mapMaybe namedContact $ Map.elems $ byKeyKey $ rtKeyDB rt - cs = filter (\(_,_,kd) -> notme kd) onionkeys - cs' = cs <&> \(a,b,c) -> IpsecPeerConfig (UidHostname a) b c - kk = keykey (fromJust $ rtWorkingKey rt) - notme kd = keykey (keyPacket kd) /= kk - - namedContact kd = do +listPeers :: KeyRingRuntime -> [Peer] +listPeers rt = map conv . filter notme . mapMaybe namedContact . Map.elems . byKeyKey . rtKeyDB $ rt + where + conv = \(a,b,c) -> Peer (UidHostname a) b c + kk = keykey (fromJust $ rtWorkingKey rt) + notme (_,_,kd) = keykey (keyPacket kd) /= kk + namedContact kd = do -- The getHostnames command requires a valid cross-signed tor key -- for each onion name returned in (_,(ns,_)). let Hostnames addr ns _ _ = getHostnames kd fmap (\n -> (n,addr, kd)) $ listToMaybe ns -- only first onion name. - known_hosts = L.concat $ map getssh onionkeys +writePublicKeyFiles :: KeyRingRuntime -> FileWriter -> String -> MyIdentity -> IO () +writePublicKeyFiles rt fw grip myId = do + + -- Finally, export public keys if they do not exist. + either warn (write fw "root/.ssh/id_rsa.pub") $ show_ssh' "ssh-client" grip (rtKeyDB rt) + either warn (write fw "ssh_host_rsa_key.pub") $ show_ssh' "ssh-server" grip (rtKeyDB rt) + either warn (write fw $ ipsecCertPath myId) $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket + + let cs = listPeers rt + known_hosts = L.concat $ map getssh $ cs writeL fw "ssh_known_hosts" known_hosts - installIpsecConf fw wkaddr (Char8.pack $ takeBaseName $ ipsecCertPath oname) cs' + installIpsecConf fw myId cs fileWriterCommit fw sshKeyToHostname :: Packet -> IO Char8.ByteString @@ -584,16 +586,24 @@ sshKeyToHostname sshkey = do "f=$(mktemp) && cat > \"$f\" && ssh-keygen -r _ -f \"$f\" |" ++ " (read _ _ _ _ _ hash _ && echo -n $hash.ssh.cryptonomic.net); r=$?; rm -f \"$f\"; exit $r" -strongswanPeerConfiguration :: SockAddr -> UidHostname -> ResolvableHostname -> Char8.ByteString -strongswanPeerConfiguration addr (UidHostname oname) (ResolvableHostname rightip) = Char8.unlines - [ "conn " <> oname - , " right=" <> rightip - , " rightsubnet=" <> p (showA addr) <> "/128" +peerConnectionName :: Peer -> Char8.ByteString +peerConnectionName (Peer (UidHostname x) _ _) = x + +peerCertificateName :: Peer -> Char8.ByteString +peerCertificateName = (<> ".pem") . peerConnectionName + +peerAddress :: Peer -> Char8.ByteString +peerAddress (Peer _ addr _) = Char8.pack $ showA addr + +strongswanPeerConfiguration :: Peer -> ResolvableHostname -> Char8.ByteString +strongswanPeerConfiguration peer@(Peer _ addr _) (ResolvableHostname rightip) = Char8.unlines + [ "conn " <> peerConnectionName peer + , " right=" <> rightip + , " rightsubnet=" <> peerAddress peer <> "/128" , " rightauth=pubkey" - , " rightid=" <> p (showA addr) - , " rightsigkey=" <> oname <> ".pem" + , " rightid=" <> peerAddress peer + , " rightsigkey=" <> peerCertificateName peer ] - where p = Char8.pack -- conn hiotuxliwisbp6mi.onion -- right=%hiotuxliwisbp6mi.onion.ipv4 -- cgit v1.2.3