From fbf425fbef1c1e60fcdddfbd9b25976162725f97 Mon Sep 17 00:00:00 2001 From: joe Date: Sun, 24 Apr 2016 18:43:00 -0400 Subject: Refactored build of executable and library. --- lib/KeyRing.hs | 3505 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 3505 insertions(+) create mode 100644 lib/KeyRing.hs (limited to 'lib/KeyRing.hs') diff --git a/lib/KeyRing.hs b/lib/KeyRing.hs new file mode 100644 index 0000000..0fbf2c2 --- /dev/null +++ b/lib/KeyRing.hs @@ -0,0 +1,3505 @@ +--------------------------------------------------------------------------- +-- | +-- 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(..) + , MappedPacket(..) + , 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 + , secretPemFromPacket + , getCrossSignedSubkeys + ) 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, hPutStr, 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, stderr) +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 + deriving (Eq,Ord,Enum,Show) + +-- | 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. + deriving (Eq,Ord,Show) + +-- | 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. + } + deriving (Eq,Show) + + +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)) + +instance Show PassphraseSpec where + show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c) + show (PassphraseMemoizer _) = "PassphraseMemoizer" +instance Eq PassphraseSpec where + PassphraseSpec a b c == PassphraseSpec d e f + = and [a==d,b==e,c==f] + _ == _ + = False + + + +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,Show) + +-- | 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. + } + deriving (Eq,Show) + +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 -- fp: + | KeyTag Packet String -- fp:????/t: + | KeyUidMatch String -- u: + deriving Show + +data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum) +data SingleKeySpec = FingerprintMatch String + | SubstringMatch (Maybe MatchingField) String + | EmptyMatch + | AnyMatch + | WorkingKeyMatch + deriving (Show,Eq,Ord) + +-- A pair of specs. The first specifies an identity and the second +-- specifies a specific key (possibly master) associated with that +-- identity. +-- +-- When no slash is specified, context will decide whether the SingleKeySpec +-- is specifying an identity or a key belonging to the working identity. +type Spec = (SingleKeySpec,SingleKeySpec) + +parseSingleSpec :: String -> SingleKeySpec +parseSingleSpec "*" = AnyMatch +parseSingleSpec "-" = WorkingKeyMatch +parseSingleSpec "" = EmptyMatch +parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag +parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag +parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp +parseSingleSpec str + | is40digitHex str = FingerprintMatch str + | otherwise = SubstringMatch Nothing str + +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 + + + -- t:tor -- (FingerprintMatch "", SubstringMatch "tor") + -- u:joe -- (SubstringMatch "joe", FingerprintMatch "") + -- u:joe/ -- (SubstringMatch "joe", FingerprintMatch "!") + -- fp:4A39F/tor -- (FingerprintMatch "4A39F", SubstringMatch "tor") + -- u:joe/tor -- (SubstringMatch "joe", SubstringMatch "tor") + -- u:joe/t:tor -- (SubstringMatch "joe", SubstringMatch "tor") + -- u:joe/fp:4abf30 -- (SubstringMatch "joe", FingerprintMatch "4abf30") + -- joe/tor -- (SubstringMatch "joe", SubstringMatch "tor") + +-- | Parse a key specification. +-- The first argument is a grip for the default working key. +parseSpec :: String -> String -> (KeySpec,Maybe String) +parseSpec wkgrip spec = + if not slashed + then + case prespec of + AnyMatch -> (KeyGrip "", Nothing) + EmptyMatch -> error "Bad key spec." + WorkingKeyMatch -> (KeyGrip wkgrip, Nothing) + SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag) + SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str) + SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing) + FingerprintMatch fp -> (KeyGrip fp, Nothing) + else + case (prespec,postspec) of + (FingerprintMatch fp, SubstringMatch st t) + | st /= Just UserIDField -> (KeyGrip fp, Just t) + (SubstringMatch mt u, _) + | postspec `elem` [AnyMatch,EmptyMatch] + && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing) + (SubstringMatch mt u, SubstringMatch st t) + | mt /= Just KeyTypeField + && st /= Just UserIDField -> (KeyUidMatch u, Just t) + (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec" + (_,FingerprintMatch fp) -> error "todo: support /fp: spec" + (FingerprintMatch fp,_) -> error "todo: support fp:/ spec" + _ -> error "Bad key spec." + where + (preslash,slashon) = break (=='/') spec + slashed = not $ null $ take 1 slashon + postslash = drop 1 slashon + + prespec = parseSingleSpec preslash + postspec = parseSingleSpec postslash + +{- + - BUGGY +parseSpec grip spec = (topspec,subspec) + where + (topspec0,subspec0) = unprefix '/' spec + (toptyp,top) = unprefix ':' topspec0 + (subtyp,sub) = unprefix ':' subspec0 + topspec = case () of + _ | null top && or [ subtyp=="fp" + , null subtyp && is40digitHex sub + ] + -> KeyGrip sub + _ | null top && null grip -> KeyUidMatch sub + _ | null top -> KeyGrip grip + _ | toptyp=="fp" || (null toptyp && is40digitHex top) + -> KeyGrip top + _ | toptyp=="u" -> KeyUidMatch top + _ -> KeyUidMatch top + subspec = case subtyp of + "t" -> Just sub + "fp" | top=="" -> Nothing + "" | top=="" && is40digitHex sub -> Nothing + "" -> listToMaybe sub >> Just sub + _ -> Nothing + + is40digitHex xs = ys == xs && length ys==40 + where + ys = filter ishex xs + ishex c | '0' <= c && c <= '9' = True + | 'A' <= c && c <= 'F' = True + | 'a' <= c && c <= 'f' = True + ishex c = False + + -- | Split a string into two at the first occurance of the given + -- delimiter. If the delimeter does not occur, then the first + -- item of the returned pair is empty and the second item is the + -- input string. + unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p)) + where p = break (==c) spec +-} + + +filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] +filterMatches spec ks = filter (matchSpec spec . snd) ks + +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.hPutStr stderr 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], StreamInfo, t) + -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) +importSecretKey doDecrypt db' tup = do + try db' $ \(db',report0) -> do + r <- doImport doDecrypt + db' + tup + try r $ \(db'',report) -> do + return $ KikiSuccess (db'', report0 ++ report) + + +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,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], StreamInfo, t) + -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)])) +doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do + flip (maybe $ return CannotImportMasterKey) + subspec $ \tag -> do + (certs,keys) <- case typ of + PEMFile -> do + ps <- readSecretPEMFile (ArgFile fname) + let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) + = partition (isJust . spemCert) ps + return (certs,keys) + DNSPresentation -> do + p <- readSecretDNSFile (ArgFile fname) + return ([],[p]) + -- TODO Probably we need to move to a new design where signature + -- packets are merged into the database in one phase with null + -- signatures, and then the signatures are made in the next phase. + -- This would let us merge annotations (like certificates) from + -- seperate files. + foldM (importKey tag certs) (KikiSuccess (db,[])) keys + where + importKey tag certs prior key = do + try prior $ \(db,report) -> do + let (m0,tailms) = splitAt 1 ms + if (not (null tailms) || null m0) + then return $ AmbiguousKeySpec fname + else do + let kk = keykey key + cs = filter (\c -> kk==keykey (pcertKey c)) certs + blobs = map mkCertNotation $ nub $ map pcertBlob cs + mkCertNotation bs = NotationDataPacket + { human_readable = False + , notation_name = "x509cert@" + , notation_value = Char8.unpack bs } + datedKey = key { timestamp = fromTime $ minimum dates } + dates = fromTime (timestamp key) : map pcertTimestamp certs + r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey + try r $ \(db',report') -> do + return $ KikiSuccess (db',report++report') + +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 + +secretPemFromPacket packet = pemFromPacket Sec packet + +pemFromPacket Sec packet = + case key_algorithm packet of + RSA -> do + rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey + let asn1 = toASN1 rsa [] + bs = encodeASN1 DER asn1 + dta = Base64.encode (L.unpack bs) + output = writePEM "RSA PRIVATE KEY" dta + Just output + algo -> Nothing +pemFromPacket Pub packet = + case key_algorithm packet of + RSA -> do + rsa <- rsaKeyFromPacket packet + let asn1 = toASN1 (pkcs8 rsa) [] + bs = encodeASN1 DER asn1 + dta = Base64.encode (L.unpack bs) + output = writePEM "PUBLIC KEY" dta + Just output + algo -> Nothing +pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p +pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p +pemFromPacket AutoAccess _ = Nothing + +writeKeyToFile :: + Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] +writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do + case pemFromPacket (access stream) packet of + Just output -> do + let 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)] + Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)] + +writeKeyToFile False StreamInfo { typ = 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],StreamInfo)] + -> 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,stream,p) -> writeKeyToFile False stream (ArgFile f) p) + (rights ds') + return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs) + else do + return (head $ lefts ds') + where + decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub })) + = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted. + decryptKeys (fname,subspec,[p],stream) = do + pun <- doDecrypt p + try pun $ \pun -> do + return $ KikiSuccess (fname,stream,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] + , StreamInfo )]) + , [(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,stream) + (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd)) + notmissing + exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) 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,stream) = do + cmd <- initializer stream + return (fname,subspec,ms,stream,cmd) + rs <- forM cmds $ \tup@(fname,subspec,ms,stream,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,stream,cmd),r) <- rs + guard $ case r of + ExternallyGeneratedFile -> True + _ -> False + return (f,subspec,map fst ms,stream,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 + +getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet] +getCrossSignedSubkeys topk subs tag = do + SubKey k sigs <- Map.elems subs + let subk = packet k + let sigs' = do + torsig <- filter (has_tag tag) $ 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 + where + has_tag tag p = isSignaturePacket p + && or [ tag `elem` mapMaybe usage (hashed_subpackets p) + , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ] + + +-- | +-- Returns (ip6 fingerprint address,(onion names,other host names)) +-- +-- Requires a validly cross-signed tor key for each onion name returned. +-- (Signature checks are performed.) +getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString])) +getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames)) + where + othernames = do + mp <- flattenAllUids "" True uids + let p = packet mp + guard $ isSignaturePacket p + uh <- unhashed_subpackets p + case uh of + NotationDataPacket True "hostname@" v + -> return $ Char8.pack v + _ -> mzero + + addr = fingerdress topk + -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key? + topk = packet topmp + torkeys = getCrossSignedSubkeys topk subs "tor" + + -- subkeyPacket (SubKey k _ ) = k + onames :: [L.ByteString] + onames = map ( (<> ".onion") + . Char8.pack + . take 16 + . torhash ) + torkeys + +hasFingerDress :: KeyDB -> SockAddr -> Bool +hasFingerDress db addr | socketFamily addr/=AF_INET6 = False +hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db) + where + (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr + g' = map toUpper g + +-- We return into IO in case we want to make a signature here. +setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData +setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) = + -- TODO: we are removing the origin from the UID OriginMap, + -- when we should be removing origins from the locations + -- field of the sig's MappedPacket records. + -- Call getHostnames and compare to see if no-op. + if not (pred addr) || 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 -- cgit v1.2.3