Merge branch 'master' of jotunheim:samizdat/kiki

1 files changed, 173 insertions, 52 deletions

diff --git a/kiki.hs b/kiki.hs
index b3147ff..00e458f 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -32,7 +32,6 @@ import qualified Data.ByteString      as S
 import qualified Data.ByteString.Lazy as L
 import qualified Data.ByteString.Lazy.Char8 as Char8
 import qualified Data.Map as Map
-import qualified Data.Text as T
 import Control.Arrow   (first,second)
 import Data.Binary.Get (runGet)
 import Data.Binary.Put (putWord32be,runPut,putByteString)
@@ -598,37 +597,6 @@ kiki_usage bSecret cmd = putStr $
                  ,"      5E24CD442AA6965D2012E62A905C24185D5379C2"
                  ]
 
-doAutosign rt kd@(KeyData k ksigs umap submap) = ops
- where
-    ops = map (\u -> InducerSignature u []) us
-    us = filter torStyle $ Map.keys umap
-    torStyle str = and [ uid_topdomain parsed == "onion"
-                        , uid_realname parsed `elem` ["","Anonymous"]
-                        , uid_user parsed == "root"
-                        , fmap (match . fst) (lookup (packet k) torbindings)
-                            == Just True ]
-      where parsed = parseUID str
-            match =  (==subdom) . take (fromIntegral len)
-            subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
-            subdom = Char8.unpack subdom0
-            len = T.length (uid_subdomain parsed)
-            torbindings = getTorKeys (map packet $ flattenTop "" True kd)
-            getTorKeys pub = do
-                xs <- groupBindings pub
-                (_,(top,sub),us,_,_) <- xs
-                guard ("tor" `elem` us)
-                let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
-                return (top,(torhash,sub))
-
-            groupBindings pub = gs
-             where (_,bindings) = getBindings pub
-                   bindings' = accBindings bindings
-                   code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
-                   ownerkey (_,(a,_),_,_,_) = a
-                   sameMaster (ownerkey->a) (ownerkey->b)
-                        = fingerprint_material a==fingerprint_material b
-                   gs = groupBy sameMaster (sortBy (comparing code) bindings')
-
 processArgs sargspec polyVariadicArgs defaultPoly args_raw = (sargs,margs)
     where
         (args,trail1) = break (=="--") args_raw
@@ -725,7 +693,9 @@ sync bExport bImport bSecret cmdarg args_raw = do
                                                        , spill = KF_Match usage
                                                        , typ = PEMFile
                                                        , access = Sec
-                                                       , initializer = cmd' })
+                                                       , initializer = cmd'
+                                                       , transforms = []
+                                                       } )
                         else if isNothing cmd'
                                 then ( ArgFile path
                                      , (buildStreamInfo KF_None PEMFile)
@@ -735,18 +705,10 @@ sync bExport bImport bSecret cmdarg args_raw = do
                                , (buildStreamInfo reftyp WalletFile) { access = Sec }))
                     wallets
         rings = map (\fname -> ( ArgFile fname
-                               , buildStreamInfo reftyp $ KeyRingFile passfd))
+                               , buildStreamInfo reftyp KeyRingFile ))
                     keyrings_
         hosts = maybe [] (map decorate) $ Map.lookup "--hosts" margs
                     where decorate fname = (ArgFile fname, buildStreamInfo reftyp Hosts)
-        importStyle = maybe (\_ _ -> subkeysOnly)
-                            (\f rt kd -> f rt kd >> importPublic)
-                        $ mplus import_f importifauth_f
-            where
-                import_f = do Map.lookup "--import" margs
-                              return $ \rt kd -> Just ()
-                importifauth_f = do Map.lookup "--import-if-authentic" margs
-                                    return guardAuthentic
         pubfill = maybe KF_Subkeys id
                         $ mplus import_f importifauth_f
             where
@@ -758,22 +720,25 @@ sync bExport bImport bSecret cmdarg args_raw = do
                                                , fill = rtyp
                                                , spill = KF_All
                                                , access = AutoAccess
-                                               , initializer = Nothing }
+                                               , initializer = Nothing
+                                               , transforms = [] }
         kikiOp = KeyRingOperation
-            { kFiles = Map.fromList $
+            { opFiles = Map.fromList $
                 [ ( HomeSec, buildStreamInfo (if bSecret && bImport then KF_All
                                                                     else KF_None)
-                                             (KeyRingFile passfd) )
+                                             KeyRingFile )
                 , ( HomePub, buildStreamInfo (if bImport then pubfill
                                                          else KF_None)
-                                             (KeyRingFile Nothing) )
+                                             KeyRingFile )
                 ]
                 ++ rings
                 ++ if bSecret then pems else []
                 ++ if bSecret then walts else []
                 ++ hosts
-            , kManip = maybe noManip (const doAutosign) $ Map.lookup "--autosign" margs
-            , homeSpec = homespec
+            , opPassphrases = do pfile <- maybeToList passfd
+                                 return $ PassphraseSpec Nothing Nothing pfile
+            , opTransforms = maybe [] (const [Autosign]) $ Map.lookup "--autosign" margs
+            , opHome = homespec
             }
 
     (\f -> maybe f (const $ kiki_usage bSecret cmdarg) $ Map.lookup "--help" margs) $ do
