WIP: tar command.

2 files changed, 209 insertions, 20 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 7369acf..d4bb099 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -938,7 +938,7 @@ parseSpec grip spec = (topspec,subspec)
                 "fp" | top=="" -> Nothing
                 "" | top=="" && is40digitHex sub -> Nothing
                 "" -> listToMaybe sub >> Just sub
-                -- "fp" -> ???  TODO: non-ehaustive patterns in case: fp:7/fp:
+                _ -> Nothing
 
      is40digitHex xs = ys == xs && length ys==40
       where
@@ -992,11 +992,14 @@ selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
 selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
 
-selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(Packet,[Packet])]
+selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
 selectPublicKeyAndSigs (spec,mtag) db =
     case mtag of
-        Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db
-        Just tag -> Map.elems (Map.filter (matchSpec spec) db) >>= findsubs tag
+        Nothing -> do
+            (kk,r) <- Map.toList $ fmap (findbyspec spec) db
+            (sub,sigs) <- r
+            return (kk,sub,sigs)
+        Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
  where
     topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
 
@@ -1009,22 +1012,22 @@ selectPublicKeyAndSigs (spec,mtag) db =
         ismatch (p,sigs) = matchpr g p ==g
     findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
 
-    findsubs tag (KeyData topk _ _ subs) = Map.elems subs >>= gettag
+    findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
      where
         gettag (SubKey sub sigs) = do
             let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
             (hastag,_) <- maybeToList mb
             guard hastag
-            return $ (packet sub, map (packet . fst) sigs)
+            return $ (kk, packet sub, map (packet . fst) sigs)
 
 selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
 selectKey0 wantPublic (spec,mtag) db = do
     let Message ps = flattenKeys wantPublic db
         ys = snd $ seek_key spec ps
     flip (maybe (listToMaybe ys)) mtag $ \tag -> do
-    let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys
-        zs = snd $ seek_key subspec ys1
-    listToMaybe zs
+    case ys of
+        y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
+        []    -> Nothing
 
 {-
 selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
diff --git a/kiki.hs b/kiki.hs
index 9a2000a..d58ef2a 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -17,18 +17,24 @@ import Data.Binary
 import Data.Bits
 import Data.Char
 import Data.IORef
+import Data.Int
 import Data.List
 import Data.Maybe
 import Data.OpenPGP
 import Data.Ord
 import Data.Text.Encoding
 import System.Posix.User
+import System.Posix.Files
+import System.Posix.Types
 import System.FilePath.Posix
+import Foreign.C.Types (CTime(..))
 import System.Directory
 import System.Environment
 import System.Exit
 import System.IO (hPutStrLn,stderr)
 import qualified Codec.Binary.Base64 as Base64
+import qualified Codec.Archive.Tar as Tar
+import qualified Codec.Archive.Tar.Entry as Tar
 #if !defined(VERSION_cryptonite)
 import qualified Crypto.Hash.RIPEMD160 as RIPEMD160
 import qualified Crypto.Hash.SHA256    as SHA256
@@ -42,7 +48,6 @@ import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map as Map
 import Control.Arrow   (first,second)
-import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
 import Data.Monoid ( (<>) )
 import Data.Binary.Put
 
@@ -58,6 +63,8 @@ import ProcessUtils
 import qualified SSHKey as SSH
 import Text.Printf
 import qualified DNSKey as DNS
+import Data.Time.Clock.POSIX ( posixSecondsToUTCTime )
+import Debug.Trace
 
 -- {-# ANN module ("HLint: ignore Eta reduce"::String) #-}
 -- {-# ANN module ("HLint: ignore Use camelCase"::String) #-}
@@ -329,11 +336,13 @@ show_ssh' keyspec wkgrip db = do
     let s = parseSpec wkgrip keyspec
     flip (maybe . Left $ keyspec ++ ": not found")
          (selectPublicKey s db)
-         $ \k -> do
-    let Just (RSAKey (MPI n) (MPI e)) = rsaKeyFromPacket k
-        bs = SSH.keyblob (n,e)
-        blob = Char8.unpack bs
-    return blob
+         $ 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
@@ -376,7 +385,7 @@ show_cert keyspec wkgrip db = do
     let s = parseSpec wkgrip keyspec
     case selectPublicKeyAndSigs s db of
         [] -> void $ warn (keyspec ++ ": not found")
-        [(k,sigs)] -> do
+        [(_,k,sigs)] -> do
             {-
             let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
                 der = encodeASN1 DER (toASN1 rsa [])
@@ -944,9 +953,27 @@ documentHostsOption bExport bImport bSecret =
             ,"                but they are currently NOT signed and may be altered in"
             ,"                transit."
             ,""]
-            
-            
 
+
+
+-- |
+-- Arguments:
+--
+--   * option-count pairs - List of option names paired with number of expected values to follow them.
+--
+--   * polyvariadic options - List of option names that can take any number of arguments.
+--
+--   * default polyvariadic - Implicit polyvariadic option if no other option is specified.
+--
+--   * arguments - list of arguments to be parsed.
+--
+-- Returns:
+--
+--   * (non-variadic only) options and corresponding arguemnts in list of lists form.
+--
+--   * (variadic only) map of option name to argument lists.
+--
+processArgs :: [(String,Int)] -> [String] -> String -> [String] -> ([[String]],Map.Map String [String])
 processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs)
     where
         (args,trail1) = break (=="--") args_raw
@@ -962,7 +989,7 @@ processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs)
                                gargs)
                     where (sargs,vargs) = partitionStaticArguments sargspec' args
                           argspec = map fst sargspec' ++ polyVariadicArgs
