{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module KeyRing.BuildKeyDB where import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 import Control.Applicative (liftA2) import Control.Arrow (first, second) import Control.Exception (catch) import Control.Monad import ControlMaybe (handleIO_) import Data.ASN1.BinaryEncoding (DER (..)) import Data.ASN1.Encoding (decodeASN1, encodeASN1) import Data.ASN1.Types (fromASN1, toASN1) import Data.Binary import Data.Bits ((.&.), (.|.)) import Data.Bits (Bits) import qualified Data.ByteString as S (ByteString, breakSubstring, concat, drop, hGetContents, hPutStr, length, null, readFile, spanEnd, unpack) import Data.ByteString.Lazy (ByteString) import qualified Data.ByteString.Lazy as L (ByteString, concat, empty, fromChunks, hGetContents, null, readFile, toChunks) import Data.Char import Data.List import qualified Data.Map as Map import Data.Maybe import Data.Monoid import Data.OpenPGP import Data.OpenPGP.Util (GenerateKeyParams (..), decryptSecretKey, fingerprint, generateKey, pgpSign, verify) import Data.Ord import Data.Text.Encoding (encodeUtf8) import Data.Time.Clock (UTCTime) import Data.Time.Clock.POSIX (utcTimeToPOSIXSeconds) import System.Directory (doesFileExist) import System.IO.Error (isDoesNotExistError) import Text.Show.Pretty as PP (ppShow) #if !defined(VERSION_cryptonite) import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Types.PubKey.ECC as ECC #else import qualified Crypto.Hash as Vincent import qualified Crypto.PubKey.ECC.Types as ECC import Data.ByteArray (convert) #endif import qualified Codec.Compression.GZip as GZip import qualified Crypto.PubKey.RSA as RSA import qualified Data.Text as T (break, drop, dropAround, length, pack, reverse, strip, unpack) import qualified Data.X509 as X509 import System.Posix.Files (getFdStatus, getFileStatus, modificationTime) import qualified System.Posix.Types as Posix #if MIN_VERSION_x509(1,5,0) import Data.Hourglass #endif #if MIN_VERSION_unix(2,7,0) import Foreign.C.Types (CTime (..)) #else import Foreign.C.Error (throwErrnoIfMinus1_) import Foreign.C.Types (CInt (..), CLong, CTime (..)) import Foreign.Marshal.Array (withArray) import Foreign.Ptr import Foreign.Storable #endif import Data.IORef import Data.Traversable (sequenceA) import qualified Data.Traversable as Traversable import System.IO (stderr) import System.Posix.IO (fdToHandle) #if ! MIN_VERSION_base(4,6,0) import GHC.Exts (Down (..)) #endif #if MIN_VERSION_binary(0,7,0) #endif import Compat () import qualified Data.ByteString.Lazy.Char8 as Char8 import Network.Socket import Base58 import qualified CryptoCoins import FunctorToMaybe import qualified Hosts import PEM import ScanningParser import TimeUtil import KeyRing.Types -- | buildKeyDB -- -- merge all keyrings, PEM files, and wallets into process memory. -- buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiCondition (({- db -} KeyDB ,{- grip -} Maybe String ,{- wk -} Maybe MappedPacket ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], {- hostdbs -}[Hosts.Hosts], {- u1 -}Hosts.Hosts, {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], {- outgoing_names -}[SockAddr]) ,{- accs -} Map.Map InputFile Access ,{- doDecrypt -} MappedPacket -> IO (KikiCondition Packet) ,{- unspilled -} Map.Map InputFile Message ) ,{- report_imports -} [(FilePath,KikiReportAction)])) buildKeyDB ctx grip0 keyring = do let files istyp = do (f,stream) <- Map.toList (opFiles keyring) guard (istyp $ typ stream) resolveInputFile ctx f ringMap0 = Map.filter (isring . typ) $ opFiles keyring (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 where isgen (Generate _ _) _ = True isgen _ _ = False readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message) readp f stream = fmap readp0 $ readPacketsFromFile ctx f where readp0 ps = (stream { access = acc' }, ps) where acc' = case access stream of AutoAccess -> case ps of Message ((PublicKeyPacket {}):_) -> Pub Message ((SecretKeyPacket {}):_) -> Sec _ -> AutoAccess acc -> acc readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) -- KeyRings (todo: KikiCondition reporting?) (spilled,mwk,grip,accs,keys,unspilled) <- do #if MIN_VERSION_containers(0,5,0) ringPackets <- Map.traverseWithKey readp ringMap #else ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap #endif let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) let grip = grip0 `mplus` (fingerprint <$> fstkey) where fstkey = do (_,Message ps) <- Map.lookup HomeSec ringPackets listToMaybe ps -- | spilled -- ring packets with info available for export -- | unspilled -- the rest (spilled,unspilled) = Map.partition (spillable . fst) ringPackets -- | keys -- process ringPackets, and get a map of fingerprint info to -- to a packet, remembering it's original file, access. keys :: Map.Map KeyKey MappedPacket keys = Map.foldl slurpkeys Map.empty $ Map.mapWithKey filterSecrets ringPackets where filterSecrets f (_,Message ps) = filter (isSecretKey . packet) $ zipWith (mappedPacketWithHint fname) ps [1..] where fname = resolveForReport (Just ctx) f slurpkeys m ps = m `Map.union` Map.fromList ps' where ps' = zip (map (keykey . packet) ps) ps -- | mwk -- first master key matching the provided grip -- (the m is for "MappedPacket", wk for working key) mwk :: Maybe MappedPacket mwk = listToMaybe $ do fp <- maybeToList grip let matchfp mp = not (is_subkey p) && matchpr fp p == fp where p = packet mp Map.elems $ Map.filter matchfp keys -- | accs -- file access(Sec | Pub) lookup table accs :: Map.Map InputFile Access accs = fmap (access . fst) ringPackets return (spilled,mwk,grip,accs,keys,fmap snd unspilled) doDecrypt <- makeMemoizingDecrypter keyring ctx keys let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty , rtPassphrases = doDecrypt } -- autosigns and deletes transformed0 <- do let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) trans f (info,ps) = do let manip = combineTransforms (transforms info) rt1 = rt0 { rtKeyDB = merge Map.empty f ps } acc = Just Sec /= Map.lookup f accs r <- performManipulations doDecrypt rt1 mwk manip try r $ \(rt2,report) -> do return $ KikiSuccess (report,rtKeyDB rt2) #if MIN_VERSION_containers(0,5,0) fmap sequenceA $ Map.traverseWithKey trans spilled #else fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled #endif try transformed0 $ \transformed -> do let -- | db_rings - all keyrings combined into one db_rings :: Map.Map KeyKey KeyData db_rings = Map.foldlWithKey' mergeIt Map.empty transformed where mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans -- | reportTrans -- events, indexed by file reportTrans :: [(FilePath, KikiReportAction)] reportTrans = concat $ Map.elems $ fmap fst transformed -- Wallets let importWalletKey wk db' (top,fname,sub,tag) = do try db' $ \(db',report0) -> do r <- doImportG doDecrypt db' (fmap keykey $ maybeToList wk) [mkUsage tag] fname sub try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) wms <- mapM (readw wk) (files iswallet) let wallet_keys = do maybeToList wk (fname,xs) <- wms (_,sub,(_,m)) <- xs (tag,top) <- Map.toList m return (top,fname,sub,tag) db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys try db $ \(db,reportWallets) -> do -- PEM files let pems = do (n,stream) <- Map.toList $ opFiles keyring grip <- maybeToList grip n <- resolveInputFile ctx n guard $ spillable stream && isSecretKeyFile (typ stream) let us = mapMaybe usageFromFilter [fill stream,spill stream] usage <- take 1 us guard $ all (==usage) $ drop 1 us -- TODO: KikiCondition reporting for spill/fill usage mismatch? -- TODO: parseSpec3 let (topspec,subspec) = parseSpec grip usage ms = map fst $ filterMatches topspec (Map.toList db) cmd = initializer stream return (n,subspec,ms,stream, cmd) imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do -- generate keys let gens = mapMaybe g $ Map.toList genMap where g (Generate _ params,v) = Just (params,v) g _ = Nothing db <- generateInternals doDecrypt mwk db gens try db $ \(db,reportGens) -> do r <- mergeHostFiles keyring db ctx try r $ \((db,hs),reportHosts) -> do return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) resolveInputFile :: InputFileContext -> InputFile -> [FilePath] resolveInputFile ctx = resolve where resolve HomeSec = return (homesecPath ctx) resolve HomePub = return (homepubPath ctx) resolve (ArgFile f) = return f resolve _ = [] isring :: FileType -> Bool isring (KeyRingFile {}) = True isring _ = False readPacketsFromFile :: InputFileContext -> InputFile -> IO Message readPacketsFromFile ctx fname = do -- warn $ fname ++ ": reading..." input <- readInputFileL ctx fname #if MIN_VERSION_binary(0,7,0) return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> -- FIXME -- trace (fname++": read fail") $ Message [] #else return $ decode input #endif readPacketsFromWallet :: Maybe Packet -> InputFile -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] readPacketsFromWallet wk fname = do let ctx = InputFileContext "" "" timestamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let (ks,_) = slurpWIPKeys timestamp input unless (null ks) $ do -- decrypt wk -- create sigs -- return key/sig pairs return () return $ do wk <- maybeToList wk guard (not $ null ks) let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk)) where tag = CryptoCoins.nameFromSecretByte tagbyte (wk,MarkerPacket,(MarkerPacket,Map.empty)) :map prep ks spillable :: StreamInfo -> Bool spillable (spill -> KF_None) = False spillable _ = True isSecretKey :: Packet -> Bool isSecretKey (SecretKeyPacket {}) = True isSecretKey _ = False mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket mappedPacketWithHint filename p hint = MappedPacket { packet = p , locations = Map.singleton filename (origin p hint) } resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) where str = case (fdr,fdw) of (0,1) -> "-" _ -> "&pipe" ++ show (fdr,fdw) resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) where str = "&" ++ show fd resolveForReport mctx f = concat $ resolveInputFile ctx f where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx keykey :: Packet -> KeyKey keykey key = -- Note: The key's timestamp is normally included in it's fingerprint. -- This is undesirable for kiki because it causes the same -- key to be imported multiple times and show as apparently -- distinct keys with different fingerprints. -- Thus, we will remove the timestamp. fingerprint_material (key {timestamp=0}) -- TODO: smaller key? -- matchpr computes the fingerprint of the given key truncated to -- be the same lenght as the given fingerprint for comparison. -- -- matchpr fp = Data.List.Extra.takeEnd (length fp) -- matchpr :: String -> Packet -> String matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext -> Map.Map KeyKey MappedPacket -> IO (MappedPacket -> IO (KikiCondition Packet)) makeMemoizingDecrypter operation ctx keys = if null chains then do -- (*) Notice we do not pass ctx to resolveForReport. -- This is because the merge function does not currently use a context -- and the pws map keys must match the MappedPacket locations. -- TODO: Perhaps these should both be of type InputFile rather than -- FilePath? -- pws :: Map.Map FilePath (IO S.ByteString) {- pws <- Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above $ Map.filter (isJust . pwfile . typ) $ opFiles operation) -} let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" pws2 <- Traversable.mapM (cachedContents prompt ctx) $ Map.fromList $ mapMaybe (\spec -> (,passSpecPassFile spec) `fmap` do guard $ isNothing $ passSpecKeySpec spec passSpecRingFile spec) passspecs defpw <- do Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) && isNothing (passSpecKeySpec sp)) $ opPassphrases operation unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw else let PassphraseMemoizer f = head chains in return f where (chains,passspecs) = partition isChain $ opPassphrases operation where isChain (PassphraseMemoizer {}) = True isChain _ = False doDecrypt :: IORef (Map.Map KeyKey Packet) -> Map.Map FilePath (IO S.ByteString) -> Maybe (IO S.ByteString) -> MappedPacket -> IO (KikiCondition Packet) doDecrypt unkeysRef pws defpw mp0 = do unkeys <- readIORef unkeysRef let mp = fromMaybe mp0 $ do k <- Map.lookup kk keys return $ mergeKeyPacket "decrypt" mp0 k wk = packet mp0 kk = keykey wk fs = Map.keys $ locations mp decryptIt [] = return BadPassphrase decryptIt (getpw:getpws) = do -- TODO: This function should use mergeKeyPacket to -- combine the packet with it's unspilled version before -- attempting to decrypt it. pw <- getpw let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) return $ KikiSuccess wkun _ -> decryptIt getpws getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw case symmetric_algorithm wk of Unencrypted -> return (KikiSuccess wk) _ -> maybe (decryptIt getpws) (return . KikiSuccess) $ Map.lookup kk unkeys -- | combineTransforms -- remove rundant transforms, and compile the rest to PacketUpdate(s) -- -- eqivalent to: -- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt kd combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate] combineTransforms trans rt kd = updates where updates = -- kManip operation rt kd ++ concatMap (\t -> resolveTransform t rt kd) sanitized sanitized = group (sort trans) >>= take 1 merge :: KeyDB -> InputFile -> Message -> KeyDB merge db inputfile (Message ps) = merge_ db filename qs where filename = resolveForReport Nothing inputfile qs = scanPackets filename ps scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] scanPackets filename [] = [] scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps where ret p = (p,Map.empty) doit (top,sub,prev) p = case p of _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p) _ | isKey p && is_subkey p -> (top,p,ret p) _ | isUserID p -> (top,p,ret p) _ | isTrust p -> (top,sub,updateTrust top sub prev p) _ -> (top,sub,ret p) updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret performManipulations :: (MappedPacket -> IO (KikiCondition Packet)) -> KeyRingRuntime -> Maybe MappedPacket -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) -> IO (KikiCondition (KeyRingRuntime,KikiReport)) performManipulations doDecrypt rt wk manip = do let db = rtKeyDB rt performAll kd = foldM perform (KikiSuccess (kd, [])) $ manip rt kd r <- Traversable.mapM performAll db try (sequenceA r) $ \db -> do return $ KikiSuccess (rt {rtKeyDB = fmap fst db}, concatMap snd $ Map.elems db) where perform :: KikiCondition (KeyData, KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData, KikiReport)) perform kd (InducerSignature uid subpaks) = do try kd $ \(kd, report) -> do flip (maybe $ return NoWorkingKey) wk $ \wk' -> do wkun' <- doDecrypt wk' try wkun' $ \wkun -> do let flgs = if keykey (keyPacket kd) == keykey wkun then keyFlags0 (keyPacket kd) (map (\(x, _, _) -> x) selfsigs) else [] sigOver = makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $ flgs ++ subpaks om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid toMappedPacket om p = (mappedPacket "" p) {locations = om} selfsigs = filter (\(sig, v, whosign) -> isJust (v >> Just wkun >>= guard . (== keykey whosign) . keykey)) vs keys = map keyPacket $ Map.elems (rtKeyDB rt) overs sig = signatures $ Message (keys ++ [keyPacket kd, UserIDPacket uid, sig]) vs :: [(Packet -- signature , Maybe SignatureOver -- Nothing means non-verified , Packet -- key who signed )] vs = do x <- maybeToList $ Map.lookup uid (keyUids kd) sig <- map (packet . fst) (fst x) o <- overs sig k <- keys let ov = verify (Message [k]) $ o signatures_over ov return (sig, Just ov, k) additional new_sig = do new_sig <- maybeToList new_sig guard (null $ selfsigs) signatures_over new_sig sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) let f :: ([SigAndTrust], OriginMap) -> ([SigAndTrust], OriginMap) f x = ( map ((, Map.empty) . toMappedPacket om) (additional sigr) ++ fst x , om `Map.union` snd x) -- XXX: Shouldn't this signature generation show up in the KikiReport ? return $ KikiSuccess $ (kd {keyUids = Map.adjust f uid (keyUids kd)}, report) perform kd (SubKeyDeletion topk subk) = do try kd $ \(kd, report) -> do let kk = keykey $ packet $ keyMappedPacket kd kd' | kk /= topk = kd | otherwise = kd {keySubKeys = Map.filterWithKey pred $ keySubKeys kd} pred k _ = k /= subk ps = concat $ maybeToList $ do SubKey mp sigs <- Map.lookup subk (keySubKeys kd) return $ packet mp : concatMap (\(p, ts) -> packet p : Map.elems ts) sigs ctx = InputFileContext (rtSecring rt) (rtPubring rt) rings = [HomeSec, HomePub] >>= resolveInputFile ctx return $ KikiSuccess ( kd' , report ++ [(f, DeletedPacket $ showPacket p) | f <- rings, p <- ps]) try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b) try x body = case functorToEither x of Left e -> return e Right x -> body x mergeKeyData :: KeyData -> KeyData -> KeyData mergeKeyData (KeyData atop asigs auids asubs) (KeyData btop bsigs buids bsubs) = KeyData top sigs uids subs where mergeMapped a b = MappedPacket { packet = packet a , locations = Map.union (locations a) (locations b) } top = mergeMapped atop btop sigs = foldl' (flip mergeSig) asigs bsigs uids = Map.unionWith mergeUIDSigs auids buids subs = Map.unionWith mergeSub asubs bsubs mergeSub :: SubKey -> SubKey -> SubKey mergeSub (SubKey a as) (SubKey b bs) = SubKey (mergeMapped a b) (foldl' (flip mergeSig) as bs) mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) doImportG :: (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags -> FilePath -> Packet -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) doImportG doDecrypt db m0 tags fname key = do let kk = head m0 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db kdr <- insertSubkey doDecrypt kk kd tags fname key try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 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 } iswallet :: FileType -> Bool iswallet (WalletFile {}) = True iswallet _ = False isSecretKeyFile :: FileType -> Bool isSecretKeyFile PEMFile = True isSecretKeyFile DNSPresentation = True isSecretKeyFile _ = False usageFromFilter :: MonadPlus m => KeyFilter -> m String usageFromFilter (KF_Match usage) = return usage usageFromFilter _ = mzero -- | Parse a key specification. -- The first argument is a grip for the default working key. parseSpec :: String -> String -> (KeySpec,Maybe String) parseSpec wkgrip spec = if not slashed then case prespec of AnyMatch -> (KeyGrip "", Nothing) EmptyMatch -> error "Bad key spec." WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) FingerprintMatch fp -> (KeyGrip fp, Nothing) else case (prespec,postspec) of (FingerprintMatch fp, SubstringMatch st t) | st /= Just UserIDField -> (KeyGrip fp, Just t) (SubstringMatch mt u, _) | postspec `elem` [AnyMatch,EmptyMatch] && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) (SubstringMatch mt u, SubstringMatch st t) | mt /= Just KeyTypeField && st /= Just UserIDField -> (KeyUidMatch u, Just t) (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" (_,FingerprintMatch fp) -> error "todo: support /fp: spec" (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" _ -> error "Bad key spec." where (preslash,slashon) = break (=='/') spec slashed = not $ null $ take 1 slashon postslash = drop 1 slashon prespec = parseSingleSpec preslash postspec = parseSingleSpec postslash {- - BUGGY parseSpec grip spec = (topspec,subspec) where (topspec0,subspec0) = unprefix '/' spec (toptyp,top) = unprefix ':' topspec0 (subtyp,sub) = unprefix ':' subspec0 topspec = case () of _ | null top && or [ subtyp=="fp" , null subtyp && is40digitHex sub ] -> KeyGrip sub _ | null top && null grip -> KeyUidMatch sub _ | null top -> KeyGrip grip _ | toptyp=="fp" || (null toptyp && is40digitHex top) -> KeyGrip top _ | toptyp=="u" -> KeyUidMatch top _ -> KeyUidMatch top subspec = case subtyp of "t" -> Just sub "fp" | top=="" -> Nothing "" | top=="" && is40digitHex sub -> Nothing "" -> listToMaybe sub >> Just sub _ -> Nothing is40digitHex xs = ys == xs && length ys==40 where ys = filter ishex xs ishex c | '0' <= c && c <= '9' = True | 'A' <= c && c <= 'F' = True | 'a' <= c && c <= 'f' = True ishex c = False -- | Split a string into two at the first occurance of the given -- delimiter. If the delimeter does not occur, then the first -- item of the returned pair is empty and the second item is the -- input string. unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) where p = break (==c) spec -} filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec . snd) ks importSecretKey :: (MappedPacket -> IO (KikiCondition Packet)) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) importSecretKey doDecrypt db' tup = do try db' $ \(db',report0) -> do r <- doImport doDecrypt db' tup try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) generateInternals :: (MappedPacket -> IO (KikiCondition Packet)) -> Maybe MappedPacket -> Map.Map KeyKey KeyData -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) generateInternals doDecrypt mwk db gens = do case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of Just kd0 -> do kd <- foldM (generateSubkey doDecrypt) (KikiSuccess (kd0,[])) gens try kd $ \(kd,reportGens) -> do let kk = keykey $ packet $ fromJust mwk return $ KikiSuccess (Map.insert kk kd db,reportGens) Nothing -> return $ KikiSuccess (db,[]) mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext -> IO (KikiCondition ( ( Map.Map [Char8.ByteString] KeyData , ( [Hosts.Hosts] , [Hosts.Hosts] , Hosts.Hosts , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] , [SockAddr])) , [(FilePath,KikiReportAction)])) mergeHostFiles krd db ctx = do let hns = files ishosts ishosts Hosts = True ishosts _ = False files istyp = do (f,stream) <- Map.toList (opFiles krd) guard (istyp $ typ stream) return f readInputFileL' ctx f = readInputFileL ctx f `catch` \e -> do when (not $ isDoesNotExistError e) $ do return () -- todo report problem return L.empty hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL' ctx) hns let gpgnames = map getHostnames $ Map.elems db os = do (addr,(ns,_)) <- gpgnames n <- ns return (addr,n) setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os -- we ensure .onion names are set properly hostdbs = map setOnions hostdbs0 outgoing_names = do (addr,(_,gns)) <- gpgnames guard . not $ null gns guard $ all (null . Hosts.namesForAddress addr) hostdbs0 return addr -- putStrLn $ "hostdbs = " ++ show hostdbs -- 1. let U = union all the host dbs -- preserving whitespace and comments of the first let u0 = foldl' Hosts.plus Hosts.empty hostdbs -- we filter U to be only finger-dresses u1 = Hosts.filterAddrs (hasFingerDress db) u0 -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h {- putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}" putStrLn $ "--> " ++ show (nf (head hostdbs)) putStrLn $ "u0 = {\n" ++ show u0 ++ "}" putStrLn $ "--> " ++ show (nf u0) putStrLn $ "u1 = {\n" ++ show u1 ++ "}" putStrLn $ "--> " ++ show (nf u1) -} -- 2. replace gpg annotations with those in U -- forM use_db db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents readInputFileL ctx inp = do let fname = resolveInputFile ctx inp fmap L.concat $ mapM L.readFile fname getInputFileTime :: InputFileContext -> InputFile -> IO CTime getInputFileTime ctx (Pipe fdr fdw) = do mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr maybe tryw return mt where tryw = do handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?") $ modificationTime <$> getFdStatus fdw getInputFileTime ctx (FileDesc fd) = do handleIO_ (error $ "&"++show fd++": modificaiton time?") $ modificationTime <$> getFdStatus fd getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) slurpWIPKeys stamp "" = ([],[]) slurpWIPKeys stamp cs = let (b58,xs) = Char8.span (`elem` base58chars) cs mb = decode_btc_key stamp (Char8.unpack b58) in if L.null b58 then let (ys,xs') = Char8.break (`elem` base58chars) cs (ks,js) = slurpWIPKeys stamp xs' in (ks,ys:js) else let (ks,js) = slurpWIPKeys stamp xs in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb origin :: Packet -> Int -> OriginFlags origin p n = OriginFlags ispub n where ispub = case p of SecretKeyPacket {} -> False _ -> True cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) cachedContents maybePrompt ctx fd = do ref <- newIORef Nothing return $ get maybePrompt ref fd where trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs get maybePrompt ref fd = do pw <- readIORef ref flip (flip maybe return) pw $ do if fd == FileDesc 0 then case maybePrompt of Just prompt -> S.hPutStr stderr prompt Nothing -> return () else return () pw <- fmap trimCR $ readInputFileS ctx fd writeIORef ref (Just pw) return pw mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket mergeKeyPacket what key p = key { packet = minimumBy (keyCompare what) [packet key,packet p] , locations = Map.union (locations key) (locations p) } -- | resolveTransform resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] 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') -- (2 of 3) 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 subk = do (k,sub) <- Map.toList submap guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) return k -- (3 of 3) 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 subk = do (k,SubKey p sigs) <- Map.toList submap take 1 $ filter (has_tag tag) $ map (packet . fst) sigs return k merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) where -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db where update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty update (Just kd) = dbInsertPacket kd filename adding mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p whatP (a,_) = concat . take 1 . words . show $ a isKey :: Packet -> Bool isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isUserID :: Packet -> Bool isUserID (UserIDPacket {}) = True isUserID _ = False isTrust :: Packet -> Bool isTrust (TrustPacket {}) = True isTrust _ = False keyPacket :: KeyData -> Packet keyPacket (KeyData k _ _ _) = packet k keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] keyFlags0 wkun uidsigs = concat [ keyflags , preferredsym , preferredhash , preferredcomp , features ] where subs = concatMap hashed_subpackets uidsigs keyflags = filterOr isflags subs $ KeyFlagsPacket { certify_keys = True , sign_data = True , encrypt_communication = False , encrypt_storage = False , split_key = False , authentication = False , group_key = False } preferredsym = filterOr ispreferedsym subs $ PreferredSymmetricAlgorithmsPacket [ AES256 , AES192 , AES128 , CAST5 , TripleDES ] preferredhash = filterOr ispreferedhash subs $ PreferredHashAlgorithmsPacket [ SHA256 , SHA1 , SHA384 , SHA512 , SHA224 ] preferredcomp = filterOr ispreferedcomp subs $ PreferredCompressionAlgorithmsPacket [ ZLIB , BZip2 , ZIP ] features = filterOr isfeatures subs $ FeaturesPacket { supports_mdc = True } filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs isflags (KeyFlagsPacket {}) = True isflags _ = False ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True ispreferedsym _ = False ispreferedhash (PreferredHashAlgorithmsPacket {}) = True ispreferedhash _ = False ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True ispreferedcomp _ = False isfeatures (FeaturesPacket {}) = True isfeatures _ = False makeInducerSig :: Packet -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver -- torsig g topk wkun uid timestamp extras = todo makeInducerSig topk wkun uid extras = CertificationSignature (secretToPublic topk) uid (sigpackets 0x13 subpackets subpackets_unh) where subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ] tsign ++ extras subpackets_unh = [IssuerPacket (fingerprint wkun)] tsign = if keykey wkun == keykey topk then [] -- tsign doesnt make sense for self-signatures else [ TrustSignaturePacket 1 120 , RegularExpressionPacket regex] -- <[^>]+[@.]asdf\.nowhere>$ regex = "<[^>]+[@.]"++hostname++">$" -- regex = username ++ "@" ++ hostname -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String hostname = subdomain' pu ++ "\\." ++ topdomain' pu pu = parseUID uidstr where UserIDPacket uidstr = uid subdomain' = escape . T.unpack . uid_subdomain topdomain' = escape . T.unpack . uid_topdomain escape s = concatMap echar s where echar '|' = "\\|" echar '*' = "\\*" echar '+' = "\\+" echar '?' = "\\?" echar '.' = "\\." echar '^' = "\\^" echar '$' = "\\$" echar '\\' = "\\\\" echar '[' = "\\[" echar ']' = "\\]" echar c = [c] insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)])) insertSubkey doDecrypt kk (KeyData top topsigs uids subs) tags fname key = do let subkk = keykey key (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key) []) ( (False,) . addOrigin ) (Map.lookup subkk subs) where addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) (locations mp) } in SubKey mp' sigs subs' = Map.insert subkk subkey subs istor = do guard ("tor" `elem` mapMaybe usage tags) return $ "Anonymous " uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do let has_torid = do -- TODO: check for omitted real name field (sigtrusts,om) <- Map.lookup idstr uids listToMaybe $ do s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) signatures_over $ verify (Message [packet top]) s flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do wkun <- doDecrypt top try wkun $ \wkun -> do let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) uid = UserIDPacket idstr -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags tor_ov = makeInducerSig (packet top) wkun uid keyflags sig_ov <- pgpSign (Message [wkun]) tor_ov SHA1 (fingerprint wkun) flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) (sig_ov >>= listToMaybe . signatures_over) $ \sig -> do let om = Map.singleton fname (origin sig (-1)) trust = Map.empty return $ KikiSuccess ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} , trust)],om) uids , [] ) try uids' $ \(uids',report) -> do let SubKey subkey_p subsigs = subkey wk = packet top (xs',minsig,ys') = findTag tags wk key subsigs doInsert mbsig = do -- NEW SUBKEY BINDING SIGNATURE sig' <- makeSig doDecrypt top fname subkey_p tags mbsig try sig' $ \(sig',report) -> do report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] let subs' = Map.insert subkk (SubKey subkey_p $ xs'++[sig']++ys') subs return $ KikiSuccess ( KeyData top topsigs uids' subs' , report ) report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) else id s = show (fmap fst minsig,fingerprint key) in return (f report) case minsig of Nothing -> doInsert Nothing -- we need to create a new sig Just (True,sig) -> -- we can deduce is_new == False -- we may need to add a tor id return $ KikiSuccess ( KeyData top topsigs uids' subs' , report ) Just (False,sig) -> doInsert (Just sig) -- We have a sig, but is missing usage@ tag mappedPacket :: FilePath -> Packet -> MappedPacket mappedPacket filename p = MappedPacket { packet = p , locations = Map.singleton filename (origin p (-1)) } showPacket :: Packet -> String showPacket p | isKey p = (if is_subkey p then showPacket0 p else ifSecret p "----Secret-----" "----Public-----") ++ " "++show (key_algorithm p)++" "++fingerprint p | isUserID p = showPacket0 p ++ " " ++ show (uidkey p) | otherwise = showPacket0 p showPacket0 :: Show a => a -> [Char] showPacket0 p = concat . take 1 $ words (show p) mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] mergeSig sig sigs = let (xs,ys) = break (isSameSig (first packet sig)) sigs in if null ys then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig] else let y:ys'=ys in xs ++ (mergeSameSig sig y : ys') where isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } isSameSig (a,_) (MappedPacket {packet=b},_) = a==b mergeSameSig :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket (packet a) && isSignaturePacket b = ( m { packet = b { unhashed_subpackets = union (unhashed_subpackets b) (unhashed_subpackets $ packet a) } , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs } -- TODO: when merging items, we should delete invalidated origins -- from the orgin map. , tb `Map.union` ta ) mergeSameSig a b = b -- trace ("discarding dup "++show a) b usageString :: PGPKeyFlags -> String usageString flgs = case flgs of Special -> "special" Vouch -> "vouch" -- signkey Sign -> "sign" VouchSign -> "vouch-sign" Communication -> "communication" VouchCommunication -> "vouch-communication" SignCommunication -> "sign-communication" VouchSignCommunication -> "vouch-sign-communication" Storage -> "storage" VouchStorage -> "vouch-storage" SignStorage -> "sign-storage" VouchSignStorage -> "vouch-sign-storage" Encrypt -> "encrypt" VouchEncrypt -> "vouch-encrypt" SignEncrypt -> "sign-encrypt" VouchSignEncrypt -> "vouch-sign-encrypt" parseSingleSpec :: String -> SingleKeySpec parseSingleSpec "*" = AnyMatch parseSingleSpec "-" = WorkingKeyMatch parseSingleSpec "" = EmptyMatch parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag parseSingleSpec ('c':':':tag) = SubstringMatch (Just GroupIDField) tag parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp parseSingleSpec str | is40digitHex str = FingerprintMatch str | otherwise = SubstringMatch Nothing str is40digitHex :: [Char] -> Bool is40digitHex xs = ys == xs && length ys==40 where ys = filter ishex xs ishex c | '0' <= c && c <= '9' = True | 'A' <= c && c <= 'F' = True | 'a' <= c && c <= 'f' = True ishex c = False matchSpec :: KeySpec -> KeyData -> Bool matchSpec (KeyGrip grip) (KeyData p _ _ _) | matchpr grip (packet p)==grip = True | otherwise = False matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps where ps = map (packet .fst) sigs match p = isSignaturePacket p && has_tag tag p && has_issuer key p has_issuer key p = isJust $ do issuer <- signature_issuer p guard $ matchpr issuer key == issuer has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us where us = filter (isInfixOf pat) $ Map.keys uids doImport :: (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map KeyKey KeyData -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do (certs,keys) <- case typ of PEMFile -> do ps <- readSecretPEMFile (ArgFile fname) let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) = partition (isJust . spemCert) ps return (certs,keys) DNSPresentation -> do p <- readSecretDNSFile (ArgFile fname) return ([],[p]) -- TODO Probably we need to move to a new design where signature -- packets are merged into the database in one phase with null -- signatures, and then the signatures are made in the next phase. -- This would let us merge annotations (like certificates) from -- seperate files. foldM (importKey tag certs) (KikiSuccess (db,[])) keys where importKey tag certs prior key = do try prior $ \(db,report) -> do let (m0,tailms) = splitAt 1 ms if (not (null tailms) || null m0) then return $ AmbiguousKeySpec fname else do let kk = keykey key cs = filter (\c -> kk==keykey (pcertKey c)) certs blobs = map mkCertNotation $ nub $ map pcertBlob cs mkCertNotation bs = NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = Char8.unpack bs } datedKey = key { timestamp = fromTime $ minimum dates } dates = fromTime (timestamp key) : map pcertTimestamp certs r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey try r $ \(db',report') -> do return $ KikiSuccess (db',report++report') generateSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -- decrypt[ -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db -> (GenerateKeyParams, StreamInfo) -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) generateSubkey doDecrypt kd' (genparam,StreamInfo { spill = KF_Match tag }) = do try kd' $ \(kd,report0) -> do let subs = do SubKey p sigs <- Map.elems $ keySubKeys kd filter (has_tag tag) $ map (packet . fst) sigs if null subs then do newkey <- generateKey genparam kdr <- insertSubkey doDecrypt (keykey (keyPacket kd)) kd [mkUsage tag] "" newkey try kdr $ \(newkd,report) -> do return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) else do return $ KikiSuccess (kd,report0) generateSubkey _ kd _ = return kd -- | -- Returns (ip6 fingerprint address,(onion names,other host names)) -- -- Requires a validly cross-signed tor key for each onion name returned. -- (Signature checks are performed.) getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) where othernames = do mp <- flattenAllUids "" True uids let p = packet mp guard $ isSignaturePacket p uh <- unhashed_subpackets p case uh of NotationDataPacket True "hostname@" v -> return $ Char8.pack v _ -> mzero addr = fingerdress topk topk = packet topmp torkeys = getSubkeys CrossSigned topk subs "tor" -- subkeyPacket (SubKey k _ ) = k onames :: [L.ByteString] onames = map ( (<> ".onion") . Char8.pack . take 16 . torhash ) torkeys hasFingerDress :: KeyDB -> SockAddr -> Bool hasFingerDress db addr | socketFamily addr/=AF_INET6 = False hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) where (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr g' = map toUpper g -- We return into IO in case we want to make a signature here. setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = -- TODO: we are removing the origin from the UID OriginMap, -- when we should be removing origins from the locations -- field of the sig's MappedPacket records. -- Call getHostnames and compare to see if no-op. if not (pred addr) || gotNonOnions == namesWithoutGotOnions then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) , " file: "++show (map Char8.unpack names) , " pred: "++show (pred addr)]) -} (return kd) else do -- We should be sure to remove origins so that the data is written -- (but only if something changed). -- Filter all hostnames present in uids -- Write notations into first uid {- trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0) , " file: "++show (map Char8.unpack names) ]) $ do -} return $ KeyData topmp topsigs uids1 subs where topk = packet topmp addr = fingerdress topk names :: [Char8.ByteString] names = Hosts.namesForAddress addr hosts (_, (gotOnions, gotNonOnions)) = getHostnames kd namesWithoutGotOnions = names \\ gotOnions notations = map (NotationDataPacket True "hostname@" . Char8.unpack) namesWithoutGotOnions isName (NotationDataPacket True "hostname@" _) = True isName _ = False uids0 = fmap zapIfHasName uids fstuid = head $ do p <- map packet $ flattenAllUids "" True uids guard $ isUserID p return $ uidkey p uids1 = Map.adjust addnames fstuid uids0 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin where (ss,ts) = splitAt 1 sigs f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm) else (sig, tm) where p' = (packet sig) { unhashed_subpackets=uh } uh = unhashed_subpackets (packet sig) ++ notations zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin else (sigs,om) where (bs, sigs') = unzip $ map unhash sigs unhash (sig,tm) = ( not (null ns) , ( sig { packet = p', locations = Map.empty } , tm ) ) where psig = packet sig p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps } else psig uh = unhashed_subpackets psig (ns,ps) = partition isName uh decode_btc_key :: Enum timestamp => timestamp -> String -> Maybe (Word8, Message) decode_btc_key timestamp str = do (network_id,us) <- base58_decode str return . (network_id,) $ Message $ do let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer]) {- xy = secp256k1_G `pmul` d x = getx xy y = gety xy -- y² = x³ + 7 (mod p) y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve) y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve) -} secp256k1 = ECC.getCurveByName ECC.SEC_p256k1 ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1 -- pub = cannonical_eckey x y -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub -- address = base58_encode hash -- pubstr = concatMap (printf "%02x") $ pub -- _ = pubstr :: String return $ {- trace (unlines ["pub="++show pubstr ,"add="++show address ,"y ="++show y ,"y' ="++show y' ,"y''="++show y'']) -} SecretKeyPacket { version = 4 , timestamp = toEnum (fromEnum timestamp) , key_algorithm = ECDSA , key = [ -- public fields... ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve) ,('l',MPI 256) ,('x',MPI x) ,('y',MPI y) -- secret fields ,('d',MPI d) ] , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } -- DER-encoded elliptic curve ids -- nistp256_id = 0x2a8648ce3d030107 secp256k1_id :: Integer secp256k1_id = 0x2b8104000a -- "\x2a\x86\x48\xce\x3d\x03\x01\x07" {- OID Curve description Curve name ---------------------------------------------------------------- 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256" 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384" 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521" Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST P-521". The hexadecimal representation used in the public and private key encodings are: Curve Name Len Hexadecimal representation of the OID ---------------------------------------------------------------- "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07 "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23 -} readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents readInputFileS ctx inp = do let fname = resolveInputFile ctx inp fmap S.concat $ mapM S.readFile fname keyCompare :: String -> Packet -> Packet -> Ordering keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT keyCompare what a b | keykey a==keykey b = EQ keyCompare what a b = error $ unlines ["Unable to merge "++what++":" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] parseUID :: String -> UserIDRecord parseUID str = UserIDRecord { uid_full = str, uid_realname = realname, uid_user = user, uid_subdomain = subdomain, uid_topdomain = topdomain } where text = T.pack str (T.strip-> realname, T.dropAround isBracket-> email) = T.break (=='<') text (user, T.drop 1-> hostname) = T.break (=='@') email ( T.reverse -> topdomain, T.reverse . T.drop 1 -> subdomain) = T.break (=='.') . T.reverse $ hostname flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket] flattenTop fname ispub (KeyData key sigs uids subkeys) = unk ispub key : ( flattenAllUids fname ispub uids ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys)) derToBase32 :: ByteString -> String #if !defined(VERSION_cryptonite) derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy #else derToBase32 = map toLower . Base32.encode . S.unpack . sha1 where sha1 :: L.ByteString -> S.ByteString sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) #endif derRSA :: Packet -> Maybe ByteString derRSA rsa = do k <- rsaKeyFromPacket rsa return $ encodeASN1 DER (toASN1 k []) 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) -- 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) subkeyMappedPacket :: SubKey -> MappedPacket subkeyMappedPacket (SubKey k _ ) = k has_tag :: String -> Packet -> Bool has_tag tag p = isSignaturePacket p && or [ tag `elem` mapMaybe usage (hashed_subpackets p) , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) where asMapped n p = mappedPacketWithHint filename p n asSigAndTrust n (p,tm) = (asMapped n p,tm) -- NOTE: -- if a keyring file has both a public key packet and a secret key packet -- for the same key, then only one of them will survive, which ever is -- later in the file. -- -- This is due to the use of statements like -- (Map.insert filename (origin p n) (locations key)) -- update :: Maybe KeyData -> Maybe KeyData update v | isKey p && not (is_subkey p) = case v of Nothing -> Just $ KeyData (asMapped n p) [] Map.empty Map.empty Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p) sigs uids subkeys _ -> error . concat $ ["Unexpected master key merge error: " ,show (fingerprint top, fingerprint p)] update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys) update (Just (KeyData key sigs uids subkeys)) | isUserID p = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids) subkeys update (Just (KeyData key sigs uids subkeys)) = case sub of MarkerPacket -> Just $ KeyData key (mergeSig (first (flip (mappedPacketWithHint filename) n) ptt) sigs) uids subkeys UserIDPacket {} -> Just $ KeyData key sigs (Map.alter (mergeUidSig n ptt) (uidkey sub) uids) subkeys _ | isKey sub -> Just $ KeyData key sigs uids (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys) _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1) update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1) mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) [] mergeSubkey n p (Just (SubKey key sigs)) = Just $ SubKey (mergeKeyPacket "subs" key $ asMapped n p) sigs mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap) mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n)) mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m) mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p whatP (a,_) = concat . take 1 . words . show $ a mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs, m) mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty) mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig (first (flip (mappedPacketWithHint filename) n) sig) sigs) mergeSubSig n sig Nothing = error $ "Unable to merge subkey signature: "++(words (show sig) >>= take 1) secretToPublic :: Packet -> Packet secretToPublic pkt@(SecretKeyPacket {}) = PublicKeyPacket { version = version pkt , timestamp = timestamp pkt , key_algorithm = key_algorithm pkt -- , ecc_curve = ecc_curve pkt , key = let seckey = key pkt pubs = public_key_fields (key_algorithm pkt) in filter (\(k,v) -> k `elem` pubs) seckey , is_subkey = is_subkey pkt , v3_days_of_validity = Nothing } secretToPublic pkt = pkt sigpackets :: Monad m => Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet sigpackets typ hashed unhashed = return $ signaturePacket 4 -- version typ -- 0x18 subkey binding sig, or 0x19 back-signature RSA SHA1 hashed unhashed 0 -- Word16 -- Left 16 bits of the signed hash value [] -- [MPI] usage :: SignatureSubpacket -> Maybe String usage (NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = u }) = Just u usage _ = Nothing torhash :: Packet -> String torhash key = fromMaybe "" $ derToBase32 <$> derRSA key keyFlags :: t -> [Packet] -> [SignatureSubpacket] keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] flattenAllUids fname ispub uids = concatSort fname head (flattenUid fname ispub) (Map.assocs uids) -- | 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) makeSig :: (MappedPacket -> IO (KikiCondition Packet)) -> MappedPacket -> [Char] -> 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 ifSecret :: Packet -> t -> t -> t ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f uidkey :: Packet -> String uidkey (UserIDPacket str) = str keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags keyflags flgs@(KeyFlagsPacket {}) = Just . toEnum $ ( bit 0x1 certify_keys .|. bit 0x2 sign_data .|. bit 0x4 encrypt_communication .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags -- other flags: -- split_key -- authentication (ssh-client) -- group_key where bit v f = if f flgs then v else 0 keyflags _ = Nothing readSecretPEMFile :: InputFile -> IO [SecretPEMData] readSecretPEMFile fname = do -- warn $ fname ++ ": reading ..." let ctx = InputFileContext "" "" -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. stamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input pkcs1 = fmap (parseRSAPrivateKey . pemBlob) $ pemParser $ Just "RSA PRIVATE KEY" cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) $ pemParser $ Just "CERTIFICATE" parseRSAPrivateKey dta = do let e = decodeASN1 DER dta asn1 <- either (const $ mzero) return e rsa <- either (const mzero) (return . fst) (fromASN1 asn1) let _ = rsa :: RSAPrivateKey return $ PEMPacket $ rsaToPGP stamp rsa dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta mergeDate (_,obj) (Left tm) = (fromTime tm,obj) mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') where key' = if tm < fromTime (timestamp key) then key { timestamp = fromTime tm } else key mergeDate (tm,_) (Right mb) = (tm,mb) return $ dta readSecretDNSFile :: InputFile -> IO Packet readSecretDNSFile fname = do let ctx = InputFileContext "" "" stamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) . Char8.break (==':')) $ Char8.lines input alg = maybe RSA parseAlg $ lookup "Algorithm" kvs parseAlg spec = case Char8.words spec of nstr:_ -> case read (Char8.unpack nstr) :: Int of 2 -> DH 3 -> DSA -- SHA1 5 -> RSA -- SHA1 6 -> DSA -- NSEC3-SHA1 (RFC5155) 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) 8 -> RSA -- SHA256 10 -> RSA -- SHA512 (RFC5702) -- 12 -> GOST 13 -> ECDSA -- P-256 SHA256 (RFC6605) 14 -> ECDSA -- P-384 SHA384 (RFC6605) _ -> RSA case alg of RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs spemPacket :: SecretPEMData -> Maybe Packet spemPacket (PEMPacket p) = Just p spemPacket _ = Nothing spemCert :: SecretPEMData -> Maybe ParsedCert spemCert (PEMCertificate p) = Just p spemCert _ = Nothing fingerdress :: Packet -> SockAddr fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str where zero = SockAddrInet 0 0 addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk) colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs colons xs = xs getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet] getSubkeys ck topk subs tag = do SubKey k sigs <- Map.elems subs let subk = packet k let sigs' = do -- require tag torsig <- filter (has_tag tag) $ map (packet . fst) sigs -- require parent's signature when (ck > Unsigned) $ do sig <- (signatures $ Message [topk,subk,torsig]) let v = verify (Message [topk]) sig -- Require parent's signature guard (not . null $ signatures_over v) -- require child's back signature when (ck == CrossSigned ) $ do let unhashed = unhashed_subpackets torsig subsigs = mapMaybe backsig unhashed -- This should consist only of 0x19 values -- subtypes = map signature_type subsigs -- subtyp <- subtypes -- guard (subtyp == 0x19) sig' <- signatures . Message $ [topk,subk]++subsigs let v' = verify (Message [subk]) sig' -- Require subkey's signature guard . not . null $ signatures_over v' return torsig guard (not $ null sigs') return subk socketFamily :: SockAddr -> Family socketFamily (SockAddrInet _ _) = AF_INET socketFamily (SockAddrInet6 {}) = AF_INET6 socketFamily (SockAddrUnix _) = AF_UNIX selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db isBracket :: Char -> Bool isBracket '<' = True isBracket '>' = True isBracket _ = False unk :: Bool -> MappedPacket -> MappedPacket unk isPublic = if isPublic then toPacket secretToPublic else id where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} concatSort :: FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] concatSort fname getp f = concat . sortByHint fname getp . map f flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey rsaKeyFromPacket p | isKey p = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p return $ RSAKey n e rsaKeyFromPacket _ = Nothing disjoint_fp :: [Packet] -> [[Packet]] 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 [] = [] -} verifyBindings :: [Packet] -> [Packet] -> ([SignatureOver], [SignatureOver]) 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 flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket] flattenUid fname ispub (str,(sigs,om)) = (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs -- | 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 _ = [] 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 parseCertBlob :: Bool -> ByteString -> Maybe ParsedCert parseCertBlob comp bs = do asn1 <- either (const Nothing) Just $ decodeASN1 DER bs let asn1' = drop 2 asn1 cert <- either (const Nothing) (Just . fst) (fromASN1 asn1') let _ = cert :: X509.Certificate notBefore :: UTCTime #if MIN_VERSION_x509(1,5,0) notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano where (vincentTime,_) = X509.certValidity cert #else (notBefore,_) = X509.certValidity cert #endif case X509.certPubKey cert of X509.PubKeyRSA key -> do let withoutkey = let ekey = toStrict $ encodeASN1 DER (toASN1 key []) (pre,post) = S.breakSubstring ekey $ toStrict bs post' = S.drop (S.length ekey) post len :: Word16 len = if S.null post then maxBound else fromIntegral $ S.length pre in if len < 4096 then encode len <> GZip.compress (Char8.fromChunks [pre,post']) else bs return ParsedCert { pcertKey = packetFromPublicRSAKey notBefore (MPI $ RSA.public_n key) (MPI $ RSA.public_e key) , pcertTimestamp = notBefore , pcertBlob = if comp then withoutkey else bs } _ -> Nothing rsaToPGP :: TimeUtil.IsUTC a => a -> RSAPrivateKey -> Packet rsaToPGP stamp rsa = SecretKeyPacket { version = 4 , timestamp = fromTime stamp -- toEnum (fromEnum stamp) , key_algorithm = RSA , key = [ -- public fields... ('n',rsaN rsa) ,('e',rsaE rsa) -- secret fields ,('d',rsaD rsa) ,('p',rsaQ rsa) -- Note: p & q swapped ,('q',rsaP rsa) -- Note: p & q swapped ,('u',rsaCoefficient rsa) ] -- , ecc_curve = def , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey extractRSAKeyFields kvs = do let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs n <- lookup "Modulus" kvs' e <- lookup "PublicExponent" kvs' d <- lookup "PrivateExponent" kvs' p <- lookup "Prime1" kvs' -- p q <- lookup "Prime2" kvs' -- q dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) u <- lookup "Coefficient" kvs' {- case (d,p,dmodp1) of (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () _ -> error "dmodp fail!" case (d,q,dmodqminus1) of (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () _ -> error "dmodq fail!" -} return $ RSAPrivateKey { rsaN = n , rsaE = e , rsaD = d , rsaP = p , rsaQ = q , rsaDmodP1 = dmodp1 , rsaDmodQminus1 = dmodqminus1 , rsaCoefficient = u } where parseField blob = MPI <$> m where m = bigendian <$> Base64.decode (Char8.unpack blob) bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs where nlen = length bs backsig :: SignatureSubpacket -> Maybe Packet backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectKey0 wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db ys = snd $ seek_key spec ps flip (maybe (listToMaybe ys)) mtag $ \tag -> do case ys of y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 [] -> Nothing sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] sortByHint fname f = sortBy (comparing gethint) where gethint = maybe defnum originalNum . Map.lookup fname . locations . f defnum = -1 unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket] unsig fname isPublic (sig,trustmap) = sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap) where f n _ = n==fname -- && trace ("fname=n="++show n) True asMapped n p = let m = mappedPacket fname p in m { locations = fmap (\x->x {originalNum=n}) (locations m) } smallpr :: Packet -> [Char] smallpr k = drop 24 $ fingerprint k isSubkeySignature :: SignatureOver -> Bool isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False toStrict :: L.ByteString -> S.ByteString toStrict = foldr1 (<>) . L.toChunks packetFromPublicRSAKey :: UTCTime -> MPI -> MPI -> Packet packetFromPublicRSAKey notBefore n e = PublicKeyPacket { version = 4 , timestamp = round $ utcTimeToPOSIXSeconds notBefore , key_algorithm = RSA , key = [('n',n),('e',e)] , is_subkey = True , v3_days_of_validity = Nothing } flattenKeys :: Bool -> KeyDB -> Message flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db) where prefilter = if isPublic then id else filter isSecret where isSecret (_,(KeyData (MappedPacket { packet=(SecretKeyPacket {})}) _ _ _)) = True isSecret _ = False seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet]) seek_key (KeyGrip grip) sec = (pre, subs) where (pre,subs) = break pred sec pred p@(SecretKeyPacket {}) = matchpr grip p == grip pred p@(PublicKeyPacket {}) = matchpr grip p == grip pred _ = False seek_key (KeyTag key tag) ps | null bs = (ps, []) | null qs = let (as', bs') = seek_key (KeyTag key tag) (tail bs) in (as ++ (head bs : as'), bs') | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) where (as,bs) = break (\p -> isSignaturePacket p && has_tag tag p && isJust (signature_issuer p) && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) ) ps (rs,qs) = break isKey (reverse as) has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) seek_key (KeyUidMatch pat) ps | null bs = (ps, []) | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in (as ++ (head bs : as'), bs') | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs) where (as,bs) = break (isInfixOf pat . uidStr) ps (rs,qs) = break isKey (reverse as) uidStr (UserIDPacket s) = s uidStr _ = ""