From 970665ceb98b969b040e9f5400705846d54f77ad Mon Sep 17 00:00:00 2001 From: joe Date: Fri, 2 May 2014 14:31:17 -0400 Subject: Implemented kTransforms --- KeyRing.hs | 153 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 146 insertions(+), 7 deletions(-) (limited to 'KeyRing.hs') 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) -- cgit v1.2.3