body of kiki init is now library call: importAndRefresh.

3 files changed, 161 insertions, 148 deletions

diff --git a/cokiki.hs b/cokiki.hs
index 055be9b..8e013d6 100644
--- a/cokiki.hs
+++ b/cokiki.hs
@@ -40,7 +40,7 @@ main = do
                 ["ssh-server"] -> pure (whenRoot sshServer)
                 ["strongswan"] -> pure (whenRoot strongswan)
                 _   -> pure $ hPutStr stderr usage
-        spec = fancy [("--chroot",1),("--passphrase-fd",1),("--homedir",1)] [] ""
+        spec = uncurry fancy Kiki.kikiOptions ""
     case runArgs (parseInvocation spec args) sel of
         Left e   -> hPutStrLn stderr $ usageErrorMessage e
         Right io -> io
diff --git a/kiki.hs b/kiki.hs
index f239410..3f1843f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -1417,142 +1417,13 @@ kiki "init" args | "--help" `elem` args = do
         , "     --chroot=ROOTDIR"
         , "                Use ROOTDIR for input of ssh keys and export files to"
         , "                ROOTDIR/var/cache/kiki instead of the current system path."
-        , "                When this option is specified, the GNUPGHOME environment"
-        , "                variable is ignored and you must use --homedir to specify"
+        , "                When this option is specified, the GNUPGHOME environment"
+        , "                variable is ignored and you must use --homedir to specify"
         , "                a value other than /root/.gnupg."
         , ""
         ] ++ documentHomeDir ++ [""] ++ documentPassphraseFDFlag True True True
