{-# LANGUAGE CPP #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} module KeyRing.BuildKeyDB where #if defined(VERSION_memory) import Data.ByteArray.Encoding import qualified Data.ByteString.Char8 as S8 import qualified Data.ByteString as S #elif defined(VERSION_dataenc) import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 #endif 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 (ASN1 (BitString, End, IntVal, Null, OID, Start), ASN1ConstructionType (Sequence), ASN1Object, 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.Function 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,openFile,IOMode(ReadMode)) 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 import Transforms import PacketTranscoder import GnuPGAgent import ByteStringUtil -- | 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, ([ByteString],[ByteString]))], {- outgoing_names -}[SockAddr]) ,{- accs -} Map.Map InputFile Access ,{- transcode -} PacketTranscoder ,{- 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) return f -- 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 (codec,ps) = (stream { access = acc', typ = PGPPackets codec }, 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 n) -- KeyRings (todo: KikiCondition reporting?) (spilled,mwk,grip,accs,keyqs,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 (OriginMapped Query) mwk :: Maybe MappedPacket (mwk, keys) = keyQueries grip ringPackets -- | 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) transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs) let doDecrypt = transcode (Unencrypted,S2K 100 "") let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty , rtPassphrases = transcode } -- autosigns and deletes transformed0 <- 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) -- XXX: Unspilled keys are not obtainable from rtKeyDB. -- If the working key is marked non spillable, then how -- would we look up it's UID and such? #if MIN_VERSION_containers(0,5,0) in fmap sequenceA $ Map.traverseWithKey trans spilled #else in 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 transcode 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 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 (\case (ArgFile n,_,_,_,_) -> doesFileExist n _ -> return True) pems db <- foldM (importSecretKey transcode) (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 transcode 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, transcode, unspilled) , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) isring :: FileType -> Bool isring (PGPPackets {}) = True isring _ = False readPacketsFromFile :: InputFileContext -> InputFile -> IO (PacketsCodec, Message) readPacketsFromFile ctx fname = do -- warn $ fname ++ ": reading..." input <- readInputFileL ctx fname return $ (,) BinaryPackets $ #if MIN_VERSION_binary(0,7,0) Message $ flip fix input $ \again some -> case decodeOrFail some of Right (more,_,msg ) -> msg : again more Left (_,_,_) -> -- TODO: try ascii armor [] #else 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 -- | combineTransforms -- remove redundant transforms, and compile the rest to PacketUpdate(s) -- -- equivalent 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 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 :: PacketTranscoder -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags -> InputFile -> Packet -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) doImportG transcode db m0 tags fname key = do let kk = head m0 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db kdr <- insertSubkey transcode kk kd tags fname key try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) 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 :: (PacketTranscoder) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) importSecretKey transcode db' tup = do try db' $ \(db',report0) -> do r <- doImport transcode db' tup try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) generateInternals :: PacketTranscoder -> Maybe MappedPacket -> Map.Map KeyKey KeyData -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) generateInternals transcode mwk db gens = do case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of Just kd0 -> do kd <- foldM (generateSubkey transcode) (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 ( ( KeyDB , ( [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 hs <- mapM (`openFile` ReadMode) fname fmap L.concat $ mapM (hGetContentsN oneMeg) hs 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 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 -- insertSubkey :: (MappedPacket -> IO (KikiCondition Packet)) -> t -> KeyData -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (KeyData, [([Char], KikiReportAction)])) insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do let topcipher = symmetric_algorithm $ packet top tops2k = s2k $ packet top doDecrypt = transcode (Unencrypted,S2K 100 "") fname = resolveForReport Nothing inputfile subkk = keykey key0 istor = do guard ("tor" `elem` mapMaybe usage tags) return $ torUIDFromKey key0 addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) (locations mp) } in SubKey mp' sigs subkey_result <- do case Map.lookup subkk subs of Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing) Nothing -> do wkun' <- doDecrypt top try wkun' $ \wkun -> do key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0 try key' $ \key -> do return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key)) try subkey_result $ \(is_new,subkey,decrypted) -> do let subs' = Map.insert subkk subkey subs 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 let keyflags = keyFlags (error "dummy argument (insertSubkey)") (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) (packet top) uid keyflags wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted try wkun' $ \wkun -> do 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 key0 subsigs doInsert mbsig = do -- NEW SUBKEY BINDING SIGNATURE -- XXX: Here I assume that key0 is the unencrypted version -- of subkey_p. TODO: Check this assumption. sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} 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 key0) 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 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 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 :: PacketTranscoder -> Map.Map KeyKey KeyData -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) doImport transcode db (fname,subspec,ms,typ -> typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do (certs,keys) <- case typ of PEMFile -> do ps <- readSecretPEMFile fname let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) = partition (isJust . spemCert) ps return (certs,keys) DNSPresentation -> do p <- readSecretDNSFile 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 (resolveForReport Nothing 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 transcode db m0 (mkUsage tag:blobs) fname datedKey try r $ \(db',report') -> do return $ KikiSuccess (db',report++report') generateSubkey :: PacketTranscoder -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db -> (GenerateKeyParams, StreamInfo) -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) generateSubkey transcode 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 transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") 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 -} 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) instance ASN1Object RSAPrivateKey where toASN1 rsa@(RSAPrivateKey {}) = \xs -> Start Sequence : IntVal 0 : mpiVal rsaN : mpiVal rsaE : mpiVal rsaD : mpiVal rsaP : mpiVal rsaQ : mpiVal rsaDmodP1 : mpiVal rsaDmodQminus1 : mpiVal rsaCoefficient : End Sequence : xs where mpiVal f = IntVal x where MPI x = f rsa fromASN1 ( Start Sequence : IntVal _ -- version : IntVal n : IntVal e : IntVal d : IntVal p : IntVal q : IntVal dmodp1 : IntVal dmodqminus1 : IntVal coefficient : ys) = Right ( privkey, tail $ dropWhile notend ys) where notend (End Sequence) = False notend _ = True privkey = RSAPrivateKey { rsaN = MPI n , rsaE = MPI e , rsaD = MPI d , rsaP = MPI p , rsaQ = MPI q , rsaDmodP1 = MPI dmodp1 , rsaDmodQminus1 = MPI dmodqminus1 , rsaCoefficient = MPI coefficient } fromASN1 _ = Left "fromASN1: RSAPrivateKey: unexpected format" 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 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 #if defined(VERSION_memory) where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob) bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs where nlen = S.length bs #elif defined(VERSION_dataenc) 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 #endif 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 -- TODO: Data.ByteString.Lazy now exports this. 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 _ = ""