--------------------------------------------------------------------------- -- | -- 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 , getHomeDir , unconditionally , SecretPEMData(..) , readSecretPEMFile , writeInputFileL , InputFileContext(..) , onionNameForContact , keykey , keyPacket , KeySpec(..) , getHostnames ) 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, shiftR ) 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, break, pack ) import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, putStr, singleton, unfoldr, reverse ) import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 #if !defined(VERSION_cryptonite) import qualified Crypto.Hash.SHA1 as SHA1 import qualified Crypto.Types.PubKey.ECC as ECC #else import qualified Crypto.Hash as Vincent import Data.ByteArray (convert) import qualified Crypto.PubKey.ECC.Types as ECC #endif 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_x509(1,5,0) import Data.Hourglass.Types import Data.Hourglass #endif #if MIN_VERSION_unix(2,7,0) import System.Posix.Files ( setFdTimesHiRes ) import Foreign.C.Types ( CTime(..), CLong, CInt(..) ) #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 Compat 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 | DNSPresentation | 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 isSecretKeyFile :: FileType -> Bool isSecretKeyFile PEMFile = True isSecretKeyFile DNSPresentation = True isSecretKeyFile _ = 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. , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet) } -- | Roster-entry level actions data PacketUpdate = InducerSignature String [SignatureSubpacket] | SubKeyDeletion KeyKey KeyKey -- | 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. } -- | Use this to carry pasphrases from a previous run. | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet)) 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 | DeleteSubKey String -- ^ Delete the subkey specified by the given fingerprint and any -- associated signatures on that key. 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] : Null -- Doesn't seem to be neccessary, but i'm adding it -- to match PEM files I see in the wild. : 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 | DeletedPacket String 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 :: KikiReport -- ^ A list of non-fatal warnings and informational messages -- along with the files that triggered them. } type KikiReport = [ (FilePath, KikiReportAction) ] 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 _ -> Nothing is40digitHex xs = ys == xs && length ys==40 where ys = filter ishex xs ishex c | '0' <= c && c <= '9' = True | 'A' <= c && c <= 'F' = True | 'a' <= c && c <= 'f' = True ishex c = False -- | Split a string into two at the first occurance of the given -- delimiter. If the delimeter does not occur, then the first -- item of the returned pair is empty and the second item is the -- input string. unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) where p = break (==c) spec filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] filterMatches spec ks = filter (matchSpec spec . snd) ks 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 -> [(KeyKey,Packet,[Packet])] selectPublicKeyAndSigs (spec,mtag) db = case mtag of Nothing -> do (kk,r) <- Map.toList $ fmap (findbyspec spec) db (sub,sigs) <- r return (kk,sub,sigs) Just tag -> Map.toList (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 (kk, 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 $ (kk, 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 case ys of y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1 [] -> Nothing {- 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 :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString) cachedContents maybePrompt ctx fd = do ref <- newIORef Nothing return $ get maybePrompt ref fd where trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs get maybePrompt ref fd = do pw <- readIORef ref flip (flip maybe return) pw $ do if fd == FileDesc 0 then case maybePrompt of Just prompt -> S.putStr prompt Nothing -> return () else return () pw <- fmap trimCR $ readInputFileS ctx fd writeIORef ref (Just pw) return pw importSecretKey :: (MappedPacket -> IO (KikiCondition Packet)) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (FilePath, Maybe [Char], [KeyKey], FileType, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) importSecretKey doDecrypt db' tup = do try db' $ \(db',report0) -> do r <- doImport doDecrypt db' tup try r $ \(db'',report) -> do return $ KikiSuccess (db'', report0 ++ report) 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 , rtPassphrases = doDecrypt } 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 && isSecretKeyFile (typ stream) let us = mapMaybe usageFromFilter [fill stream,spill stream] usage <- take 1 us guard $ all (==usage) $ drop 1 us -- TODO: KikiCondition reporting for spill/fill usage mismatch? let (topspec,subspec) = parseSpec grip usage ms = map fst $ filterMatches topspec (Map.toList db) cmd = initializer stream return (n,subspec,ms,typ stream, cmd) imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems db <- foldM (importSecretKey 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 #if !defined(VERSION_cryptonite) derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy #else derToBase32 = map toLower . Base32.encode . S.unpack . sha1 where sha1 :: L.ByteString -> S.ByteString sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1) #endif derRSA :: Packet -> Maybe ByteString derRSA rsa = do k <- rsaKeyFromPacket rsa return $ encodeASN1 DER (toASN1 k []) unconditionally :: IO (KikiCondition a) -> IO a unconditionally action = do r <- action case r of KikiSuccess x -> return x e -> error $ errorString e 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 -- No instance for (ASN1Object RSA.PublicKey) parseCertBlob comp bs = do asn1 <- either (const Nothing) Just $ decodeASN1 DER bs let asn1' = drop 2 asn1 cert <- either (const Nothing) (Just . fst) (fromASN1 asn1') let _ = cert :: X509.Certificate notBefore :: UTCTime #if MIN_VERSION_x509(1,5,0) notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano where (vincentTime,_) = X509.certValidity cert #else (notBefore,_) = X509.certValidity cert #endif case X509.certPubKey cert of X509.PubKeyRSA key -> do let withoutkey = let ekey = toStrict $ encodeASN1 DER (toASN1 key []) (pre,post) = S.breakSubstring ekey $ toStrict bs post' = S.drop (S.length ekey) post len :: Word16 len = if S.null post then maxBound else fromIntegral $ S.length pre in if len < 4096 then encode len <> GZip.compress (Char8.fromChunks [pre,post']) else bs return ParsedCert { pcertKey = packetFromPublicRSAKey notBefore (MPI $ RSA.public_n key) (MPI $ RSA.public_e key) , pcertTimestamp = notBefore , pcertBlob = if comp then withoutkey else bs } _ -> Nothing 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 extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey extractRSAKeyFields kvs = do let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs n <- lookup "Modulus" kvs' e <- lookup "PublicExponent" kvs' d <- lookup "PrivateExponent" kvs' p <- lookup "Prime1" kvs' -- p q <- lookup "Prime2" kvs' -- q dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1) dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1) u <- lookup "Coefficient" kvs' {- case (d,p,dmodp1) of (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return () _ -> error "dmodp fail!" case (d,q,dmodqminus1) of (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return () _ -> error "dmodq fail!" -} return $ RSAPrivateKey { rsaN = n , rsaE = e , rsaD = d , rsaP = p , rsaQ = q , rsaDmodP1 = dmodp1 , rsaDmodQminus1 = dmodqminus1 , rsaCoefficient = u } where parseField blob = MPI <$> m where m = bigendian <$> Base64.decode (Char8.unpack blob) bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs where nlen = length bs rsaToPGP stamp rsa = SecretKeyPacket { version = 4 , timestamp = fromTime stamp -- toEnum (fromEnum stamp) , key_algorithm = RSA , key = [ -- public fields... ('n',rsaN rsa) ,('e',rsaE rsa) -- secret fields ,('d',rsaD rsa) ,('p',rsaQ rsa) -- Note: p & q swapped ,('q',rsaP rsa) -- Note: p & q swapped ,('u',rsaCoefficient rsa) ] -- , ecc_curve = def , s2k_useage = 0 , s2k = S2K 100 "" , symmetric_algorithm = Unencrypted , encrypted_data = "" , is_subkey = True } readSecretDNSFile :: InputFile -> IO Packet readSecretDNSFile fname = do let ctx = InputFileContext "" "" stamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1) . Char8.break (==':')) $ Char8.lines input alg = maybe RSA parseAlg $ lookup "Algorithm" kvs parseAlg spec = case Char8.words spec of nstr:_ -> case read (Char8.unpack nstr) :: Int of 2 -> DH 3 -> DSA -- SHA1 5 -> RSA -- SHA1 6 -> DSA -- NSEC3-SHA1 (RFC5155) 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155) 8 -> RSA -- SHA256 10 -> RSA -- SHA512 (RFC5702) -- 12 -> GOST 13 -> ECDSA -- P-256 SHA256 (RFC6605) 14 -> ECDSA -- P-384 SHA384 (RFC6605) _ -> RSA case alg of RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs readSecretPEMFile :: InputFile -> IO [SecretPEMData] readSecretPEMFile fname = do -- warn $ fname ++ ": reading ..." let ctx = InputFileContext "" "" -- Note: The key's timestamp is included in it's fingerprint. -- Therefore, we should attempt to preserve it. stamp <- getInputFileTime ctx fname input <- readInputFileL ctx fname let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input pkcs1 = fmap (parseRSAPrivateKey . pemBlob) $ pemParser $ Just "RSA PRIVATE KEY" cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob) $ pemParser $ Just "CERTIFICATE" parseRSAPrivateKey dta = do let e = decodeASN1 DER dta asn1 <- either (const $ mzero) return e rsa <- either (const mzero) (return . fst) (fromASN1 asn1) let _ = rsa :: RSAPrivateKey return $ PEMPacket $ rsaToPGP stamp rsa dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta mergeDate (_,obj) (Left tm) = (fromTime tm,obj) mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key') where key' = if tm < fromTime (timestamp key) then key { timestamp = fromTime tm } else key mergeDate (tm,_) (Right mb) = (tm,mb) return $ dta doImport :: Ord k => (MappedPacket -> IO (KikiCondition Packet)) -> Map.Map k KeyData -> (FilePath, Maybe [Char], [k], FileType, t) -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) doImport doDecrypt db (fname,subspec,ms,typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do (certs,keys) <- case typ of PEMFile -> do ps <- readSecretPEMFile (ArgFile fname) let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) = partition (isJust . spemCert) ps return (certs,keys) DNSPresentation -> do p <- readSecretDNSFile (ArgFile fname) return ([],[p]) -- TODO Probably we need to move to a new design where signature -- packets are merged into the database in one phase with null -- signatures, and then the signatures are made in the next phase. -- This would let us merge annotations (like certificates) from -- seperate files. foldM (importKey tag certs) (KikiSuccess (db,[])) keys where importKey tag certs prior key = do try prior $ \(db,report) -> do let (m0,tailms) = splitAt 1 ms if (not (null tailms) || null m0) then return $ AmbiguousKeySpec fname else do let kk = keykey key cs = filter (\c -> kk==keykey (pcertKey c)) certs blobs = map mkCertNotation $ nub $ map pcertBlob cs mkCertNotation bs = NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = Char8.unpack bs } datedKey = key { timestamp = fromTime $ minimum dates } dates = fromTime (timestamp key) : map pcertTimestamp certs r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey try r $ \(db',report') -> do return $ KikiSuccess (db',report++report') 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 -> [(FilePath,KikiReportAction)] {- -> KeyDB -> Maybe Packet -> FilePath -> FilePath -} -> IO (KikiCondition [(FilePath,KikiReportAction)]) writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = 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) -- TODO: We depend on an exact string match between the reported -- file origin of the deleted packet and the path of the file we are -- writing. Verify that this is a safe assumption. isdeleted (f',DeletedPacket _) = f'==f isdeleted _ = False guard (not (null new_packets) || any isdeleted report_manips) 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 :: String -> [String] 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 -> FileType -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] writeKeyToFile False PEMFile fname packet = do 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)] writeKeyToFile False DNSPresentation fname packet = do 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) b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i) where MPI i = ac rsa i2bs_unsized :: Integer -> S.ByteString i2bs_unsized 0 = S.singleton 0 i2bs_unsized i = S.reverse $ S.unfoldr go i where go i' = if i' <= 0 then Nothing else Just (fromIntegral i', (i' `shiftR` 8)) output = unlines [ "Private-key-format: v1.2" , "Algorithm: 8 (RSASHA256)" , "Modulus: " ++ b64 rsaN rsa , "PublicExponent: " ++ b64 rsaE rsa , "PrivateExponent: " ++ b64 rsaD rsa , "Prime1: " ++ b64 rsaP rsa , "Prime2: " ++ b64 rsaQ rsa , "Exponent1: " ++ b64 rsaDmodP1 rsa , "Exponent2: " ++ b64 rsaDmodQminus1 rsa , "Coefficient: " ++ b64 rsaCoefficient rsa ] 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],FileType,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,typ,p) -> writeKeyToFile False typ (ArgFile f) p) (rights ds') return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs) else do return (head $ lefts ds') where decryptKeys (fname,subspec,[p],typ,_) = do pun <- doDecrypt p try pun $ \pun -> do return $ KikiSuccess (fname,typ,pun) makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext -> Map.Map KeyKey MappedPacket -> IO (MappedPacket -> IO (KikiCondition Packet)) makeMemoizingDecrypter operation ctx keys = if null chains then do -- (*) Notice we do not pass ctx to resolveForReport. -- This is because the merge function does not currently use a context -- and the pws map keys must match the MappedPacket locations. -- TODO: Perhaps these should both be of type InputFile rather than -- FilePath? -- pws :: Map.Map FilePath (IO S.ByteString) {- pws <- Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ) (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above $ Map.filter (isJust . pwfile . typ) $ opFiles operation) -} let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n" pws2 <- Traversable.mapM (cachedContents prompt ctx) $ Map.fromList $ mapMaybe (\spec -> (,passSpecPassFile spec) `fmap` do guard $ isNothing $ passSpecKeySpec spec passSpecRingFile spec) passspecs defpw <- do Traversable.mapM (cachedContents prompt ctx . passSpecPassFile) $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp) && isNothing (passSpecKeySpec sp)) $ opPassphrases operation unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet) return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw else let PassphraseMemoizer f = head chains in return f where (chains,passspecs) = partition isChain $ opPassphrases operation where isChain (PassphraseMemoizer {}) = True isChain _ = False doDecrypt :: IORef (Map.Map KeyKey Packet) -> Map.Map FilePath (IO S.ByteString) -> Maybe (IO S.ByteString) -> MappedPacket -> IO (KikiCondition Packet) doDecrypt unkeysRef pws defpw mp0 = do unkeys <- readIORef unkeysRef let mp = fromMaybe mp0 $ do k <- Map.lookup kk keys return $ mergeKeyPacket "decrypt" mp0 k wk = packet mp0 kk = keykey wk fs = Map.keys $ locations mp decryptIt [] = return BadPassphrase decryptIt (getpw:getpws) = do -- TODO: This function should use mergeKeyPacket to -- combine the packet with it's unspilled version before -- attempting to decrypt it. pw <- getpw let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp) case symmetric_algorithm wkun of Unencrypted -> do writeIORef unkeysRef (Map.insert kk wkun unkeys) return $ KikiSuccess wkun _ -> decryptIt getpws getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw case symmetric_algorithm wk of Unencrypted -> return (KikiSuccess wk) _ -> maybe (decryptIt getpws) (return . KikiSuccess) $ Map.lookup kk unkeys performManipulations :: (MappedPacket -> IO (KikiCondition Packet)) -> KeyRingRuntime -> Maybe MappedPacket -> (KeyRingRuntime -> KeyData -> [PacketUpdate]) -> IO (KikiCondition (KeyRingRuntime,KikiReport)) performManipulations doDecrypt rt wk manip = do let db = rtKeyDB rt performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd r <- Traversable.mapM performAll db try (sequenceA r) $ \db -> do return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db) where perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport)) perform kd (InducerSignature uid subpaks) = do try kd $ \(kd,report) -> do flip (maybe $ return NoWorkingKey) wk $ \wk' -> do wkun' <- doDecrypt wk' try wkun' $ \wkun -> do let flgs = if keykey (keyPacket kd) == keykey wkun then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs) else [] sigOver = makeInducerSig (keyPacket kd) wkun (UserIDPacket uid) $ flgs ++ subpaks om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid toMappedPacket om p = (mappedPacket "" p) {locations=om} selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard . (== keykey whosign) . keykey)) vs keys = map keyPacket $ Map.elems (rtKeyDB rt) overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig]) vs :: [ ( Packet -- signature , Maybe SignatureOver -- Nothing means non-verified , Packet ) -- key who signed ] vs = do x <- maybeToList $ Map.lookup uid (keyUids kd) sig <- map (packet . fst) (fst x) o <- overs sig k <- keys let ov = verify (Message [k]) $ o signatures_over ov return (sig,Just ov,k) additional new_sig = do new_sig <- maybeToList new_sig guard (null $ selfsigs) signatures_over new_sig sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun) let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x , om `Map.union` snd x ) -- XXX: Shouldn't this signature generation show up in the KikiReport ? return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report ) perform kd (SubKeyDeletion topk subk) = do try kd $ \(kd,report) -> do let kk = keykey $ packet $ keyMappedPacket kd kd' | kk /= topk = kd | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd } pred k _ = k /= subk ps = concat $ maybeToList $ do SubKey mp sigs <- Map.lookup subk (keySubKeys kd) return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs ctx = InputFileContext (rtSecring rt) (rtPubring rt) rings = [HomeSec, HomePub] >>= resolveInputFile ctx return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ]) initializeMissingPEMFiles :: KeyRingOperation -> InputFileContext -> Maybe String -> (MappedPacket -> IO (KikiCondition Packet)) -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath , Maybe String , [MappedPacket] , FileType , 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 $ isSecretKeyFile (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,(typ stream),initializer stream) (exports0,ambiguous) = partition (\(_,_,ns,_,_)->null $ drop 1 $ (ns>>=snd)) notmissing exports = map (\(f,subspec,ns,typ,cmd) -> (f,subspec,ns >>= snd,typ,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,typ,mcmd) = do cmd <- mcmd return (fname,subspec,ms,typ,cmd) rs <- forM cmds $ \tup@(fname,subspec,ms,typ,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 (importSecretKey decrypt) (KikiSuccess (db,[])) $ do ((f,subspec,ms,typ,cmd),r) <- rs guard $ case r of ExternallyGeneratedFile -> True _ -> False return (f,subspec,map fst ms,typ,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 :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate] resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops where ops = map (\u -> InducerSignature u []) us us = filter torStyle $ Map.keys umap torStyle str = and [ uid_topdomain parsed == "onion" , uid_realname parsed `elem` ["","Anonymous"] , uid_user parsed == "root" , fmap (match . fst) (lookup (packet k) torbindings) == Just True ] where parsed = parseUID str match = (==subdom) . take (fromIntegral len) subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)] subdom = Char8.unpack subdom0 len = T.length (uid_subdomain parsed) torbindings = getTorKeys (map packet $ flattenTop "" True kd) getTorKeys pub = do xs <- groupBindings pub (_,(top,sub),us,_,_) <- xs guard ("tor" `elem` us) let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub return (top,(torhash,sub)) groupBindings pub = gs where (_,bindings) = getBindings pub bindings' = accBindings bindings code (c,(m,s),_,_,_) = (fingerprint_material m,-c) ownerkey (_,(a,_),_,_,_) = a sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b gs = groupBy sameMaster (sortBy (comparing code) bindings') resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk where topk = keykey $ packet k -- key to master of key to be deleted subk = do (k,sub) <- Map.toList submap guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub))) return k -- | 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 , rtPassphrases = decrypt } 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 report_manips 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 } deriving Show type TrustMap = Map.Map FilePath Packet type SigAndTrust = ( MappedPacket , TrustMap ) -- trust packets type KeyKey = [ByteString] data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show -- | 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 } deriving Show 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 onionNameForContact :: KeyKey -> KeyDB -> Maybe String onionNameForContact kk db = do contact <- Map.lookup kk db let (_,(name:_,_)) = getHostnames contact return $ Char8.unpack name