-kiki "init" args = do
-    me <- getEffectiveUserID
-    {-
-    if me/=0 then error "This command requires root." else do
-    -}
-    let as = lefts $ map splitArg args
-        lefts = mapMaybe isLeft where { isLeft (Left x) = Just x; isLeft _ = Nothing }
-        bads = map fst as \\ ["passphrase-fd","homedir","chroot"]
-    if not (null bads) then error ("Bad option: " ++ unwords bads) else do
-    let rootdir = fmap (fromMaybe "") $ lookup "chroot" as
-    let noChrootArg = rootdir == Nothing
-        bUnprivileged = (me/=0) && noChrootArg
-    if rootdir==Just "" then error "--chroot requires an argument" else do
-    -- maybe id fchroot rootdir $ do
-    args <- return $ map (second $ fromMaybe "") as
-
-    let homespec = mplus (slash <$> rootdir <*> lookup "homedir" args )
-                         (fmap (++"/root/.gnupg") rootdir)
-        sshkeygen size = Just $ concat [ "mkdir -p \"$(dirname $file)\" && "
-                                       , "ssh-keygen -P \"\" -q -f $file -b "
-                                       , show size ]
-        mkdirFor path = do
-            let dir = takeDirectory path
-            -- putStrLn $ "mkdirFor " ++ show dir
-            createDirectoryIfMissing True dir
-        -- ssl = Just "mkdir -p \"$(dirname $file)\" && openssl genrsa -out $file 1024"
-    (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec
-    osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root"
-    putStrLn $ "gnupg home = " ++ show (home,secring,pubring,mbwk)
-    putStrLn $ "os    home = " ++ show osHomeDir
-    -- gnupg home = ("TESTS/tmpgh","TESTS/tmpgh/secring.gpg","TESTS/tmpgh/pubring.gpg",Nothing)
-    -- os    home = "/root"
-
-
-    -- Generate secring.gpg if it does not exist...
-    gotsec <- doesFileExist secring
-    when (not gotsec) $ do
-        {-  ssh-keygen to create master key...
-        let mkpath = home ++ "/master-key"
-        mkdirFor mkpath
-        e <- systemEnv [ ("file",mkpath) ] (fromJust $ sshkeygen 4096)
-        case e of
-            ExitFailure num -> error "ssh-keygen failed to create master key"
-            ExitSuccess     -> return ()
-        [PEMPacket mk] <- readSecretPEMFile (ArgFile mkpath)
-        writeInputFileL (InputFileContext secring pubring)
-                        HomeSec
-                        ( encode $ Message [mk { is_subkey = False }] )
-        -}
-        master <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
-        mkdirFor secring
-        writeInputFileL (InputFileContext secring pubring)
-                        HomeSec
-                        $ encode $ Message [master { is_subkey = False}]
-
-    gotpub <- doesFileExist pubring
-    when (not gotpub) $ do
-        mkdirFor pubring
-        writeInputFileL (InputFileContext secring pubring)
-                        HomePub
-                        ( encode $ Message [] )
-
-    -- Old paths..
-    --
-    -- Private
-    -- pem tor        /var/lib/tor/samizdat/private_key
-    -- pem ssh-client %(home)/.ssh/id_rsa
-    -- pem ssh-server /etc/ssh/ssh_host_rsa_key
-    -- pem ipsec      /etc/ipsec.d/private/%(onion).pem
-
-    -- Public
-    -- ssh-client %(home)/.ssh/id_rsa.pub
-    -- ssh-server /etc/ssh/ssh_host_rsa_key.pub
-    -- ipsec      /etc/ipsec.d/certs/%(onion).pem
-
-    -- First, we ensure that the tor key exists and is imported
-    -- so that we know where to put the strongswan key.
-    let passfd = fmap (FileDesc . read) $ lookup "passphrase-fd" args
-        strm = StreamInfo { typ = KeyRingFile
-                          , fill = KF_None
-                          , spill = KF_All
-                          , access = AutoAccess
-                          , initializer = NoCreate
-                          , transforms = [] }
-        buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp
-                                               , fill = rtyp
-                                               , spill = KF_All
-                                               , access = AutoAccess
-                                               , initializer = NoCreate
-                                               , transforms = [] }
-        peminfo bits usage =
-                  StreamInfo { typ = PEMFile
-                             , fill = KF_None -- KF_Match usage
-                             , spill = KF_Match usage
-                             , access = Sec
-                             , initializer = Internal (GenRSA $ bits `div` 8)
-                             , transforms = []
-                             }
-        sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
-        sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key"
-        op = KeyRingOperation
-             { opFiles = Map.fromList $
-                [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
-                , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
-                , ( Generate 0 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "tor" })
-                , ( Generate 1 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "ipsec" })
-                , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
-                , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
-                ]
-             , opPassphrases = do pfd <- maybeToList passfd
-                                  return $ PassphraseSpec Nothing Nothing pfd
-             , opHome = homespec
-             , opTransforms = []
-             }
-        -- doNothing = return ()
-        nop = KeyRingOperation
-            { opFiles = Map.empty
-            , opPassphrases = do pfd <- maybeToList passfd
-                                 return $ PassphraseSpec Nothing Nothing pfd
-            , opHome=homespec, opTransforms = []
-            }
-    -- if bUnprivileged then doNothing else mkdirFor torpath
-    KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op)
-    forM_ report $ \(fname,act) -> do
-        putStrLn $ fname ++ ": " ++ reportString act
-    rt <- case rt of
-        BadPassphrase ->
-            error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
-        _ -> unconditionally $ return rt
 
-    when (not bUnprivileged) $ refreshCache rt rootdir
+kiki "init" args = run args $ importAndRefresh <$> ㄧchroot <*> ㄧhomedir
 
 kiki "delete" args | "--help" `elem` args = do
     putStr . unlines $
diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index ec34542..1682811 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -1,26 +1,29 @@
 {-# LANGUAGE CPP #-}
 module Kiki where
 
-import Control.Monad
 import Control.Applicative
+import Control.Arrow
+import Control.Monad
+import Data.ASN1.BinaryEncoding
+import Data.ASN1.Encoding
+import Data.ASN1.Types
+import Data.Binary
 import Data.List
 import Data.Maybe
+import Data.OpenPGP
+import Data.OpenPGP.Util
 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 System.Posix.User
 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 qualified Data.Map.Strict as Map
+import qualified SSHKey as SSH
 
 import CommandLine
-import qualified SSHKey as SSH
 import KeyRing
 
 -- |
@@ -70,6 +73,139 @@ minimalOp cap = op
         , opHome = cap_homespec cap
         }
 
