New command to rename subkeys.

1 files changed, 241 insertions, 14 deletions

diff --git a/lib/Transforms.hs b/lib/Transforms.hs
index 093d594..ba85b18 100644
--- a/lib/Transforms.hs
+++ b/lib/Transforms.hs
@@ -1,9 +1,13 @@
-{-# LANGUAGE CPP #-}
-{-# LANGUAGE TupleSections #-}
-{-# LANGUAGE ViewPatterns #-}
+{-# LANGUAGE CPP               #-}
+{-# LANGUAGE DoAndIfThenElse   #-}
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE PatternGuards     #-}
+{-# LANGUAGE TupleSections     #-}
+{-# LANGUAGE ViewPatterns      #-}
 module Transforms where
 
+import Control.Applicative
+import Control.Arrow
 import Control.Monad
 import Data.Char
 import Data.List
@@ -11,11 +15,12 @@ import Data.Maybe
 import Data.Ord
 import Data.OpenPGP
 import Data.OpenPGP.Util
-import Data.Word (Word8)
+import Data.Word
 import Types
 import FunctorToMaybe
 import GnuPGAgent ( key_nbits )
 import PacketTranscoder
+import TimeUtil
 import qualified Data.Traversable as Traversable
 import qualified Data.ByteString      as S
 import qualified Data.ByteString.Lazy as L
@@ -88,6 +93,7 @@ data KeyRingRuntime = KeyRingRuntime
 -- | Roster-entry level actions
 data PacketUpdate = InducerSignature String [SignatureSubpacket]
                   | SubKeyDeletion KeyKey KeyKey
+                  | SubKeyRenaming String String
 
 data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
 
@@ -166,6 +172,99 @@ data PGPKeyFlags =
 
 -- Functions
 
+splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
+splitAtMinBy comp xs = minimumBy comp' xxs
+ where
+    xxs = zip (inits xs) (tails xs)
+    comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
+    compM (Just a) (Just b) = comp a b
+    compM Nothing  mb       = GT
+    compM _        _        = LT
+
+
+-- | Get the time stamp of a signature.
+--
+-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
+-- the hashed section.  TODO: change this?
+--
+signature_time :: SignatureOver -> Word32
+signature_time ov = case (if null cs then ds else cs) of
+                                [] -> minBound
+                                xs -> maximum xs
+          where
+            ps = signatures_over ov
+            ss = filter isSignaturePacket ps
+            cs = concatMap (concatMap creationTime . hashed_subpackets) ss
+            ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
+            creationTime (SignatureCreationTimePacket t) = [t]
+            creationTime _                               = []
+
+
+-- | Given list of subpackets, a master key, one of its subkeys and a
+-- list of signatures on that subkey, yields:
+--
+--   * preceding list of signatures
+--
+--   * The most recent valid signature made by the master key along with a
+--   flag that indicates whether or not all of the supplied subpackets occur in
+--   it or, if no valid signature from the working key is present, Nothing.
+--
+--   * following list of signatures
+--
+findTag ::
+  [SignatureSubpacket]
+  -> Packet
+  -> Packet
+  -> [(MappedPacket, b)]
+  -> ([(MappedPacket, b)],
+      Maybe (Bool, (MappedPacket, b)),
+      [(MappedPacket, b)])
+findTag tag topk subkey subsigs = (xs',minsig,ys')
+         where
+            vs = map (\sig ->
+                          (sig, do
+                                sig <- Just (packet . fst $ sig)
+                                guard (isSignaturePacket sig)
+                                guard $ flip isSuffixOf
+                                             (fingerprint topk)
+                                        . fromMaybe "%bad%" 
+                                        . signature_issuer
+                                        $ sig
+                                listToMaybe $
+                                  map (signature_time . verify (Message [topk]))
+                                      (signatures $ Message [topk,subkey,sig])))
+                     subsigs
+            (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
+            xs' = map fst xs
+            ys' = map fst $ if isNothing minsig then ys else drop 1 ys
+            minsig = do
+                (sig,ov) <- listToMaybe ys
+                ov
+                let hshed = hashed_subpackets $ packet $ fst sig
+                return ( null $ tag \\ hshed, sig)
+
+mkUsage :: String -> SignatureSubpacket
+mkUsage tag | Just flags <- lookup tag specials
+  = KeyFlagsPacket
+        { certify_keys          = fromEnum flags .&. 0x1 /= 0
+        , sign_data             = fromEnum flags .&. 0x2 /= 0
+        , encrypt_communication = fromEnum flags .&. 0x4 /= 0
+        , encrypt_storage       = fromEnum flags .&. 0x8 /= 0
+        , split_key             = False
+        , authentication        = False
+        , group_key             = False
+        }
+ where
+    flagsets = [Special .. VouchSignEncrypt]
+    specials = map (\f -> (usageString f, f)) flagsets
+
+mkUsage tag = NotationDataPacket
+                { human_readable = True
+                , notation_name = "usage@"
+                , notation_value = tag
+                }
+
+
 unk :: Bool -> MappedPacket -> MappedPacket
 unk isPublic = if isPublic then toPacket secretToPublic else id
                 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
@@ -421,15 +520,14 @@ showPacket p | isKey p   = (if is_subkey p
              | otherwise           = showPacket0 p
  where
     sigusage p =
-        case take 1 (tagStrings p) of
-            []    -> ""
-            tag:_ -> " "++show tag -- "("++tag++")"
+        case (usage_tags,flags) of
+            ([],[]) -> ""
+            (_:_,_) -> " "++show usage_tags
+            (_,ts)  -> " "++show ts
      where
-        tagStrings p = usage_tags ++ flags
-         where
-            usage_tags = mapMaybe usage xs
-            flags = mapMaybe (fmap usageString . keyflags) xs
-            xs = hashed_subpackets p
+        usage_tags = mapMaybe usage xs
+        flags = mapMaybe (fmap usageString . keyflags) xs
+        xs = hashed_subpackets p
 
 
 showPacket0 p = dropSuffix "Packet" . concat . take 1 $ words (show p)
@@ -588,6 +686,99 @@ try x body =
            Left e -> return e
            Right x -> body x
 
+makeSig ::
+  PacketDecrypter
+  -> MappedPacket
+  -> FilePath
+  -> MappedPacket
+  -> [SignatureSubpacket]
+  -> Maybe (MappedPacket, Map.Map k a)
+  -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
+makeSig doDecrypt top fname subkey_p tags mbsig = do
+    let wk = packet top
+    wkun <- doDecrypt top
+    try wkun $ \wkun -> do
+    let grip = fingerprint wk
+        addOrigin new_sig =
+            flip (maybe $ return FailedToMakeSignature)
+                 (new_sig >>= listToMaybe . signatures_over)
+                 $ \new_sig -> do
+            let mp' = mappedPacket fname new_sig
+            return $ KikiSuccess (mp', Map.empty)
+        parsedkey = [packet subkey_p]
+        hashed0 | any isFlagsPacket tags = tags
+                | otherwise
+                  = KeyFlagsPacket
+                    { certify_keys = False
+                    , sign_data = False
+                    , encrypt_communication = False
+                    , encrypt_storage = False
+                    , split_key = False
+                    , authentication = True
+                    , group_key = False }
+                    : tags
+                    -- implicitly added:
+                    -- , SignatureCreationTimePacket (fromIntegral timestamp)
+        isFlagsPacket (KeyFlagsPacket {}) = True
+        isFlagsPacket _                   = False
+        subgrip = fingerprint (head parsedkey)
+
+    back_sig <- pgpSign (Message parsedkey)
+                        (SubkeySignature wk
+                                         (head parsedkey)
+                                         (sigpackets 0x19
+                                                     hashed0
+                                                     [IssuerPacket subgrip]))
+                        (if key_algorithm (head parsedkey)==ECDSA
+                            then SHA256
+                            else SHA1)
+                        subgrip
+    let iss = IssuerPacket (fingerprint wk)
+        cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
+        unhashed0 = maybe [iss] cons_iss back_sig
+
+    new_sig <- pgpSign (Message [wkun])
+                       (SubkeySignature wk
+                                        (head parsedkey)
+                                        (sigpackets 0x18
+                                                   hashed0
+                                                   unhashed0))
+                      SHA1
+                      grip
+    let newSig = do
+            r <- addOrigin new_sig
+            return $ fmap (,[]) r
+    flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
+    let sig = packet mp
+        isCreation (SignatureCreationTimePacket {}) = True
+        isCreation _ = False
+        isExpiration (SignatureExpirationTimePacket {}) = True
+        isExpiration _ = False
+        (cs,ps) = partition isCreation (hashed_subpackets sig)
+        (es,qs) = partition isExpiration ps
+        stamp = listToMaybe . sortBy (comparing Down) $
+                 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
+        exp = listToMaybe $ sort $
+                 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
+        expires = liftA2 (+) stamp exp
+    timestamp <- now
+    if fmap ( (< timestamp) . fromIntegral) expires == Just True then
+        return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
+    else do
+        let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
+                        $ maybeToList $ do
+                            e <- expires
+                            return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
+            sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
+        new_sig <- pgpSign (Message [wkun])
+                           (SubkeySignature wk
+                                            (packet subkey_p)
+                                            [sig'] )
+                           SHA1
+                           (fingerprint wk)
+        newsig <- addOrigin new_sig
+        return $ fmap (,[]) newsig
+
 
 
 
@@ -660,6 +851,40 @@ performManipulations doDecrypt rt wk manip = do
             rings = [HomeSec, HomePub] >>= resolveInputFile ctx
         return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
 
+    -- perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
+    perform kd (SubKeyRenaming srctag dsttag) = do
+        try kd $ \(kd,report) -> do
+        flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
+        subkeys' <- traverse (freshenOne wk') (keySubKeys kd)
+        let _ = subkeys' :: Map.Map KeyKey (KikiCondition (SubKey, KikiReport))
+            succeded (KikiSuccess a) = True
+            succeded _               = False
+            (good,bad) = Map.partition succeded subkeys'
+            uncondition (KikiSuccess a) = a
+            uncondition _               = error "unexpected error"
+            good' = fmap uncondition good
+        if not (Map.null bad)
+            then return $ fmap (error "bad cast") $ head (Map.elems bad)
+            else return $ KikiSuccess ( kd { keySubKeys = fmap fst good' }
+                                      , report ++ concatMap snd (Map.elems good'))
+     where
+        freshenOne :: MappedPacket -> SubKey -> IO (KikiCondition (SubKey,[(FilePath, KikiReportAction)]))
+        freshenOne wk subkey@(SubKey subkey_p subsigs) = do
+            let (xs',minsig,ys') = findTag [mkUsage srctag] (packet wk) (packet subkey_p) subsigs
+            case minsig of
+                Just (True,sig) -> do
+                    let fname = "--rename-subkey"
+                        not_deleted p = mkUsage srctag /= p
+                        mod sig = sig { hashed_subpackets = filter not_deleted $ hashed_subpackets sig }
+                        sig' = first (fmap mod) sig
+                    sigr <- makeSig doDecrypt wk fname subkey_p [mkUsage dsttag] (Just sig')
+                    try sigr $ \(sig',sigreport) -> do
+                    let old = packet (fst sig)
+                    report <- return $ fmap (fname,) sigreport ++ [(fname, DeletedPacket (showPacket old)),(fname, YieldSignature)]
+                    return $ KikiSuccess $ (SubKey subkey_p $ xs'++[sig']++ys', report)
+                _ -> return $ KikiSuccess (subkey, [])
+
+
 isBracket :: Char -> Bool
 isBracket '<' = True
 isBracket '>' = True
@@ -717,7 +942,7 @@ resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
                    gs = groupBy sameMaster (sortBy (comparing code) bindings')
 
 
--- (2 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+-- (2 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
 resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
  where
     topk = keykey $ packet k -- key to master of key to be deleted
@@ -726,7 +951,7 @@ resolveTransform (DeleteSubkeyByFingerprint fp) rt kd@(KeyData k ksigs umap subm
         guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
         return k
 
--- (3 of 3) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+-- (3 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
 resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
  where
     topk = keykey $ packet k -- key to master of key to be deleted
@@ -736,3 +961,5 @@ resolveTransform (DeleteSubkeyByUsage tag) rt kd@(KeyData k ksigs umap submap) =
         take 1 $ filter (has_tag tag) $ map (packet . fst) sigs
         return k
 
+-- (4 of 4) resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+resolveTransform (RenameSubkeys srctag dsttag) rt kd = [SubKeyRenaming srctag dsttag]