1 files changed, 158 insertions, 24 deletions

diff --git a/lib/Kiki.hs b/lib/Kiki.hs
index f5490e0..468394f 100644
--- a/lib/Kiki.hs
+++ b/lib/Kiki.hs
@@ -2,14 +2,16 @@
 {-# LANGUAGE OverloadedStrings #-}
 module Kiki where
 
-import Control.Exception
 import Control.Applicative
 import Control.Arrow
+import Control.Concurrent
+import Control.Exception
 import Control.Monad
 import Data.ASN1.BinaryEncoding
 import Data.ASN1.Encoding
 import Data.ASN1.Types
 import Data.Binary
+import Data.Char
 import Data.List
 import Data.Maybe
 import Data.Monoid
@@ -21,11 +23,17 @@ import System.FilePath.Posix as FilePath
 import System.IO
 import System.IO.Temp
 import System.IO.Error
+import System.Posix.IO as Posix (createPipe)
 import System.Posix.User
 import System.Process
 import System.Posix.Files
 import qualified Data.Traversable as T (mapM)
+#if defined(VERSION_memory)
+import qualified Data.ByteString.Char8 as S8
+import Data.ByteArray.Encoding
+#elif defined(VERSION_dataenc)
 import qualified Codec.Binary.Base64 as Base64
+#endif
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map.Strict as Map
@@ -33,10 +41,50 @@ import qualified SSHKey as SSH
 import Network.Socket -- (SockAddr)
 import ProcessUtils
 
+import GnuPGAgent (Query(..))
 import CommandLine
 import KeyRing
 import DotLock
 
+withAgent :: [PassphraseSpec] -> [PassphraseSpec]
+withAgent [] = [PassphraseAgent]
+withAgent ps = ps
+
+ciphername Unencrypted = "-"
+ciphername TripleDES   = "3des"
+ciphername (SymmetricAlgorithm w8) = "cipher-"++show w8
+ciphername c = map toLower $ show c
+
+cipherFromString "clear"       = Unencrypted
+cipherFromString "unencrypted" = Unencrypted
+cipherFromString s             =
+    case filter ( (== s) . ciphername) ciphers of
+        x:_                  -> x
+        -- _ | all isHexDigit s -> unhex s
+        _                    -> error $ "known ciphers: "++unwords (map ciphername ciphers)
+ {-
+ where
+#if defined(VERSION_memory)
+    unhex hx = case convertFromBase Base16 (S8.pack hx) of
+                Left e -> do
+                    -- Useful for debugging but insecure generally ;)
+                    -- putStrLn $ "convertFromBase error for input "++show hx++": "++show e
+                    return Nothing
+                Right bs -> return $ Just $ S8.unpack bs
+#elif defined(VERSION_dataenc)
+    unhex hx = maybe (return () {- putStrLn $ "dataenc error for input "++show hx -})
+                     return
+                     $ fmap (map $ chr . fromIntegral) $ Base16.decode hx
+#endif
+-}
+
+
+ciphers :: [SymmetricAlgorithm]
+ciphers = takeWhile notFallback $ map toEnum $ [0..4]++[7..]
+ where
+    notFallback (SymmetricAlgorithm _) = False
+    notFallback _                      = True
+
 -- |
 -- Regenerate /var/cache/kiki
 refresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
@@ -78,8 +126,8 @@ minimalOp cap = op
             [ ( HomeSec, streaminfo { access = Sec })
             , ( HomePub, streaminfo { access = Pub })
             ]
-        , opPassphrases = do pfile <- maybeToList (cap_passfd cap)
-                             return $ PassphraseSpec Nothing Nothing pfile
+        , opPassphrases = withAgent $ do pfile <- maybeToList (cap_passfd cap)
+                                         return $ PassphraseSpec Nothing Nothing pfile
         , opTransforms = []
         , opHome = cap_homespec cap
         }
@@ -95,8 +143,8 @@ outputReport report = do
     forM_ report $ \(fname,act) -> do
         putStrLn $ fname ++ ": " ++ reportString act
 
-importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> IO ()
-importAndRefresh root cmn = do
+importAndRefresh :: (FilePath -> FilePath) -> CommonArgsParsed -> SymmetricAlgorithm -> IO ()
+importAndRefresh root cmn cipher = do
     let rootdir = do guard (root "x" /= "x")
                      Just $ root ""
 
@@ -122,7 +170,13 @@ importAndRefresh root cmn = do
     old_umask <- setFileCreationMask(0o077);
     -- Generate secring.gpg if it does not exist...
     gotsec <- doesFileExist secring