+run :: [String] -> Args (IO ()) -> IO ()
+run args x =
+    case runArgs (parseInvocation (uncurry fancy kikiOptions "") args) x of
+        Left e   -> hPutStrLn stderr $ usageErrorMessage e
+        Right io -> io
+
+importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
+importAndRefresh root cmn = do
+    let rootdir = do guard (root "x" /= "x")
+                     Just $ root ""
+
+    me <- getEffectiveUserID
+
+    let noChrootArg = rootdir == Nothing
+        bUnprivileged = (me/=0) && noChrootArg
+    if rootdir==Just "" then error "--chroot requires an argument" else do
+
+    let homespec = mplus (slash <$> rootdir <*> cap_homespec cmn)
+                         (fmap (++"/root/.gnupg") rootdir)
+        sshkeygen size = Just $ concat [ "mkdir -p \"$(dirname $file)\" && "
+                                       , "ssh-keygen -P \"\" -q -f $file -b "
+                                       , show size ]
+        mkdirFor path = do
+            let dir = takeDirectory path
+            -- putStrLn $ "mkdirFor " ++ show dir
+            createDirectoryIfMissing True dir
+        -- ssl = Just "mkdir -p \"$(dirname $file)\" && openssl genrsa -out $file 1024"
+    (home,secring,pubring,mbwk) <- unconditionally $ getHomeDir homespec
+    osHomeDir <- if bUnprivileged then getHomeDirectory else return "/root"
+    putStrLn $ "gnupg home = " ++ show (home,secring,pubring,mbwk)
+    putStrLn $ "os    home = " ++ show osHomeDir
+    -- gnupg home = ("TESTS/tmpgh","TESTS/tmpgh/secring.gpg","TESTS/tmpgh/pubring.gpg",Nothing)
+    -- os    home = "/root"
+
+
+    -- Generate secring.gpg if it does not exist...
+    gotsec <- doesFileExist secring
+    when (not gotsec) $ do
+        {-  ssh-keygen to create master key...
+        let mkpath = home ++ "/master-key"
+        mkdirFor mkpath
+        e <- systemEnv [ ("file",mkpath) ] (fromJust $ sshkeygen 4096)
+        case e of
+            ExitFailure num -> error "ssh-keygen failed to create master key"
+            ExitSuccess     -> return ()
+        [PEMPacket mk] <- readSecretPEMFile (ArgFile mkpath)
+        writeInputFileL (InputFileContext secring pubring)
+                        HomeSec
+                        ( encode $ Message [mk { is_subkey = False }] )
+        -}
+        master <- (\k -> k { is_subkey = False }) <$> generateKey (GenRSA $ 4096 `div` 8 )
+        mkdirFor secring
+        writeInputFileL (InputFileContext secring pubring)
+                        HomeSec
+                        $ encode $ Message [master { is_subkey = False}]
+
+    gotpub <- doesFileExist pubring
+    when (not gotpub) $ do
+        mkdirFor pubring
+        writeInputFileL (InputFileContext secring pubring)
+                        HomePub
+                        ( encode $ Message [] )
+
+    -- Old paths..
+    --
+    -- Private
+    -- pem tor        /var/lib/tor/samizdat/private_key
+    -- pem ssh-client %(home)/.ssh/id_rsa
+    -- pem ssh-server /etc/ssh/ssh_host_rsa_key
+    -- pem ipsec      /etc/ipsec.d/private/%(onion).pem
+
+    -- Public
+    -- ssh-client %(home)/.ssh/id_rsa.pub
+    -- ssh-server /etc/ssh/ssh_host_rsa_key.pub
+    -- ipsec      /etc/ipsec.d/certs/%(onion).pem
+
+    -- First, we ensure that the tor key exists and is imported
+    -- so that we know where to put the strongswan key.
+    let passfd = cap_passfd cmn
+        strm = StreamInfo { typ = KeyRingFile
+                          , fill = KF_None
+                          , spill = KF_All
+                          , access = AutoAccess
+                          , initializer = NoCreate
+                          , transforms = [] }
+        buildStreamInfo rtyp ftyp = StreamInfo { typ = ftyp
+                                               , fill = rtyp
+                                               , spill = KF_All
+                                               , access = AutoAccess
+                                               , initializer = NoCreate
+                                               , transforms = [] }
+        peminfo bits usage =
+                  StreamInfo { typ = PEMFile
+                             , fill = KF_None -- KF_Match usage
+                             , spill = KF_Match usage
+                             , access = Sec
+                             , initializer = Internal (GenRSA $ bits `div` 8)
+                             , transforms = []
+                             }
+        sshcpath = fromMaybe "" rootdir ++ osHomeDir ++ ".ssh/id_rsa"
+        sshspath = fromMaybe "" rootdir ++ "/etc/ssh/ssh_host_rsa_key"
+        op = KeyRingOperation
+             { opFiles = Map.fromList $
+                [ ( HomeSec, buildStreamInfo KF_All KeyRingFile )
+                , ( HomePub, (buildStreamInfo KF_All KeyRingFile) { access = Pub } )
+                , ( Generate 0 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "tor" })
+                , ( Generate 1 (GenRSA (1024 `div` 8)), strm { spill = KF_Match "ipsec" })
+                , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
+                , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
+                ]
+             , opPassphrases = do pfd <- maybeToList passfd
+                                  return $ PassphraseSpec Nothing Nothing pfd
+             , opHome = homespec
+             , opTransforms = []
+             }
+        -- doNothing = return ()
+        nop = KeyRingOperation
+            { opFiles = Map.empty
+            , opPassphrases = do pfd <- maybeToList passfd
+                                 return $ PassphraseSpec Nothing Nothing pfd
+            , opHome=homespec, opTransforms = []
+            }
+    -- if bUnprivileged then doNothing else mkdirFor torpath
+    KikiResult rt report <- runKeyRing (if bUnprivileged then nop else op)
+    forM_ report $ \(fname,act) -> do
+        putStrLn $ fname ++ ": " ++ reportString act
+    rt <- case rt of
+        BadPassphrase ->
+            error "Operation requires correct passphrase. (Hint: Use --passphrase-fd=0 to input it on stdin.)"
+        _ -> unconditionally $ return rt
+
+    when (not bUnprivileged) $ refreshCache rt rootdir
+
 
 refreshCache :: KeyRingRuntime -> Maybe FilePath -> IO ()
 refreshCache rt rootdir = do
