--------------------------------------------------------------------------- -- | -- 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 PatternGuards #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE DeriveFunctor #-} {-# LANGUAGE DoAndIfThenElse #-} {-# LANGUAGE PatternGuards #-} {-# LANGUAGE ForeignFunctionInterface #-} {-# LANGUAGE LambdaCase #-} module KeyRing ( -- * Error Handling KikiResult(..) , KikiCondition(..) , KikiReportAction(..) , errorString , reportString -- * Manipulating Keyrings , runKeyRing , KeyRingOperation(..) , PassphraseSpec(..) , Transform(..) -- , PacketUpdate(..) -- , guardAuthentic -- * Describing File Operations , StreamInfo(..) , Access(..) , FileType(..) , InputFile(..) , Initializer(..) , KeyFilter(..) -- * Results of a KeyRing Operation , KeyRingRuntime(..) , OriginMapped(..) , MappedPacket , KeyDB , KeyData(..) , SubKey(..) , keyflags -- * Miscelaneous Utilities , isKey , isSecretKey , derRSA , derToBase32 , backsig , filterMatches , flattenKeys , flattenTop , Hosts.Hosts , isCryptoCoinKey , matchpr , parseSpec , Spec , parseUID , UserIDRecord(..) , pkcs8 , RSAPublicKey(..) , PKCS8_RSAPublicKey(..) , rsaKeyFromPacket , secretToPublic , selectPublicKey , selectSecretKey , usage , usageString , walletImportFormat , writePEM , getBindings , accBindings , isSubkeySignature , torhash , torUIDFromKey , ParsedCert(..) , parseCertBlob , packetFromPublicRSAKey , decodeBlob , selectPublicKeyAndSigs , x509cert , getHomeDir , unconditionally , SecretPEMData(..) , readSecretPEMFile , writeInputFileL , InputFileContext(..) , onionNameForContact , keykey , keyPacket , KeySpec(..) , MatchingField(..) , SpecError(..) , SingleKeySpec(..) , parseSpec3 , getHostnames , secretPemFromPacket , SubkeyStatus(..) , getSubkeys , writeKeyToFile , resolveForReport , KeyKey -- needed for Type sigs , makeMemoizingDecrypter , showPacket ) where import System.Environment import Control.Monad import Control.Exception ( catch ) import System.IO.Error ( isDoesNotExistError ) 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 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 import qualified Data.ByteString as S #if defined(VERSION_memory) import qualified Data.ByteString.Char8 as S8 import Data.ByteArray.Encoding #elif defined(VERSION_dataenc) import qualified Codec.Binary.Base32 as Base32 import qualified Codec.Binary.Base64 as Base64 #endif #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, hClose) 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) ) import GnuPGAgent as Agent import Types import PacketTranscoder import Transforms -- 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"] } spillable :: StreamInfo -> Bool spillable (spill -> KF_None) = False spillable _ = True isMutable :: StreamInfo -> Bool isMutable stream | KF_None <- fill stream = 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 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 PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey pkcs8 (RSAKey n e) = RSAKey8 n e 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" 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. } x509cert :: SignatureSubpacket -> Maybe Char8.ByteString x509cert (NotationDataPacket { human_readable = False , notation_name = "x509cert@" , notation_value = u }) = Just (Char8.pack u) x509cert _ = Nothing 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 KeySpec = KeyGrip String -- fp: | KeyTag Packet String -- fp:????/t: | KeyUidMatch String -- u: deriving Show data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum) data SingleKeySpec = FingerprintMatch String | SubstringMatch (Maybe MatchingField) String | EmptyMatch | AnyMatch | WorkingKeyMatch deriving (Show,Eq,Ord) getStr (FingerprintMatch x) = x getStr (SubstringMatch _ x) = x getStr _ = "" -- | Spec -- -- The product type, SingleKeySpec³ = Circle × Identity × Key. -- -- Key - A single public or private key (subkey, or master without subkeys) (eg, pem file) -- Identity - A single master key with all its subkeys -- Circle - A collection of master keys with their subkeys (eg, gpg file) -- -- The three fields are deliminated by slashes. -- -- When context does not disambiguate, use the following default rules: -- There are(is) -- - no slashes, so interpret as Key -- - one slash, so interpret as Identity/Key -- - two slashes, so interpret as Circle/Identity/Key -- -- (Any of the fields may be left empty.) type Spec = (SingleKeySpec,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 ('c':':':tag) = SubstringMatch (Just GroupIDField) 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 data SpecError = SpecENone String | SpecEMissMatch String (Maybe MatchingField) MatchingField | SpecETooBig Spec | SpecETooMany String deriving (Eq,Show,Ord) -- t:tor -- (AnyMatch , AnyMatch, SubstringMatch type "tor") -- u:joe -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "" ) -- u:joe/ -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "!" ) -- fp:4A39F/tor -- (AnyMatch , FingerprintMatch "4A39F", SubstringMatch type "tor") -- u:joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe/t:tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe/fp:4abf30 -- (AnyMatch , SubstringMatch user "joe", FingerprintMatch "4abf30") -- joe/tor -- (AnyMatch , SubstringMatch user "joe", SubstringMatch type "tor") -- u:joe//fp:4abf30 -- (SubstringMatch user "joe", AnyMatch , FingerprintMatch "4abf30") -- c:buds//fp:4abf3 -- (SubstringMatch circ "buds", AnyMatch , FingerprintMatch "4abf3" ) -- -- where type = Just KeyTypeField -- user = Just UserIDField -- circ = Just GroupIDField -- | parseSpec3 - Parse a key specification. parseSpec3 :: Maybe MatchingField -> String -> Either SpecError Spec parseSpec3 maybeExpecting spec@(wordsBy '/' -> fields) = tooBigError maybeExpecting =<< applyContext maybeExpecting . fixUpSubstrMatch <$> case fields of [] -> Left (SpecENone spec) xs@[t] -> let ds = [0] x = l ds xs getTup1 [x] = tupSection1 (adjustPos x maybeExpecting) x where tupSection1 0 = (AnyMatch,AnyMatch,) tupSection1 1 = (AnyMatch,,AnyMatch) tupSection1 2 = (,AnyMatch,AnyMatch) tupSection1 _ = tupSection1 0 in if all fst x then Right $ getTup1 (map (fst . snd) x) else Left $ mismatch x xs@[u,t] -> let ds = [1,0] x = l ds xs getTup2 [u,t] = indexHole (head (filter (`notElem` gots [u,t]) [0..2])) u t where gots xs = zipWith gotIndex [1,0] xs indexHole 0 = (,,AnyMatch) indexHole 1 = (,AnyMatch,) indexHole 2 = (AnyMatch,,) in if all fst x then Right $ getTup2 (map (fst . snd) x) else Left $ mismatch x xs@[c,u,t] -> let ds = [2,1,0] x = l ds xs getTup3 [a,b,c] = (a,b,c) in if all fst x then Right $ getTup3 (map (fst . snd) x) else Left $ mismatch x _ -> Left (SpecETooMany spec) where expectIndex dflt = maybe dflt fromEnum maybeExpecting l :: [Int] -> [String] -> [(Bool, (SingleKeySpec,Int))] l defaults specs = zipWith (\x y -> (valid (p x) y, (p x,y))) specs defaults where p x = parseSingleSpec x valid :: SingleKeySpec -> Int -> Bool valid spec dflt = ("tuc"::String) !! gotIndex dflt spec `notElem` forbidden (gotIndex dflt spec) where forbidden 0 = "uc" :: [Char] forbidden 1 = "tc" forbidden 2 = "tu" adjustPos (SubstringMatch (Just KeyTypeField) _) Nothing = 0 adjustPos (SubstringMatch (Just UserIDField) _) Nothing = 1 adjustPos (SubstringMatch (Just GroupIDField) _) Nothing = 2 adjustPos _ (Just i) = fromEnum i gotIndex :: Int -> SingleKeySpec -> Int gotIndex dflt (SubstringMatch (Just got) _) = fromEnum got gotIndex dflt _ = dflt -- FIXME: This throws an exception if input is -- not an erroneous SubstringMatch. mismatch :: [(Bool,(SingleKeySpec,Int))] -> SpecError mismatch xs = case find (not . fst) (reverse xs) of Just (_,(SubstringMatch mbF s,n)) -> SpecEMissMatch s mbF (toEnum n) fixUpSubstrMatch (g,u,t) = (set GroupIDField g, set UserIDField u, set KeyTypeField t) where set field (SubstringMatch Nothing xs) = SubstringMatch (Just field) xs set _ EmptyMatch = AnyMatch set field x = x applyContext :: Maybe MatchingField -> Spec -> Spec applyContext Nothing x = x applyContext (Just KeyTypeField) ((AnyMatch,u,AnyMatch)) = (AnyMatch,AnyMatch,u) applyContext (Just KeyTypeField) ((g,u,AnyMatch)) = (g,AnyMatch,u) applyContext (Just KeyTypeField) x = x applyContext (Just UserIDField) ((AnyMatch,AnyMatch,x)) = (AnyMatch,x,AnyMatch) applyContext (Just UserIDField) ((AnyMatch,u,x)) = (AnyMatch,u,x) applyContext (Just UserIDField) x = x applyContext (Just GroupIDField) ((AnyMatch,AnyMatch,x)) = (x,AnyMatch,AnyMatch) applyContext (Just GroupIDField) ((AnyMatch,u,x)) = (u,AnyMatch,x) applyContext (Just GroupIDField) x = x --applyContext (Just UserIDField) (Right (g,u,x)) = Left $ -- SpecEMissMatch (getStr g) (Just GroupIDField) UserIDField tooBigError _ s@(_,_,SubstringMatch (Just GroupIDField) str) = Left $ SpecEMissMatch str (Just GroupIDField) KeyTypeField tooBigError _ s@(_,SubstringMatch (Just GroupIDField) str,_) = Left $ SpecEMissMatch str (Just GroupIDField) UserIDField tooBigError Nothing x = return x tooBigError (Just UserIDField) s@(g,u,t) | g /= AnyMatch = Left $ SpecETooBig s -- (getStr g) (Just GroupIDField) UserIDField tooBigError (Just KeyTypeField) s@(g,u,t) | g /= AnyMatch = Left $ SpecETooBig s --(getStr g) (Just GroupIDField) KeyTypeField tooBigError _ x = return x wordsBy _ [] = [] wordsBy c xs = let (b,a) = span (/=c) xs in b:wordsBy c (drop 1 a) -- | 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 _ = "" 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 (\h x-> hPutStr h x >> hClose h) 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 -} generateSubkey :: PacketTranscoder -> KikiCondition (KeyData, [(FilePath, KikiReportAction)]) -- db -> (GenerateKeyParams, StreamInfo) -> IO (KikiCondition (KeyData, [(FilePath, KikiReportAction)])) generateSubkey transcode kd' (genparam,StreamInfo { spill = KF_Match tag }) = do try kd' $ \(kd,report0) -> do let subs = do SubKey p sigs <- Map.elems $ keySubKeys kd filter (has_tag tag) $ map (packet . fst) sigs if null subs then do newkey <- generateKey genparam kdr <- insertSubkey transcode (keykey (keyPacket kd)) kd [mkUsage tag] (ArgFile "") newkey try kdr $ \(newkd,report) -> do return $ KikiSuccess (newkd, report ++ [("", NewPacket $ showPacket newkey)]) else do return $ KikiSuccess (kd,report0) generateSubkey _ kd _ = return kd importSecretKey :: (PacketTranscoder) -> KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]) -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) importSecretKey transcode db' tup = do try db' $ \(db',report0) -> do r <- doImport transcode 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 readInputFileL' ctx f = readInputFileL ctx f `catch` \e -> do when (not $ isDoesNotExistError e) $ do return () -- todo report problem return L.empty 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 stream | KF_None <- fill stream = False isMutableHosts stream | Hosts <- typ stream = 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 -- | buildKeyDB -- -- merge all keyrings, PEM files, and wallets into process memory. -- buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation -> IO (KikiCondition (({- db -} KeyDB ,{- grip -} Maybe String ,{- wk -} Maybe MappedPacket ,{- hs -} ({- hostdbs0 -}[Hosts.Hosts], {- hostdbs -}[Hosts.Hosts], {- u1 -}Hosts.Hosts, {- gpgnames -}[(SockAddr, (KeyKey, KeyKey))], {- outgoing_names -}[SockAddr]) ,{- accs -} Map.Map InputFile Access ,{- doDecrypt -} PacketTranscoder ,{- unspilled -} Map.Map InputFile Message ) ,{- report_imports -} [(FilePath,KikiReportAction)])) buildKeyDB ctx grip0 keyring = do let files istyp = do (f,stream) <- Map.toList (opFiles keyring) guard (istyp $ typ stream) return f -- resolveInputFile ctx f ringMap0 = Map.filter (isring . typ) $ opFiles keyring (genMap,ringMap) = Map.partitionWithKey isgen ringMap0 where isgen (Generate _ _) _ = True isgen _ _ = False readp :: InputFile -> StreamInfo -> IO (StreamInfo, Message) 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 n) -- KeyRings (todo: KikiCondition reporting?) (spilled,mwk,grip,accs,keyqs,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 -- ring packets with info available for export -- | unspilled -- the rest (spilled,unspilled) = Map.partition (spillable . fst) ringPackets -- | keys -- process ringPackets, and get a map of fingerprint info to -- to a packet, remembering it's original file, access. keys :: Map.Map KeyKey (OriginMapped Query) mwk :: Maybe MappedPacket (mwk, keys) = keyQueries grip ringPackets -- | accs -- file access(Sec | Pub) lookup table accs :: Map.Map InputFile Access accs = fmap (access . fst) ringPackets return (spilled,mwk,grip,accs,keys,fmap snd unspilled) transcode <- makeMemoizingDecrypter keyring ctx (mwk,keyqs) let doDecrypt = transcode (Unencrypted,S2K 100 "") let wk = fmap packet mwk rt0 = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = wk , rtRingAccess = accs , rtKeyDB = Map.empty , rtPassphrases = transcode } -- autosigns and deletes transformed0 <- let trans :: InputFile -> (StreamInfo,Message) -> IO (KikiCondition (KikiReport,KeyDB)) 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,rtKeyDB rt2) -- XXX: Unspilled keys are not obtainable from rtKeyDB. -- If the working key is marked non spillable, then how -- would we look up it's UID and such? #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 - all keyrings combined into one db_rings :: Map.Map KeyKey KeyData db_rings = Map.foldlWithKey' mergeIt Map.empty transformed where mergeIt db f (_,dbtrans) = Map.unionWith mergeKeyData db dbtrans -- | reportTrans -- events, indexed by file reportTrans :: [(FilePath, KikiReportAction)] reportTrans = concat $ Map.elems $ fmap fst transformed -- Wallets let importWalletKey wk db' (top,fname,sub,tag) = do try db' $ \(db',report0) -> do r <- doImportG transcode 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 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? -- TODO: parseSpec3 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 (\case (ArgFile n,_,_,_,_) -> doesFileExist n _ -> return True) pems db <- foldM (importSecretKey transcode) (KikiSuccess (db,[])) imports try db $ \(db,reportPEMs) -> do -- generate keys let gens = mapMaybe g $ Map.toList genMap where g (Generate _ params,v) = Just (params,v) g _ = Nothing db <- generateInternals transcode mwk db gens try db $ \(db,reportGens) -> do r <- mergeHostFiles keyring db ctx try r $ \((db,hs),reportHosts) -> do return $ KikiSuccess ( (db, grip, mwk, hs, accs, transcode, unspilled) , reportTrans ++ reportWallets ++ reportPEMs ++ reportGens ++ reportHosts ) generateInternals :: PacketTranscoder -> Maybe MappedPacket -> Map.Map KeyKey KeyData -> [(GenerateKeyParams,StreamInfo)] -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])) generateInternals transcode mwk db gens = do case fmap packet mwk >>= \wk -> Map.lookup (keykey wk) db of Just kd0 -> do kd <- foldM (generateSubkey transcode) (KikiSuccess (kd0,[])) gens try kd $ \(kd,reportGens) -> do let kk = keykey $ packet $ fromJust mwk return $ KikiSuccess (Map.insert kk kd db,reportGens) Nothing -> return $ KikiSuccess (db,[]) unconditionally :: IO (KikiCondition a) -> IO a unconditionally action = do r <- action case r of KikiSuccess x -> return x e -> error $ errorString e 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 #if defined(VERSION_memory) where m = bigendian <$> functorToMaybe (convertFromBase Base64 $ Char8.toStrict blob) bigendian bs = snd $ S.foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs where nlen = S.length bs #elif defined(VERSION_dataenc) 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 #endif 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 :: PacketTranscoder -> Map.Map KeyKey KeyData -> (InputFile, Maybe [Char], [KeyKey], StreamInfo, t) -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) doImport transcode db (fname,subspec,ms,typ -> typ,_) = do flip (maybe $ return CannotImportMasterKey) subspec $ \tag -> do (certs,keys) <- case typ of PEMFile -> do ps <- readSecretPEMFile fname let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys) = partition (isJust . spemCert) ps return (certs,keys) DNSPresentation -> do p <- readSecretDNSFile 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 (resolveForReport Nothing 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 transcode db m0 (mkUsage tag:blobs) fname datedKey try r $ \(db',report') -> do return $ KikiSuccess (db',report++report') doImportG :: PacketTranscoder -> Map.Map KeyKey KeyData -> [KeyKey] -- m0, only head is used -> [SignatureSubpacket] -- tags -> InputFile -> Packet -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath,KikiReportAction)])) doImportG transcode db m0 tags fname key = do let kk = head m0 Just kd@(KeyData top topsigs uids subs) = Map.lookup kk db kdr <- insertSubkey transcode kk kd tags fname key try kdr $ \(kd',rrs) -> return $ KikiSuccess (Map.insert kk kd' db, rrs) insertSubkey transcode kk (KeyData top topsigs uids subs) tags inputfile key0 = do let topcipher = symmetric_algorithm $ packet top tops2k = s2k $ packet top doDecrypt = transcode (Unencrypted,S2K 100 "") fname = resolveForReport Nothing inputfile subkk = keykey key0 istor = do guard ("tor" `elem` mapMaybe usage tags) return $ torUIDFromKey key0 addOrigin (SubKey mp sigs) = let mp' = mp { locations = Map.insert fname (origin (packet mp) (-1)) (locations mp) } in SubKey mp' sigs subkey_result <- do case Map.lookup subkk subs of Just sub -> return $ KikiSuccess (False,addOrigin sub,Nothing) Nothing -> do wkun' <- doDecrypt top try wkun' $ \wkun -> do key' <- transcode (topcipher,tops2k) $ mappedPacket "" key0 try key' $ \key -> do return $ KikiSuccess (True, SubKey (mappedPacket fname key) [], Just (wkun,key)) try subkey_result $ \(is_new,subkey,decrypted) -> do let subs' = Map.insert subkk subkey subs 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 let keyflags = keyFlags (error "dummy argument (insertSubkey)") (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) (packet top) uid keyflags wkun' <- maybe (doDecrypt top) (return . KikiSuccess . fst) decrypted try wkun' $ \wkun -> do 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 key0 subsigs doInsert mbsig = do -- NEW SUBKEY BINDING SIGNATURE -- XXX: Here I assume that key0 is the unencrypted version -- of subkey_p. TODO: Check this assumption. sig' <- makeSig doDecrypt top fname subkey_p{packet=key0} 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 ( KeyData top topsigs uids' subs' , report ) report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)]) else id s = show (fmap fst minsig,fingerprint key0) in return (f report) case minsig of Nothing -> doInsert Nothing -- 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 ( KeyData top topsigs uids' subs' , report ) Just (False,sig) -> doInsert (Just sig) -- 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 stream | KF_None <- fill stream = False isMutableWallet stream | WalletFile {} <- typ stream = 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 -- | 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 -- TODO: parseSpec3 _ -> 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 -> Maybe String secretPemFromPacket packet = pemFromPacket Sec packet pemFromPacket :: Access -> Packet -> Maybe String pemFromPacket Sec packet = case key_algorithm packet of RSA -> do rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey let asn1 = toASN1 rsa [] bs = encodeASN1 DER asn1 #if defined(VERSION_memory) dta = S8.unpack $ convertToBase Base64 (L.toStrict bs) #elif defined(VERSION_dataenc) dta = Base64.encode (L.unpack bs) #endif 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 #if defined(VERSION_memory) dta = S8.unpack $ convertToBase Base64 (L.toStrict bs) #elif defined(VERSION_dataenc) dta = Base64.encode (L.unpack bs) #endif 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 :: StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)] writeKeyToFile 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 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) #if defined(VERSION_memory) b64 ac rsa = S8.unpack $ convertToBase Base64 $ i2bs_unsized i #elif defined(VERSION_dataenc) b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i) #endif 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 :: (PacketDecrypter) -> 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 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) initializeMissingPEMFiles :: KeyRingOperation -> InputFileContext -> Maybe String -> Maybe MappedPacket -> PacketTranscoder -> KeyDB -> IO (KikiCondition ( (KeyDB,[( FilePath , Maybe String , [MappedPacket] , StreamInfo )]) , [(FilePath,KikiReportAction)])) initializeMissingPEMFiles operation ctx grip mwk transcode db = do let decrypt = transcode (Unencrypted,S2K 100 "") -- nonexistants - files missing from disk. nonexistents <- filterM (fmap not . doesFileExist . fst) $ do (f,t) <- Map.toList (opFiles operation) f <- resolveInputFile ctx f return (f,t) -- missing - mutable files not in the keyring and not on disk -- notmissing - mutable keys in the keyring, but not on disk let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do (fname,stream) <- nonexistents let mutableTag | isMutable stream = usageFromFilter (fill stream) | otherwise = Nothing usage <- maybeToList mutableTag -- TODO: Use parseSpec3 -- TODO: Report error if generating without specifying usage tag. 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 <- case initializer stream of External str -> Just str _ -> Nothing 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 transcode) (KikiSuccess (db,[])) $ do ((f,subspec,ms,stream,cmd),r) <- rs guard $ case r of ExternallyGeneratedFile -> True _ -> False return (ArgFile f,subspec,map fst ms,stream,cmd) try v $ \(db,import_rs) -> do -- generateInternals let internals = mapMaybe getParams $ do (f,stream) <- nonexistents usage <- take 1 $ mapMaybe usageFromFilter [fill stream,spill stream] let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage guard $ null $ do (kk,kd) <- filterMatches topspec $ Map.toList db subkeysForExport subspec kd return (f,stream) where getParams (fname,stream) = case initializer stream of Internal p -> do _ <- internalInitializer stream Just $ Right (p, stream) WarnMissing warning -> Just $ Left warning _ -> Nothing internalInitializer StreamInfo { initializer = Internal _ , spill = KF_Match tag } = Just tag internalInitializer _ = Nothing mapM_ (hPutStrLn stderr) (lefts internals) v <- generateInternals transcode mwk db (rights internals) try v $ \(db,internals_rs) -> do return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs ++ import_rs ++ internals_rs) -- | combineTransforms -- remove rundant transforms, and compile the rest to PacketUpdate(s) -- -- eqivalent to: -- > combineTransforms = group (sort trans) >>= take 1 >>= resolveTransform t rt 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 -- | Load and update key files according to the specified 'KeyRingOperation'. runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime) runKeyRing operation = do -- get homedir and keyring files + fingerprint for working key 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 createDirectoryIfMissing True $ takeDirectory f 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,transcode,unspilled),report_imports) -> do externals_ret <- initializeMissingPEMFiles operation ctx grip wk transcode db try' externals_ret $ \((db,exports),report_externals) -> do let decrypt = transcode (Unencrypted,S2K 100 "") rt = KeyRingRuntime { rtPubring = homepubPath ctx , rtSecring = homesecPath ctx , rtGrip = grip , rtWorkingKey = fmap packet wk , rtKeyDB = db , rtRingAccess = accs , rtPassphrases = transcode } -- Maybe add signatures, delete subkeys 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 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 } 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 | Just flags <- lookup tag specials = KeyFlagsPacket { certify_keys = fromEnum flags .&. 0x1 /= 0 , sign_data = fromEnum flags .&. 0x2 /= 0 , encrypt_communication = fromEnum flags .&. 0x4 /= 0 , encrypt_storage = fromEnum flags .&. 0x8 /= 0 , split_key = False , authentication = False , group_key = False } where flagsets = [Special .. VouchSignEncrypt] specials = map (\f -> (usageString f, f)) flagsets mkUsage tag = NotationDataPacket { human_readable = True , notation_name = "usage@" , notation_value = tag } makeSig :: (PacketDecrypter) -> 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 | any isFlagsPacket tags = tags | otherwise = 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) isFlagsPacket (KeyFlagsPacket {}) = True isFlagsPacket _ = False 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 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 -} merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))] -> KeyDB merge_ db filename qs = foldl mergeit db (zip [0..] qs) where -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB mergeit db adding@(n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db where update Nothing = Just $ KeyData (mappedPacketWithHint filename p n) [] Map.empty Map.empty update (Just kd) = dbInsertPacket kd filename adding mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p whatP (a,_) = concat . take 1 . words . show $ a mergeKeyData :: KeyData -> KeyData -> KeyData mergeKeyData (KeyData atop asigs auids asubs) (KeyData btop bsigs buids bsubs) = KeyData top sigs uids subs where mergeMapped a b = MappedPacket { packet = packet a , locations = Map.union (locations a) (locations b) } top = mergeMapped atop btop sigs = foldl' (flip mergeSig) asigs bsigs uids = Map.unionWith mergeUIDSigs auids buids subs = Map.unionWith mergeSub asubs bsubs mergeSub :: SubKey -> SubKey -> SubKey mergeSub (SubKey a as) (SubKey b bs) = SubKey (mergeMapped a b) (foldl' (flip mergeSig) as bs) mergeUIDSigs :: ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap) mergeUIDSigs (as,am) (bs,bm) = (foldl' (flip mergeSig) as bs, Map.union am bm) dbInsertPacket :: KeyData -> FilePath -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> Maybe KeyData dbInsertPacket kd filename (n,(top,sub,ptt@(p,trustmap))) = update (Just kd) where asMapped n p = mappedPacketWithHint filename p n asSigAndTrust n (p,tm) = (asMapped n p,tm) -- 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) [] Map.empty 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 (first (flip (mappedPacketWithHint filename) 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) 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 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig (first (flip (mappedPacketWithHint filename) 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 (first (flip (mappedPacketWithHint filename) n) sig) sigs) mergeSubSig n sig Nothing = error $ "Unable to merge subkey signature: "++(words (show sig) >>= take 1) mergeSig :: SigAndTrust -> [SigAndTrust] -> [SigAndTrust] mergeSig sig sigs = let (xs,ys) = break (isSameSig (first packet sig)) sigs in if null ys then sigs++[sig] -- [first (flip (mappedPacketWithHint fname) n) sig] else let y:ys'=ys in xs ++ (mergeSameSig 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 :: (MappedPacket,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap) mergeSameSig (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket (packet a) && isSignaturePacket b = ( m { packet = b { unhashed_subpackets = union (unhashed_subpackets b) (unhashed_subpackets $ packet a) } , locations = Map.union (locations a) locs } -- Map.insert fname (origin a n) locs } -- TODO: when merging items, we should delete invalidated origins -- from the orgin map. , tb `Map.union` ta ) mergeSameSig a b = b -- trace ("discarding dup "++show a) b 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 data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned deriving (Eq,Ord,Enum,Show,Read) getSubkeys :: SubkeyStatus -> Packet -> Map.Map KeyKey SubKey -> String -> [Packet] getSubkeys ck topk subs tag = do SubKey k sigs <- Map.elems subs let subk = packet k let sigs' = do -- require tag torsig <- filter (has_tag tag) $ map (packet . fst) sigs -- require parent's signature when (ck > Unsigned) $ do sig <- (signatures $ Message [topk,subk,torsig]) let v = verify (Message [topk]) sig -- Require parent's signature guard (not . null $ signatures_over v) -- require child's back signature when (ck == CrossSigned ) $ do let unhashed = unhashed_subpackets torsig subsigs = mapMaybe backsig unhashed -- This should consist only of 0x19 values -- subtypes = map signature_type subsigs -- subtyp <- subtypes -- guard (subtyp == 0x19) 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 -- | -- 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 = getSubkeys CrossSigned 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 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 case getHostnames contact of (_,(name:_,_)) -> Just $ Char8.unpack name _ -> Nothing