-    when (not gotsec) $ do
+
+    let passfd = cap_passfd cmn
+
+    (torgen,pwds) <-
+     if gotsec
+      then return (Generate 0 $ GenRSA $ 1024 `div` 8, [])
+      else do
         {-  ssh-keygen to create master key...
         let mkpath = home ++ "/master-key"
         mkdirFor mkpath
@@ -135,12 +189,46 @@ importAndRefresh root cmn = do
                         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}]
-
+        master_un <- (\k -> MappedPacket (k { is_subkey = False }) Map.empty) <$> generateKey (GenRSA $ 4096 `div` 8 )
+        tor_un <- generateKey (GenRSA $ 1024 `div` 8 )
+        (read_tor,write_tor) <- Posix.createPipe
+        do rs <- writeKeyToFile (streaminfo { typ = PEMFile, access = Sec, spill = KF_Match "tor", fill = KF_All }) (FileDesc write_tor) tor_un
+           -- outputReport $ map (first show) rs
+           return ()
+        let cipher's2k = (cipher {- AES128 -}, IteratedSaltedS2K SHA1 4073382889203176146 7864320)
+            ctx = InputFileContext secring pubring
+            main_passwds = withAgent $ do pfd <- maybeToList passfd
+                                          return $ PassphraseSpec Nothing Nothing pfd
+            passwordop = KeyRingOperation
+                            { opFiles = Map.empty
+                            , opPassphrases = main_passwds
+                            , opHome = homespec
+                            , opTransforms = []
+                            }
+        let uidentry = Map.singleton (keykey $ packet master_un)
+                        $ master_un { packet = Query (packet master_un)
+                                                     (torUIDFromKey tor_un)
+                                                     Nothing
+                                    }
+        transcoder <- makeMemoizingDecrypter passwordop ctx (Just master_un, uidentry)
+        master0 <- transcoder cipher's2k master_un
+        case master0 of
+            KikiSuccess master -> do
+                mkdirFor secring
+                writeInputFileL ctx
+                                HomeSec
+                                $ encode $ Message [master]
+                putStrLn "Wrote master key"
+                return (FileDesc read_tor, [PassphraseMemoizer transcoder])
+            er -> do
+                hPutStrLn stderr ("warning: " ++ errorString er)
+                hPutStrLn stderr "warning: keys will not be encrypted.";
+                mkdirFor secring
+                writeInputFileL ctx
+                                HomeSec
+                                $ encode $ Message [packet master_un]
+                putStrLn "Wrote master key"
+                return (Generate 0 (GenRSA $ 1024 `div` 8 ), [])
     gotpub <- doesFileExist pubring
     when (not gotpub) $ do
         mkdirFor pubring
@@ -164,8 +252,7 @@ importAndRefresh root cmn = do
 
     -- 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
+    let strm = StreamInfo { typ = KeyRingFile
                           , fill = KF_None
                           , spill = KF_All
                           , access = AutoAccess
@@ -191,21 +278,30 @@ importAndRefresh root cmn = do
              { 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" })
+                , ( torgen , case torgen of
+                                FileDesc _ -> StreamInfo { typ = PEMFile
+                                                         , fill = KF_Match "tor"
+                                                         , spill = KF_Match "tor"
+                                                         , access = Sec
+                                                         , initializer = NoCreate
+                                                         , transforms = [] }
+                                _          -> strm { spill = KF_Match "tor" })
+                , ( Generate 1 (GenRSA (2048 `div` 8)), strm { spill = KF_Match "ipsec" })
                 , ( ArgFile sshcpath, (peminfo 2048 "ssh-client") )
                 , ( ArgFile sshspath, (peminfo 2048 "ssh-server") )
+                , ( Generate 2 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "encrypt" })
+                , ( Generate 3 (GenRSA (4096 `div` 8)), strm { spill = KF_Match "sign" })
                 ]
-             , opPassphrases = do pfd <- maybeToList passfd
-                                  return $ PassphraseSpec Nothing Nothing pfd
+             , opPassphrases = withAgent $ pwds ++ 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
+            , opPassphrases = withAgent $ do pfd <- maybeToList passfd
+                                             return $ PassphraseSpec Nothing Nothing pfd
             , opHome=homespec, opTransforms = []
             }
     -- if bUnprivileged then doNothing else mkdirFor torpath
@@ -299,12 +395,39 @@ refreshCache rt rootdir = do
         wkkd = rtKeyDB rt Map.! keykey wk
         getSecret tag = sortOn (Down . timestamp)
                         $ getSubkeys Unsigned wk (keySubKeys wkkd) tag
