1 files 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