-                          args' = if map (take 1) (take 1 vargs) == ["-"]
+                          args' = if null defaultPoly || map (take 1) (take 1 vargs) == ["-"]
                                     then vargs
                                     else defaultPoly:vargs
                           -- grouped args
@@ -1175,7 +1202,7 @@ kiki "show" args = do
                    , ("--torhash",1)
                    ]
         polyVariadicArgs = ["--show"]
-    let cap = parseCommonArgs margs 
+    let cap = parseCommonArgs margs
         homespec = cap_homespec cap
         passfd = cap_passfd cap
         pems = []
@@ -1592,6 +1619,164 @@ kiki "delete" args = do
     forM_ report $ \(fname,act) -> do
         putStrLn $ fname ++ ": " ++ reportString act
 
+kiki "tar" args | "--help" `elem` args = do
+    putStr . unlines $
+        [ "kiki tar (-c|-A|-t) [--secrets SPEC] [--passphrase-fd FD] [--homedir HOMEDIR]"
+        , ""
+        , "Import or export a tar archive containing key files in the proper"
+        , "format for software configuration."
+        , ""
+        ,"    -c  Generate tar archive on stdout."
+        ,""
+        ,"    -A  Read tar archive on stdin."
+        ,""
+        ,"    -t  List filepaths that would be included in the (-c) output archive."
+        ,""
+        ,"    --secrets SPEC"
+        ,"        Include secret keys for the specified identity."
+        ,"        Otherwise, only public keys are included."
+        ,""
+        ,"        SPEC is matched against the following forms in order:"
+        ,""
+        ,"          -"
+        ,"           (current working identity)"
+        ,""
+        ,"          fp:4A39F"
+        ,"            (tail end of a fingerprint prefixed by 'fp:')"
+        ,""
+        ,"          u:joe"
+        ,"            (sub-string of a user id prefixed by 'u:')"
+        ,""
+        ,"          5E24CD442AA6965D2012E62A905C24185D5379C2"
+        ,"            (fingerprint as 40 characters of hexidecimal)"
+        ,""
+        ,"          joe"
+        ,"            (sub-string of a user id without 'u:' prefix)"
+        ]
+
+kiki "tar" args = do
+    let parsed_args = processArgs sargspec [] "" args
+        sargspec = [("-t",0),("-c",0),("-A",0),("-C",1),("--secrets",1)]
+        ismode ("-t":_) = True
+        ismode ("-c":_) = True
+        ismode ("-A":_) = True
+        ismode _        = False
+    case filter ismode (fst parsed_args) of
+        ["-t":_] -> tarT parsed_args
+        ["-c":_] -> tarC parsed_args
+        ["-A":_] -> putStrLn "unimplemented."
+        _ -> kiki "tar" ["--help"]
+
+tarContent rt spec pubpem knownhosts secpem = ipsecs ++ sshs ++ secrets "root"
+ where
+    ipsecs = do
+        (kk,ipsec,sigs) <- selectPublicKeyAndSigs (KeyUidMatch "",Just "strongswan") (rtKeyDB rt)
+        let kd = (rtKeyDB rt Map.! kk)
+            k = packet $ keyMappedPacket kd
+            (addr,(onames,ns)) = getHostnames kd
+        oname <- onames
+        return ("etc/ipsec.d/certs/" ++ Char8.unpack oname ++ ".pem", pubpem ns addr ipsec sigs)
+
+    sshs = case selectPublicKeyAndSigs (KeyUidMatch "",Just "ssh-host") (rtKeyDB rt) of
+            []      -> []
+            ssh_sel -> [("etc/ssh/ssh_known_hosts", knownhosts ssh_sel)]
+
+    secrets_kd = case fst . parseSpec "" <$> (++"/") <$> spec of
+                    _ | spec == Just "-" || spec == Just ""
+                        -> maybeToList (rtWorkingKey rt) >>= return . (Map.!) (rtKeyDB rt) . keykey
+                    Just topspec
+                        -> map snd $ filterMatches topspec $ Map.toList $ rtKeyDB rt
+                    w -> []
+
+    lookupSecret tag kd = maybeToList $ selectSecretKey (KeyGrip "",Just tag) m
+      where
+        m = Map.singleton (keykey $ keyPacket kd) kd
+
+    sshkeyname SecretKeyPacket { key_algorithm = RSA } = "id_rsa"
+
+    dir :: FilePath -> FilePath
+    dir d = d -- TODO: prepend prefix path?
+
+    spem d k = (d, secpem k)
+
+    secrets homedir = do
+        kd <- secrets_kd
+        let torkey = spem (dir "var/lib/tor/samizdat/private_key") <$> lookupSecret "tor" kd
+            sshcli = do k <- lookupSecret "ssh-client" kd
+                        return $ spem (dir $ homedir ++ "/.ssh/" ++ sshkeyname k) k
+            sshsvr = spem (dir "etc/ssh/ssh_host_rsa_key") <$> lookupSecret "ssh-host" kd
+            ipseckey = do
+                k <- lookupSecret "strongswan" kd
+                oname <- fst . snd $ getHostnames kd
+                return $ spem (dir $ "etc/ipsec.d/private/"++Char8.unpack oname++".pem") k
+        torkey ++ sshcli ++ sshsvr ++ ipseckey
+
+tarT :: ([[String]],Map.Map String [String]) -> IO ()
+tarT (sargs,margs) = do
+    KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs
+    case rt of
+      KikiSuccess rt -> do
+        let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs
+            nil = error "internal error!"
+            fs = map fst $ tarContent rt keyspec nil nil nil
+        mapM_ putStrLn fs
+      err -> putStrLn $ errorString err
+
+tarC :: ([[String]],Map.Map String [String]) -> IO ()
+tarC (sargs,margs) = do
+    KikiResult rt report <- runKeyRing $ minimalOp $ parseCommonArgs margs
+    case rt of
+      KikiSuccess rt -> do
+        CTime pubtime <- modificationTime <$> getFileStatus (rtPubring rt)
+        let keyspec = concat . take 1 <$> Map.lookup "--secrets" margs
+            fs = tarContent rt keyspec build_ipsec (build_ssh rt pubtime) (error "todo")
+            es = do
+                (n,(epoch_time_int64,bs)) <- fs
+                entry <- either (const []) (return . flip Tar.fileEntry bs) $ Tar.toTarPath False n
+                return $ entry { Tar.entryTime = epoch_time_int64 }
+            tarbs = Tar.write es
+        L.putStr tarbs
+      err -> putStrLn $ errorString err
+ where
+    build_ipsec ns addr ipsec sigs
+       = ( fromIntegral $ timestamp ipsec
+         , Char8.pack $ fromJust $ pemFromPacket ipsec)
+    build_ssh rt timestamp sshs = (timestamp, Char8.unlines $ map knownhost sshs)
+     where
+        knownhost (kk,hostkey,sigs) = Char8.intercalate "," ns <> " " <> Char8.pack (sshblobFromPacket hostkey)
+         where
+            ns = onames ++ others
+            (_,(onames,others)) = getHostnames $ rtKeyDB rt Map.! kk
+
+minimalOp :: CommonArgsParsed -> KeyRingOperation
+minimalOp cap = op
+ where
+    streaminfo = StreamInfo { fill = KF_None
+                            , typ = KeyRingFile
+                            , spill = KF_All
+                            , initializer = Nothing
+                            , 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).
+--
+-- single leading hyphen, quits program with "Unrecognized option" error
+--
+-- Otherwise, Left (key-value pair) is returend by parsing
+-- a string of the form --key=value.
 splitArg :: String -> Either (String,Maybe String) String
 splitArg arg =
     case hyphens of
@@ -1620,6 +1805,7 @@ commands =
  , ( "merge", "low level import/export operation" )
  , ( "init-key", "initialize the samizdat key ring")
  , ( "delete", "Delete a subkey and its associated signatures" )
+ , ( "tar", "import or export system key files in tar format" )
  ]
 
 interp vars raw = es >>= interp1