--------------------------------------------------------------------------- -- | -- Module : KeyRing -- -- Maintainer : joe@jerkface.net -- Stability : experimental -- -- kiki is a command-line utility for manipulating GnuPG's keyring files. This -- module is the programmer-facing API it uses to do that. -- -- Note: This is *not* a public facing API. I (the author) consider this -- library to be internal to kiki and subject to change at my whim. -- -- Typically, a client to this module would prepare a 'KeyRingOperation' -- describing what he wants done, and then invoke 'runKeyRing' to make it -- happen. {-# LANGUAGE CPP #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE NoPatternGuards #-} {-# LANGUAGE ForeignFunctionInterface #-} module KeyRing ( -- * Error Handling KikiResult(..) , KikiCondition(..) , KikiReportAction(..) , errorString , reportString -- * Manipulating Keyrings , runKeyRing , KeyRingOperation(..) , PassphraseSpec(..) , Transform(..) -- , PacketUpdate(..) -- , guardAuthentic -- * Describing File Operations , StreamInfo(..) , Access(..) , FileType(..) , InputFile(..) , KeyFilter(..) -- * Results of a KeyRing Operation , KeyRingRuntime(..) , KeyDB , KeyData(..) , SubKey(..) , packet , locations , keyflags -- * Miscelaneous Utilities , isKey , derRSA , derToBase32 , backsig , filterMatches , flattenKeys , flattenTop , Hosts.Hosts , isCryptoCoinKey , matchpr , parseSpec , parseUID , UserIDRecord(..) , pkcs8 , RSAPublicKey(..) , PKCS8_RSAPublicKey(..) , rsaKeyFromPacket , secretToPublic , selectPublicKey , selectSecretKey , usage , usageString , walletImportFormat , writePEM , getBindings , accBindings , isSubkeySignature , torhash , ParsedCert(..) , parseCertBlob , packetFromPublicRSAKey , decodeBlob , selectPublicKeyAndSigs , x509cert ) 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,Null), 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 ( POSIXTime, utcTimeToPOSIXSeconds ) import Data.Time.Clock ( UTCTime ) import Data.Bits ( Bits ) import Data.Text.Encoding ( encodeUtf8 ) import qualified Data.Map as Map import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt , index ) import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null ) 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.X509 as X509 import qualified Crypto.PubKey.RSA as RSA import qualified Codec.Compression.GZip as GZip import qualified Data.Text as T ( Text, unpack, pack, strip, reverse, drop, break, dropAround, length ) import qualified System.Posix.Types as Posix import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus , setFileCreationMask, setFileTimes ) #if MIN_VERSION_unix(2,7,0) import System.Posix.Files ( setFdTimesHiRes ) #else import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) import Foreign.Marshal.Array ( withArray ) import Foreign.Ptr import Foreign.C.Error ( throwErrnoIfMinus1_ ) import Foreign.Storable #endif import System.FilePath ( takeDirectory ) import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr) import Data.IORef import System.Posix.IO ( fdToHandle ) import qualified Data.Traversable as Traversable import Data.Traversable ( sequenceA ) #if ! MIN_VERSION_base(4,6,0) import GHC.Exts ( Down(..) ) #endif #if MIN_VERSION_binary(0,7,0) import Debug.Trace #endif import Network.Socket -- (SockAddr) import qualified Data.ByteString.Lazy.Char8 as Char8 import TimeUtil import PEM import ScanningParser 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 -- ^ A file named secring.gpg located in the home directory. -- See 'opHome'. | HomePub -- ^ A file named pubring.gpg located in the home directory. -- See 'opHome'. | ArgFile FilePath -- ^ Contents will be read or written from the specified path. | FileDesc Posix.Fd -- ^ Contents will be read or written from the specified file -- descriptor. | Pipe Posix.Fd Posix.Fd -- ^ Contents will be read from the first descriptor and updated -- content will be writen to the second. Note: Don't use Pipe -- for 'Wallet' files. (TODO: Wallet support) deriving (Eq,Ord,Show) -- type UsageTag = String type Initializer = String data FileType = KeyRingFile | PEMFile | WalletFile | Hosts -- | Use this type to indicate whether a file of type 'KeyRingFile' is expected -- to contain secret or public PGP key packets. Note that it is not supported -- to mix both in the same file and that the secret key packets include all of -- the information contained in their corresponding public key packets. data Access = AutoAccess -- ^ secret or public as appropriate based on existing content. -- (see 'rtRingAccess') | Sec -- ^ secret information | Pub -- ^ public information deriving (Eq,Ord,Show) -- | Note that the documentation here is intended for when this value is -- assigned to 'fill'. For other usage, see 'spill'. data KeyFilter = KF_None -- ^ No keys will be imported. | KF_Match String -- ^ Only the key that matches the spec will be imported. | KF_Subkeys -- ^ Subkeys will be imported if their owner key is -- already in the ring. TODO: Even if their signatures -- are bad? | KF_Authentic -- ^ Keys are imported if they belong to an authenticated -- identity (signed or self-authenticating). | KF_All -- ^ All keys will be imported. -- | This type describes how 'runKeyRing' will treat a file. data StreamInfo = StreamInfo { access :: Access -- ^ Indicates whether the file is allowed to contain secret information. , typ :: FileType -- ^ Indicates the format and content type of the file. , fill :: KeyFilter -- ^ This filter controls what packets will be inserted into a file. , spill :: KeyFilter -- -- ^ Use this to indicate whether or not a file's contents should be -- available for updating other files. Note that although its type is -- 'KeyFilter', it is usually interpretted as a boolean flag. Details -- depend on 'typ' and are as follows: -- -- 'KeyRingFile': -- -- * 'KF_None' - The file's contents will not be shared. -- -- * otherwise - The file's contents will be shared. -- -- 'PEMFile': -- -- * 'KF_None' - The file's contents will not be shared. -- -- * 'KF_Match' - The file's key will be shared with the specified owner -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be -- equal to this value; changing the usage or owner of a key is not -- supported via the fill/spill mechanism. -- -- * otherwise - Unspecified. Do not use. -- -- 'WalletFile': -- -- * The 'spill' setting is ignored and the file's contents are shared. -- (TODO) -- -- 'Hosts': -- -- * The 'spill' setting is ignored and the file's contents are shared. -- (TODO) -- , initializer :: Maybe String -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is -- interpretted as a shell command that may be used to create the key if it -- does not exist. , transforms :: [Transform] -- ^ Per-file transformations that occur before the contents of a file are -- spilled into the common pool. } spillable :: StreamInfo -> Bool spillable (spill -> KF_None) = False spillable _ = True isMutable :: StreamInfo -> Bool isMutable (fill -> KF_None) = False isMutable _ = True isring :: FileType -> Bool isring (KeyRingFile {}) = True isring _ = False ispem :: FileType -> Bool ispem (PEMFile {}) = True ispem _ = False {- pwfile :: FileType -> Maybe InputFile pwfile (KeyRingFile f) = f pwfile _ = Nothing -} iswallet :: FileType -> Bool iswallet (WalletFile {}) = True iswallet _ = False usageFromFilter :: MonadPlus m => KeyFilter -> m String usageFromFilter (KF_Match usage) = return usage usageFromFilter _ = mzero data KeyRingRuntime = KeyRingRuntime { rtPubring :: FilePath -- ^ Path to the file represented by 'HomePub' , rtSecring :: FilePath -- ^ Path to the file represented by 'HomeSec' , rtGrip :: Maybe String -- ^ Fingerprint or portion of a fingerprint used -- to identify the working GnuPG identity used to -- make signatures. , rtWorkingKey :: Maybe Packet -- ^ The master key of the working GnuPG identity. , rtKeyDB :: KeyDB -- ^ The common information pool where files spilled -- their content and from which they received new -- content. , rtRingAccess :: Map.Map InputFile Access -- ^ The 'Access' values used for files of type -- 'KeyRingFile'. If 'AutoAccess' was specified -- for a file, this 'Map.Map' will indicate the -- detected value that was used by the algorithm. } -- | TODO: Packet Update should have deletion action -- and any other kind of roster-entry level -- action. data PacketUpdate = InducerSignature String [SignatureSubpacket] -- | This type is used to indicate where to obtain passphrases. data PassphraseSpec = PassphraseSpec { passSpecRingFile :: Maybe FilePath -- ^ If not Nothing, the passphrase is to be used for packets -- from this file. , passSpecKeySpec :: Maybe String -- ^ Non-Nothing value reserved for future use. -- (TODO: Use this to implement per-key passphrase associations). , passSpecPassFile :: InputFile -- ^ The passphrase will be read from this file or file descriptor. } data Transform = Autosign -- ^ This operation will make signatures for any tor-style UID -- that matches a tor subkey and thus can be authenticated without -- requring the judgement of a human user. -- -- A tor-style UID is one of the following form: -- -- > Anonymous deriving (Eq,Ord) -- | This type describes an idempotent transformation (merge or import) on a -- set of GnuPG keyrings and other key files. data KeyRingOperation = KeyRingOperation { opFiles :: Map.Map InputFile StreamInfo -- ^ Indicates files to be read or updated. , opPassphrases :: [PassphraseSpec] -- ^ Indicates files or file descriptors where passphrases can be found. , opTransforms :: [Transform] -- ^ Transformations to be performed on the key pool after all files have -- been read and before any have been written. , opHome :: Maybe FilePath -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub' -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted -- and if that is not set, it falls back to $HOME/.gnupg. } resolveInputFile :: InputFileContext -> InputFile -> [FilePath] resolveInputFile ctx = resolve where resolve HomeSec = return (homesecPath ctx) resolve HomePub = return (homepubPath ctx) resolve (ArgFile f) = return f resolve _ = [] resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str) where str = case (fdr,fdw) of (0,1) -> "-" _ -> "&pipe" ++ show (fdr,fdw) resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str) where str = "&" ++ show fd resolveForReport mctx f = concat $ resolveInputFile ctx f where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx filesToLock :: KeyRingOperation -> InputFileContext -> [FilePath] filesToLock k ctx = do (f,stream) <- Map.toList (opFiles k) case fill stream of KF_None -> [] _ -> resolveInputFile ctx 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 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) = Right (RSAKey (MPI n) (MPI e), 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]:Null: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 (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" {- RSAPrivateKey ::= SEQUENCE { version Version, modulus INTEGER, -- n publicExponent INTEGER, -- e privateExponent INTEGER, -- d prime1 INTEGER, -- p prime2 INTEGER, -- q exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1) exponent2 INTEGER, -- d mod (q-1) coefficient INTEGER, -- (inverse of q) mod p otherPrimeInfos OtherPrimeInfos OPTIONAL } -} 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" -- | This type is used to indicate success or failure -- and in the case of success, return the computed object. -- The 'FunctorToMaybe' class is implemented to facilitate -- branching on failture. 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 -- | This type is used to describe events triggered by 'runKeyRing'. In -- addition to normal feedback (e.g. 'NewPacket'), it also may indicate -- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a -- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with -- many inputs and outputs, an operation may be partially (or even mostly) -- successful even when I/O failures occured. In this situation, the files may -- not have all the information they were intended to store, but they will be -- in a valid format for GnuPG or kiki to operate on in the future. 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 uncamel :: String -> String uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args where (.:) = fmap . fmap ( firstWord , otherWords ) = splitAt 1 ws ws = camel >>= groupBy (\_ c -> isLower c) ( camel, args) = splitAt 1 $ words str reportString :: KikiReportAction -> String reportString x = uncamel $ show x errorString :: KikiCondition a -> String errorString (KikiSuccess {}) = "success" errorString e = uncamel . show $ fmap (const ()) e -- | Errors in kiki are indicated by the returning of this record. data KikiResult a = KikiResult { kikiCondition :: KikiCondition a -- ^ The result or a fatal error condition. , kikiReport :: [ (FilePath, KikiReportAction) ] -- ^ A list of non-fatal warnings and informational messages -- along with the files that triggered them. } keyPacket :: KeyData -> Packet keyPacket (KeyData 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 x509cert :: SignatureSubpacket -> Maybe Char8.ByteString x509cert (NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = u }) = Just (Char8.pack u) x509cert _ = 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 -> 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) -> 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 -- "fp" -> ??? TODO: non-ehaustive patterns in case: fp:7/fp: 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 filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' where matchAll = KeyGrip "" subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip) subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag) match spec mps = not . null . snd . seek_key spec . map packet $ mps old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub) oldOrMatch spec sub = old sub || match spec (flattenSub "" True sub) subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty) then oldOrMatch subspec else old) subs where (topspec,subspec) = subkeySpec spec 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 selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(Packet,[Packet])] selectPublicKeyAndSigs (spec,mtag) db = case mtag of Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db Just tag -> Map.elems (Map.filter (matchSpec spec) db) >>= findsubs tag where topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd) findbyspec (KeyGrip g) kd = do filter ismatch $ topresult kd : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs)) (Map.elems $ keySubKeys kd) where ismatch (p,sigs) = matchpr g p ==g findbyspec spec kd = if matchSpec spec kd then [topresult kd] else [] findsubs tag (KeyData topk _ _ subs) = Map.elems subs >>= gettag where gettag (SubKey sub sigs) = do let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs (hastag,_) <- maybeToList mb guard hastag return $ (packet sub, map (packet . fst) sigs) 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 | 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 _ = "" data InputFileContext = InputFileContext { homesecPath :: FilePath , homepubPath :: FilePath } readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents readInputFileS ctx inp = do let fname = resolveInputFile ctx inp fmap S.concat $ mapM S.readFile fname readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents readInputFileL ctx inp = do let fname = resolveInputFile ctx inp fmap L.concat $ mapM L.readFile fname writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs) writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs) writeInputFileL ctx inp bs = do let fname = resolveInputFile ctx inp mapM_ (`L.writeFile` bs) fname -- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () -- writeStamped0 :: InputFileContext -> InputFile getWriteFD :: InputFile -> Maybe Posix.Fd getWriteFD (Pipe _ fd) = Just fd getWriteFD (FileDesc fd) = Just fd getWriteFD _ = Nothing writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> (Either Handle FilePath -> t -> IO ()) -> t -> IO () writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do h <- fdToHandle fd dowrite (Left h) bs handleIO_ (return ()) $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp) writeStamped0 ctx inp stamp dowrite bs = do let fname = resolveInputFile ctx inp forM_ fname $ \fname -> do createDirectoryIfMissing True $ takeDirectory fname dowrite (Right fname) bs setFileTimes fname stamp stamp {- This may be useful later. Commented for now, as it is not used. - writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO () writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs -} writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO () writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str 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 {- - This may be useful later. Commented for now as it is not used. - doesInputFileExist :: InputFileContext -> InputFile -> IO Bool doesInputFileExist ctx f = do case resolveInputFile ctx f of [n] -> doesFileExist n _ -> return True -} cachedContents :: InputFileContext -> InputFile -> IO (IO S.ByteString) cachedContents ctx 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 $ readInputFileS ctx fd writeIORef ref (Just pw) return pw importPEMKey :: (MappedPacket -> IO (KikiCondition Packet)) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (FilePath, 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 -> InputFileContext -> IO (KikiCondition ( ( Map.Map [Char8.ByteString] KeyData , ( [Hosts.Hosts] , [Hosts.Hosts] , Hosts.Hosts , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))] , [SockAddr])) , [(FilePath,KikiReportAction)])) mergeHostFiles krd db ctx = do let hns = files ishosts ishosts Hosts = True ishosts _ = False files istyp = do (f,stream) <- Map.toList (opFiles krd) guard (istyp $ typ stream) return f 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)),[]) writeHostsFiles :: KeyRingOperation -> InputFileContext -> ([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [(SockAddr, (t1, [Char8.ByteString]))], [SockAddr]) -> IO [(FilePath, KikiReportAction)] writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do let hns = files isMutableHosts isMutableHosts (fill -> KF_None) = False isMutableHosts (typ -> Hosts) = True isMutableHosts _ = False files istyp = do (f,stream) <- Map.toList (opFiles krd) guard (istyp stream) return f -- resolveInputFile ctx 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 unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h return $ map (first $ resolveForReport $ Just ctx) rs return $ concat rss isSecretKey :: Packet -> Bool isSecretKey (SecretKeyPacket {}) = True isSecretKey _ = False buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiCondition ((KeyDB ,Maybe String ,Maybe MappedPacket ,([Hosts.Hosts], [Hosts.Hosts], Hosts.Hosts, [(SockAddr, (KeyKey, KeyKey))], [SockAddr]) ,Map.Map InputFile Access ,MappedPacket -> IO (KikiCondition Packet) ,Map.Map InputFile Message ) ,[(FilePath,KikiReportAction)])) buildKeyDB ctx grip0 keyring = do let files isring = do (f,stream) <- Map.toList (opFiles keyring) guard (isring $ typ stream) resolveInputFile ctx f ringMap = Map.filter (isring . typ) $ opFiles keyring readp f stream = fmap readp0 $ readPacketsFromFile ctx f where readp0 ps = (stream { access = acc' }, ps) where acc' = case access stream of AutoAccess -> case ps of Message ((PublicKeyPacket {}):_) -> Pub Message ((SecretKeyPacket {}):_) -> Sec _ -> AutoAccess acc -> acc readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n)) -- KeyRings (todo: KikiCondition reporting?) (spilled,mwk,grip,accs,keys,unspilled) <- do #if MIN_VERSION_containers(0,5,0) ringPackets <- Map.traverseWithKey readp ringMap #else ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap #endif let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message) let grip = grip0 `mplus` (fingerprint <$> fstkey) where fstkey = do (_,Message ps) <- Map.lookup HomeSec ringPackets listToMaybe ps (spilled,unspilled) = Map.partition (spillable . fst) ringPackets keys :: Map.Map KeyKey MappedPacket keys = Map.foldl slurpkeys Map.empty $ Map.mapWithKey filterSecrets ringPackets where filterSecrets f (_,Message ps) = filter (isSecretKey . packet) $ zipWith (mappedPacketWithHint fname) ps [1..] where fname = resolveForReport (Just ctx) f slurpkeys m ps = m `Map.union` Map.fromList ps' where ps' = zip (map (keykey . packet) ps) ps wk = listToMaybe $ do fp <- maybeToList grip let matchfp mp = not (is_subkey p) && matchpr fp p == fp where p = packet mp Map.elems $ Map.filter matchfp keys accs = fmap (access . fst) ringPackets return (spilled,wk,grip,accs,keys,fmap snd unspilled) doDecrypt <- makeMemoizingDecrypter keyring ctx keys let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty } transformed0 <- let 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,(info,flattenKeys acc $ rtKeyDB rt2)) #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 = Map.foldlWithKey' mergeIt Map.empty transformed where mergeIt db f (_,(info,ps)) = merge db f ps reportTrans = concat $ Map.elems $ fmap fst transformed -- Wallets let importWalletKey wk db' (top,fname,sub,tag) = do try db' $ \(db',report0) -> do r <- doImportG doDecrypt db' (fmap keykey $ maybeToList wk) [mkUsage tag] fname sub try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) wms <- mapM (readw wk) (files iswallet) let wallet_keys = do maybeToList wk (fname,xs) <- wms (_,sub,(_,m)) <- xs (tag,top) <- Map.toList m return (top,fname,sub,tag) db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys try db $ \(db,reportWallets) -> do -- PEM files let pems = do (n,stream) <- Map.toList $ opFiles keyring grip <- maybeToList grip n <- resolveInputFile ctx n guard $ spillable stream && ispem (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? let (topspec,subspec) = parseSpec grip usage ms = map fst $ filterMatches topspec (Map.toList db) cmd = initializer stream 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 ctx try r $ \((db,hs),reportHosts) -> do return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled) , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts ) torhash :: Packet -> String torhash key = fromMaybe "" $ 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 data ParsedCert = ParsedCert { pcertKey :: Packet , pcertTimestamp :: UTCTime , pcertBlob :: L.ByteString } deriving (Show,Eq) data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert deriving (Show,Eq) spemPacket (PEMPacket p) = Just p spemPacket _ = Nothing spemCert (PEMCertificate p) = Just p spemCert _ = Nothing toStrict :: L.ByteString -> S.ByteString toStrict = foldr1 (<>) . L.toChunks 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,_) = X509.certValidity cert 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 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 } decodeBlob cert = if 0 /= (bs `L.index` 0) .&. 0x10 then bs else let (keypos0,bs') = L.splitAt 2 bs keypos :: Word16 keypos = decode keypos0 ds = GZip.decompress bs' (prekey,postkey) = L.splitAt (fromIntegral keypos) ds in prekey <> key <> postkey where bs = pcertBlob cert key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert 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. timestamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let dta = catMaybes $ scanAndParse (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 $ 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 } return dta doImport :: Ord k => (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map k KeyData -> (FilePath, Maybe [Char], [k], t) -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) doImport doDecrypt db (fname,subspec,ms,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do ps <- readSecretPEMFile (ArgFile fname) let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) = partition (isJust . spemCert) ps -- 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 (importPEMKey tag certs) (KikiSuccess (db,[])) keys where importPEMKey tag certs prior key = do try prior $ \(db,report) -> do let (m0,tailms) = splitAt 1 ms if (not (null tailms) || null m0) then return $ AmbiguousKeySpec fname else do let kk = keykey key cs = filter (\c -> kk==keykey (pcertKey c)) certs blobs = map mkCertNotation $ nub $ map pcertBlob cs mkCertNotation bs = NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = Char8.unpack bs } r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname key try r $ \(db',report') -> do return $ KikiSuccess (db',report++report') doImportG :: Ord k => (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map k KeyData -> [k] -> [SignatureSubpacket] -> [Char] -> Packet -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) doImportG doDecrypt db m0 tags 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 ("tor" `elem` mapMaybe usage tags) return $ "Anonymous " uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do let has_torid = do -- TODO: check for omitted real name field (sigtrusts,om) <- Map.lookup idstr uids listToMaybe $ do s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts)) signatures_over $ verify (Message [packet top]) s flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do wkun <- doDecrypt top try wkun $ \wkun -> do let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids) uid = UserIDPacket idstr -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags tor_ov = makeInducerSig (packet top) wkun uid keyflags sig_ov <- pgpSign (Message [wkun]) tor_ov SHA1 (fingerprint wkun) flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)])) (sig_ov >>= listToMaybe . signatures_over) $ \sig -> do let om = Map.singleton fname (origin sig (-1)) trust = Map.empty return $ KikiSuccess ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om} , trust)],om) uids , [] ) try uids' $ \(uids',report) -> do let SubKey subkey_p subsigs = subkey wk = packet top (xs',minsig,ys') = findTag tags wk key subsigs doInsert mbsig db = do -- NEW SUBKEY BINDING SIGNATURE sig' <- makeSig doDecrypt top fname subkey_p tags mbsig try sig' $ \(sig',report) -> do report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)] let subs' = Map.insert subkk (SubKey subkey_p $ xs'++[sig']++ys') subs return $ KikiSuccess ( 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 . 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 (fill -> KF_None) = False isMutableWallet (typ -> WalletFile {}) = True isMutableWallet _ = False files pred = do (f,stream) <- Map.toList (opFiles krd) guard (pred stream) resolveInputFile (InputFileContext "" "") 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 -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based -- to InputFile-based. 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) -- | returns Just True so as to indicate that -- the public portions of keys will be imported importPublic :: Maybe Bool importPublic = Just True -- | returns False True so as to indicate that -- the public portions of keys will be imported importSecret :: Maybe Bool importSecret = Just False -- TODO: Do we need to memoize this? 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.elems use_db guard $ matchSpec (KeyGrip fp) elm return $ keyPacket elm writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath -} -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeRingKeys krd rt {- db wk secring pubring -} unspilled = do let isring (KeyRingFile {}) = True isring _ = False db = rtKeyDB rt secring = rtSecring rt pubring = rtPubring rt ctx = InputFileContext secring pubring let s = do (f,f0,stream) <- do (f0,stream) <- Map.toList (opFiles krd) guard (isring $ typ stream) f <- resolveInputFile ctx f0 return (f,f0,stream) let db' = fromMaybe db $ do msg <- Map.lookup f0 unspilled return $ merge db f0 msg x = do let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool wantedForFill acc KF_None = importByExistingMaster -- Note the KF_None case is almost irrelevent as it will be -- filtered later when isMutable returns False. -- We use importByExistingMaster in order to generate -- MissingPacket warnings. To disable those warnings, use -- const Nothing instead. wantedForFill acc (KF_Match {}) = importByExistingMaster wantedForFill acc KF_Subkeys = importByExistingMaster wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd importByAccess acc kd wantedForFill acc KF_All = importByAccess acc importByAccess Pub kd = importPublic importByAccess Sec kd = importSecret importByAccess AutoAccess kd = mplus (importByExistingMaster kd) (error $ f ++ ": write public or secret key to file?") importByExistingMaster kd@(KeyData p _ _ _) = fmap originallyPublic $ Map.lookup f $ locations p d <- sortByHint f keyMappedPacket (Map.elems db') acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt) only_public <- maybeToList $ wantedForFill acc (fill stream) d guard $ only_public || isSecretKey (keyPacket d) case fill stream of KF_Match usage -> do grip <- maybeToList $ rtGrip rt flattenTop f only_public $ filterNewSubs f (parseSpec grip usage) d _ -> flattenTop f only_public d new_packets = filter isnew x where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p) guard (not $ null new_packets) return ((f0,isMutable stream),(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 -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c)) in (ws++[(f,x)],report++rs) else let rs = flip map new_packets $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c))) in (ws,report++rs) forM_ towrites $ \(f,x) -> do let m = Message $ map packet x -- warn $ "writing "++f writeInputFileL ctx f (encode m) return $ KikiSuccess report {- getSubkeysForExport kk subspec db = do kd <- maybeToList $ Map.lookup kk db subkeysForExport subspec kd -} -- | If provided Nothing for the first argument, this function returns the -- master key of the given identity. Otherwise, it returns all the subkeys of -- the given identity which have a usage tag that matches the first argument. 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 [mkUsage 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 -> InputFile -> Packet -> IO [(InputFile, 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 handleIO_ (return [(fname, FailedFileWrite)]) $ do saved_mask <- setFileCreationMask 0o077 -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. writeStamped (InputFileContext "" "") fname stamp output 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 (\(f,p) -> writeKeyToFile False "PEM" (ArgFile f) p) (rights ds') return $ KikiSuccess (map (first $ resolveForReport Nothing) $ 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 -> InputFileContext -> Map.Map KeyKey MappedPacket -> IO (MappedPacket -> IO (KikiCondition Packet)) makeMemoizingDecrypter operation ctx keys = do -- (*) Notice we do not pass ctx to resolveForReport. -- This is because the merge function does not currently use a context -- and the pws map keys must match the MappedPacket locations. -- TODO: Perhaps these should both be of type InputFile rather than -- FilePath? -- pws :: Map.Map FilePath (IO S.ByteString) {- pws <- Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above $ Map.filter (isJust . pwfile . typ) $ opFiles operation) -} pws2 <- Traversable.mapM (cachedContents ctx) $ Map.fromList $ mapMaybe (\spec -> (,passSpecPassFile spec) `fmap` do guard $ isNothing $ passSpecKeySpec spec passSpecRingFile spec) (opPassphrases operation) defpw <- do Traversable.mapM (cachedContents ctx . passSpecPassFile) $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) && isNothing (passSpecKeySpec sp)) $ opPassphrases operation unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw where doDecrypt :: IORef (Map.Map KeyKey Packet) -> Map.Map FilePath (IO S.ByteString) -> Maybe (IO S.ByteString) -> MappedPacket -> IO (KikiCondition Packet) doDecrypt unkeysRef pws defpw mp0 = do unkeys <- readIORef unkeysRef let mp = fromMaybe mp0 $ do k <- Map.lookup kk keys return $ mergeKeyPacket "decrypt" mp0 k wk = packet mp0 kk = keykey wk fs = Map.keys $ locations mp decryptIt [] = return BadPassphrase decryptIt (getpw:getpws) = do -- TODO: This function should use mergeKeyPacket to -- combine the packet with it's unspilled version before -- attempting to decrypt it. pw <- getpw let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) return $ KikiSuccess wkun _ -> decryptIt getpws getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw case symmetric_algorithm wk of Unencrypted -> return (KikiSuccess wk) _ -> maybe (decryptIt getpws) (return . KikiSuccess) $ Map.lookup kk unkeys performManipulations :: (MappedPacket -> IO (KikiCondition Packet)) -> KeyRingRuntime -> Maybe MappedPacket -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) -> IO (KikiCondition (KeyRingRuntime,[(FilePath,KikiReportAction)])) performManipulations doDecrypt rt wk manip = do let db = rtKeyDB rt performAll kd = foldM perform (KikiSuccess kd) $ manip rt kd r <- Traversable.mapM performAll db try (sequenceA r) $ \db -> do return $ KikiSuccess (rt { rtKeyDB = 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 (keyUids kd) sig <- map (packet . fst) (fst x) o <- overs sig k <- keys let ov = verify (Message [k]) $ o signatures_over ov return (sig,Just ov,k) additional new_sig = do new_sig <- maybeToList new_sig guard (null $ selfsigs) signatures_over new_sig sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x , om `Map.union` snd x ) return $ KikiSuccess $ kd { keyUids = Map.adjust f uid (keyUids kd) } initializeMissingPEMFiles :: KeyRingOperation -> InputFileContext -> Maybe String -> (MappedPacket -> IO (KikiCondition Packet)) -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath , Maybe String , [MappedPacket] , Maybe Initializer)]) , [(FilePath,KikiReportAction)])) initializeMissingPEMFiles operation ctx grip decrypt db = do nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (opFiles operation) f <- resolveInputFile ctx f return (f,t) let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do (fname,stream) <- nonexistents guard $ isMutable stream guard $ ispem (typ stream) usage <- usageFromFilter (fill stream) -- TODO: Error if no result? let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage -- ms will contain duplicates if a top key has multiple matching -- subkeys. This is intentional. -- 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 stream) (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",fromMaybe "" 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 -} 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 isSubkeySignature (SubkeySignature {}) = True isSubkeySignature _ = False -- Returned data is simmilar to getBindings but the Word8 codes -- are ORed together. accBindings :: Bits t => [(t, (Packet, Packet), [a], [a1], [a2])] -> [(t, (Packet, Packet), [a], [a1], [a2])] accBindings bs = as where gs = groupBy samePair . sortBy (comparing bindingPair) $ bs as = map (foldl1 combine) gs bindingPair (_,p,_,_,_) = pub2 p where pub2 (a,b) = (pub a, pub b) pub a = fingerprint_material a samePair a b = bindingPair a == bindingPair b combine (ac,p,akind,ahashed,aclaimaints) (bc,_,bkind,bhashed,bclaimaints) = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints) verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs) where verified = do sig <- signatures (Message nonkeys) let v = verify (Message keys) sig guard (not . null $ signatures_over v) return v (top,othersigs) = partition isSubkeySignature verified embedded = do sub <- top let sigover = signatures_over sub unhashed = sigover >>= unhashed_subpackets subsigs = mapMaybe backsig unhashed -- This should consist only of 0x19 values -- subtypes = map signature_type subsigs -- trace ("subtypes = "++show subtypes) (return ()) -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ()) sig <- signatures (Message ([topkey sub,subkey sub]++subsigs)) let v = verify (Message [subkey sub]) sig guard (not . null $ signatures_over v) return v smallpr k = drop 24 $ fingerprint k disjoint_fp ks = {- concatMap group2 $ -} transpose grouped where grouped = groupBy samepr . sortBy (comparing smallpr) $ ks samepr a b = smallpr a == smallpr b {- -- useful for testing group2 :: [a] -> [[a]] group2 (x:y:ys) = [x,y]:group2 ys group2 [x] = [[x]] group2 [] = [] -} getBindings :: [Packet] -> ( [([Packet],[SignatureOver])] -- other signatures with key sets -- that were used for the verifications , [(Word8, (Packet, Packet), -- (topkey,subkey) [String], -- usage flags [SignatureSubpacket], -- hashed data [Packet])] -- binding signatures ) getBindings pkts = (sigs,bindings) where (sigs,concat->bindings) = unzip $ do let (keys,_) = partition isKey pkts keys <- disjoint_fp keys let (bs,sigs) = verifyBindings keys pkts return . ((keys,sigs),) $ do b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs i <- map signature_issuer (signatures_over b) i <- maybeToList i who <- maybeToList $ find_key fingerprint (Message keys) i let (code,claimants) = case () of _ | who == topkey b -> (1,[]) _ | who == subkey b -> (2,[]) _ -> (0,[who]) let hashed = signatures_over b >>= hashed_subpackets kind = guard (code==1) >> hashed >>= maybeToList . usage return (code,(topkey b,subkey b), kind, hashed,claimants) resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops where ops = map (\u -> InducerSignature u []) us us = filter torStyle $ Map.keys umap torStyle str = and [ uid_topdomain parsed == "onion" , uid_realname parsed `elem` ["","Anonymous"] , uid_user parsed == "root" , fmap (match . fst) (lookup (packet k) torbindings) == Just True ] where parsed = parseUID str match = (==subdom) . take (fromIntegral len) subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] subdom = Char8.unpack subdom0 len = T.length (uid_subdomain parsed) torbindings = getTorKeys (map packet $ flattenTop "" True kd) getTorKeys pub = do xs <- groupBindings pub (_,(top,sub),us,_,_) <- xs guard ("tor" `elem` us) let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub return (top,(torhash,sub)) groupBindings pub = gs where (_,bindings) = getBindings pub bindings' = accBindings bindings code (c,(m,s),_,_,_) = (fingerprint_material m,-c) ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b gs = groupBy sameMaster (sortBy (comparing code) bindings') -- | Load and update key files according to the specified 'KeyRingOperation'. runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) runKeyRing operation = do homedir <- getHomeDir (opHome 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 ctx = InputFileContext secring pubring tolocks = filesToLock operation ctx secring <- return Nothing pubring <- return Nothing 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 -- merge all keyrings, PEM files, and wallets bresult <- buildKeyDB ctx grip0 operation try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation ctx grip decrypt db try' externals_ret $ \((db,exports),report_externals) -> do let rt = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = fmap packet wk , rtKeyDB = db , rtRingAccess = accs } r <- performManipulations decrypt rt wk (combineTransforms $ opTransforms operation) try' r $ \(rt,report_manips) -> do r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk) try' r $ \report_wallets -> do r <- writeRingKeys operation rt unspilled try' r $ \report_rings -> do r <- writePEMKeys decrypt (rtKeyDB rt) exports try' r $ \report_pems -> do import_hosts <- writeHostsFiles operation ctx 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 :: FilePath -> IO [String] 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 <- fmap (mfilter (/="")) $ lookupEnv (homevar home) homed <- fmap (mfilter (/="") . Just) getHomeDirectory 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 :: String -> IO (Maybe String) lookupEnv var = handleIO_ (return Nothing) $ fmap Just (getEnv var) #endif isKey :: Packet -> Bool isKey (PublicKeyPacket {}) = True isKey (SecretKeyPacket {}) = True isKey _ = False isUserID :: Packet -> Bool isUserID (UserIDPacket {}) = True isUserID _ = False isTrust :: Packet -> Bool isTrust (TrustPacket {}) = True isTrust _ = False sigpackets :: Monad m => Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet sigpackets typ hashed unhashed = return $ signaturePacket 4 -- version typ -- 0x18 subkey binding sig, or 0x19 back-signature RSA SHA1 hashed unhashed 0 -- Word16 -- Left 16 bits of the signed hash value [] -- [MPI] secretToPublic :: Packet -> Packet secretToPublic pkt@(SecretKeyPacket {}) = PublicKeyPacket { version = version pkt , timestamp = timestamp pkt , key_algorithm = key_algorithm pkt -- , ecc_curve = ecc_curve pkt , key = let seckey = key pkt pubs = public_key_fields (key_algorithm pkt) in filter (\(k,v) -> k `elem` pubs) seckey , is_subkey = is_subkey pkt , v3_days_of_validity = Nothing } secretToPublic pkt = pkt 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 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 } rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey rsaKeyFromPacket p | isKey p = do n <- lookup 'n' $ key p e <- lookup 'e' $ key p return $ RSAKey n e rsaKeyFromPacket _ = Nothing 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 readPacketsFromFile :: InputFileContext -> InputFile -> IO Message readPacketsFromFile ctx fname = do -- warn $ fname ++ ": reading..." input <- readInputFileL ctx fname #if MIN_VERSION_binary(0,7,0) return $ case decodeOrFail input of Right (_,_,msg ) -> msg Left (_,_,_) -> -- FIXME -- trace (fname++": read fail") $ Message [] #else return $ decode input #endif -- | Get the time stamp of a signature. -- -- Warning: This function checks unhashed_subpackets if no timestamp occurs in -- the hashed section. TODO: change this? -- signature_time :: SignatureOver -> Word32 signature_time ov = case (if null cs then ds else cs) of [] -> minBound xs -> maximum xs where ps = signatures_over ov ss = filter isSignaturePacket ps cs = concatMap (concatMap creationTime . hashed_subpackets) ss ds = concatMap (concatMap creationTime . unhashed_subpackets) ss creationTime (SignatureCreationTimePacket t) = [t] creationTime _ = [] splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t]) splitAtMinBy comp xs = minimumBy comp' xxs where xxs = zip (inits xs) (tails xs) comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs) compM (Just a) (Just b) = comp a b compM Nothing mb = GT compM _ _ = LT -- | Given list of subpackets, a master key, one of its subkeys and a -- list of signatures on that subkey, yields: -- -- * preceding list of signatures -- -- * The most recent valid signature made by the master key along with a -- flag that indicates whether or not all of the supplied subpackets occur in -- it or, if no valid signature from the working key is present, Nothing. -- -- * following list of signatures -- findTag :: [SignatureSubpacket] -> Packet -> Packet -> [(MappedPacket, b)] -> ([(MappedPacket, b)], Maybe (Bool, (MappedPacket, b)), [(MappedPacket, b)]) findTag tag topk subkey subsigs = (xs',minsig,ys') where vs = map (\sig -> (sig, do sig <- Just (packet . fst $ sig) guard (isSignaturePacket sig) guard $ flip isSuffixOf (fingerprint topk) . fromMaybe "%bad%" . signature_issuer $ sig listToMaybe $ map (signature_time . verify (Message [topk])) (signatures $ Message [topk,subkey,sig]))) subsigs (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs xs' = map fst xs ys' = map fst $ if isNothing minsig then ys else drop 1 ys minsig = do (sig,ov) <- listToMaybe ys ov let hshed = hashed_subpackets $ packet $ fst sig return ( null $ tag \\ hshed, sig) mkUsage :: String -> SignatureSubpacket mkUsage tag = NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = tag } makeSig :: (MappedPacket -> IO (KikiCondition Packet)) -> MappedPacket -> [Char] -> MappedPacket -> [SignatureSubpacket] -> Maybe (MappedPacket, Map.Map k a) -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction])) makeSig doDecrypt top fname subkey_p tags mbsig = do let wk = packet top wkun <- doDecrypt top try wkun $ \wkun -> do let grip = fingerprint wk addOrigin new_sig = flip (maybe $ return FailedToMakeSignature) (new_sig >>= listToMaybe . signatures_over) $ \new_sig -> do let mp' = mappedPacket fname new_sig return $ KikiSuccess (mp', Map.empty) parsedkey = [packet subkey_p] hashed0 = KeyFlagsPacket { certify_keys = False , sign_data = False , encrypt_communication = False , encrypt_storage = False , split_key = False , authentication = True , group_key = False } : tags -- implicitly added: -- , SignatureCreationTimePacket (fromIntegral timestamp) subgrip = fingerprint (head parsedkey) back_sig <- pgpSign (Message parsedkey) (SubkeySignature wk (head parsedkey) (sigpackets 0x19 hashed0 [IssuerPacket subgrip])) (if key_algorithm (head parsedkey)==ECDSA then SHA256 else SHA1) subgrip let iss = IssuerPacket (fingerprint wk) cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig) unhashed0 = maybe [iss] cons_iss back_sig new_sig <- pgpSign (Message [wkun]) (SubkeySignature wk (head parsedkey) (sigpackets 0x18 hashed0 unhashed0)) SHA1 grip let newSig = do r <- addOrigin new_sig return $ fmap (,[]) r flip (maybe newSig) mbsig $ \(mp,trustmap) -> do let sig = packet mp isCreation (SignatureCreationTimePacket {}) = True isCreation _ = False isExpiration (SignatureExpirationTimePacket {}) = True isExpiration _ = False (cs,ps) = partition isCreation (hashed_subpackets sig) (es,qs) = partition isExpiration ps stamp = listToMaybe . sortBy (comparing Down) $ map unwrap cs where unwrap (SignatureCreationTimePacket x) = x exp = listToMaybe $ sort $ map unwrap es where unwrap (SignatureExpirationTimePacket x) = x expires = liftA2 (+) stamp exp timestamp <- now if fmap ( (< timestamp) . fromIntegral) expires == Just True then return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] ) else do let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp)) $ maybeToList $ do e <- expires return $ SignatureExpirationTimePacket (e - fromIntegral timestamp) sig' = sig { hashed_subpackets = times ++ (qs `union` tags) } new_sig <- pgpSign (Message [wkun]) (SubkeySignature wk (packet subkey_p) [sig'] ) SHA1 (fingerprint wk) newsig <- addOrigin new_sig return $ fmap (,[]) newsig data OriginFlags = OriginFlags { originallyPublic :: Bool, originalNum :: Int } deriving Show type OriginMap = Map.Map FilePath OriginFlags data MappedPacket = MappedPacket { packet :: Packet , 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 GPG Identity which includes a master key and all its UIDs and -- subkeys and associated signatures. data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key , keySigAndTrusts :: [SigAndTrust] -- sigs on main key , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids , keySubKeys :: (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 :: FilePath -> Packet -> MappedPacket mappedPacket filename p = MappedPacket { packet = p , locations = Map.singleton filename (origin p (-1)) } mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket mappedPacketWithHint filename p hint = MappedPacket { packet = p , locations = Map.singleton filename (origin p hint) } keykey :: Packet -> KeyKey keykey key = -- Note: The key's timestamp is normally included in it's fingerprint. -- This is undesirable for kiki because it causes the same -- key to be imported multiple times and show as apparently -- distinct keys with different fingerprints. -- Thus, we will remove the timestamp. fingerprint_material (key {timestamp=0}) -- TODO: smaller key? uidkey :: Packet -> String uidkey (UserIDPacket str) = str 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 {- onionName :: KeyData -> (SockAddr,L.ByteString) onionName kd = (addr,name) where (addr,(name:_,_)) = getHostnames kd -} keyCompare :: String -> Packet -> Packet -> Ordering keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT keyCompare what a b | keykey a==keykey b = EQ keyCompare what a b = error $ unlines ["Unable to merge "++what++":" , fingerprint a , PP.ppShow a , fingerprint b , PP.ppShow b ] mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket mergeKeyPacket what key p = key { packet = minimumBy (keyCompare what) [packet key,packet p] , locations = Map.union (locations key) (locations p) } merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) where asMapped n p = mappedPacketWithHint filename p n 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 :: Maybe KeyData -> Maybe KeyData 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 (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 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 (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 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') where 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 = union (unhashed_subpackets b) (unhashed_subpackets a) } , locations = Map.insert filename (origin a n) locs } -- TODO: when merging items, we should delete invalidated origins -- from the orgin map. , tb `Map.union` ta ) 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 :: FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a] concatSort fname getp f = concat . sortByHint fname getp . map f sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a] 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 = fromMaybe "" $ 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 = 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 backsig :: SignatureSubpacket -> Maybe Packet backsig (EmbeddedSignaturePacket s) = Just s backsig _ = Nothing socketFamily :: SockAddr -> Family socketFamily (SockAddrInet _ _) = AF_INET socketFamily (SockAddrInet6 {}) = AF_INET6 socketFamily (SockAddrUnix _) = AF_UNIX #if ! MIN_VERSION_unix(2,7,0) setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO () setFdTimesHiRes (Posix.Fd fd) atime mtime = withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times -> throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times) data CTimeSpec = CTimeSpec Posix.EpochTime CLong instance Storable CTimeSpec where sizeOf _ = (16) alignment _ = alignment (undefined :: CInt) poke p (CTimeSpec sec nsec) = do ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec peek p = do sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p return $ CTimeSpec sec nsec toCTimeSpec :: POSIXTime -> CTimeSpec toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac) where (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac') (sec', frac') = properFraction $ toRational t foreign import ccall unsafe "futimens" c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt #endif