6 files changed, 180 insertions, 137 deletions

diff --git a/cokiki.hs b/cokiki.hs
index daf2be5..899608b 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -23,6 +23,7 @@ usage = unlines
     , "  strongswan"
     ]
 
+ㄧchroot :: Args (FilePath -> FilePath)
 ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
  where
     slash :: String -> String -> String
@@ -38,11 +39,11 @@ main = do
             | uid==0    = action
             | otherwise = hPutStrLn stderr "operation requires root."
     let sel = case cmd of
-                ["ssh-client"] -> pure (sshClient uid) <*> ㄧchroot
+                ["ssh-client"] -> pure (sshClient uid) <*> ㄧchroot <*> Kiki.ㄧhomedir
                 ["ssh-server"] -> pure (whenRoot sshServer)
                 ["strongswan"] -> pure (whenRoot strongswan)
                 _   -> pure $ hPutStr stderr usage
-        spec = fancy [("--chroot",1)] [] ""
+        spec = fancy [("--chroot",1),("--passphrase-fd",1),("--homedir",1)] [] ""
     case runArgs (parseInvocation spec args) sel of
         Left e   -> hPutStrLn stderr $ usageErrorMessage e
         Right io -> io
@@ -51,7 +52,7 @@ maybeReadFile :: FilePath -> IO (Maybe L.ByteString)
 maybeReadFile path = do
     doesFileExist path >>= bool (return Nothing) (Just <$> L.readFile path)
 
-sshClient uid root = do
+sshClient uid root cmn = do
     -- /etc/ssh/ssh_config    <--  'GlobalKnownHostsFile /var/cache/kiki/ssh_known_hosts'
     sshconfig <- parseSshConfig . fromMaybe "" <$> maybeReadFile (root "/etc/ssh/ssh_config")
     let (ps,qs) = sshSplitAtDirective "GlobalKnownHostsFile" sshconfig
@@ -64,20 +65,21 @@ sshClient uid root = do
             d:ds | elem "/var/cache/kiki/ssh_known_hosts" d
                  -> do hPutStrLn stderr "ssh-client already configured."
                        return Nothing
-            d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile not implemented"
-                       return Nothing
-            []   -> do
+            d:ds -> do hPutStrLn stderr "modifying GlobalKnownHostsFile directive"
+                       let hs = " " : "/var/cache/kiki/ssh_known_hosts" : drop 1 d
+                           stmt = take 1 d ++ hs
+                       return $ Just (ps ++ stmt : ds)
+            []   -> do -- Unconfigured add fresh directive.
                        let stmt = L8.unwords ["GlobalKnownHostsFile"
                                              ,  "/var/cache/kiki/ssh_known_hosts"
                                              ,  "/etc/ssh/ssh_known_hosts"
                                              ,  "/etc/ssh/ssh_known_hosts2"
                                              ]
                        return $ Just (sshconfig ++ parseSshConfig stmt)
-    -- sshconfig' `deepseq` return () -- force lazy input
+    sshconfig' `deepseq` return () -- force lazy input
     maybe (return ()) (myWriteFile (root "/etc/ssh/ssh_config") . unparseSshConfig) sshconfig'
     -- /root/.gnupg/...       <--  contains known hosts from /etc/ssh/ssh_known_hosts
-
-    -- Kiki.refresh
+    Kiki.refresh root cmn
     -- /var/cache/kiki/ssh_known_hosts        <--  contains known hosts from /root/.gnupg/...
 
 sshServer = do
@@ -87,7 +89,7 @@ sshServer = do
 strongswan = do
     -- etc/ipsec.conf    <--  'include /var/cache/kiki/ipsec.conf'
     -- /root/.gnupg/...   <--  contains newly-generated ipsec subkey
-    Kiki.refresh
+    Kiki.refresh id (Kiki.CommonArgsParsed Nothing Nothing)
     -- /var/cache/kiki/ipsec.conf      <--  contains configurations for each remote ipsec host
     -- /var/cache/kiki/ipsec.conf      <--  contains '%default' configuration for this local host
     -- /var/cache/kiki/ipsec.d/certs   <--  contains relevant certs
diff --git a/kiki.cabal b/kiki.cabal
index 5ed7a4c..b64b87e 100644
--- a/kiki.cabal
+++ b/kiki.cabal
@@ -78,6 +78,8 @@ library
                      CryptoCoins,
                      ProcessUtils,
                      Hosts,
+                     SSHKey,
+                     LengthPrefixedBE,
                      CommandLine,
                      Numeric.Interval,
                      Numeric.Interval.Bounded,
diff --git a/kiki.hs b/kiki.hs
index 0284ff9..842e697 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -66,14 +66,9 @@ import qualified SSHKey as SSH
 import Text.Printf
 import qualified DNSKey as DNS
 import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import Kiki
 import Debug.Trace
 
-#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
-
 -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
 -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
 
@@ -134,8 +129,6 @@ sortOn f =
  -
  -}
 
-warn str = hPutStrLn stderr str
-
 
 isCertificationSig (CertificationSignature {}) = True
 isCertificationSig _                           = True
@@ -307,21 +300,6 @@ show_whose_key input_key db =
 
 show_dns keyspec wkgrip db = either warn putStrLn $ show_pem' keyspec wkgrip db dnsPresentationFromPacket
 
-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
-
-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)
-
 dnsPresentationFromPacket k = do
     let RSAKey (MPI n) (MPI e)  = fromJust $ rsaKeyFromPacket k
         dnskey = DNS.RSA n e
@@ -341,20 +319,6 @@ dnsPresentationFromPacket k = do
         ,qq
         ]
 
-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
-
-sshblobFromPacket k = blob
- where
-    Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
-    bs = SSH.keyblob (n,e)
-    blob = Char8.unpack bs
-
 show_id keyspec wkgrip db = do
     let s = parseSpec "" keyspec
     let ps = do
@@ -1029,8 +993,6 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs)
                               else error . unlines $ [ "unrecognized option "++k
                                                      , "Use --help for usage." ]
 
-data CommonArgsParsed = CommonArgsParsed { cap_homespec :: Maybe String, cap_passfd :: Maybe InputFile }
-
 parseCommonArgs margs = CommonArgsParsed { cap_homespec = homespec, cap_passfd = passfd }
     where
         passphrase_fd = concat <$> Map.lookup "--passphrase-fd" margs
@@ -1658,55 +1620,6 @@ kiki "tar" args = do
         ["-A":_] -> putStrLn "unimplemented." -- import tar file?
         _ -> kiki "tar" ["--help"]
 
-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
-
-
 tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
  where
     ipsecs = do
@@ -1811,27 +1724,6 @@ tarC (sargs,margs) = do
                 hPutStrLn stderr $ "Failed to decrypt "++fingerprint k++"."
                 return Nothing
 
-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
-        }
-
 -- |
 --
 -- no leading hyphen, returns Right (input string).
@@ -1872,20 +1764,6 @@ commands =
  , ( "tar", "import or export system key files in tar format" )
  ]
 
--- |
--- 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
-
 main = do
     dotlock_init
     args_raw <- getArgs
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")
+
diff --git a/LengthPrefixedBE.hs b/lib/LengthPrefixedBE.hs
index 0ccd0e2..0ccd0e2 100644
--- a/LengthPrefixedBE.hs
+++ b/lib/LengthPrefixedBE.hs
diff --git a/SSHKey.hs b/lib/SSHKey.hs
index 488f55f..488f55f 100644
--- a/SSHKey.hs
+++ b/lib/SSHKey.hs