Implemented kTransforms

1 files changed, 146 insertions, 7 deletions

diff --git a/KeyRing.hs b/KeyRing.hs
index 2bde001..b1e23b4 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -55,6 +55,9 @@ module KeyRing
     , usageString
     , walletImportFormat
     , writePEM
+    , getBindings
+    , accBindings
+    , isSubkeySignature
     ) where
 
 import System.Environment
@@ -83,16 +86,18 @@ import Data.ASN1.BitArray ( BitArray(..), toBitArray )
 import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
 import Data.ASN1.BinaryEncoding ( DER(..) )
 import Data.Time.Clock.POSIX ( getPOSIXTime, POSIXTime )
+import Data.Bits ( Bits )
+import Data.Text.Encoding ( encodeUtf8 )
 import qualified Data.Map as Map
 import qualified Data.ByteString.Lazy as L ( unpack, pack, null, readFile, writeFile
-        , ByteString, toChunks, hGetContents, hPut, concat )
+        , ByteString, toChunks, hGetContents, hPut, concat, fromChunks )
 import qualified Data.ByteString      as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile)
 import qualified Crypto.Types.PubKey.ECC as ECC
 import qualified Codec.Binary.Base32 as Base32
 import qualified Codec.Binary.Base64 as Base64
 import qualified Crypto.Hash.SHA1 as SHA1
 import qualified Data.Text as T ( Text, unpack, pack,
-        strip, reverse, drop, break, dropAround )
+        strip, reverse, drop, break, dropAround, length )
 import qualified System.Posix.Types as Posix
 import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus
         , setFileCreationMask, setFileTimes )
@@ -199,7 +204,7 @@ data StreamInfo = StreamInfo
     , typ :: FileType
     , fill :: KeyFilter
     , spill :: KeyFilter -- ^ Currently respected for PEMFile and KeyRingFile.
-                         -- TODO: WalletFile and Hosts
+                         -- (TODO: WalletFile and Hosts)
                          -- Note that this is currently treated as a boolean
                          -- flag.  KF_None means the file is not spillable
                          -- and anything else means that it is.
@@ -262,14 +267,14 @@ data PassphraseSpec = PassphraseSpec
     }
 
 data Transform = Autosign
+ deriving (Eq,Ord)
 
 data KeyRingOperation = KeyRingOperation
     { kFiles :: Map.Map InputFile StreamInfo
     , kPassphrases :: [PassphraseSpec]
     , kTransform :: [Transform]
-    -- ^ TODO: this is currently ignored
     , kManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]--[KeyRingAddress PacketUpdate]
-    -- ^ TODO: this should be obsoleted by kTransform
+    -- ^ TODO: this is deprecated in favor of kTransform (remove it)
     , homeSpec :: Maybe String
     }
 
@@ -1725,10 +1730,11 @@ performManipulations ::
                 -> KeyRingOperation
                 -> KeyRingRuntime
                 -> Maybe MappedPacket
+                -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
                 -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)]))
-performManipulations doDecrypt operation rt wk = do
+performManipulations doDecrypt operation rt wk manip = do
     let db = rtKeyDB rt
-        performAll kd = foldM perform (KikiSuccess kd) $ kManip operation rt kd
+        performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd
     r <- Traversable.mapM performAll db
     try (sequenceA r) $ \db -> do
     return $ KikiSuccess (rt { rtKeyDB = db },[])
@@ -1849,6 +1855,138 @@ interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
 interpretManip kd manip = return kd
 -}
 
+combineTransforms :: KeyRingOperation -> KeyRingRuntime -> KeyData -> [PacketUpdate]
+combineTransforms operation rt kd = updates
+ where
+    updates = kManip operation rt kd
+                ++ concatMap (\t -> resolveTransform t rt kd) sanitized
+    sanitized = group (sort (kTransform operation)) >>= take 1
+
+isSubkeySignature (SubkeySignature {}) = True
+isSubkeySignature _                    = False
+
+-- Returned data is simmilar to getBindings but the Word8 codes
+-- are ORed together.
+accBindings ::
+  Bits t =>
+  [(t, (Packet, Packet), [a], [a1], [a2])]
+  -> [(t, (Packet, Packet), [a], [a1], [a2])]
+accBindings bs = as
+  where
+    gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
+    as = map (foldl1 combine) gs
+    bindingPair (_,p,_,_,_) = pub2 p
+      where
+        pub2 (a,b) = (pub a, pub b)
+        pub a = fingerprint_material a
+    samePair a b = bindingPair a == bindingPair b
+    combine (ac,p,akind,ahashed,aclaimaints)
+            (bc,_,bkind,bhashed,bclaimaints)
+        = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
+
+
+
+verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
+ where
+    verified = do
+        sig <- signatures (Message nonkeys)
+        let v = verify (Message keys) sig
+        guard (not . null $ signatures_over v)
+        return v
+    (top,othersigs) = partition isSubkeySignature verified
+    embedded = do
+        sub <- top
+        let sigover = signatures_over sub
+            unhashed = sigover >>= unhashed_subpackets
+            subsigs = mapMaybe backsig unhashed
+            -- This should consist only of 0x19 values
+            -- subtypes = map signature_type subsigs
+        -- trace ("subtypes = "++show subtypes) (return ())
+        -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
+        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
+        let v = verify (Message [subkey sub]) sig
+        guard (not . null $ signatures_over v)
+        return v
+
+smallpr k = drop 24 $ fingerprint k
+
+disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
+ where
+    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
+    samepr a b = smallpr a == smallpr b
+
+    {-
+    -- useful for testing
+    group2 :: [a] -> [[a]]
+    group2 (x:y:ys) = [x,y]:group2 ys
+    group2 [x]      = [[x]]
+    group2 []       = []
+    -}
+
+
+getBindings ::
+  [Packet]
+  ->
+    ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
+                                   --   that were used for the verifications
+    , [(Word8,
+       (Packet, Packet), -- (topkey,subkey)
+       [String],         -- usage flags
+       [SignatureSubpacket], -- hashed data
+       [Packet])] -- ^ binding signatures
+    )
+getBindings pkts = (sigs,bindings)
+ where
+    (sigs,concat->bindings) = unzip $ do
+        let (keys,_) = partition isKey pkts
+        keys <- disjoint_fp keys
+        let (bs,sigs) = verifyBindings keys pkts
+        return . ((keys,sigs),) $ do
+            b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
+            i <- map signature_issuer (signatures_over b)
+            i <- maybeToList i
+            who <- maybeToList $ find_key fingerprint (Message keys) i
+            let (code,claimants) =
+                    case () of
+                        _ | who == topkey b -> (1,[])
+                        _ | who == subkey b -> (2,[])
+                        _                   -> (0,[who])
+            let hashed = signatures_over b >>= hashed_subpackets
+                kind = guard (code==1) >> hashed >>= maybeToList . usage
+            return (code,(topkey b,subkey b), kind, hashed,claimants)
+
+resolveTransform Autosign 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')
+
+
 runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
 runKeyRing operation = do
     homedir <- getHomeDir (homeSpec operation)
@@ -1902,6 +2040,7 @@ runKeyRing operation = do
                                   operation
                                   rt
                                   wk
+                                  (combineTransforms operation)
         try' r $ \(rt,report_manips) -> do
 
         r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)