more work on cokiki (ssh-client)

1 files changed, 165 insertions, 4 deletions

diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index 783b6ed..575cf26 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,8 +1,169 @@
+{-# LANGUAGE CPP #-}
 module Kiki where
 
+import Control.Monad
+import Control.Applicative
+import Data.List
+import Data.Maybe
+import Data.Ord
+import System.Directory
+import System.FilePath.Posix
+import System.IO
+import Data.OpenPGP
+import Data.OpenPGP.Util
+import qualified Data.Map.Strict as Map
+import qualified Codec.Binary.Base64 as Base64
+import Data.ASN1.BinaryEncoding
+import Data.ASN1.Encoding
+import Data.ASN1.Types
+import qualified Data.ByteString.Lazy as L
+import qualified Data.ByteString.Lazy.Char8 as Char8
+
+import CommandLine
+import qualified SSHKey as SSH
+import KeyRing
+
 -- |
 -- Regenerate /var/cache/kiki
-refresh :: IO ()
-refresh = do
-    -- TODO
-    return ()
+refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
+refresh root homepass = do
+    let homepass' = homepass { cap_homespec = fmap root (cap_homespec homepass) }
+    KikiResult r report <- runKeyRing $ minimalOp homepass'
+    let mroot = case root "" of
+                    "/" -> Nothing
+                    ""  -> Nothing
+                    pth -> Just pth
+    case r of
+        KikiSuccess rt -> refreshCache rt mroot
+        _ -> return () -- XXX: silent fail?
+
+data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
+
+
+minimalOp :: CommonArgsParsed -> KeyRingOperation
+minimalOp cap = op
+ where
+    streaminfo = StreamInfo { fill = KF_None
+                            , typ = KeyRingFile
+                            , spill = KF_All
+                            , initializer = NoCreate
+                            , access = AutoAccess
+                            , transforms = []
+                            }
+    op = KeyRingOperation
+        { opFiles = Map.fromList $
+            [ ( HomeSec, streaminfo { access = Sec })
+            , ( HomePub, streaminfo { access = Pub })
+            ]
+        , opPassphrases = do pfile <- maybeToList (cap_passfd cap)
+                             return $ PassphraseSpec Nothing Nothing pfile
+        , opTransforms = []
+        , opHome = cap_homespec cap
+        }
+
+
+refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
+refreshCache rt rootdir = do
+
+    let mkpath pth = fromMaybe "" rootdir ++ "/var/cache/kiki/"++pth
+
+        write f bs = do
+            createDirectoryIfMissing True $ takeDirectory f
+            writeFile f bs
+
+    let oname' = do wk <- rtWorkingKey rt
+                    -- XXX unnecessary signature check
+                    onionNameForContact (keykey wk) (rtKeyDB rt)
+        bUnprivileged = False -- TODO
+    if (oname' == Nothing) && (not bUnprivileged) then error "Missing tor key" else do
+    let oname = fromMaybe "" oname'
+    -- 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"
+
+    -- Finally, export public keys if they do not exist.
+    flip (maybe $ warn "missing working key?") (rtGrip rt) $ \grip -> do
+    either warn (write $ mkpath "root/.ssh/id_rsa.pub")
+            $ show_ssh' "ssh-client" grip (rtKeyDB rt)
+    either warn (write $ mkpath "ssh_host_rsa_key.pub")
+        $ show_ssh' "ssh-server" grip (rtKeyDB rt)
+    either warn (write $ mkpath "ipsec.d/certs/" ++ oname++".pem")
+        $ show_pem' "ipsec" grip (rtKeyDB rt) pemFromPacket
+
+    let cs = filter notme (Map.elems $ rtKeyDB rt)
+        kk = keykey (fromJust $ rtWorkingKey rt)
+        notme kd = keykey (keyPacket kd) /= kk
+
+        installConctact kd = do
+            -- The getHostnames command requires a valid cross-signed tor key
+            -- for each onion name returned in (_,(ns,_)).
+            let (_,(ns,_)) = getHostnames kd
+                contactname = fmap Char8.unpack $ listToMaybe ns -- only first onion name.
+            flip (maybe $ return ()) contactname $ \contactname -> do
+
+            let cpath = interp (Map.singleton "onion" contactname) "ipsec.d/certs/%(onion).pem"
+                their_master = packet $ keyMappedPacket kd
+                -- We find all cross-certified ipsec keys for the given cross-certified onion name.
+                ipsecs = sortOn (Down . timestamp)
+                         $ getCrossSignedSubkeys their_master (keySubKeys kd) "ipsec"
+            forM_ (take 1 ipsecs) $ \k -> do
+            either warn (write $ mkpath cpath) $ pemFromPacket k
+
+    mapM_ installConctact cs
+
+
+#if !MIN_VERSION_base(4,8,0)
+sortOn :: Ord b => (a -> b) -> [a] -> [a]
+sortOn f =
+    map snd . sortBy (comparing fst) . map (\x -> let y = f x in y `seq` (y, x))
+#endif
+
+pemFromPacket k = do
+    let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
+        der = encodeASN1 DER (toASN1 rsa [])
+        qq  = Base64.encode (L.unpack der)
+    return $
+        writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)
+
+show_pem keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db pemFromPacket
+
+show_pem' keyspec wkgrip db keyfmt = do
+    let s = parseSpec wkgrip keyspec
+    flip (maybe . Left $ keyspec ++ ": not found")
+         (selectPublicKey s db)
+         keyfmt
+
+warn str = hPutStrLn stderr str
+
+show_ssh keyspec wkgrip db = either warn putStrLn $ show_ssh' keyspec wkgrip db
+
+show_ssh' keyspec wkgrip db = do
+    let s = parseSpec wkgrip keyspec
+    flip (maybe . Left $ keyspec ++ ": not found")
+         (selectPublicKey s db)
+         $ return . sshblobFromPacket
+
+-- |
+-- interpolate %var patterns in a string.
+interp vars raw = es >>= interp1
+ where
+    gs = groupBy (\_ c -> c/='%') raw
+    es = dropWhile null $ gobbleEscapes ("":gs)
+            where gobbleEscapes :: [String] -> [String]
+                  gobbleEscapes (a:"%":b:bs) = (a++b) : gobbleEscapes bs
+                  gobbleEscapes (g:gs)       = g : gobbleEscapes gs
+                  gobbleEscapes []           = []
+    interp1 ('%':'(':str) = fromMaybe "" (Map.lookup key vars) ++ drop 1 rest
+                            where (key,rest) = break (==')') str
+    interp1 plain = plain
+
+sshblobFromPacket k = blob
+ where
+    Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
+    bs = SSH.keyblob (n,e)
+    blob = Char8.unpack bs
+
+ㄧhomedir = Kiki.CommonArgsParsed
+                <$> optional (arg "--homedir")
+                <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
+