@@ -172,10 +308,6 @@ sshblobFromPacket k = blob
     bs = SSH.keyblob (n,e)
     blob = Char8.unpack bs
 
-ㄧhomedir = Kiki.CommonArgsParsed
-                <$> optional (arg "--homedir")
-                <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
-
 replaceSshServerKeys root cmn = do
     let homepass' = cmn { cap_homespec = fmap root (cap_homespec cmn) }
         replaceSSH op = op { opFiles = files }
@@ -194,12 +326,22 @@ replaceSshServerKeys root cmn = do
                                                     pth -> Just pth
         err            -> hPutStrLn stderr $ errorString err
 
-ㄧchroot :: Args (FilePath -> FilePath)
-ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
-
 slash :: String -> String -> String
 slash "/"    ('/':xs) = '/':xs
 slash ""     ('/':xs) = '/':xs
 slash ""     xs       = '/':xs
 slash (y:ys) xs       = y:slash ys xs
 
+ㄧchroot :: Args (FilePath -> FilePath)
+ㄧchroot = pure (\r a -> slash r a) <*> arg "--chroot" <|> pure id
+
+ㄧhomedir :: Args CommonArgsParsed
+ㄧhomedir = CommonArgsParsed
+                <$> optional (arg "--homedir")
+                <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
+
+kikiOptions :: ( [(String,Int)], [String] )
+kikiOptions = ( ss, ps )
+ where
+    ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1)]
+    ps = []