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. --- KeyRing.hs | 3505 ------------------------------------------------------------ 1 file changed, 3505 deletions(-) delete mode 100644 KeyRing.hs (limited to 'KeyRing.hs') diff --git a/KeyRing.hs b/KeyRing.hs deleted file mode 100644 index 0fbf2c2..0000000 --- a/KeyRing.hs +++ /dev/null @@ -1,3505 +0,0 @@ ---------------------------------------------------------------------------- --- | --- 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