@@ -860,13 +825,14 @@ kiki "show" args = do
         hosts = []
         walts = []
         streaminfo = StreamInfo { fill = KF_None
-                                , typ = KeyRingFile passfd
+                                , typ = KeyRingFile
                                 , spill = KF_All
                                 , initializer = Nothing
                                 , access = AutoAccess
+                                , transforms = []
                                 }
         kikiOp = KeyRingOperation
-            { kFiles = Map.fromList $
+            { opFiles = Map.fromList $
                 [ ( HomeSec, streaminfo { access = Sec })
                 , ( HomePub, streaminfo { access = Pub })
                 ]
@@ -874,8 +840,10 @@ kiki "show" args = do
                 ++ pems 
                 ++ walts 
                 ++ hosts
-            , kManip = noManip 
-            , homeSpec = homespec
+            , opPassphrases = do pfile <- maybeToList passfd
+                                 return $ PassphraseSpec Nothing Nothing pfile
+            , opTransforms = []
+            , opHome = homespec
             }
 
     (\f -> maybe f (const $ kiki_usage False "show") $ Map.lookup "--help" margs) $ do
@@ -904,6 +872,158 @@ kiki "show" args = do
     forM_ report $ \(fname,act) -> do
         putStrLn $ fname ++ ": " ++ reportString act
 
+kiki "merge" [] = do
+    putStr . unlines $
+        [ "kiki merge [ --passphrase-fd=FD ... ]"
+        , "           ( --home[=HOMEDIR]"
+        , "           | --type=(keyring|pem|wallet|hosts)"
+        , "           | --access=[auto|secret|public]"
+        , "           | --flow=(fill|spill|sync)[,(subkeys|match=SPEC)]"
+        , "           | --create=CMD"
+        , "           | --autosign[=no]"
+        , "           | --"
+        , "           | FILE ) ..."]
+kiki "merge" args | "--help" `elem` args = do
+    kiki "merge" []
+    -- TODO: more help
+kiki "merge" args = do
+    KikiResult rt report <- runKeyRing op
+    case rt of
+      KikiSuccess rt -> return ()
+      err            -> putStrLn $ errorString err
+    forM_ report $ \(fname,act) -> do
+        putStrLn $ fname ++ ": " ++ reportString act
+ where
+    (_,(_,op)) = foldl' buildOp (True,(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
+
+    doFile :: StreamInfo -> KeyRingOperation -> FilePath -> (StreamInfo,KeyRingOperation)
+    doFile flow op fname =
+        ( flow
+        , op { opFiles= Map.insert (ArgFile fname) flow (opFiles op) })
+
+    doAutosign :: Bool -> StreamInfo -> KeyRingOperation -> (StreamInfo,KeyRingOperation)
+    doAutosign True flow op = 
+        if Map.null (opFiles op)
+            then (flow, op { opTransforms = opTransforms op ++ [Autosign] })
+            else (flow { transforms = transforms flow ++ [Autosign] }, op)
+    doAutosign False flow op =
+        ( flow { transforms = filter (/=Autosign) (transforms flow) }
+        , op { opTransforms = filter (/=Autosign) (opTransforms op) } )
+
+    doPassphrase :: StreamInfo -> KeyRingOperation -> String -> (StreamInfo,KeyRingOperation)
+    doPassphrase flow op pass =
+        if Map.null (opFiles op)
+            then ( flow
+                 , op { opPassphrases = PassphraseSpec Nothing Nothing pfd
+                                        : opPassphrases op } )
+            else error "passphrase-fd must come before any file arguments or --home"
+     where
+        pfd = FileDesc (read pass)
+
+    buildOp (False,(flow,op)) fname = (False,doFile flow op fname)
+    buildOp (True,(flow,op)) arg@(splitArg->parsed) =
+        case parsed of
+            Left ("",Nothing) -> (False,(flow,op))
+            _ -> (True,) dispatch
+     where
+      dispatch =
+        case parsed of
+            Right fname -> doFile flow op fname
+            Left ("autosign",Nothing)     -> doAutosign True  flow op
+            Left ("autosign",Just "y")    -> doAutosign True  flow op
+            Left ("autosign",Just "yes")  -> doAutosign True  flow op
+            Left ("autosign",Just "true") -> doAutosign True  flow op
+            Left ("autosign",Just "n")    -> doAutosign False flow op
+            Left ("autosign",Just "no")   -> doAutosign False flow op
+            Left ("autosign",Just "false")-> doAutosign False flow op
+            Left ("passphrase-fd",Just pass) -> doPassphrase flow op pass
+            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 { typ=KeyRingFile
+                                                         , access=Pub }
+                                 $ Map.insert HomeSec flow { typ=KeyRingFile
+                                                           , 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
+
+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" )
@@ -916,6 +1036,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