-
+        exportOp = withOutgoing $ minimalOp (CommonArgsParsed (Just $ takeDirectory $ rtPubring rt)
+                                                              Nothing)
+         where
+          withOutgoing op = op
+            { opFiles = opFiles op `Map.union` Map.fromList outgoing_secrets
+            , opPassphrases = [PassphraseMemoizer (rtPassphrases rt)]
+            }
+          outgoing_secrets =
+            [ send "ipsec"      (mkpath "ipsec.d/private/" ++ Char8.unpack oname++".pem") "missing ipsec key?"
+            , send "ssh-client" (mkpath "root/.ssh/id_rsa")                               "missing ssh-client key?"
+            , send "ssh-server" (mkpath "ssh_host_rsa_key")                               "missing ssh host key?"
+            , send "tor"        (mkpath "tor/private_key")                                "missing tor key?"
+            ]
+          send usage path warning =
+            ( ArgFile path, StreamInfo { typ = PEMFile
+                                       , fill = KF_Match usage
+                                       , spill = KF_None
+                                       , access = Sec
+                                       , initializer = WarnMissing warning
+                                       , transforms = []
+                                       })
+    KikiResult rt' report <- runKeyRing exportOp
+
+    {-
     let writeSecret tag path warning = do
         let my_ks :: [Packet]
-            my_ks = getSecret "ipsec"
+            my_ks = getSecret tag
         case my_ks of
-            sec:_ -> do report <- writeKeyToFile streaminfo { typ = PEMFile
+            se0:_ -> do sc1 <- rtPassphrases rt (Unencrypted,S2K 100 "") $ MappedPacket se0 Map.empty
+                        let sec = case sc1 of
+                                    KikiSuccess s -> s
+                                    _             -> se0
+                        report <- writeKeyToFile streaminfo { typ = PEMFile
                                                             , access = Sec
                                                             , spill = KF_All
                                                             }
@@ -335,6 +458,7 @@ refreshCache rt rootdir = do
     writeSecret "tor"
                 (mkpath "tor/private_key")
                 "missing tor key?"
+    -}
 
     -- Finally, export public keys if they do not exist.
     either warn (write $ mkpath "root/.ssh/id_rsa.pub")
@@ -364,6 +488,7 @@ refreshCache rt rootdir = do
                 ipsecs :: [Packet]
                 ipsecs = sortOn (Down . timestamp)
                          $ getSubkeys CrossSigned their_master (keySubKeys kd) "ipsec"
+                           -- ++ getSubkeys CrossSigned their_master (keySubKeys kd) "strongswan"
                 sshs :: [Packet]
                 sshs = sortOn (Down . timestamp)
                          $ getSubkeys CrossSigned their_master (keySubKeys kd) "ssh-server"
@@ -449,7 +574,11 @@ sortOn f =
 pemFromPacket k = do
     let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
         der = encodeASN1 DER (toASN1 rsa [])
+#if defined(VERSION_memory)
+        qq  = S8.unpack $ convertToBase Base64 (L.toStrict der)
+#elif defined(VERSION_dataenc)
         qq  = Base64.encode (L.unpack der)
+#endif
     return $
         writePEM "PUBLIC KEY" qq -- ("TODO "++show keyspec)
 
@@ -491,6 +620,7 @@ sshblobFromPacketL k = do
     RSAKey (MPI n) (MPI e) <- rsaKeyFromPacket k
     return $ SSH.keyblob (n,e)
 
+{-
 replaceSshServerKeys root cmn = do
     let homepass' = cmn { cap_homespec = fmap root (cap_homespec cmn) }
         replaceSSH op = op { opFiles = files }
@@ -508,6 +638,7 @@ replaceSshServerKeys root cmn = do
                                                     ""  -> Nothing
                                                     pth -> Just pth
         err            -> hPutStrLn stderr $ errorString err
+-}
 
 slash :: String -> String -> String
 slash "/"    ('/':xs) = '/':xs
@@ -523,8 +654,11 @@ slash (y:ys) xs       = y:slash ys xs
                 <$> optional (arg "--homedir")
                 <*> optional (FileDesc <$> read <$> arg "--passphrase-fd")
 
+ㄧcipher :: Args SymmetricAlgorithm
+ㄧcipher = fromMaybe CAST5 <$> optional (cipherFromString <$> arg "--cipher")
+
 kikiOptions :: ( [(String,Int)], [String] )
 kikiOptions = ( ss, ps )
  where
-    ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1)]
+    ss = [("--chroot",1),("--passphrase-fd",1),("--homedir",1),("--cipher",1)]
     ps = []