The 'merge' command exposes low-level KeyRingOperation functionality.

1 files changed, 107 insertions, 0 deletions

diff --git a/kiki.hs b/kiki.hs
index cae8ae8..f99a928 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -872,6 +872,112 @@ kiki "show" args = do
     forM_ report $ \(fname,act) -> do
         putStrLn $ fname ++ ": " ++ reportString act
 
+kiki "merge" args = do
+    let op = snd $ foldl' buildOp (flow,noop) args
+        noop = KeyRingOperation
+                { opFiles = Map.empty
+                , opTransforms = []
+                , opHome = Nothing
+                , opPassphrases = []
+                }
+        flow = StreamInfo
+                { access = AutoAccess
+                , typ = KeyRingFile
+                , spill = KF_None
+                , fill = KF_None
+                , initializer = Nothing
+                , transforms = []
+                }
+        updateFlow fil spil mtch flow = spill' $ fill' $ flow
+         where
+            fill' flow  = flow { fill  = if fil  then val else KF_None }
+            spill' flow = flow { spill = if spil then val else KF_None }
+            val = either (\subkeys -> if subkeys then KF_Subkeys else KF_All)
+                         KF_Match
+                         mtch
+        parseFlow spec =
+            if null bads
+                then Just ( ( "spill" `elem` goods
+                             || "sync" `elem` goods
+                            , "fill" `elem` goods
+                             || "sync" `elem` goods )
+                          , maybe (Left $ "subkeys" `elem` goods)
+                                  Right
+                                  match )
+                else Nothing
+         where
+            ws = case groupBy (\_ c->c/=',') spec of
+                    w:xs -> w:map (drop 1) xs
+                    []   -> []
+            (goods,bads) = partition acceptable ws
+            acceptable "spill"   = True
+            acceptable "fill"    = True
+            acceptable "sync"    = True
+            acceptable "subkeys" = True
+            acceptable s | "match=" `isPrefixOf` s = True
+            acceptable _ = False
+            match = listToMaybe $ do
+                m <- filter ("match=" `isPrefixOf`) goods
+                return $ drop 6 m
+
+        buildOp (flow,op) arg =
+            case splitArg arg of
+                Right fname ->
+                    ( flow
+                    , op { opFiles= Map.insert (ArgFile fname) flow (opFiles op) })
+                Left ("autosign",Nothing) ->
+                    if Map.null (opFiles op)
+                        then (flow, op { opTransforms = opTransforms op ++ [Autosign] })
+                        else (flow { transforms = transforms flow ++ [Autosign] }, op)
+                Left ("noautosign",Nothing) ->
+                    ( flow { transforms = filter (/=Autosign) (transforms flow) }
+                    , op { opTransforms = filter (/=Autosign) (opTransforms op) } )
+                Left ("create",Just cmd) ->
+                    ( flow { initializer = if null cmd then Nothing else Just cmd }
+                    , op )
+                Left ("type",Just "keyring") -> ( flow { typ = KeyRingFile }, op )
+                Left ("type",Just "pem"    ) -> ( flow { typ = PEMFile     }, op )
+                Left ("type",Just "wallet" ) -> ( flow { typ = WalletFile  }, op )
+                Left ("type",Just "hosts"  ) -> ( flow { typ = Hosts       }, op )
+                Left ("access",Just "public") -> ( flow { access = Pub }, op )
+                Left ("access",Just "secret") -> ( flow { access = Sec }, op )
+                Left ("access",Just "auto")   -> ( flow { access = AutoAccess }, op )
+                Left ("home",mb) ->
+                    ( flow
+                    , op { opFiles = Map.insert HomePub flow { access=Pub }
+                                     $ Map.insert HomeSec flow { access=Sec }
+                                     $ opFiles op
+                         , opHome = opHome op `mplus` mb
+                         }
+                    )
+                Left ("flow",Just flowspec) ->
+                    case parseFlow flowspec of
+                        Just ( (fil,spil), mtch ) ->
+                            ( updateFlow fil spil mtch flow
+                            , op )
+                        Nothing -> error "Valid flow words are: spill,fill,sync,subkeys or match=KEYSPEC"
+                Left (option,_) -> error $ "Unrecognized option: " ++ option
+    KikiResult rt report <- runKeyRing op
+    case rt of
+      KikiSuccess rt -> return ()
+      err            -> putStrLn $ errorString err
+    forM_ report $ \(fname,act) -> do
+        putStrLn $ fname ++ ": " ++ reportString act
+
+splitArg :: String -> Either (String,Maybe String) String
+splitArg arg =
+    case hyphens of
+        ""  -> Right name
+        "-" -> error $ "Unrecognized option: " ++ arg
+        _   -> Left $ parseLongOption name
+ where
+    (hyphens, name) = span (=='-') arg
+    parseLongOption name = (key,val v)
+     where
+        (key,v) = break (=='=') name
+        val ('=':vs) = Just vs
+        val _        = Nothing
+
 commands :: [(String,String)]
 commands =
  [ ( "help", "display usage information" )
@@ -884,6 +990,7 @@ commands =
  , ( "export-secret", "export (both public and secret) information into your keyring" )
  , ( "export-public", "import (public) information into your keyring" )
  , ( "working-key", "show the current working master key and its subkeys" )
+ , ( "merge", "low level import/export operation" )
  ]
 
 main = do