--------------------------------------------------------------------------- -- | -- 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 (module KeyRing.Types, module KeyRing, module KeyRing.BuildKeyDB) 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 KeyRing.BuildKeyDB (accBindings, backsig, buildKeyDB, combineTransforms, concatSort, derRSA, derToBase32, filterMatches, findTag, fingerdress, flattenAllUids, flattenKeys, flattenSub, flattenTop, generateInternals, getBindings, getHostnames, getSubkeys, importSecretKey, insertSubkey, isKey, isSecretKey, isSubkeySignature, isUserID, keyFlags0, keyPacket, keyflags, keykey, mappedPacket, matchSpec, matchpr, merge, mergeKeyPacket, mkUsage, origin, packetFromPublicRSAKey, parseCertBlob, parseSingleSpec, parseSpec, parseUID, performManipulations, readInputFileL, readSecretPEMFile, resolveForReport, resolveInputFile, rsaKeyFromPacket, secp256k1_id, secretToPublic, seek_key, selectKey0, selectPublicKey, showPacket, sortByHint, subkeyMappedPacket, torhash, try, usage, usageFromFilter, usageString) 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" reportString :: KikiReportAction -> String reportString x = uncamel $ show x -- | 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 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