{-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE RankNTypes #-} {-# LANGUAGE KindSignatures #-} module KeyRing ( InputFile(..) , backsig , derRSA , derToBase32 , filterMatches , flattenKeys , flattenTop , guardAuthentic , Hosts.Hosts , importPublic , importSecret , PacketUpdate(..) , isCryptoCoinKey , isKey , KeyData(..) , KeyDB , keyflags , KeyRingOperation(..) , KikiResult(..) , KikiCondition(..) , locations , matchpr , RefType(..) , FileType(..) , noManip , packet , parseSpec , parseUID , pkcs8 , RSAPublicKey(..) , rsaKeyFromPacket , KeyRingRuntime(..) , runKeyRing , secretToPublic , selectPublicKey , selectSecretKey , SubKey(..) , subkeysOnly , UserIDRecord(..) , usage , usageString , walletImportFormat , writePEM ) where import System.Environment import Control.Monad import Data.Maybe import Data.Either import Data.Char import Data.Ord import Data.List import Data.OpenPGP import Data.Functor import Data.Monoid import Data.Tuple ( swap ) import Data.Bits ( (.|.) ) import Control.Applicative ( Applicative, pure, liftA2, (<*>) ) import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing ) import Control.Arrow ( first, second ) import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign) import Data.ByteString.Lazy ( ByteString ) import Text.Show.Pretty as PP ( ppShow ) import Data.Binary {- decode, decodeOrFail -} import ControlMaybe ( handleIO_ ) import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1 , ASN1(Start,End,IntVal,OID,BitString), ASN1ConstructionType(Sequence) ) import Data.ASN1.BitArray ( BitArray(..), toBitArray ) import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' ) import Data.ASN1.BinaryEncoding ( DER(..) ) import Data.Time.Clock.POSIX ( getPOSIXTime ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L ( unpack, pack, null, readFile, writeFile , ByteString, toChunks ) import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile) import qualified Crypto.Types.PubKey.ECC as ECC import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 import qualified Crypto.Hash.SHA1 as SHA1 import qualified Data.Text as T ( Text, unpack, pack, strip, reverse, drop, break, dropAround ) import qualified System.Posix.Types as Posix import System.Posix.Files ( modificationTime, getFileStatus , setFileCreationMask, setFileTimes ) import System.FilePath ( takeDirectory ) import System.IO (hPutStrLn,withFile,IOMode(..)) import Data.IORef import System.Posix.IO ( fdToHandle ) import qualified Data.Traversable as Traversable ( mapM ) import Data.Traversable ( sequenceA ) #if ! MIN_VERSION_base(4,6,0) import GHC.Exts ( Down(..) ) #endif import Network.Socket -- (SockAddr) import qualified Data.ByteString.Lazy.Char8 as Char8 import qualified Hosts import qualified CryptoCoins import Base58 import FunctorToMaybe import DotLock import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) ) -- 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 -} data HomeDir = HomeDir { homevar :: String , appdir :: String , optfile_alts :: [String] } home :: HomeDir home = HomeDir { homevar = "GNUPGHOME" , appdir = ".gnupg" , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"] } data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Posix.Fd deriving (Eq,Ord) type UsageTag = String type Initializer = String type PassWordFile = InputFile data FileType = KeyRingFile (Maybe PassWordFile) | PEMFile UsageTag | WalletFile -- (Maybe UsageTag) | Hosts -- | RefType is perhaps not a good name for this... -- It is sort of like a read/write flag, although -- semantically, it is indicating the intention of -- an action and not just the access level of an -- object. data RefType = ConstRef -- ^ merge into database but do not update | MutableRef (Maybe Initializer) -- ^ sync into database -- update dabase and also update file -- Initializer is a shell command that creates -- the file; eg, ssh-keygen isMutable :: RefType -> Bool isMutable (MutableRef {}) = True isMutable _ = False isring :: FileType -> Bool isring (KeyRingFile {}) = True isring _ = False pwfile :: FileType -> Maybe PassWordFile pwfile (KeyRingFile f) = f pwfile _ = Nothing iswallet :: FileType -> Bool iswallet (WalletFile {}) = True iswallet _ = False initializer :: RefType -> Maybe Initializer initializer (MutableRef x) = x initializer _ = Nothing getUsage :: forall (m :: * -> *). MonadPlus m => FileType -> m UsageTag getUsage (PEMFile usage) = return usage getUsage _ = mzero data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath , rtSecring :: FilePath , rtGrip :: Maybe String , rtWorkingKey :: Maybe Packet , rtKeyDB :: KeyDB } -- | TODO: Packet Update should have deletiong action -- and any other kind of roster entry level -- action. data PacketUpdate = InducerSignature String [SignatureSubpacket] noManip :: KeyRingRuntime -> KeyData -> [PacketUpdate] noManip _ _ = [] data KeyRingOperation = KeyRingOperation { kFiles :: Map.Map InputFile (RefType,FileType) , kImports :: Map.Map InputFile (KeyRingRuntime -> KeyData -> Maybe Bool) -- ^ -- Indicates what pgp master keys get written to which keyring files. -- Just True = import public key -- Just False = import secret key -- Nothing = do not import -- Note that subkeys will always be imported if their owner key is -- already in the ring. -- TODO: Even if their signatures are bad? , kManip :: KeyRingRuntime -> KeyData -> [PacketUpdate]--[KeyRingAddress PacketUpdate] , homeSpec :: Maybe String } resolveInputFile :: FilePath -> FilePath -> InputFile -> [FilePath] resolveInputFile secring pubring = resolve where resolve HomeSec = return secring resolve HomePub = return pubring resolve (ArgFile f) = return f resolve _ = [] filesToLock :: KeyRingOperation -> FilePath -> FilePath -> [FilePath] filesToLock k secring pubring = do (f,(rtyp,ftyp)) <- Map.toList (kFiles k) case rtyp of ConstRef -> [] MutableRef {} -> resolveInputFile secring pubring f -- kret :: a -> KeyRingOperation a -- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x) data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey pkcs8 (RSAKey n e) = RSAKey8 n e instance ASN1Object RSAPublicKey where -- PKCS #1 RSA Public Key toASN1 (RSAKey (MPI n) (MPI e)) = \xs -> Start Sequence : IntVal n : IntVal e : End Sequence : xs fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" instance ASN1Object PKCS8_RSAPublicKey where -- PKCS #8 Public key data toASN1 (RSAKey8 (MPI n) (MPI e)) = \xs -> Start Sequence : Start Sequence : OID [1,2,840,113549,1,1,1] : End Sequence : BitString (toBitArray bs 0) : End Sequence : xs where pubkey = Start Sequence : IntVal n : IntVal e : End Sequence : [] bs = encodeASN1' DER pubkey fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) = Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs) fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) = case decodeASN1' DER bs of Right as -> fromASN1 as Left e -> Left ("fromASN1: RSAPublicKey: "++show e) where BitArray _ bs = b fromASN1 _ = Left "fromASN1: RSAPublicKey: unexpected format" data RSAPrivateKey = RSAPrivateKey { rsaN :: MPI , rsaE :: MPI , rsaD :: MPI , rsaP :: MPI , rsaQ :: MPI , rsaDmodP1 :: MPI , rsaDmodQminus1 :: MPI , rsaCoefficient :: MPI } deriving Show 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" data KikiCondition a = KikiSuccess a | FailedToLock [FilePath] | BadPassphrase | FailedToMakeSignature | CantFindHome | AmbiguousKeySpec FilePath | CannotImportMasterKey | NoWorkingKey deriving ( Functor, Show ) instance FunctorToMaybe KikiCondition where functorToMaybe (KikiSuccess a) = Just a functorToMaybe _ = Nothing instance Applicative KikiCondition where pure a = KikiSuccess a f <*> a = case functorToEither f of Right f -> case functorToEither a of Right a -> pure (f a) Left err -> err Left err -> err data KikiReportAction = NewPacket String | MissingPacket String | ExportedSubkey | GeneratedSubkeyFile | NewWalletKey String | YieldSignature | YieldSecretKeyPacket String | UnableToUpdateExpiredSignature | WarnFailedToMakeSignature | FailedExternal Int | ExternallyGeneratedFile | UnableToExport KeyAlgorithm String | FailedFileWrite | HostsDiff ByteString deriving Show data KikiResult a = KikiResult { kikiCondition :: KikiCondition a , kikiReport :: [ (FilePath, KikiReportAction) ] } keyPacket :: KeyData -> Packet keyPacket (KeyData k _ _ _) = packet k -- subkeyPacket (SubKey k _ ) = packet k subkeyMappedPacket :: SubKey -> MappedPacket subkeyMappedPacket (SubKey k _ ) = k usage :: SignatureSubpacket -> Maybe String usage (NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = u }) = Just u usage _ = Nothing 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] 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 data PGPKeyFlags = Special | Vouch -- Signkey | Sign | VouchSign | Communication | VouchCommunication | SignCommunication | VouchSignCommunication | Storage | VouchStorage | SignStorage | VouchSignStorage | Encrypt | VouchEncrypt | SignEncrypt | VouchSignEncrypt deriving (Eq,Show,Read,Enum) 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" -- matchpr computes the fingerprint of the given key truncated to -- be the same lenght as the given fingerprint for comparison. matchpr :: String -> Packet -> String matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp keyFlags :: t -> [Packet] -> [SignatureSubpacket] keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) 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 matchSpec :: KeySpec -> (t, 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 data UserIDRecord = UserIDRecord { uid_full :: String, uid_realname :: T.Text, uid_user :: T.Text, uid_subdomain :: T.Text, uid_topdomain :: T.Text } deriving Show 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 isBracket :: Char -> Bool isBracket '<' = True isBracket '>' = True isBracket _ = False data KeySpec = KeyGrip String | KeyTag Packet String | KeyUidMatch String deriving Show -- | Parse a key specification. -- The first argument is a grip for the default working key. parseSpec :: String -> String -> (KeySpec,Maybe String) 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) -> {- trace "using top" $ -} KeyGrip top _ | toptyp=="u" -> KeyUidMatch top _ | otherwise -> KeyUidMatch top subspec = case subtyp of "t" -> Just sub "fp" | top=="" -> Nothing "" | top=="" && is40digitHex sub -> Nothing "" -> listToMaybe sub >> Just sub 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 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) ks selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db 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 let (subspec,ys1) = (KeyTag y tag,ys1) where y:ys1 = ys zs = snd $ seek_key subspec ys1 listToMaybe zs {- selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)] selectAll wantPublic (spec,mtag) db = do let Message ps = flattenKeys wantPublic db ys = snd $ seek_key spec ps y <- take 1 ys case mtag of Nothing -> return (y,Nothing) Just tag -> let search ys1 = do let zs = snd $ seek_key (KeyTag y tag) ys1 z <- take 1 zs (y,Just z):search (drop 1 zs) in search (drop 1 ys) -} 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 = if null bs then (ps,[]) else if null qs then let (as',bs') = seek_key (KeyTag key tag) (tail bs) in (as ++ (head bs:as'), bs') else (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 = if null bs then (ps,[]) else if null qs then let (as',bs') = seek_key (KeyUidMatch pat) (tail bs) in (as ++ (head bs:as'), bs') else (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 _ = "" cachedContents :: FilePath -> FilePath -> InputFile -> IO (IO S.ByteString) cachedContents secring pubring fd = do ref <- newIORef Nothing return $ get ref fd where trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs get ref fd = do pw <- readIORef ref flip (flip maybe return) pw $ do pw <- fmap trimCR $ getContents fd writeIORef ref (Just pw) return pw getContents (FileDesc fd) = fdToHandle fd >>= S.hGetContents getContents inp = do let fname = resolveInputFile secring pubring inp fmap S.concat $ mapM S.readFile fname importPEMKey :: (MappedPacket -> IO (KikiCondition Packet)) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> ([Char], Maybe [Char], [KeyKey], t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) importPEMKey doDecrypt db' tup = do try db' $ \(db',report0) -> do r <- doImport doDecrypt db' tup try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) mergeHostFiles :: KeyRingOperation -> KeyDB -> FilePath -> FilePath -> IO (KikiCondition ( ( Map.Map [Char8.ByteString] KeyData , ( [Hosts.Hosts] , [Hosts.Hosts] , Hosts.Hosts , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] , [SockAddr])) , [(FilePath,KikiReportAction)])) mergeHostFiles krd db secring pubring = do let hns = files ishosts ishosts Hosts = True ishosts _ = False files istyp = do (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) guard (istyp ftyp) resolveInputFile secring pubring f hostdbs0 <- mapM (fmap Hosts.decode . L.readFile) 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 (\a -> not $ elem a outgoing_names) u1) db return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[]) writeHostsFiles :: KeyRingOperation -> [Char] -> [Char] -> ([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [(SockAddr, (t1, [Char8.ByteString]))], [SockAddr]) -> IO [(FilePath, KikiReportAction)] writeHostsFiles krd secring pubring (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do let hns = files isMutableHosts isMutableHosts (MutableRef _,Hosts) = True isMutableHosts _ = False files istyp = do (f,typ) <- Map.toList (kFiles krd) guard (istyp typ) resolveInputFile secring pubring f -- 3. add hostnames from gpg for addresses not in U let u = foldl' f u1 ans ans = reverse $ do (addr,(_,ns)) <- gpgnames guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0 n <- ns return (addr,n) f h (addr,n) = Hosts.assignNewName addr n h -- 4. for each host db H, union H with U and write it out as H' -- only if there is a non-empty diff rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do let h = h1 `Hosts.plus` u d = Hosts.diff h0 h rs = map ((fname,) . HostsDiff) d when (not $ null d) $ L.writeFile fname $ Hosts.encode h return rs return $ concat rss buildKeyDB :: (MappedPacket -> IO (KikiCondition Packet)) -> FilePath -> FilePath -> Maybe String -> KeyRingOperation -> IO (KikiCondition ((KeyDB,Maybe String,Maybe MappedPacket, ([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [(SockAddr, ([ByteString], [ByteString]))], [SockAddr]) ) ,[(FilePath,KikiReportAction)])) buildKeyDB doDecrypt secring pubring grip0 keyring = do let files isring = do (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring) guard (isring ftyp) resolveInputFile secring pubring f readp n = fmap (n,) (readPacketsFromFile n) readw wk n = fmap (n,) (readPacketsFromWallet wk n) importWalletKey wk db' (top,fname,sub,tag) = do try db' $ \(db',report0) -> do r <- doImportG doDecrypt db' (fmap keykey $ maybeToList wk) tag fname sub try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) -- KeyRings (todo: KikiCondition reporting?) (db_rings,mwk,grip) <- do ms <- mapM readp (files isring) let grip = grip0 `mplus` (fingerprint <$> fstkey) where fstkey = listToMaybe $ mapMaybe isSecringKey ms where isSecringKey (fn,Message ps) | fn==secring = listToMaybe ps isSecringKey _ = Nothing db_rings = foldl' (uncurry . merge) Map.empty ms wk = listToMaybe $ do fp <- maybeToList grip elm <- Map.toList db_rings guard $ matchSpec (KeyGrip fp) elm return $ keyMappedPacket (snd elm) return (db_rings,wk,grip) let wk = fmap packet mwk -- Wallets 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,(rtyp,ftyp)) <- Map.toList $ kFiles keyring grip <- maybeToList grip (topspec,subspec) <- fmap (parseSpec grip) $ getUsage ftyp n <- resolveInputFile secring pubring n let ms = map fst $ filterMatches topspec (Map.toList db) cmd = initializer rtyp return (n,subspec,ms,cmd) imports <- filterM (\(n,_,_,_) -> doesFileExist n) pems db <- foldM (importPEMKey doDecrypt) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do r <- mergeHostFiles keyring db secring pubring try r $ \((db,hs),reportHosts) -> do return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs ) torhash :: Packet -> String torhash key = maybe "" id $ derToBase32 <$> derRSA key derToBase32 :: ByteString -> String derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy derRSA :: Packet -> Maybe ByteString derRSA rsa = do k <- rsaKeyFromPacket rsa return $ encodeASN1 DER (toASN1 k []) 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 readKeyFromFile :: Bool -> String -> FilePath -> IO Message readKeyFromFile False "PEM" fname = do -- warn $ fname ++ ": reading ..." -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname input <- L.readFile fname let dta = extractPEM "RSA PRIVATE KEY" input -- Char8.putStrLn $ "dta = " <> dta let rsa = do e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta) asn1 <- either (const Nothing) Just e k <- either (const Nothing) (Just . fst) (fromASN1 asn1) let _ = k :: RSAPrivateKey return k -- putStrLn $ "rsa = "++ show rsa return . Message $ do rsa <- maybeToList rsa return $ SecretKeyPacket { version = 4 , timestamp = toEnum (fromEnum timestamp) , 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 } readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) extractPEM :: ByteString -> ByteString -> ByteString extractPEM typ pem = dta where dta = case ys of _:dta_lines -> Char8.concat dta_lines [] -> "" xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem) ys = takeWhile (/="-----END " <> typ <> "-----") xs doImport :: Ord k => (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map k KeyData -> ([Char], Maybe [Char], [k], t) -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) doImport doDecrypt db (fname,subspec,ms,_) = do let fetchkey = readKeyFromFile False "PEM" fname flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do Message parsedkey <- fetchkey flip (maybe $ return $ KikiSuccess (db,[])) (listToMaybe parsedkey) $ \key -> do let (m0,tailms) = splitAt 1 ms if (not (null tailms) || null m0) then return $ AmbiguousKeySpec fname else doImportG doDecrypt db m0 tag fname key doImportG :: Ord k => (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map k KeyData -> [k] -> [Char] -> [Char] -> Packet -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) doImportG doDecrypt db m0 tag fname key = do let kk = head m0 Just (KeyData top topsigs uids subs) = Map.lookup kk db 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 (tag == "tor") 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 tag wk key subsigs doInsert mbsig db = do sig' <- makeSig doDecrypt top fname subkey_p tag 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 ( Map.insert kk (KeyData top topsigs uids' subs') db , 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 db -- 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 ( Map.insert kk (KeyData top topsigs uids' subs') db , report ) Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag isCryptoCoinKey :: Packet -> Bool isCryptoCoinKey p = and [ isKey p , key_algorithm p == ECDSA , lookup 'c' (key p) == Just (MPI secp256k1_id) ] getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork getCryptoCoinTag p | isSignaturePacket p = do -- CryptoCoins.secret let sps = hashed_subpackets p ++ unhashed_subpackets p u <- listToMaybe $ mapMaybe usage sps CryptoCoins.lookupNetwork CryptoCoins.network_name u getCryptoCoinTag _ = Nothing coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)] coinKeysOwnedBy db wk = do wk <- maybeToList wk let kk = keykey wk KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db (subkk,SubKey mp sigs) <- Map.toList subs let sub = packet mp guard $ isCryptoCoinKey sub tag <- take 1 $ mapMaybe getCryptoCoinTag (map (packet . fst) sigs) return (tag,mp) walletImportFormat :: Word8 -> Packet -> String walletImportFormat idbyte k = secret_base58_foo where -- isSecret (SecretKeyPacket {}) = True -- isSecret _ = False secret_base58_foo = base58_encode seckey Just d = lookup 'd' (key k) (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d) seckey = S.cons idbyte bigendian writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeWalletKeys krd db wk = do let cs = db `coinKeysOwnedBy` wk -- export wallet keys isMutableWallet (MutableRef {}) (WalletFile {}) = True isMutableWallet _ _ = False files pred = do (f,(rtyp,ftyp)) <- Map.toList (kFiles krd) guard (pred rtyp ftyp) resolveInputFile "" "" f let writeWallet report n = do let cs' = do (nw,mp) <- cs -- let fns = Map.keys (locations mp) -- trace ("COIN KEY: "++show fns) $ return () guard . not $ Map.member n (locations mp) let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp) return (CryptoCoins.network_name nw,wip) handleIO_ (return report) $ do withFile n AppendMode $ \fh -> do rs <- forM cs' $ \(net,wip) -> do hPutStrLn fh wip return (n, NewWalletKey net) return (report ++ rs) report <- foldM writeWallet [] (files isMutableWallet) return $ KikiSuccess report ifSecret :: Packet -> t -> t -> t ifSecret (SecretKeyPacket {}) t f = t ifSecret _ t f = f 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 p = concat . take 1 $ words (show p) importPublic :: Maybe Bool importPublic = Just True importSecret :: Maybe Bool importSecret = Just False subkeysOnly :: Maybe Bool subkeysOnly = Nothing guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe () guardAuthentic rt keydata = guard (isauth rt keydata) isauth :: KeyRingRuntime -> KeyData -> Bool isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk where wk = workingKey (rtGrip rt) (rtKeyDB rt) dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt) $ locations p has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids where goodsig (uidstr,(sigs,_)) = not . null $ do sig0 <- fmap (packet . fst) sigs pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0]) signatures_over $ verify (Message [wk]) pre_ov workingKey grip use_db = listToMaybe $ do fp <- maybeToList grip elm <- Map.toList use_db guard $ matchSpec (KeyGrip fp) elm return $ keyPacket (snd elm) writeRingKeys :: KeyRingOperation -> KeyRingRuntime {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath -} -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeRingKeys krd rt {- db wk secring pubring -} = do let isring (KeyRingFile {}) = True isring _ = False db = rtKeyDB rt secring = rtSecring rt pubring = rtPubring rt let s = do (f,f0,mutable) <- do (f0,(rtyp,ftyp)) <- Map.toList (kFiles krd) guard (isring ftyp) f <- resolveInputFile secring pubring f0 return (f,f0,isMutable rtyp) let x = do let wanted kd@(KeyData p _ _ _) = mplus (fmap originallyPublic $ Map.lookup f $ locations p) $ do pred <- Map.lookup f0 $ kImports krd pred rt kd d <- sortByHint f keyMappedPacket (Map.elems db) only_public <- maybeToList $ wanted d flattenTop f only_public d new_packets = filter isnew x where isnew p = isNothing (Map.lookup f $ locations p) guard (not $ null new_packets) return ((f,mutable),(new_packets,x)) let (towrites,report) = (\f -> foldl f ([],[]) s) $ \(ws,report) ((f,mutable),(new_packets,x)) -> if mutable then let rs = flip map new_packets $ \c -> (f, NewPacket $ showPacket (packet c)) in (ws++[(f,x)],report++rs) else let rs = flip map new_packets $ \c -> (f,MissingPacket (showPacket (packet c))) in (ws,report++rs) forM_ towrites $ \(f,x) -> do let m = Message $ map packet x -- warn $ "writing "++f L.writeFile f (encode m) return $ KikiSuccess report {- getSubkeysForExport kk subspec db = do kd <- maybeToList $ Map.lookup kk db subkeysForExport subspec kd -} subkeysForExport :: Maybe String -> KeyData -> [MappedPacket] subkeysForExport subspec (KeyData key _ _ subkeys) = do let subs tag = do e <- Map.elems subkeys guard $ doSearch key tag e return $ subkeyMappedPacket e maybe [key] subs subspec where doSearch key tag (SubKey sub_mp sigtrusts) = let (_,v,_) = findTag tag (packet key) (packet sub_mp) sigtrusts in fmap fst v==Just True writePEM :: String -> String -> String writePEM typ dta = pem where pem = unlines . concat $ [ ["-----BEGIN " <> typ <> "-----"] , split64s dta , ["-----END " <> typ <> "-----"] ] split64s "" = [] split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta -- 64 byte lines rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do -- public fields... n <- lookup 'n' $ key pkt e <- lookup 'e' $ key pkt -- secret fields MPI d <- lookup 'd' $ key pkt MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped -- Note: Here we fail if 'u' key is missing. -- Ideally, it would be better to compute (inverse q) mod p -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg -- (package constructive-algebra) coefficient <- lookup 'u' $ key pkt let dmodp1 = MPI $ d `mod` (p - 1) dmodqminus1 = MPI $ d `mod` (q - 1) return $ RSAPrivateKey { rsaN = n , rsaE = e , rsaD = MPI d , rsaP = MPI p , rsaQ = MPI q , rsaDmodP1 = dmodp1 , rsaDmodQminus1 = dmodqminus1 , rsaCoefficient = coefficient } rsaPrivateKeyFromPacket _ = Nothing writeKeyToFile :: Bool -> String -> FilePath -> Packet -> IO [(FilePath, KikiReportAction)] writeKeyToFile False "PEM" fname packet = case key_algorithm packet of RSA -> do flip (maybe (return [])) (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey $ \rsa -> do let asn1 = toASN1 rsa [] bs = encodeASN1 DER asn1 dta = Base64.encode (L.unpack bs) output = writePEM "RSA PRIVATE KEY" dta stamp = toEnum . fromEnum $ timestamp packet createDirectoryIfMissing True (takeDirectory fname) handleIO_ (return [(fname, FailedFileWrite)]) $ do saved_mask <- setFileCreationMask 0o077 writeFile fname output -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. setFileTimes fname stamp stamp setFileCreationMask saved_mask return [(fname, ExportedSubkey)] algo -> return [(fname, UnableToExport algo $ fingerprint packet)] writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet)) -> KeyDB -> [(FilePath,Maybe String,[MappedPacket],Maybe Initializer)] -> IO (KikiCondition [(FilePath,KikiReportAction)]) writePEMKeys doDecrypt db exports = do ds <- mapM decryptKeys exports let ds' = map functorToEither ds if null (lefts ds') then do rs <- mapM (uncurry $ writeKeyToFile False "PEM") (rights ds') return $ KikiSuccess (concat rs) else do return (head $ lefts ds') where decryptKeys (fname,subspec,[p],_) = do pun <- doDecrypt p try pun $ \pun -> do return $ KikiSuccess (fname,pun) makeMemoizingDecrypter :: KeyRingOperation -> FilePath -> FilePath -> IO (MappedPacket -> IO (KikiCondition Packet)) makeMemoizingDecrypter operation secring pubring = do pws <- -- TODO: head will throw an exception if a File Descriptor operation -- file is present. We probably should change OriginMap to use InputFile -- instead of FilePath. Traversable.mapM (cachedContents secring pubring . fromJust . pwfile . snd) (Map.mapKeys (head . resolveInputFile secring pubring) $ Map.filter (isJust . pwfile . snd) $ kFiles operation) unkeysRef <- newIORef Map.empty return $ doDecrypt unkeysRef pws where doDecrypt :: IORef (Map.Map KeyKey Packet) -> Map.Map FilePath (IO S.ByteString) -> MappedPacket -> IO (KikiCondition Packet) doDecrypt unkeysRef pws mp = do unkeys <- readIORef unkeysRef let wk = packet mp kk = keykey wk fs = Map.keys $ locations mp decryptIt [] = return BadPassphrase decryptIt (getpw:getpws) = do pw <- getpw let wkun = maybe wk id $ decryptSecretKey pw wk case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) return $ KikiSuccess wkun _ -> decryptIt getpws getpws = mapMaybe (flip Map.lookup pws) fs case symmetric_algorithm wk of Unencrypted -> return (KikiSuccess wk) _ -> maybe (decryptIt getpws) (return . KikiSuccess) $ Map.lookup kk unkeys performManipulations :: (MappedPacket -> IO (KikiCondition Packet)) -> KeyRingOperation -> KeyRingRuntime -> Maybe MappedPacket -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) performManipulations doDecrypt operation rt wk = do let db = rtKeyDB rt performAll kd = foldM perform (KikiSuccess kd) $ kManip operation rt kd r <- Traversable.mapM performAll db try (sequenceA r) $ \db -> do return $ KikiSuccess (rt { rtKeyDB = db },[]) where perform kd (InducerSignature uid subpaks) = do try kd $ \kd -> 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 (rentryUids 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 ) return $ KikiSuccess $ kd { rentryUids = Map.adjust f uid (rentryUids kd) } initializeMissingPEMFiles :: KeyRingOperation -> FilePath -> FilePath -> Maybe String -> (MappedPacket -> IO (KikiCondition Packet)) -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath , Maybe String , [MappedPacket] , Maybe Initializer)]) , [(FilePath,KikiReportAction)])) initializeMissingPEMFiles operation secring pubring grip decrypt db = do nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (kFiles operation) f <- resolveInputFile secring pubring f return (f,t) let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do (fname,(rtyp,ftyp)) <- nonexistents guard $ isMutable rtyp (topspec,subspec) <- fmap (parseSpec $ maybe "" id grip) $ getUsage ftyp -- ms will contain duplicates if a top key has multiple matching -- subkeys. This is intentional. let -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db -- ms = filterMatches topspec $ Map.toList db ns = do (kk,kd) <- filterMatches topspec $ Map.toList db return (kk , subkeysForExport subspec kd) return (fname,subspec,ns,initializer rtyp) (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) notmissing exports = map (\(f,subspec,ns,cmd) -> (f,subspec,ns >>= snd,cmd)) exports0 ambiguity (f,topspec,subspec,_) = do return $ AmbiguousKeySpec f ifnotnull (x:xs) f g = f x ifnotnull _ f g = g ifnotnull ambiguous ambiguity $ do -- create nonexistent files via external commands do let cmds = mapMaybe getcmd missing where getcmd (fname,subspec,ms,mcmd) = do cmd <- mcmd return (fname,subspec,ms,cmd) rs <- forM cmds $ \tup@(fname,subspec,ms,cmd) -> do e <- systemEnv [ ("file",fname) , ("usage",maybe "" id subspec) ] cmd case e of ExitFailure num -> return (tup,FailedExternal num) ExitSuccess -> return (tup,ExternallyGeneratedFile) v <- foldM (importPEMKey decrypt) (KikiSuccess (db,[])) $ do ((f,subspec,ms,cmd),r) <- rs guard $ case r of ExternallyGeneratedFile -> True _ -> False return (f,subspec,map fst ms,cmd) try v $ \(db,import_rs) -> do return $ KikiSuccess ((db,exports), map (\((f,_,_,_),r)->(f,r)) rs ++ import_rs) {- interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo" interpretManip kd manip = return kd -} runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) runKeyRing operation = do homedir <- getHomeDir (homeSpec operation) let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b) -- FIXME: try' should probably accept a list of KikiReportActions. -- This would be useful for reporting on disk writes that have already -- succeded prior to this termination. try' v body = case functorToEither v of Left e -> return $ KikiResult e [] Right wkun -> body wkun try' homedir $ \(homedir,secring,pubring,grip0) -> do let tolocks = filesToLock operation secring pubring lks <- forM tolocks $ \f -> do lk <- dotlock_create f 0 v <- flip (maybe $ return Nothing) lk $ \lk -> do e <- dotlock_take lk (-1) if e==0 then return $ Just lk else dotlock_destroy lk >> return Nothing return (v,f) let (lked, map snd -> failed_locks) = partition (isJust . fst) lks ret <- if not $ null failed_locks then return $ KikiResult (FailedToLock failed_locks) [] else do -- memoizing decrypter decrypt <- makeMemoizingDecrypter operation secring pubring -- merge all keyrings, PEM files, and wallets bresult <- buildKeyDB decrypt secring pubring grip0 operation try' bresult $ \((db,grip,wk,hs),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation secring pubring grip decrypt db try' externals_ret $ \((db,exports),report_externals) -> do let rt = KeyRingRuntime { rtPubring = pubring , rtSecring = secring , rtGrip = grip , rtWorkingKey = fmap packet wk , rtKeyDB = db } r <- performManipulations decrypt operation rt wk try' r $ \(rt,report_manips) -> do r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) try' r $ \report_wallets -> do r <- writeRingKeys operation rt -- db wk secring pubring try' r $ \report_rings -> do r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do import_hosts <- writeHostsFiles operation secring pubring hs return $ KikiResult (KikiSuccess rt) $ concat [ report_imports , report_externals , report_manips , report_wallets , report_rings , report_pems ] forM_ lked $ \(Just lk, fname) -> dotlock_release lk return ret parseOptionFile fname = do xs <- fmap lines (readFile fname) let ys = filter notComment xs notComment ('#':_) = False notComment cs = not (all isSpace cs) return ys -- | returns ( home directory -- , path to secret ring -- , path to public ring -- , fingerprint of working key -- ) getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String)) getHomeDir protohome = do homedir <- envhomedir protohome flip (maybe (return CantFindHome)) homedir $ \homedir -> do -- putStrLn $ "homedir = " ++show homedir let secring = homedir ++ "/" ++ "secring.gpg" pubring = homedir ++ "/" ++ "pubring.gpg" -- putStrLn $ "secring = " ++ show secring workingkey <- getWorkingKey homedir return $ KikiSuccess (homedir,secring,pubring,workingkey) where envhomedir opt = do gnupghome <- lookupEnv (homevar home) >>= \d -> return $ d >>= guard . (/="") >> d homed <- flip fmap getHomeDirectory $ \d -> fmap (const d) $ guard (d/="") let homegnupg = (++('/':(appdir home))) <$> homed let val = (opt `mplus` gnupghome `mplus` homegnupg) return $ val -- TODO: rename this to getGrip getWorkingKey homedir = do let o = Nothing h = Just homedir ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h -> let optfiles = map (second ((h++"/")++)) (maybe optfile_alts' (:[]) o') optfile_alts' = zip (False:repeat True) (optfile_alts home) o' = fmap (False,) o in filterM (doesFileExist . snd) optfiles args <- flip (maybe $ return []) ofile $ \(forgive,fname) -> parseOptionFile fname let config = map (topair . words) args where topair (x:xs) = (x,xs) return $ lookup "default-key" config >>= listToMaybe #if MIN_VERSION_base(4,6,0) #else lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isUserID (UserIDPacket {}) = True isUserID _ = False isTrust (TrustPacket {}) = True isTrust _ = False 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] 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 slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString]) slurpWIPKeys stamp "" = ([],[]) slurpWIPKeys stamp cs = let (b58,xs) = Char8.span (\x -> elem x base58chars) cs mb = decode_btc_key stamp (Char8.unpack b58) in if L.null b58 then let (ys,xs') = Char8.break (\x -> elem x 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 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 } rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey rsaKeyFromPacket p@(PublicKeyPacket {}) = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p return $ RSAKey n e rsaKeyFromPacket p@(SecretKeyPacket {}) = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p return $ RSAKey n e rsaKeyFromPacket _ = Nothing readPacketsFromWallet :: Maybe Packet -> FilePath -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))] readPacketsFromWallet wk fname = do timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ modificationTime <$> getFileStatus fname input <- L.readFile fname let (ks,_) = slurpWIPKeys timestamp input when (not (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 readPacketsFromFile :: FilePath -> IO Message readPacketsFromFile fname = do -- warn $ fname ++ ": reading..." input <- L.readFile fname #if MIN_VERSION_binary(0,7,0) return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> trace (fname++": read fail") $ Message [] #else return $ decode input #endif now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime signature_time ov = case if null cs then ds else cs of [] -> minBound xs -> last (sort 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 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 findTag tag wk subkey subsigs = (xs',minsig,ys') where vs = map (\sig -> (sig, do sig <- Just (packet . fst $ sig) guard (isSignaturePacket sig) guard $ flip isSuffixOf (fingerprint wk) . maybe "%bad%" id . signature_issuer $ sig listToMaybe $ map (signature_time . verify (Message [wk])) (signatures $ Message [wk,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 hs = filter (\p->isNotation p && notation_name p=="usage@") (hashed_subpackets . packet . fst $ sig) ks = map notation_value hs isNotation (NotationDataPacket {}) = True isNotation _ = False return (tag `elem` ks, sig) makeSig doDecrypt top fname subkey_p tag mbsig = do let wk = packet top wkun <- doDecrypt top try wkun $ \wkun -> do let grip = fingerprint wk addOrigin new_sig = do 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 = [ KeyFlagsPacket { certify_keys = False , sign_data = False , encrypt_communication = False , encrypt_storage = False , split_key = False , authentication = True , group_key = False } , NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = tag } -- implicitly added: -- , SignatureCreationTimePacket (fromIntegral timestamp) ] 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 do return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) else do let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $ maybeToList $ do e <- expires return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) notation = NotationDataPacket { notation_name = "usage@" , notation_value = tag , human_readable = True } sig' = sig { hashed_subpackets = times ++ [notation] ++ qs } new_sig <- pgpSign (Message [wkun]) (SubkeySignature wk (packet subkey_p) [sig'] ) SHA1 (fingerprint wk) newsig <- addOrigin new_sig return $ fmap (,[]) newsig data OriginFlags = OriginFlags { originallyPublic :: Bool, originalNum :: Int } deriving Show type OriginMap = Map.Map FilePath OriginFlags data MappedPacket = MappedPacket { packet :: Packet , usage_tag :: Maybe String , locations :: OriginMap } type TrustMap = Map.Map FilePath Packet type SigAndTrust = ( MappedPacket , TrustMap ) -- trust packets type KeyKey = [ByteString] data SubKey = SubKey MappedPacket [SigAndTrust] -- | This is a roster entry, it's poorly named -- but we are keeping the name around until -- we're sure we wont be cutting and pasting -- code with master any more data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key , rentrySigAndTrusts :: [SigAndTrust] -- sigs on main key , rentryUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids , rentrySubKeys :: (Map.Map KeyKey SubKey) -- subkeys } type KeyDB = Map.Map KeyKey KeyData origin :: Packet -> Int -> OriginFlags origin p n = OriginFlags ispub n where ispub = case p of SecretKeyPacket {} -> False _ -> True mappedPacket filename p = MappedPacket { packet = p , usage_tag = Nothing , locations = Map.singleton filename (origin p (-1)) } keykey key = -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, the same key with a different timestamp is -- considered distinct using this keykey implementation. fingerprint_material (key {timestamp=0}) -- TODO: smaller key? uidkey (UserIDPacket str) = str merge :: KeyDB -> FilePath -> Message -> KeyDB merge db filename (Message ps) = merge_ db filename qs where 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) _ | otherwise -> (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 merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) where keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT keycomp a b | keykey a==keykey b = EQ keycomp a b = error $ unlines ["Unable to merge keys:" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] asMapped n p = let m = mappedPacket filename p in m { locations = fmap (\x->x {originalNum=n}) (locations m) } asSigAndTrust n (p,tm) = (asMapped n p,tm) emptyUids = Map.empty -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db where -- 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 v | isKey p && not (is_subkey p) = case v of Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p])) { locations = Map.insert filename (origin p n) (locations key) } ) 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 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) mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p 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 ((asMapped n (minimumBy subcomp [packet key,p])) { locations = Map.insert filename (origin p n) (locations key) }) sigs where -- Compare master keys, LT is prefered for merging -- Compare subkeys, LT is prefered for merging subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT subcomp a b | keykey a==keykey b = EQ subcomp a b = error $ unlines ["Unable to merge subs:" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] -- subcomp_m a b = subcomp (packet a) (packet b) 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 mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust] mergeSig n sig sigs = let (xs,ys) = break (isSameSig sig) sigs in if null ys then sigs++[first (asMapped n) sig] else let y:ys'=ys in xs ++ (mergeSameSig n sig y : ys') isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b = a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] } isSameSig (a,_) (MappedPacket {packet=b},_) = a==b mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b = ( m { packet = (b { unhashed_subpackets = foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) }) , locations = Map.insert filename (origin a n) locs } , tb `Map.union` ta ) where -- TODO: when merging items, we should delete invalidated origins -- from the orgin map. mergeItem ys x = if x `elem` ys then ys else ys++[x] mergeSameSig n a b = b -- trace ("discarding dup "++show a) b mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig 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 n sig sigs) mergeSubSig n sig Nothing = error $ "Unable to merge subkey signature: "++(words (show sig) >>= take 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) } concatSort fname getp f = concat . sortByHint fname getp . map f sortByHint fname f = sortBy (comparing gethint) where gethint = maybe defnum originalNum . Map.lookup fname . locations . f defnum = -1 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 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)) flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket] flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs unk :: Bool -> MappedPacket -> MappedPacket unk isPublic = if isPublic then toPacket secretToPublic else id where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)} flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket] flattenAllUids fname ispub uids = concatSort fname head (flattenUid fname ispub) (Map.assocs uids) 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 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 -- name = maybe "" id $ listToMaybe onames -- TODO: more than one tor key? topk = packet topmp torkeys = do SubKey k sigs <- Map.elems subs let subk = packet k let sigs' = do torsig <- filter (has_tag "tor") $ map (packet . fst) sigs sig <- (signatures $ Message [topk,subk,torsig]) let v = verify (Message [topk]) sig -- Require parent's signature guard (not . null $ signatures_over v) let unhashed = unhashed_subpackets torsig subsigs = mapMaybe backsig unhashed -- This should consist only of 0x19 values -- subtypes = map signature_type subsigs 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 has_tag tag p = isSignaturePacket p && or [ tag `elem` mapMaybe usage (hashed_subpackets p) , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] -- 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) || names0 == names \\ onions 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 (_,(onions,names0)) = getHostnames kd notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions) 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 fingerdress :: Packet -> SockAddr fingerdress topk = maybe zero id $ 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 backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing socketFamily (SockAddrInet _ _) = AF_INET socketFamily (SockAddrInet6 _ _ _ _) = AF_INET6 socketFamily (SockAddrUnix _) = AF_UNIX