summaryrefslogtreecommitdiff
path: root/KeyRing.hs
diff options
context:
space:
mode:
authorjoe <joe@jerkface.net>2016-04-24 18:43:00 -0400
committerjoe <joe@jerkface.net>2016-04-24 18:43:00 -0400
commitfbf425fbef1c1e60fcdddfbd9b25976162725f97 (patch)
treeb3877b56401f22efed0486ae10950af3a5ebadf8 /KeyRing.hs
parent7d8798f60b11973fd17d85caf3da2e8473842d2a (diff)
Refactored build of executable and library.
Diffstat (limited to 'KeyRing.hs')
-rw-r--r--KeyRing.hs3505
1 files changed, 0 insertions, 3505 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
deleted file mode 100644
index 0fbf2c2..0000000
--- a/KeyRing.hs
+++ /dev/null
@@ -1,3505 +0,0 @@
1---------------------------------------------------------------------------
2-- |
3-- Module : KeyRing
4--
5-- Maintainer : joe@jerkface.net
6-- Stability : experimental
7--
8-- kiki is a command-line utility for manipulating GnuPG's keyring files. This
9-- module is the programmer-facing API it uses to do that.
10--
11-- Note: This is *not* a public facing API. I (the author) consider this
12-- library to be internal to kiki and subject to change at my whim.
13--
14-- Typically, a client to this module would prepare a 'KeyRingOperation'
15-- describing what he wants done, and then invoke 'runKeyRing' to make it
16-- happen.
17{-# LANGUAGE CPP #-}
18{-# LANGUAGE TupleSections #-}
19{-# LANGUAGE ViewPatterns #-}
20{-# LANGUAGE OverloadedStrings #-}
21{-# LANGUAGE DeriveFunctor #-}
22{-# LANGUAGE DoAndIfThenElse #-}
23{-# LANGUAGE NoPatternGuards #-}
24{-# LANGUAGE ForeignFunctionInterface #-}
25module KeyRing
26 (
27 -- * Error Handling
28 KikiResult(..)
29 , KikiCondition(..)
30 , KikiReportAction(..)
31 , errorString
32 , reportString
33 -- * Manipulating Keyrings
34 , runKeyRing
35 , KeyRingOperation(..)
36 , PassphraseSpec(..)
37 , Transform(..)
38 -- , PacketUpdate(..)
39 -- , guardAuthentic
40 -- * Describing File Operations
41 , StreamInfo(..)
42 , Access(..)
43 , FileType(..)
44 , InputFile(..)
45 , KeyFilter(..)
46 -- * Results of a KeyRing Operation
47 , KeyRingRuntime(..)
48 , MappedPacket(..)
49 , KeyDB
50 , KeyData(..)
51 , SubKey(..)
52 , packet
53 , locations
54 , keyflags
55 -- * Miscelaneous Utilities
56 , isKey
57 , derRSA
58 , derToBase32
59 , backsig
60 , filterMatches
61 , flattenKeys
62 , flattenTop
63 , Hosts.Hosts
64 , isCryptoCoinKey
65 , matchpr
66 , parseSpec
67 , parseUID
68 , UserIDRecord(..)
69 , pkcs8
70 , RSAPublicKey(..)
71 , PKCS8_RSAPublicKey(..)
72 , rsaKeyFromPacket
73 , secretToPublic
74 , selectPublicKey
75 , selectSecretKey
76 , usage
77 , usageString
78 , walletImportFormat
79 , writePEM
80 , getBindings
81 , accBindings
82 , isSubkeySignature
83 , torhash
84 , ParsedCert(..)
85 , parseCertBlob
86 , packetFromPublicRSAKey
87 , decodeBlob
88 , selectPublicKeyAndSigs
89 , x509cert
90 , getHomeDir
91 , unconditionally
92 , SecretPEMData(..)
93 , readSecretPEMFile
94 , writeInputFileL
95 , InputFileContext(..)
96 , onionNameForContact
97 , keykey
98 , keyPacket
99 , KeySpec(..)
100 , getHostnames
101 , secretPemFromPacket
102 , getCrossSignedSubkeys
103 ) where
104
105import System.Environment
106import Control.Monad
107import Data.Maybe
108import Data.Either
109import Data.Char
110import Data.Ord
111import Data.List
112import Data.OpenPGP
113import Data.Functor
114import Data.Monoid
115import Data.Tuple ( swap )
116import Data.Bits ( (.|.), (.&.) )
117import Control.Applicative ( Applicative, pure, liftA2, (<*>) )
118import System.Directory ( getHomeDirectory, doesFileExist, createDirectoryIfMissing )
119import Control.Arrow ( first, second )
120import Data.OpenPGP.Util (verify,fingerprint,decryptSecretKey,pgpSign)
121import Data.ByteString.Lazy ( ByteString )
122import Text.Show.Pretty as PP ( ppShow )
123import Data.Binary {- decode, decodeOrFail -}
124import ControlMaybe ( handleIO_ )
125import Data.ASN1.Types ( toASN1, ASN1Object, fromASN1
126 , ASN1(Start,End,IntVal,OID,BitString,Null), ASN1ConstructionType(Sequence) )
127import Data.ASN1.BitArray ( BitArray(..), toBitArray )
128import Data.ASN1.Encoding ( encodeASN1, encodeASN1', decodeASN1, decodeASN1' )
129import Data.ASN1.BinaryEncoding ( DER(..) )
130import Data.Time.Clock.POSIX ( POSIXTime, utcTimeToPOSIXSeconds )
131import Data.Time.Clock ( UTCTime )
132import Data.Bits ( Bits, shiftR )
133import Data.Text.Encoding ( encodeUtf8 )
134import qualified Data.Map as Map
135import qualified Data.ByteString.Lazy as L ( unpack, null, readFile, writeFile
136 , ByteString, toChunks, hGetContents, hPut, concat, fromChunks, splitAt
137 , index, break, pack )
138import qualified Data.ByteString as S ( ByteString, unpack, splitAt, concat, cons, spanEnd, hGetContents, readFile, breakSubstring, drop, length, null, hPutStr, singleton, unfoldr, reverse )
139import qualified Codec.Binary.Base32 as Base32
140import qualified Codec.Binary.Base64 as Base64
141#if !defined(VERSION_cryptonite)
142import qualified Crypto.Hash.SHA1 as SHA1
143import qualified Crypto.Types.PubKey.ECC as ECC
144#else
145import qualified Crypto.Hash as Vincent
146import Data.ByteArray (convert)
147import qualified Crypto.PubKey.ECC.Types as ECC
148#endif
149import qualified Data.X509 as X509
150import qualified Crypto.PubKey.RSA as RSA
151import qualified Codec.Compression.GZip as GZip
152import qualified Data.Text as T ( Text, unpack, pack,
153 strip, reverse, drop, break, dropAround, length )
154import qualified System.Posix.Types as Posix
155import System.Posix.Files ( modificationTime, getFileStatus, getFdStatus
156 , setFileCreationMask, setFileTimes )
157#if MIN_VERSION_x509(1,5,0)
158import Data.Hourglass.Types
159import Data.Hourglass
160#endif
161#if MIN_VERSION_unix(2,7,0)
162import System.Posix.Files ( setFdTimesHiRes )
163import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
164#else
165import Foreign.C.Types ( CTime(..), CLong, CInt(..) )
166import Foreign.Marshal.Array ( withArray )
167import Foreign.Ptr
168import Foreign.C.Error ( throwErrnoIfMinus1_ )
169import Foreign.Storable
170#endif
171import System.FilePath ( takeDirectory )
172import System.IO (hPutStrLn,withFile,IOMode(..), Handle, hPutStr, stderr)
173import Data.IORef
174import System.Posix.IO ( fdToHandle )
175import qualified Data.Traversable as Traversable
176import Data.Traversable ( sequenceA )
177#if ! MIN_VERSION_base(4,6,0)
178import GHC.Exts ( Down(..) )
179#endif
180#if MIN_VERSION_binary(0,7,0)
181import Debug.Trace
182#endif
183import Network.Socket -- (SockAddr)
184import qualified Data.ByteString.Lazy.Char8 as Char8
185import Compat
186
187import TimeUtil
188import PEM
189import ScanningParser
190import qualified Hosts
191import qualified CryptoCoins
192import Base58
193import FunctorToMaybe
194import DotLock
195import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
196
197-- DER-encoded elliptic curve ids
198-- nistp256_id = 0x2a8648ce3d030107
199secp256k1_id :: Integer
200secp256k1_id = 0x2b8104000a
201-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
202{- OID Curve description Curve name
203 ----------------------------------------------------------------
204 1.2.840.10045.3.1.7 NIST Curve P-256 [FIPS 186-2] "NIST P-256"
205 1.3.132.0.34 NIST Curve P-384 [FIPS 186-2] "NIST P-384"
206 1.3.132.0.35 NIST Curve P-521 [FIPS 186-2] "NIST P-521"
207
208 Implementations MUST implement "NIST P-256", "NIST P-384" and "NIST
209 P-521". The hexadecimal representation used in the public and
210 private key encodings are:
211
212 Curve Name Len Hexadecimal representation of the OID
213 ----------------------------------------------------------------
214 "NIST P-256" 8 0x2A, 0x86, 0x48, 0xCE, 0x3D, 0x03, 0x01, 0x07
215 "NIST P-384" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x22
216 "NIST P-521" 6 0x05, 0x2B, 0x81, 0x04, 0x00, 0x23
217-}
218
219data HomeDir =
220 HomeDir { homevar :: String
221 , appdir :: String
222 , optfile_alts :: [String]
223 }
224
225home :: HomeDir
226home = HomeDir
227 { homevar = "GNUPGHOME"
228 , appdir = ".gnupg"
229 , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
230 }
231
232data InputFile = HomeSec
233 -- ^ A file named secring.gpg located in the home directory.
234 -- See 'opHome'.
235 | HomePub
236 -- ^ A file named pubring.gpg located in the home directory.
237 -- See 'opHome'.
238 | ArgFile FilePath
239 -- ^ Contents will be read or written from the specified path.
240 | FileDesc Posix.Fd
241 -- ^ Contents will be read or written from the specified file
242 -- descriptor.
243 | Pipe Posix.Fd Posix.Fd
244 -- ^ Contents will be read from the first descriptor and updated
245 -- content will be writen to the second. Note: Don't use Pipe
246 -- for 'Wallet' files. (TODO: Wallet support)
247 deriving (Eq,Ord,Show)
248
249-- type UsageTag = String
250type Initializer = String
251
252data FileType = KeyRingFile
253 | PEMFile
254 | WalletFile
255 | DNSPresentation
256 | Hosts
257 deriving (Eq,Ord,Enum,Show)
258
259-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
260-- to contain secret or public PGP key packets. Note that it is not supported
261-- to mix both in the same file and that the secret key packets include all of
262-- the information contained in their corresponding public key packets.
263data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
264 -- (see 'rtRingAccess')
265 | Sec -- ^ secret information
266 | Pub -- ^ public information
267 deriving (Eq,Ord,Show)
268
269-- | Note that the documentation here is intended for when this value is
270-- assigned to 'fill'. For other usage, see 'spill'.
271data KeyFilter = KF_None -- ^ No keys will be imported.
272 | KF_Match String -- ^ Only the key that matches the spec will be imported.
273 | KF_Subkeys -- ^ Subkeys will be imported if their owner key is
274 -- already in the ring. TODO: Even if their signatures
275 -- are bad?
276 | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
277 -- identity (signed or self-authenticating).
278 | KF_All -- ^ All keys will be imported.
279 deriving (Eq,Ord,Show)
280
281-- | This type describes how 'runKeyRing' will treat a file.
282data StreamInfo = StreamInfo
283 { access :: Access
284 -- ^ Indicates whether the file is allowed to contain secret information.
285 , typ :: FileType
286 -- ^ Indicates the format and content type of the file.
287 , fill :: KeyFilter
288 -- ^ This filter controls what packets will be inserted into a file.
289 , spill :: KeyFilter
290 --
291 -- ^ Use this to indicate whether or not a file's contents should be
292 -- available for updating other files. Note that although its type is
293 -- 'KeyFilter', it is usually interpretted as a boolean flag. Details
294 -- depend on 'typ' and are as follows:
295 --
296 -- 'KeyRingFile':
297 --
298 -- * 'KF_None' - The file's contents will not be shared.
299 --
300 -- * otherwise - The file's contents will be shared.
301 --
302 -- 'PEMFile':
303 --
304 -- * 'KF_None' - The file's contents will not be shared.
305 --
306 -- * 'KF_Match' - The file's key will be shared with the specified owner
307 -- key and usage tag. If 'fill' is also a 'KF_Match', then it must be
308 -- equal to this value; changing the usage or owner of a key is not
309 -- supported via the fill/spill mechanism.
310 --
311 -- * otherwise - Unspecified. Do not use.
312 --
313 -- 'WalletFile':
314 --
315 -- * The 'spill' setting is ignored and the file's contents are shared.
316 -- (TODO)
317 --
318 -- 'Hosts':
319 --
320 -- * The 'spill' setting is ignored and the file's contents are shared.
321 -- (TODO)
322 --
323 , initializer :: Maybe String
324 -- ^ If 'typ' is 'PEMFile' and an 'initializer' string is set, then it is
325 -- interpretted as a shell command that may be used to create the key if it
326 -- does not exist.
327 , transforms :: [Transform]
328 -- ^ Per-file transformations that occur before the contents of a file are
329 -- spilled into the common pool.
330 }
331 deriving (Eq,Show)
332
333
334spillable :: StreamInfo -> Bool
335spillable (spill -> KF_None) = False
336spillable _ = True
337
338isMutable :: StreamInfo -> Bool
339isMutable (fill -> KF_None) = False
340isMutable _ = True
341
342isring :: FileType -> Bool
343isring (KeyRingFile {}) = True
344isring _ = False
345
346isSecretKeyFile :: FileType -> Bool
347isSecretKeyFile PEMFile = True
348isSecretKeyFile DNSPresentation = True
349isSecretKeyFile _ = False
350
351{-
352pwfile :: FileType -> Maybe InputFile
353pwfile (KeyRingFile f) = f
354pwfile _ = Nothing
355-}
356
357iswallet :: FileType -> Bool
358iswallet (WalletFile {}) = True
359iswallet _ = False
360
361usageFromFilter :: MonadPlus m => KeyFilter -> m String
362usageFromFilter (KF_Match usage) = return usage
363usageFromFilter _ = mzero
364
365data KeyRingRuntime = KeyRingRuntime
366 { rtPubring :: FilePath
367 -- ^ Path to the file represented by 'HomePub'
368 , rtSecring :: FilePath
369 -- ^ Path to the file represented by 'HomeSec'
370 , rtGrip :: Maybe String
371 -- ^ Fingerprint or portion of a fingerprint used
372 -- to identify the working GnuPG identity used to
373 -- make signatures.
374 , rtWorkingKey :: Maybe Packet
375 -- ^ The master key of the working GnuPG identity.
376 , rtKeyDB :: KeyDB
377 -- ^ The common information pool where files spilled
378 -- their content and from which they received new
379 -- content.
380 , rtRingAccess :: Map.Map InputFile Access
381 -- ^ The 'Access' values used for files of type
382 -- 'KeyRingFile'. If 'AutoAccess' was specified
383 -- for a file, this 'Map.Map' will indicate the
384 -- detected value that was used by the algorithm.
385 , rtPassphrases :: MappedPacket -> IO (KikiCondition Packet)
386 }
387
388-- | Roster-entry level actions
389data PacketUpdate = InducerSignature String [SignatureSubpacket]
390 | SubKeyDeletion KeyKey KeyKey
391
392-- | This type is used to indicate where to obtain passphrases.
393data PassphraseSpec = PassphraseSpec
394 { passSpecRingFile :: Maybe FilePath
395 -- ^ If not Nothing, the passphrase is to be used for packets
396 -- from this file.
397 , passSpecKeySpec :: Maybe String
398 -- ^ Non-Nothing value reserved for future use.
399 -- (TODO: Use this to implement per-key passphrase associations).
400 , passSpecPassFile :: InputFile
401 -- ^ The passphrase will be read from this file or file descriptor.
402 }
403 -- | Use this to carry pasphrases from a previous run.
404 | PassphraseMemoizer (MappedPacket -> IO (KikiCondition Packet))
405
406instance Show PassphraseSpec where
407 show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
408 show (PassphraseMemoizer _) = "PassphraseMemoizer"
409instance Eq PassphraseSpec where
410 PassphraseSpec a b c == PassphraseSpec d e f
411 = and [a==d,b==e,c==f]
412 _ == _
413 = False
414
415
416
417data Transform =
418 Autosign
419 -- ^ This operation will make signatures for any tor-style UID
420 -- that matches a tor subkey and thus can be authenticated without
421 -- requring the judgement of a human user.
422 --
423 -- A tor-style UID is one of the following form:
424 --
425 -- > Anonymous <root@HOSTNAME.onion>
426 | DeleteSubKey String
427 -- ^ Delete the subkey specified by the given fingerprint and any
428 -- associated signatures on that key.
429 deriving (Eq,Ord,Show)
430
431-- | This type describes an idempotent transformation (merge or import) on a
432-- set of GnuPG keyrings and other key files.
433data KeyRingOperation = KeyRingOperation
434 { opFiles :: Map.Map InputFile StreamInfo
435 -- ^ Indicates files to be read or updated.
436 , opPassphrases :: [PassphraseSpec]
437 -- ^ Indicates files or file descriptors where passphrases can be found.
438 , opTransforms :: [Transform]
439 -- ^ Transformations to be performed on the key pool after all files have
440 -- been read and before any have been written.
441 , opHome :: Maybe FilePath
442 -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
443 -- files reside. Otherwise, the evironment variable $GNUPGHOME is consulted
444 -- and if that is not set, it falls back to $HOME/.gnupg.
445 }
446 deriving (Eq,Show)
447
448resolveInputFile :: InputFileContext -> InputFile -> [FilePath]
449resolveInputFile ctx = resolve
450 where
451 resolve HomeSec = return (homesecPath ctx)
452 resolve HomePub = return (homepubPath ctx)
453 resolve (ArgFile f) = return f
454 resolve _ = []
455
456resolveForReport :: Maybe InputFileContext -> InputFile -> FilePath
457resolveForReport mctx (Pipe fdr fdw) = resolveForReport mctx (ArgFile str)
458 where str = case (fdr,fdw) of
459 (0,1) -> "-"
460 _ -> "&pipe" ++ show (fdr,fdw)
461resolveForReport mctx (FileDesc fd) = resolveForReport mctx (ArgFile str)
462 where str = "&" ++ show fd
463resolveForReport mctx f = concat $ resolveInputFile ctx f
464 where ctx = fromMaybe (InputFileContext "&secret" "&public") mctx
465
466filesToLock ::
467 KeyRingOperation -> InputFileContext -> [FilePath]
468filesToLock k ctx = do
469 (f,stream) <- Map.toList (opFiles k)
470 case fill stream of
471 KF_None -> []
472 _ -> resolveInputFile ctx f
473
474
475-- kret :: a -> KeyRingOperation a
476-- kret x = KeyRingOperation Map.empty Nothing (KeyRingAction x)
477
478data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
479data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
480
481pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
482pkcs8 (RSAKey n e) = RSAKey8 n e
483
484instance ASN1Object RSAPublicKey where
485 -- PKCS #1 RSA Public Key
486 toASN1 (RSAKey (MPI n) (MPI e))
487 = \xs -> Start Sequence
488 : IntVal n
489 : IntVal e
490 : End Sequence
491 : xs
492 fromASN1 (Start Sequence:IntVal n:IntVal e:End Sequence:xs) =
493 Right (RSAKey (MPI n) (MPI e), xs)
494
495 fromASN1 _ =
496 Left "fromASN1: RSAPublicKey: unexpected format"
497
498instance ASN1Object PKCS8_RSAPublicKey where
499
500 -- PKCS #8 Public key data
501 toASN1 (RSAKey8 (MPI n) (MPI e))
502 = \xs -> Start Sequence
503 : Start Sequence
504 : OID [1,2,840,113549,1,1,1]
505 : Null -- Doesn't seem to be neccessary, but i'm adding it
506 -- to match PEM files I see in the wild.
507 : End Sequence
508 : BitString (toBitArray bs 0)
509 : End Sequence
510 : xs
511 where
512 pubkey = [ Start Sequence, IntVal n, IntVal e, End Sequence ]
513 bs = encodeASN1' DER pubkey
514
515 fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
516 Right (RSAKey8 (MPI modulus) (MPI pubexp) , xs)
517 fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:Null:End Sequence:BitString b:End Sequence:xs) =
518 case decodeASN1' DER bs of
519 Right as -> fromASN1 as
520 Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
521 where
522 BitArray _ bs = b
523 fromASN1 (Start Sequence:Start Sequence:OID [1,2,840,113549,1,1,1]:End Sequence:BitString b:End Sequence:xs) =
524 case decodeASN1' DER bs of
525 Right as -> fromASN1 as
526 Left e -> Left ("fromASN1: RSAPublicKey: "++show e)
527 where
528 BitArray _ bs = b
529
530 fromASN1 _ =
531 Left "fromASN1: RSAPublicKey: unexpected format"
532
533{-
534RSAPrivateKey ::= SEQUENCE {
535 version Version,
536 modulus INTEGER, -- n
537 publicExponent INTEGER, -- e
538 privateExponent INTEGER, -- d
539 prime1 INTEGER, -- p
540 prime2 INTEGER, -- q
541 exponent1 INTEGER, -- d mod (p1) -- ?? d mod (p-1)
542 exponent2 INTEGER, -- d mod (q-1)
543 coefficient INTEGER, -- (inverse of q) mod p
544 otherPrimeInfos OtherPrimeInfos OPTIONAL
545 }
546-}
547data RSAPrivateKey = RSAPrivateKey
548 { rsaN :: MPI
549 , rsaE :: MPI
550 , rsaD :: MPI
551 , rsaP :: MPI
552 , rsaQ :: MPI
553 , rsaDmodP1 :: MPI
554 , rsaDmodQminus1 :: MPI
555 , rsaCoefficient :: MPI
556 }
557 deriving Show
558
559instance ASN1Object RSAPrivateKey where
560 toASN1 rsa@(RSAPrivateKey {})
561 = \xs -> Start Sequence
562 : IntVal 0
563 : mpiVal rsaN
564 : mpiVal rsaE
565 : mpiVal rsaD
566 : mpiVal rsaP
567 : mpiVal rsaQ
568 : mpiVal rsaDmodP1
569 : mpiVal rsaDmodQminus1
570 : mpiVal rsaCoefficient
571 : End Sequence
572 : xs
573 where mpiVal f = IntVal x where MPI x = f rsa
574
575 fromASN1 ( Start Sequence
576 : IntVal _ -- version
577 : IntVal n
578 : IntVal e
579 : IntVal d
580 : IntVal p
581 : IntVal q
582 : IntVal dmodp1
583 : IntVal dmodqminus1
584 : IntVal coefficient
585 : ys) =
586 Right ( privkey, tail $ dropWhile notend ys)
587 where
588 notend (End Sequence) = False
589 notend _ = True
590 privkey = RSAPrivateKey
591 { rsaN = MPI n
592 , rsaE = MPI e
593 , rsaD = MPI d
594 , rsaP = MPI p
595 , rsaQ = MPI q
596 , rsaDmodP1 = MPI dmodp1
597 , rsaDmodQminus1 = MPI dmodqminus1
598 , rsaCoefficient = MPI coefficient
599 }
600 fromASN1 _ =
601 Left "fromASN1: RSAPrivateKey: unexpected format"
602
603
604
605-- | This type is used to indicate success or failure
606-- and in the case of success, return the computed object.
607-- The 'FunctorToMaybe' class is implemented to facilitate
608-- branching on failture.
609data KikiCondition a = KikiSuccess a
610 | FailedToLock [FilePath]
611 | BadPassphrase
612 | FailedToMakeSignature
613 | CantFindHome
614 | AmbiguousKeySpec FilePath
615 | CannotImportMasterKey
616 | NoWorkingKey
617 deriving ( Functor, Show )
618
619instance FunctorToMaybe KikiCondition where
620 functorToMaybe (KikiSuccess a) = Just a
621 functorToMaybe _ = Nothing
622
623instance Applicative KikiCondition where
624 pure a = KikiSuccess a
625 f <*> a =
626 case functorToEither f of
627 Right f -> case functorToEither a of
628 Right a -> pure (f a)
629 Left err -> err
630 Left err -> err
631
632-- | This type is used to describe events triggered by 'runKeyRing'. In
633-- addition to normal feedback (e.g. 'NewPacket'), it also may indicate
634-- non-fatal IO exceptions (e.g. 'FailedExternal'). Because a
635-- 'KeyRingOperation' may describe a very intricate multifaceted algorithm with
636-- many inputs and outputs, an operation may be partially (or even mostly)
637-- successful even when I/O failures occured. In this situation, the files may
638-- not have all the information they were intended to store, but they will be
639-- in a valid format for GnuPG or kiki to operate on in the future.
640data KikiReportAction =
641 NewPacket String
642 | MissingPacket String
643 | ExportedSubkey
644 | GeneratedSubkeyFile
645 | NewWalletKey String
646 | YieldSignature
647 | YieldSecretKeyPacket String
648 | UnableToUpdateExpiredSignature
649 | WarnFailedToMakeSignature
650 | FailedExternal Int
651 | ExternallyGeneratedFile
652 | UnableToExport KeyAlgorithm String
653 | FailedFileWrite
654 | HostsDiff ByteString
655 | DeletedPacket String
656 deriving Show
657
658uncamel :: String -> String
659uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
660 where
661 (.:) = fmap . fmap
662 ( firstWord ,
663 otherWords ) = splitAt 1 ws
664 ws = camel >>= groupBy (\_ c -> isLower c)
665 ( camel, args) = splitAt 1 $ words str
666
667reportString :: KikiReportAction -> String
668reportString x = uncamel $ show x
669
670errorString :: KikiCondition a -> String
671errorString (KikiSuccess {}) = "success"
672errorString e = uncamel . show $ fmap (const ()) e
673
674-- | Errors in kiki are indicated by the returning of this record.
675data KikiResult a = KikiResult
676 { kikiCondition :: KikiCondition a
677 -- ^ The result or a fatal error condition.
678 , kikiReport :: KikiReport
679 -- ^ A list of non-fatal warnings and informational messages
680 -- along with the files that triggered them.
681 }
682
683type KikiReport = [ (FilePath, KikiReportAction) ]
684
685keyPacket :: KeyData -> Packet
686keyPacket (KeyData k _ _ _) = packet k
687
688subkeyMappedPacket :: SubKey -> MappedPacket
689subkeyMappedPacket (SubKey k _ ) = k
690
691
692usage :: SignatureSubpacket -> Maybe String
693usage (NotationDataPacket
694 { human_readable = True
695 , notation_name = "usage@"
696 , notation_value = u
697 }) = Just u
698usage _ = Nothing
699
700x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
701x509cert (NotationDataPacket
702 { human_readable = False
703 , notation_name = "x509cert@"
704 , notation_value = u
705 }) = Just (Char8.pack u)
706x509cert _ = Nothing
707
708makeInducerSig
709 :: Packet
710 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
711-- torsig g topk wkun uid timestamp extras = todo
712makeInducerSig topk wkun uid extras
713 = CertificationSignature (secretToPublic topk)
714 uid
715 (sigpackets 0x13
716 subpackets
717 subpackets_unh)
718 where
719 subpackets = -- implicit: [ SignatureCreationTimePacket (fromIntegral timestamp) ]
720 tsign
721 ++ extras
722 subpackets_unh = [IssuerPacket (fingerprint wkun)]
723 tsign = if keykey wkun == keykey topk
724 then [] -- tsign doesnt make sense for self-signatures
725 else [ TrustSignaturePacket 1 120
726 , RegularExpressionPacket regex]
727 -- <[^>]+[@.]asdf\.nowhere>$
728 regex = "<[^>]+[@.]"++hostname++">$"
729 -- regex = username ++ "@" ++ hostname
730 -- username = "[a-zA-Z0-9.][-a-zA-Z0-9.]*\\$?" :: String
731 hostname = subdomain' pu ++ "\\." ++ topdomain' pu
732 pu = parseUID uidstr where UserIDPacket uidstr = uid
733 subdomain' = escape . T.unpack . uid_subdomain
734 topdomain' = escape . T.unpack . uid_topdomain
735 escape s = concatMap echar s
736 where
737 echar '|' = "\\|"
738 echar '*' = "\\*"
739 echar '+' = "\\+"
740 echar '?' = "\\?"
741 echar '.' = "\\."
742 echar '^' = "\\^"
743 echar '$' = "\\$"
744 echar '\\' = "\\\\"
745 echar '[' = "\\["
746 echar ']' = "\\]"
747 echar c = [c]
748
749
750keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
751keyflags flgs@(KeyFlagsPacket {}) =
752 Just . toEnum $
753 ( bit 0x1 certify_keys
754 .|. bit 0x2 sign_data
755 .|. bit 0x4 encrypt_communication
756 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
757 -- other flags:
758 -- split_key
759 -- authentication (ssh-client)
760 -- group_key
761 where
762 bit v f = if f flgs then v else 0
763keyflags _ = Nothing
764
765
766data PGPKeyFlags =
767 Special
768 | Vouch -- Signkey
769 | Sign
770 | VouchSign
771 | Communication
772 | VouchCommunication
773 | SignCommunication
774 | VouchSignCommunication
775 | Storage
776 | VouchStorage
777 | SignStorage
778 | VouchSignStorage
779 | Encrypt
780 | VouchEncrypt
781 | SignEncrypt
782 | VouchSignEncrypt
783 deriving (Eq,Show,Read,Enum)
784
785
786usageString :: PGPKeyFlags -> String
787usageString flgs =
788 case flgs of
789 Special -> "special"
790 Vouch -> "vouch" -- signkey
791 Sign -> "sign"
792 VouchSign -> "vouch-sign"
793 Communication -> "communication"
794 VouchCommunication -> "vouch-communication"
795 SignCommunication -> "sign-communication"
796 VouchSignCommunication -> "vouch-sign-communication"
797 Storage -> "storage"
798 VouchStorage -> "vouch-storage"
799 SignStorage -> "sign-storage"
800 VouchSignStorage -> "vouch-sign-storage"
801 Encrypt -> "encrypt"
802 VouchEncrypt -> "vouch-encrypt"
803 SignEncrypt -> "sign-encrypt"
804 VouchSignEncrypt -> "vouch-sign-encrypt"
805
806
807
808
809-- matchpr computes the fingerprint of the given key truncated to
810-- be the same lenght as the given fingerprint for comparison.
811matchpr :: String -> Packet -> String
812matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
813
814keyFlags :: t -> [Packet] -> [SignatureSubpacket]
815keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
816
817keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
818keyFlags0 wkun uidsigs = concat
819 [ keyflags
820 , preferredsym
821 , preferredhash
822 , preferredcomp
823 , features ]
824
825 where
826 subs = concatMap hashed_subpackets uidsigs
827 keyflags = filterOr isflags subs $
828 KeyFlagsPacket { certify_keys = True
829 , sign_data = True
830 , encrypt_communication = False
831 , encrypt_storage = False
832 , split_key = False
833 , authentication = False
834 , group_key = False
835 }
836 preferredsym = filterOr ispreferedsym subs $
837 PreferredSymmetricAlgorithmsPacket
838 [ AES256
839 , AES192
840 , AES128
841 , CAST5
842 , TripleDES
843 ]
844 preferredhash = filterOr ispreferedhash subs $
845 PreferredHashAlgorithmsPacket
846 [ SHA256
847 , SHA1
848 , SHA384
849 , SHA512
850 , SHA224
851 ]
852 preferredcomp = filterOr ispreferedcomp subs $
853 PreferredCompressionAlgorithmsPacket
854 [ ZLIB
855 , BZip2
856 , ZIP
857 ]
858 features = filterOr isfeatures subs $
859 FeaturesPacket { supports_mdc = True
860 }
861
862 filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs
863
864 isflags (KeyFlagsPacket {}) = True
865 isflags _ = False
866 ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
867 ispreferedsym _ = False
868 ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
869 ispreferedhash _ = False
870 ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
871 ispreferedcomp _ = False
872 isfeatures (FeaturesPacket {}) = True
873 isfeatures _ = False
874
875
876matchSpec :: KeySpec -> KeyData -> Bool
877matchSpec (KeyGrip grip) (KeyData p _ _ _)
878 | matchpr grip (packet p)==grip = True
879 | otherwise = False
880
881matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
882 where
883 ps = map (packet .fst) sigs
884 match p = isSignaturePacket p
885 && has_tag tag p
886 && has_issuer key p
887 has_issuer key p = isJust $ do
888 issuer <- signature_issuer p
889 guard $ matchpr issuer key == issuer
890 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
891 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
892
893matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
894 where
895 us = filter (isInfixOf pat) $ Map.keys uids
896
897data UserIDRecord = UserIDRecord {
898 uid_full :: String,
899 uid_realname :: T.Text,
900 uid_user :: T.Text,
901 uid_subdomain :: T.Text,
902 uid_topdomain :: T.Text
903}
904 deriving Show
905
906parseUID :: String -> UserIDRecord
907parseUID str = UserIDRecord {
908 uid_full = str,
909 uid_realname = realname,
910 uid_user = user,
911 uid_subdomain = subdomain,
912 uid_topdomain = topdomain
913 }
914 where
915 text = T.pack str
916 (T.strip-> realname, T.dropAround isBracket-> email)
917 = T.break (=='<') text
918 (user, T.drop 1-> hostname) = T.break (=='@') email
919 ( T.reverse -> topdomain,
920 T.reverse . T.drop 1 -> subdomain)
921 = T.break (=='.') . T.reverse $ hostname
922isBracket :: Char -> Bool
923isBracket '<' = True
924isBracket '>' = True
925isBracket _ = False
926
927
928
929
930data KeySpec =
931 KeyGrip String -- fp:
932 | KeyTag Packet String -- fp:????/t:
933 | KeyUidMatch String -- u:
934 deriving Show
935
936data MatchingField = UserIDField | KeyTypeField deriving (Show,Eq,Ord,Enum)
937data SingleKeySpec = FingerprintMatch String
938 | SubstringMatch (Maybe MatchingField) String
939 | EmptyMatch
940 | AnyMatch
941 | WorkingKeyMatch
942 deriving (Show,Eq,Ord)
943
944-- A pair of specs. The first specifies an identity and the second
945-- specifies a specific key (possibly master) associated with that
946-- identity.
947--
948-- When no slash is specified, context will decide whether the SingleKeySpec
949-- is specifying an identity or a key belonging to the working identity.
950type Spec = (SingleKeySpec,SingleKeySpec)
951
952parseSingleSpec :: String -> SingleKeySpec
953parseSingleSpec "*" = AnyMatch
954parseSingleSpec "-" = WorkingKeyMatch
955parseSingleSpec "" = EmptyMatch
956parseSingleSpec ('t':':':tag) = SubstringMatch (Just KeyTypeField) tag
957parseSingleSpec ('u':':':tag) = SubstringMatch (Just UserIDField) tag
958parseSingleSpec ('f':'p':':':fp) = FingerprintMatch fp
959parseSingleSpec str
960 | is40digitHex str = FingerprintMatch str
961 | otherwise = SubstringMatch Nothing str
962
963is40digitHex xs = ys == xs && length ys==40
964 where
965 ys = filter ishex xs
966 ishex c | '0' <= c && c <= '9' = True
967 | 'A' <= c && c <= 'F' = True
968 | 'a' <= c && c <= 'f' = True
969 ishex c = False
970
971
972 -- t:tor -- (FingerprintMatch "", SubstringMatch "tor")
973 -- u:joe -- (SubstringMatch "joe", FingerprintMatch "")
974 -- u:joe/ -- (SubstringMatch "joe", FingerprintMatch "!")
975 -- fp:4A39F/tor -- (FingerprintMatch "4A39F", SubstringMatch "tor")
976 -- u:joe/tor -- (SubstringMatch "joe", SubstringMatch "tor")
977 -- u:joe/t:tor -- (SubstringMatch "joe", SubstringMatch "tor")
978 -- u:joe/fp:4abf30 -- (SubstringMatch "joe", FingerprintMatch "4abf30")
979 -- joe/tor -- (SubstringMatch "joe", SubstringMatch "tor")
980
981-- | Parse a key specification.
982-- The first argument is a grip for the default working key.
983parseSpec :: String -> String -> (KeySpec,Maybe String)
984parseSpec wkgrip spec =
985 if not slashed
986 then
987 case prespec of
988 AnyMatch -> (KeyGrip "", Nothing)
989 EmptyMatch -> error "Bad key spec."
990 WorkingKeyMatch -> (KeyGrip wkgrip, Nothing)
991 SubstringMatch (Just KeyTypeField) tag -> (KeyGrip wkgrip, Just tag)
992 SubstringMatch Nothing str -> (KeyGrip wkgrip, Just str)
993 SubstringMatch (Just UserIDField) ustr -> (KeyUidMatch ustr, Nothing)
994 FingerprintMatch fp -> (KeyGrip fp, Nothing)
995 else
996 case (prespec,postspec) of
997 (FingerprintMatch fp, SubstringMatch st t)
998 | st /= Just UserIDField -> (KeyGrip fp, Just t)
999 (SubstringMatch mt u, _)
1000 | postspec `elem` [AnyMatch,EmptyMatch]
1001 && mt /= Just KeyTypeField -> (KeyUidMatch u, Nothing)
1002 (SubstringMatch mt u, SubstringMatch st t)
1003 | mt /= Just KeyTypeField
1004 && st /= Just UserIDField -> (KeyUidMatch u, Just t)
1005 (FingerprintMatch _,FingerprintMatch _) -> error "todo: support fp:/fp: spec"
1006 (_,FingerprintMatch fp) -> error "todo: support /fp: spec"
1007 (FingerprintMatch fp,_) -> error "todo: support fp:/ spec"
1008 _ -> error "Bad key spec."
1009 where
1010 (preslash,slashon) = break (=='/') spec
1011 slashed = not $ null $ take 1 slashon
1012 postslash = drop 1 slashon
1013
1014 prespec = parseSingleSpec preslash
1015 postspec = parseSingleSpec postslash
1016
1017{-
1018 - BUGGY
1019parseSpec grip spec = (topspec,subspec)
1020 where
1021 (topspec0,subspec0) = unprefix '/' spec
1022 (toptyp,top) = unprefix ':' topspec0
1023 (subtyp,sub) = unprefix ':' subspec0
1024 topspec = case () of
1025 _ | null top && or [ subtyp=="fp"
1026 , null subtyp && is40digitHex sub
1027 ]
1028 -> KeyGrip sub
1029 _ | null top && null grip -> KeyUidMatch sub
1030 _ | null top -> KeyGrip grip
1031 _ | toptyp=="fp" || (null toptyp && is40digitHex top)
1032 -> KeyGrip top
1033 _ | toptyp=="u" -> KeyUidMatch top
1034 _ -> KeyUidMatch top
1035 subspec = case subtyp of
1036 "t" -> Just sub
1037 "fp" | top=="" -> Nothing
1038 "" | top=="" && is40digitHex sub -> Nothing
1039 "" -> listToMaybe sub >> Just sub
1040 _ -> Nothing
1041
1042 is40digitHex xs = ys == xs && length ys==40
1043 where
1044 ys = filter ishex xs
1045 ishex c | '0' <= c && c <= '9' = True
1046 | 'A' <= c && c <= 'F' = True
1047 | 'a' <= c && c <= 'f' = True
1048 ishex c = False
1049
1050 -- | Split a string into two at the first occurance of the given
1051 -- delimiter. If the delimeter does not occur, then the first
1052 -- item of the returned pair is empty and the second item is the
1053 -- input string.
1054 unprefix c spec = if null (snd p) then swap p else (fst p, tail (snd p))
1055 where p = break (==c) spec
1056-}
1057
1058
1059filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
1060filterMatches spec ks = filter (matchSpec spec . snd) ks
1061
1062filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
1063filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
1064 where
1065 matchAll = KeyGrip ""
1066
1067 subkeySpec (KeyGrip grip,Nothing) = (matchAll, KeyGrip grip)
1068 subkeySpec (topspec,Just mtag) = (topspec , KeyTag (packet p) mtag)
1069
1070 match spec mps
1071 = not . null
1072 . snd
1073 . seek_key spec
1074 . map packet
1075 $ mps
1076
1077 old sub = isJust (Map.lookup fname $ locations $ subkeyMappedPacket sub)
1078
1079 oldOrMatch spec sub = old sub
1080 || match spec (flattenSub "" True sub)
1081
1082 subs' = Map.filter (if match topspec $ flattenTop "" True (KeyData p sigs uids Map.empty)
1083 then oldOrMatch subspec
1084 else old)
1085 subs
1086 where
1087 (topspec,subspec) = subkeySpec spec
1088
1089selectSecretKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1090selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
1091
1092selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1093selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
1094
1095selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(KeyKey,Packet,[Packet])]
1096selectPublicKeyAndSigs (spec,mtag) db =
1097 case mtag of
1098 Nothing -> do
1099 (kk,r) <- Map.toList $ fmap (findbyspec spec) db
1100 (sub,sigs) <- r
1101 return (kk,sub,sigs)
1102 Just tag -> Map.toList (Map.filter (matchSpec spec) db) >>= findsubs tag
1103 where
1104 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
1105
1106 findbyspec (KeyGrip g) kd = do
1107 filter ismatch $
1108 topresult kd
1109 : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
1110 (Map.elems $ keySubKeys kd)
1111 where
1112 ismatch (p,sigs) = matchpr g p ==g
1113 findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
1114
1115 findsubs tag (kk, KeyData topk _ _ subs) = Map.elems subs >>= gettag
1116 where
1117 gettag (SubKey sub sigs) = do
1118 let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
1119 (hastag,_) <- maybeToList mb
1120 guard hastag
1121 return $ (kk, packet sub, map (packet . fst) sigs)
1122
1123selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
1124selectKey0 wantPublic (spec,mtag) db = do
1125 let Message ps = flattenKeys wantPublic db
1126 ys = snd $ seek_key spec ps
1127 flip (maybe (listToMaybe ys)) mtag $ \tag -> do
1128 case ys of
1129 y:ys1 -> listToMaybe $ snd $ seek_key (KeyTag y tag) ys1
1130 [] -> Nothing
1131
1132{-
1133selectAll :: Bool -> (KeySpec,Maybe String) -> KeyDB -> [(Packet,Maybe Packet)]
1134selectAll wantPublic (spec,mtag) db = do
1135 let Message ps = flattenKeys wantPublic db
1136 ys = snd $ seek_key spec ps
1137 y <- take 1 ys
1138 case mtag of
1139 Nothing -> return (y,Nothing)
1140 Just tag ->
1141 let search ys1 = do
1142 let zs = snd $ seek_key (KeyTag y tag) ys1
1143 z <- take 1 zs
1144 (y,Just z):search (drop 1 zs)
1145 in search (drop 1 ys)
1146-}
1147
1148seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
1149seek_key (KeyGrip grip) sec = (pre, subs)
1150 where
1151 (pre,subs) = break pred sec
1152 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
1153 pred p@(PublicKeyPacket {}) = matchpr grip p == grip
1154 pred _ = False
1155
1156seek_key (KeyTag key tag) ps
1157 | null bs = (ps, [])
1158 | null qs =
1159 let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
1160 (as ++ (head bs : as'), bs')
1161 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1162 where
1163 (as,bs) = break (\p -> isSignaturePacket p
1164 && has_tag tag p
1165 && isJust (signature_issuer p)
1166 && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
1167 ps
1168 (rs,qs) = break isKey (reverse as)
1169
1170 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
1171 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
1172
1173seek_key (KeyUidMatch pat) ps
1174 | null bs = (ps, [])
1175 | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
1176 (as ++ (head bs : as'), bs')
1177 | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
1178 where
1179 (as,bs) = break (isInfixOf pat . uidStr) ps
1180 (rs,qs) = break isKey (reverse as)
1181
1182 uidStr (UserIDPacket s) = s
1183 uidStr _ = ""
1184
1185
1186data InputFileContext = InputFileContext
1187 { homesecPath :: FilePath
1188 , homepubPath :: FilePath
1189 }
1190
1191readInputFileS :: InputFileContext -> InputFile -> IO S.ByteString
1192readInputFileS ctx (Pipe fd _) = fdToHandle fd >>= S.hGetContents
1193readInputFileS ctx (FileDesc fd) = fdToHandle fd >>= S.hGetContents
1194readInputFileS ctx inp = do
1195 let fname = resolveInputFile ctx inp
1196 fmap S.concat $ mapM S.readFile fname
1197
1198readInputFileL :: InputFileContext -> InputFile -> IO L.ByteString
1199readInputFileL ctx (Pipe fd _) = fdToHandle fd >>= L.hGetContents
1200readInputFileL ctx (FileDesc fd) = fdToHandle fd >>= L.hGetContents
1201readInputFileL ctx inp = do
1202 let fname = resolveInputFile ctx inp
1203 fmap L.concat $ mapM L.readFile fname
1204
1205
1206writeInputFileL ctx (Pipe _ fd) bs = fdToHandle fd >>= (`L.hPut` bs)
1207writeInputFileL ctx (FileDesc fd) bs = fdToHandle fd >>= (`L.hPut` bs)
1208writeInputFileL ctx inp bs = do
1209 let fname = resolveInputFile ctx inp
1210 mapM_ (`L.writeFile` bs) fname
1211
1212-- writeStamped0 :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
1213-- writeStamped0 :: InputFileContext -> InputFile
1214
1215getWriteFD :: InputFile -> Maybe Posix.Fd
1216getWriteFD (Pipe _ fd) = Just fd
1217getWriteFD (FileDesc fd) = Just fd
1218getWriteFD _ = Nothing
1219
1220writeStamped0 :: InputFileContext
1221 -> InputFile
1222 -> Posix.EpochTime
1223 -> (Either Handle FilePath -> t -> IO ())
1224 -> t
1225 -> IO ()
1226writeStamped0 ctx (getWriteFD -> Just fd) stamp dowrite bs = do
1227 h <- fdToHandle fd
1228 dowrite (Left h) bs
1229 handleIO_ (return ())
1230 $ setFdTimesHiRes fd (realToFrac stamp) (realToFrac stamp)
1231writeStamped0 ctx inp stamp dowrite bs = do
1232 let fname = resolveInputFile ctx inp
1233 forM_ fname $ \fname -> do
1234 createDirectoryIfMissing True $ takeDirectory fname
1235 dowrite (Right fname) bs
1236 setFileTimes fname stamp stamp
1237
1238{- This may be useful later. Commented for now, as it is not used.
1239 -
1240writeStampedL :: InputFileContext -> InputFile -> Posix.EpochTime -> L.ByteString -> IO ()
1241writeStampedL ctx f stamp bs = writeStamped0 ctx f stamp (either L.hPut L.writeFile) bs
1242-}
1243
1244writeStamped :: InputFileContext -> InputFile -> Posix.EpochTime -> String -> IO ()
1245writeStamped ctx f stamp str = writeStamped0 ctx f stamp (either hPutStr writeFile) str
1246
1247getInputFileTime :: InputFileContext -> InputFile -> IO CTime
1248getInputFileTime ctx (Pipe fdr fdw) = do
1249 mt <- handleIO_ (return Nothing) $ Just <$> modificationTime <$> getFdStatus fdr
1250 maybe tryw return mt
1251 where
1252 tryw = do
1253 handleIO_ (error $ (resolveForReport Nothing $ Pipe fdr fdw) ++": modificaiton time?")
1254 $ modificationTime <$> getFdStatus fdw
1255getInputFileTime ctx (FileDesc fd) = do
1256 handleIO_ (error $ "&"++show fd++": modificaiton time?") $
1257 modificationTime <$> getFdStatus fd
1258getInputFileTime ctx (resolveInputFile ctx -> [fname]) = do
1259 handleIO_ (error $ fname++": modificaiton time?") $
1260 modificationTime <$> getFileStatus fname
1261
1262{-
1263 - This may be useful later. Commented for now as it is not used.
1264 -
1265doesInputFileExist :: InputFileContext -> InputFile -> IO Bool
1266doesInputFileExist ctx f = do
1267 case resolveInputFile ctx f of
1268 [n] -> doesFileExist n
1269 _ -> return True
1270-}
1271
1272
1273cachedContents :: Maybe S.ByteString -> InputFileContext -> InputFile -> IO (IO S.ByteString)
1274cachedContents maybePrompt ctx fd = do
1275 ref <- newIORef Nothing
1276 return $ get maybePrompt ref fd
1277 where
1278 trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
1279
1280 get maybePrompt ref fd = do
1281 pw <- readIORef ref
1282 flip (flip maybe return) pw $ do
1283 if fd == FileDesc 0 then case maybePrompt of
1284 Just prompt -> S.hPutStr stderr prompt
1285 Nothing -> return ()
1286 else return ()
1287 pw <- fmap trimCR $ readInputFileS ctx fd
1288 writeIORef ref (Just pw)
1289 return pw
1290
1291importSecretKey ::
1292 (MappedPacket -> IO (KikiCondition Packet))
1293 -> KikiCondition
1294 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
1295 -> (FilePath, Maybe [Char], [KeyKey], StreamInfo, t)
1296 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
1297importSecretKey doDecrypt db' tup = do
1298 try db' $ \(db',report0) -> do
1299 r <- doImport doDecrypt
1300 db'
1301 tup
1302 try r $ \(db'',report) -> do
1303 return $ KikiSuccess (db'', report0 ++ report)
1304
1305
1306mergeHostFiles :: KeyRingOperation -> KeyDB -> InputFileContext
1307 -> IO
1308 (KikiCondition
1309 ( ( Map.Map [Char8.ByteString] KeyData
1310 , ( [Hosts.Hosts]
1311 , [Hosts.Hosts]
1312 , Hosts.Hosts
1313 , [(SockAddr, ([Char8.ByteString], [Char8.ByteString]))]
1314 , [SockAddr]))
1315 , [(FilePath,KikiReportAction)]))
1316mergeHostFiles krd db ctx = do
1317 let hns = files ishosts
1318 ishosts Hosts = True
1319 ishosts _ = False
1320 files istyp = do
1321 (f,stream) <- Map.toList (opFiles krd)
1322 guard (istyp $ typ stream)
1323 return f
1324
1325 hostdbs0 <- mapM (fmap Hosts.decode . readInputFileL ctx) hns
1326
1327 let gpgnames = map getHostnames $ Map.elems db
1328 os = do
1329 (addr,(ns,_)) <- gpgnames
1330 n <- ns
1331 return (addr,n)
1332 setOnions hosts = foldl' (flip $ uncurry Hosts.assignName) hosts os
1333 -- we ensure .onion names are set properly
1334 hostdbs = map setOnions hostdbs0
1335 outgoing_names = do
1336 (addr,(_,gns)) <- gpgnames
1337 guard . not $ null gns
1338 guard $ all (null . Hosts.namesForAddress addr) hostdbs0
1339 return addr
1340 -- putStrLn $ "hostdbs = " ++ show hostdbs
1341
1342 -- 1. let U = union all the host dbs
1343 -- preserving whitespace and comments of the first
1344 let u0 = foldl' Hosts.plus Hosts.empty hostdbs
1345 -- we filter U to be only finger-dresses
1346 u1 = Hosts.filterAddrs (hasFingerDress db) u0
1347
1348 -- let nf h = map Char8.unpack $ Hosts.namesForAddress (fromJust $ Hosts.inet_pton "fdf4:ed98:29c7:6226:9bde:a5b4:d564:3321") h
1349 {-
1350 putStrLn $ "_ = {\n" ++ show (head hostdbs) ++ "}"
1351 putStrLn $ "--> " ++ show (nf (head hostdbs))
1352 putStrLn $ "u0 = {\n" ++ show u0 ++ "}"
1353 putStrLn $ "--> " ++ show (nf u0)
1354 putStrLn $ "u1 = {\n" ++ show u1 ++ "}"
1355 putStrLn $ "--> " ++ show (nf u1)
1356 -}
1357
1358 -- 2. replace gpg annotations with those in U
1359 -- forM use_db
1360 db' <- Traversable.mapM (setHostnames (`notElem` outgoing_names) u1) db
1361
1362 return $ KikiSuccess ((db',(hostdbs0,hostdbs,u1,gpgnames,outgoing_names)),[])
1363
1364writeHostsFiles
1365 :: KeyRingOperation -> InputFileContext
1366 -> ([Hosts.Hosts],
1367 [Hosts.Hosts],
1368 Hosts.Hosts,
1369 [(SockAddr, (t1, [Char8.ByteString]))],
1370 [SockAddr])
1371 -> IO [(FilePath, KikiReportAction)]
1372writeHostsFiles krd ctx (hostdbs0,hostdbs,u1,gpgnames,outgoing_names) = do
1373 let hns = files isMutableHosts
1374 isMutableHosts (fill -> KF_None) = False
1375 isMutableHosts (typ -> Hosts) = True
1376 isMutableHosts _ = False
1377 files istyp = do
1378 (f,stream) <- Map.toList (opFiles krd)
1379 guard (istyp stream)
1380 return f -- resolveInputFile ctx f
1381
1382 -- 3. add hostnames from gpg for addresses not in U
1383 let u = foldl' f u1 ans
1384 ans = reverse $ do
1385 (addr,(_,ns)) <- gpgnames
1386 guard $ addr `elem` outgoing_names -- . null $ Hosts.namesForAddress addr u0
1387 n <- ns
1388 return (addr,n)
1389 f h (addr,n) = Hosts.assignNewName addr n h
1390
1391 -- 4. for each host db H, union H with U and write it out as H'
1392 -- only if there is a non-empty diff
1393 rss <- forM (zip hns $ zip hostdbs0 hostdbs) $ \(fname,(h0,h1)) -> do
1394 let h = h1 `Hosts.plus` u
1395 d = Hosts.diff h0 h
1396 rs = map ((fname,) . HostsDiff) d
1397 unless (null d) $ writeInputFileL ctx fname $ Hosts.encode h
1398 return $ map (first $ resolveForReport $ Just ctx) rs
1399 return $ concat rss
1400
1401isSecretKey :: Packet -> Bool
1402isSecretKey (SecretKeyPacket {}) = True
1403isSecretKey _ = False
1404
1405buildKeyDB :: InputFileContext -> Maybe String -> KeyRingOperation
1406 -> IO (KikiCondition ((KeyDB
1407 ,Maybe String
1408 ,Maybe MappedPacket
1409 ,([Hosts.Hosts],
1410 [Hosts.Hosts],
1411 Hosts.Hosts,
1412 [(SockAddr, (KeyKey, KeyKey))],
1413 [SockAddr])
1414 ,Map.Map InputFile Access
1415 ,MappedPacket -> IO (KikiCondition Packet)
1416 ,Map.Map InputFile Message
1417 )
1418 ,[(FilePath,KikiReportAction)]))
1419buildKeyDB ctx grip0 keyring = do
1420 let
1421 files isring = do
1422 (f,stream) <- Map.toList (opFiles keyring)
1423 guard (isring $ typ stream)
1424 resolveInputFile ctx f
1425
1426 ringMap = Map.filter (isring . typ) $ opFiles keyring
1427
1428 readp f stream = fmap readp0 $ readPacketsFromFile ctx f
1429 where
1430 readp0 ps = (stream { access = acc' }, ps)
1431 where acc' = case access stream of
1432 AutoAccess ->
1433 case ps of
1434 Message ((PublicKeyPacket {}):_) -> Pub
1435 Message ((SecretKeyPacket {}):_) -> Sec
1436 _ -> AutoAccess
1437 acc -> acc
1438
1439 readw wk n = fmap (n,) (readPacketsFromWallet wk (ArgFile n))
1440
1441 -- KeyRings (todo: KikiCondition reporting?)
1442 (spilled,mwk,grip,accs,keys,unspilled) <- do
1443#if MIN_VERSION_containers(0,5,0)
1444 ringPackets <- Map.traverseWithKey readp ringMap
1445#else
1446 ringPackets <- Traversable.traverse (uncurry readp) $ Map.mapWithKey (,) ringMap
1447#endif
1448 let _ = ringPackets :: Map.Map InputFile (StreamInfo, Message)
1449
1450 let grip = grip0 `mplus` (fingerprint <$> fstkey)
1451 where
1452 fstkey = do
1453 (_,Message ps) <- Map.lookup HomeSec ringPackets
1454 listToMaybe ps
1455 (spilled,unspilled) = Map.partition (spillable . fst) ringPackets
1456 keys :: Map.Map KeyKey MappedPacket
1457 keys = Map.foldl slurpkeys Map.empty
1458 $ Map.mapWithKey filterSecrets ringPackets
1459 where
1460 filterSecrets f (_,Message ps) =
1461 filter (isSecretKey . packet)
1462 $ zipWith (mappedPacketWithHint fname) ps [1..]
1463 where fname = resolveForReport (Just ctx) f
1464 slurpkeys m ps = m `Map.union` Map.fromList ps'
1465 where ps' = zip (map (keykey . packet) ps) ps
1466 wk = listToMaybe $ do
1467 fp <- maybeToList grip
1468 let matchfp mp = not (is_subkey p) && matchpr fp p == fp
1469 where p = packet mp
1470 Map.elems $ Map.filter matchfp keys
1471 accs = fmap (access . fst) ringPackets
1472 return (spilled,wk,grip,accs,keys,fmap snd unspilled)
1473
1474 doDecrypt <- makeMemoizingDecrypter keyring ctx keys
1475
1476 let wk = fmap packet mwk
1477 rt0 = KeyRingRuntime { rtPubring = homepubPath ctx
1478 , rtSecring = homesecPath ctx
1479 , rtGrip = grip
1480 , rtWorkingKey = wk
1481 , rtRingAccess = accs
1482 , rtKeyDB = Map.empty
1483 , rtPassphrases = doDecrypt
1484 }
1485 transformed0 <-
1486 let trans f (info,ps) = do
1487 let manip = combineTransforms (transforms info)
1488 rt1 = rt0 { rtKeyDB = merge Map.empty f ps }
1489 acc = Just Sec /= Map.lookup f accs
1490 r <- performManipulations doDecrypt rt1 mwk manip
1491 try r $ \(rt2,report) -> do
1492 return $ KikiSuccess (report,(info,flattenKeys acc $ rtKeyDB rt2))
1493#if MIN_VERSION_containers(0,5,0)
1494 in fmap sequenceA $ Map.traverseWithKey trans spilled
1495#else
1496 in fmap sequenceA $ Traversable.traverse (uncurry trans) $ Map.mapWithKey (,) spilled
1497#endif
1498 try transformed0 $ \transformed -> do
1499 let db_rings = Map.foldlWithKey' mergeIt Map.empty transformed
1500 where
1501 mergeIt db f (_,(info,ps)) = merge db f ps
1502 reportTrans = concat $ Map.elems $ fmap fst transformed
1503
1504 -- Wallets
1505 let importWalletKey wk db' (top,fname,sub,tag) = do
1506 try db' $ \(db',report0) -> do
1507 r <- doImportG doDecrypt
1508 db'
1509 (fmap keykey $ maybeToList wk)
1510 [mkUsage tag]
1511 fname
1512 sub
1513 try r $ \(db'',report) -> do
1514 return $ KikiSuccess (db'', report0 ++ report)
1515
1516 wms <- mapM (readw wk) (files iswallet)
1517 let wallet_keys = do
1518 maybeToList wk
1519 (fname,xs) <- wms
1520 (_,sub,(_,m)) <- xs
1521 (tag,top) <- Map.toList m
1522 return (top,fname,sub,tag)
1523 db <- foldM (importWalletKey wk) (KikiSuccess (db_rings,[])) wallet_keys
1524 try db $ \(db,reportWallets) -> do
1525
1526 -- PEM files
1527 let pems = do
1528 (n,stream) <- Map.toList $ opFiles keyring
1529 grip <- maybeToList grip
1530 n <- resolveInputFile ctx n
1531 guard $ spillable stream && isSecretKeyFile (typ stream)
1532 let us = mapMaybe usageFromFilter [fill stream,spill stream]
1533 usage <- take 1 us
1534 guard $ all (==usage) $ drop 1 us
1535 -- TODO: KikiCondition reporting for spill/fill usage mismatch?
1536 let (topspec,subspec) = parseSpec grip usage
1537 ms = map fst $ filterMatches topspec (Map.toList db)
1538 cmd = initializer stream
1539 return (n,subspec,ms,stream, cmd)
1540 imports <- filterM (\(n,_,_,_,_) -> doesFileExist n) pems
1541 db <- foldM (importSecretKey doDecrypt) (KikiSuccess (db,[])) imports
1542 try db $ \(db,reportPEMs) -> do
1543
1544 r <- mergeHostFiles keyring db ctx
1545 try r $ \((db,hs),reportHosts) -> do
1546
1547 return $ KikiSuccess ( (db, grip, mwk, hs, accs, doDecrypt, unspilled)
1548 , reportTrans ++ reportWallets ++ reportPEMs ++ reportHosts )
1549
1550torhash :: Packet -> String
1551torhash key = fromMaybe "" $ derToBase32 <$> derRSA key
1552
1553derToBase32 :: ByteString -> String
1554#if !defined(VERSION_cryptonite)
1555derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
1556#else
1557derToBase32 = map toLower . Base32.encode . S.unpack . sha1
1558 where
1559 sha1 :: L.ByteString -> S.ByteString
1560 sha1 x = convert (Vincent.hashlazy x :: Vincent.Digest Vincent.SHA1)
1561#endif
1562
1563derRSA :: Packet -> Maybe ByteString
1564derRSA rsa = do
1565 k <- rsaKeyFromPacket rsa
1566 return $ encodeASN1 DER (toASN1 k [])
1567
1568unconditionally :: IO (KikiCondition a) -> IO a
1569unconditionally action = do
1570 r <- action
1571 case r of
1572 KikiSuccess x -> return x
1573 e -> error $ errorString e
1574
1575try :: Monad m => KikiCondition a -> (a -> m (KikiCondition b)) -> m (KikiCondition b)
1576try x body =
1577 case functorToEither x of
1578 Left e -> return e
1579 Right x -> body x
1580
1581
1582data ParsedCert = ParsedCert
1583 { pcertKey :: Packet
1584 , pcertTimestamp :: UTCTime
1585 , pcertBlob :: L.ByteString
1586 }
1587 deriving (Show,Eq)
1588data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
1589 deriving (Show,Eq)
1590
1591spemPacket (PEMPacket p) = Just p
1592spemPacket _ = Nothing
1593
1594spemCert (PEMCertificate p) = Just p
1595spemCert _ = Nothing
1596
1597toStrict :: L.ByteString -> S.ByteString
1598toStrict = foldr1 (<>) . L.toChunks
1599
1600-- No instance for (ASN1Object RSA.PublicKey)
1601
1602parseCertBlob comp bs = do
1603 asn1 <- either (const Nothing) Just
1604 $ decodeASN1 DER bs
1605 let asn1' = drop 2 asn1
1606 cert <- either (const Nothing) (Just . fst) (fromASN1 asn1')
1607 let _ = cert :: X509.Certificate
1608 notBefore :: UTCTime
1609#if MIN_VERSION_x509(1,5,0)
1610 notBefore = toUTC ( timeFromElapsedP (timeGetElapsedP vincentTime) :: CTime) -- nanoToUTCTime nano
1611 where (vincentTime,_) = X509.certValidity cert
1612#else
1613 (notBefore,_) = X509.certValidity cert
1614#endif
1615 case X509.certPubKey cert of
1616 X509.PubKeyRSA key -> do
1617 let withoutkey =
1618 let ekey = toStrict $ encodeASN1 DER (toASN1 key [])
1619 (pre,post) = S.breakSubstring ekey $ toStrict bs
1620 post' = S.drop (S.length ekey) post
1621 len :: Word16
1622 len = if S.null post then maxBound
1623 else fromIntegral $ S.length pre
1624 in if len < 4096
1625 then encode len <> GZip.compress (Char8.fromChunks [pre,post'])
1626 else bs
1627 return
1628 ParsedCert { pcertKey = packetFromPublicRSAKey notBefore
1629 (MPI $ RSA.public_n key)
1630 (MPI $ RSA.public_e key)
1631 , pcertTimestamp = notBefore
1632 , pcertBlob = if comp then withoutkey
1633 else bs
1634 }
1635 _ -> Nothing
1636
1637packetFromPublicRSAKey notBefore n e =
1638 PublicKeyPacket { version = 4
1639 , timestamp = round $ utcTimeToPOSIXSeconds notBefore
1640 , key_algorithm = RSA
1641 , key = [('n',n),('e',e)]
1642 , is_subkey = True
1643 , v3_days_of_validity = Nothing
1644 }
1645
1646decodeBlob cert =
1647 if 0 /= (bs `L.index` 0) .&. 0x10
1648 then bs
1649 else let (keypos0,bs') = L.splitAt 2 bs
1650 keypos :: Word16
1651 keypos = decode keypos0
1652 ds = GZip.decompress bs'
1653 (prekey,postkey) = L.splitAt (fromIntegral keypos) ds
1654 in prekey <> key <> postkey
1655 where
1656 bs = pcertBlob cert
1657 key = maybe "" (encodeASN1 DER . flip toASN1 []) $ rsaKeyFromPacket $ pcertKey cert
1658
1659extractRSAKeyFields :: [(ByteString,ByteString)] -> Maybe RSAPrivateKey
1660extractRSAKeyFields kvs = do
1661 let kvs' = mapMaybe (\(k,v) -> (k,) <$> parseField v) kvs
1662 n <- lookup "Modulus" kvs'
1663 e <- lookup "PublicExponent" kvs'
1664 d <- lookup "PrivateExponent" kvs'
1665 p <- lookup "Prime1" kvs' -- p
1666 q <- lookup "Prime2" kvs' -- q
1667 dmodp1 <- lookup "Exponent1" kvs' -- dP = d `mod` (p - 1)
1668 dmodqminus1 <- lookup "Exponent2" kvs' -- dQ = d `mod` (q - 1)
1669 u <- lookup "Coefficient" kvs'
1670 {-
1671 case (d,p,dmodp1) of
1672 (MPI dd, MPI pp, MPI x) | x == dd `mod` (pp-1) -> return ()
1673 _ -> error "dmodp fail!"
1674 case (d,q,dmodqminus1) of
1675 (MPI dd, MPI qq, MPI x) | x == dd `mod` (qq-1) -> return ()
1676 _ -> error "dmodq fail!"
1677 -}
1678 return $ RSAPrivateKey
1679 { rsaN = n
1680 , rsaE = e
1681 , rsaD = d
1682 , rsaP = p
1683 , rsaQ = q
1684 , rsaDmodP1 = dmodp1
1685 , rsaDmodQminus1 = dmodqminus1
1686 , rsaCoefficient = u }
1687 where
1688 parseField blob = MPI <$> m
1689 where m = bigendian <$> Base64.decode (Char8.unpack blob)
1690
1691 bigendian bs = snd $ foldl' (\(c,a) w8 -> (c-1, a + 256^c * fromIntegral w8)) (nlen-1,0) bs
1692 where
1693 nlen = length bs
1694
1695rsaToPGP stamp rsa = SecretKeyPacket
1696 { version = 4
1697 , timestamp = fromTime stamp -- toEnum (fromEnum stamp)
1698 , key_algorithm = RSA
1699 , key = [ -- public fields...
1700 ('n',rsaN rsa)
1701 ,('e',rsaE rsa)
1702 -- secret fields
1703 ,('d',rsaD rsa)
1704 ,('p',rsaQ rsa) -- Note: p & q swapped
1705 ,('q',rsaP rsa) -- Note: p & q swapped
1706 ,('u',rsaCoefficient rsa)
1707 ]
1708 -- , ecc_curve = def
1709 , s2k_useage = 0
1710 , s2k = S2K 100 ""
1711 , symmetric_algorithm = Unencrypted
1712 , encrypted_data = ""
1713 , is_subkey = True
1714 }
1715
1716readSecretDNSFile :: InputFile -> IO Packet
1717readSecretDNSFile fname = do
1718 let ctx = InputFileContext "" ""
1719 stamp <- getInputFileTime ctx fname
1720 input <- readInputFileL ctx fname
1721 let kvs = map ( second (Char8.dropWhile isSpace . Char8.drop 1)
1722 . Char8.break (==':'))
1723 $ Char8.lines input
1724 alg = maybe RSA parseAlg $ lookup "Algorithm" kvs
1725 parseAlg spec = case Char8.words spec of
1726 nstr:_ -> case read (Char8.unpack nstr) :: Int of
1727 2 -> DH
1728 3 -> DSA -- SHA1
1729 5 -> RSA -- SHA1
1730 6 -> DSA -- NSEC3-SHA1 (RFC5155)
1731 7 -> RSA -- RSASHA1-NSEC3-SHA1 (RFC5155)
1732 8 -> RSA -- SHA256
1733 10 -> RSA -- SHA512 (RFC5702)
1734 -- 12 -> GOST
1735 13 -> ECDSA -- P-256 SHA256 (RFC6605)
1736 14 -> ECDSA -- P-384 SHA384 (RFC6605)
1737 _ -> RSA
1738 case alg of
1739 RSA -> return $ rsaToPGP stamp $ fromJust $ extractRSAKeyFields kvs
1740
1741
1742readSecretPEMFile :: InputFile -> IO [SecretPEMData]
1743readSecretPEMFile fname = do
1744 -- warn $ fname ++ ": reading ..."
1745 let ctx = InputFileContext "" ""
1746 -- Note: The key's timestamp is included in it's fingerprint.
1747 -- Therefore, we should attempt to preserve it.
1748 stamp <- getInputFileTime ctx fname
1749 input <- readInputFileL ctx fname
1750 let edta = scanAndParse (fmap Left dateParser <> fmap Right (pkcs1 <> cert)) $ Char8.lines input
1751 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1752 $ pemParser $ Just "RSA PRIVATE KEY"
1753 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1754 $ pemParser $ Just "CERTIFICATE"
1755 parseRSAPrivateKey dta = do
1756 let e = decodeASN1 DER dta
1757 asn1 <- either (const $ mzero) return e
1758 rsa <- either (const mzero) (return . fst) (fromASN1 asn1)
1759 let _ = rsa :: RSAPrivateKey
1760 return $ PEMPacket $ rsaToPGP stamp rsa
1761 dta = catMaybes $ map snd $ scanl mergeDate (stamp,Nothing) edta
1762 mergeDate (_,obj) (Left tm) = (fromTime tm,obj)
1763 mergeDate (tm,_) (Right (Just (PEMPacket key))) = (tm,Just $ PEMPacket key')
1764 where key' = if tm < fromTime (timestamp key)
1765 then key { timestamp = fromTime tm }
1766 else key
1767 mergeDate (tm,_) (Right mb) = (tm,mb)
1768 return $ dta
1769
1770doImport
1771 :: Ord k =>
1772 (MappedPacket -> IO (KikiCondition Packet))
1773 -> Map.Map k KeyData
1774 -> (FilePath, Maybe [Char], [k], StreamInfo, t)
1775 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1776doImport doDecrypt db (fname,subspec,ms,typ -> typ,_) = do
1777 flip (maybe $ return CannotImportMasterKey)
1778 subspec $ \tag -> do
1779 (certs,keys) <- case typ of
1780 PEMFile -> do
1781 ps <- readSecretPEMFile (ArgFile fname)
1782 let (mapMaybe spemCert -> certs,mapMaybe spemPacket-> keys)
1783 = partition (isJust . spemCert) ps
1784 return (certs,keys)
1785 DNSPresentation -> do
1786 p <- readSecretDNSFile (ArgFile fname)
1787 return ([],[p])
1788 -- TODO Probably we need to move to a new design where signature
1789 -- packets are merged into the database in one phase with null
1790 -- signatures, and then the signatures are made in the next phase.
1791 -- This would let us merge annotations (like certificates) from
1792 -- seperate files.
1793 foldM (importKey tag certs) (KikiSuccess (db,[])) keys
1794 where
1795 importKey tag certs prior key = do
1796 try prior $ \(db,report) -> do
1797 let (m0,tailms) = splitAt 1 ms
1798 if (not (null tailms) || null m0)
1799 then return $ AmbiguousKeySpec fname
1800 else do
1801 let kk = keykey key
1802 cs = filter (\c -> kk==keykey (pcertKey c)) certs
1803 blobs = map mkCertNotation $ nub $ map pcertBlob cs
1804 mkCertNotation bs = NotationDataPacket
1805 { human_readable = False
1806 , notation_name = "x509cert@"
1807 , notation_value = Char8.unpack bs }
1808 datedKey = key { timestamp = fromTime $ minimum dates }
1809 dates = fromTime (timestamp key) : map pcertTimestamp certs
1810 r <- doImportG doDecrypt db m0 (mkUsage tag:blobs) fname datedKey
1811 try r $ \(db',report') -> do
1812 return $ KikiSuccess (db',report++report')
1813
1814doImportG
1815 :: Ord k =>
1816 (MappedPacket -> IO (KikiCondition Packet))
1817 -> Map.Map k KeyData
1818 -> [k]
1819 -> [SignatureSubpacket]
1820 -> [Char]
1821 -> Packet
1822 -> IO (KikiCondition (Map.Map k KeyData, [(FilePath,KikiReportAction)]))
1823doImportG doDecrypt db m0 tags fname key = do
1824 let kk = head m0
1825 Just (KeyData top topsigs uids subs) = Map.lookup kk db
1826 subkk = keykey key
1827 (is_new, subkey) = maybe (True, SubKey (mappedPacket fname key)
1828 [])
1829 ( (False,) . addOrigin )
1830 (Map.lookup subkk subs)
1831 where
1832 addOrigin (SubKey mp sigs) =
1833 let mp' = mp
1834 { locations = Map.insert fname
1835 (origin (packet mp) (-1))
1836 (locations mp) }
1837 in SubKey mp' sigs
1838 subs' = Map.insert subkk subkey subs
1839
1840 istor = do
1841 guard ("tor" `elem` mapMaybe usage tags)
1842 return $ "Anonymous <root@" ++ take 16 (torhash key) ++ ".onion>"
1843
1844 uids' <- flip (maybe $ return $ KikiSuccess (uids,[])) istor $ \idstr -> do
1845 let has_torid = do
1846 -- TODO: check for omitted real name field
1847 (sigtrusts,om) <- Map.lookup idstr uids
1848 listToMaybe $ do
1849 s <- (signatures $ Message (packet top:UserIDPacket idstr:map (packet . fst) sigtrusts))
1850 signatures_over $ verify (Message [packet top]) s
1851 flip (flip maybe $ const $ return $ KikiSuccess (uids,[])) has_torid $ do
1852 wkun <- doDecrypt top
1853
1854 try wkun $ \wkun -> do
1855
1856 let keyflags = keyFlags wkun (map packet $ flattenAllUids fname True uids)
1857 uid = UserIDPacket idstr
1858 -- sig_ov = fst $ torsig g (packet top) wkun uid timestamp keyflags
1859 tor_ov = makeInducerSig (packet top) wkun uid keyflags
1860 sig_ov <- pgpSign (Message [wkun])
1861 tor_ov
1862 SHA1
1863 (fingerprint wkun)
1864 flip (maybe $ return $ KikiSuccess (uids,[(fname, WarnFailedToMakeSignature)]))
1865 (sig_ov >>= listToMaybe . signatures_over)
1866 $ \sig -> do
1867 let om = Map.singleton fname (origin sig (-1))
1868 trust = Map.empty
1869 return $ KikiSuccess
1870 ( Map.insert idstr ([( (mappedPacket fname sig) {locations=om}
1871 , trust)],om) uids
1872 , [] )
1873
1874 try uids' $ \(uids',report) -> do
1875
1876 let SubKey subkey_p subsigs = subkey
1877 wk = packet top
1878 (xs',minsig,ys') = findTag tags wk key subsigs
1879 doInsert mbsig db = do
1880 -- NEW SUBKEY BINDING SIGNATURE
1881 sig' <- makeSig doDecrypt top fname subkey_p tags mbsig
1882 try sig' $ \(sig',report) -> do
1883 report <- return $ fmap (fname,) report ++ [(fname, YieldSignature)]
1884 let subs' = Map.insert subkk
1885 (SubKey subkey_p $ xs'++[sig']++ys')
1886 subs
1887 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
1888 , report )
1889
1890 report <- let f = if is_new then (++[(fname,YieldSecretKeyPacket s)])
1891 else id
1892 s = show (fmap fst minsig,fingerprint key)
1893 in return (f report)
1894
1895 case minsig of
1896 Nothing -> doInsert Nothing db -- we need to create a new sig
1897 Just (True,sig) -> -- we can deduce is_new == False
1898 -- we may need to add a tor id
1899 return $ KikiSuccess ( Map.insert kk (KeyData top topsigs uids' subs') db
1900 , report )
1901 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
1902
1903isCryptoCoinKey :: Packet -> Bool
1904isCryptoCoinKey p =
1905 and [ isKey p
1906 , key_algorithm p == ECDSA
1907 , lookup 'c' (key p) == Just (MPI secp256k1_id)
1908 ]
1909
1910getCryptoCoinTag :: Packet -> Maybe CryptoCoins.CoinNetwork
1911getCryptoCoinTag p | isSignaturePacket p = do
1912 -- CryptoCoins.secret
1913 let sps = hashed_subpackets p ++ unhashed_subpackets p
1914 u <- listToMaybe $ mapMaybe usage sps
1915 CryptoCoins.lookupNetwork CryptoCoins.network_name u
1916getCryptoCoinTag _ = Nothing
1917
1918
1919coinKeysOwnedBy :: KeyDB -> Maybe Packet -> [(CryptoCoins.CoinNetwork,MappedPacket)]
1920coinKeysOwnedBy db wk = do
1921 wk <- maybeToList wk
1922 let kk = keykey wk
1923 KeyData top topsigs uids subs <- maybeToList $ Map.lookup kk db
1924 (subkk,SubKey mp sigs) <- Map.toList subs
1925 let sub = packet mp
1926 guard $ isCryptoCoinKey sub
1927 tag <- take 1 $ mapMaybe (getCryptoCoinTag . packet . fst) sigs
1928 return (tag,mp)
1929
1930walletImportFormat :: Word8 -> Packet -> String
1931walletImportFormat idbyte k = secret_base58_foo
1932 where
1933 -- isSecret (SecretKeyPacket {}) = True
1934 -- isSecret _ = False
1935 secret_base58_foo = base58_encode seckey
1936 Just d = lookup 'd' (key k)
1937 (_,bigendian) = S.splitAt 2 (S.concat $ L.toChunks $ encode d)
1938 seckey = S.cons idbyte bigendian
1939
1940writeWalletKeys :: KeyRingOperation -> KeyDB -> Maybe Packet -> IO (KikiCondition [(FilePath,KikiReportAction)])
1941writeWalletKeys krd db wk = do
1942 let cs = db `coinKeysOwnedBy` wk
1943 -- export wallet keys
1944 isMutableWallet (fill -> KF_None) = False
1945 isMutableWallet (typ -> WalletFile {}) = True
1946 isMutableWallet _ = False
1947 files pred = do
1948 (f,stream) <- Map.toList (opFiles krd)
1949 guard (pred stream)
1950 resolveInputFile (InputFileContext "" "") f
1951 let writeWallet report n = do
1952 let cs' = do
1953 (nw,mp) <- cs
1954 -- let fns = Map.keys (locations mp)
1955 -- trace ("COIN KEY: "++show fns) $ return ()
1956 guard . not $ Map.member n (locations mp)
1957 let wip = walletImportFormat (CryptoCoins.private_byte_id nw) (packet mp)
1958 return (CryptoCoins.network_name nw,wip)
1959 handleIO_ (return report) $ do
1960 -- TODO: This AppendMode stratagy is not easy to adapt from FilePath-based
1961 -- to InputFile-based.
1962 withFile n AppendMode $ \fh -> do
1963 rs <- forM cs' $ \(net,wip) -> do
1964 hPutStrLn fh wip
1965 return (n, NewWalletKey net)
1966 return (report ++ rs)
1967 report <- foldM writeWallet [] (files isMutableWallet)
1968 return $ KikiSuccess report
1969
1970ifSecret :: Packet -> t -> t -> t
1971ifSecret (SecretKeyPacket {}) t f = t
1972ifSecret _ t f = f
1973
1974showPacket :: Packet -> String
1975showPacket p | isKey p = (if is_subkey p
1976 then showPacket0 p
1977 else ifSecret p "----Secret-----" "----Public-----")
1978 ++ " "++show (key_algorithm p)++" "++fingerprint p
1979 | isUserID p = showPacket0 p ++ " " ++ show (uidkey p)
1980 | otherwise = showPacket0 p
1981showPacket0 p = concat . take 1 $ words (show p)
1982
1983
1984-- | returns Just True so as to indicate that
1985-- the public portions of keys will be imported
1986importPublic :: Maybe Bool
1987importPublic = Just True
1988
1989-- | returns False True so as to indicate that
1990-- the public portions of keys will be imported
1991importSecret :: Maybe Bool
1992importSecret = Just False
1993
1994
1995-- TODO: Do we need to memoize this?
1996guardAuthentic :: KeyRingRuntime -> KeyData -> Maybe ()
1997guardAuthentic rt keydata = guard (isauth rt keydata)
1998
1999isauth :: KeyRingRuntime -> KeyData -> Bool
2000isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
2001 where wk = workingKey (rtGrip rt) (rtKeyDB rt)
2002 dont_have (KeyData p _ _ _) = not . Map.member (rtPubring rt)
2003 $ locations p
2004 has_good_sig wk (KeyData k sigs uids subs) = any goodsig $ Map.toList uids
2005 where
2006 goodsig (uidstr,(sigs,_)) = not . null $ do
2007 sig0 <- fmap (packet . fst) sigs
2008 pre_ov <- signatures (Message [packet k, UserIDPacket uidstr, sig0])
2009 signatures_over $ verify (Message [wk]) pre_ov
2010
2011 workingKey grip use_db = listToMaybe $ do
2012 fp <- maybeToList grip
2013 elm <- Map.elems use_db
2014 guard $ matchSpec (KeyGrip fp) elm
2015 return $ keyPacket elm
2016
2017writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
2018 -> [(FilePath,KikiReportAction)]
2019 {-
2020 -> KeyDB -> Maybe Packet
2021 -> FilePath -> FilePath
2022 -}
2023 -> IO (KikiCondition [(FilePath,KikiReportAction)])
2024writeRingKeys krd rt {- db wk secring pubring -} unspilled report_manips = do
2025 let isring (KeyRingFile {}) = True
2026 isring _ = False
2027 db = rtKeyDB rt
2028 secring = rtSecring rt
2029 pubring = rtPubring rt
2030 ctx = InputFileContext secring pubring
2031 let s = do
2032 (f,f0,stream) <- do
2033 (f0,stream) <- Map.toList (opFiles krd)
2034 guard (isring $ typ stream)
2035 f <- resolveInputFile ctx f0
2036 return (f,f0,stream)
2037 let db' = fromMaybe db $ do
2038 msg <- Map.lookup f0 unspilled
2039 return $ merge db f0 msg
2040 x = do
2041 let wantedForFill :: Access -> KeyFilter -> KeyData -> Maybe Bool
2042 wantedForFill acc KF_None = importByExistingMaster
2043 -- Note the KF_None case is almost irrelevent as it will be
2044 -- filtered later when isMutable returns False.
2045 -- We use importByExistingMaster in order to generate
2046 -- MissingPacket warnings. To disable those warnings, use
2047 -- const Nothing instead.
2048 wantedForFill acc (KF_Match {}) = importByExistingMaster
2049 wantedForFill acc KF_Subkeys = importByExistingMaster
2050 wantedForFill acc KF_Authentic = \kd -> do guardAuthentic rt kd
2051 importByAccess acc kd
2052 wantedForFill acc KF_All = importByAccess acc
2053 importByAccess Pub kd = importPublic
2054 importByAccess Sec kd = importSecret
2055 importByAccess AutoAccess kd =
2056 mplus (importByExistingMaster kd)
2057 (error $ f ++ ": write public or secret key to file?")
2058 importByExistingMaster kd@(KeyData p _ _ _) =
2059 fmap originallyPublic $ Map.lookup f $ locations p
2060 d <- sortByHint f keyMappedPacket (Map.elems db')
2061 acc <- maybeToList $ Map.lookup f0 (rtRingAccess rt)
2062 only_public <- maybeToList $ wantedForFill acc (fill stream) d
2063 guard $ only_public || isSecretKey (keyPacket d)
2064 case fill stream of
2065 KF_Match usage -> do grip <- maybeToList $ rtGrip rt
2066 flattenTop f only_public
2067 $ filterNewSubs f (parseSpec grip usage) d
2068 _ -> flattenTop f only_public d
2069 new_packets = filter isnew x
2070 where isnew p = isNothing (Map.lookup (resolveForReport Nothing f0) $ locations p)
2071 -- TODO: We depend on an exact string match between the reported
2072 -- file origin of the deleted packet and the path of the file we are
2073 -- writing. Verify that this is a safe assumption.
2074 isdeleted (f',DeletedPacket _) = f'==f
2075 isdeleted _ = False
2076 guard (not (null new_packets) || any isdeleted report_manips)
2077 return ((f0,isMutable stream),(new_packets,x))
2078 let (towrites,report) = (\f -> foldl f ([],[]) s) $
2079 \(ws,report) ((f,mutable),(new_packets,x)) ->
2080 if mutable
2081 then
2082 let rs = flip map new_packets
2083 $ \c -> (concat $ resolveInputFile ctx f, NewPacket $ showPacket (packet c))
2084 in (ws++[(f,x)],report++rs)
2085 else
2086 let rs = flip map new_packets
2087 $ \c -> (concat $ resolveInputFile ctx f,MissingPacket (showPacket (packet c)))
2088 in (ws,report++rs)
2089 forM_ towrites $ \(f,x) -> do
2090 let m = Message $ map packet x
2091 -- warn $ "writing "++f
2092 writeInputFileL ctx f (encode m)
2093 return $ KikiSuccess report
2094
2095
2096{-
2097getSubkeysForExport kk subspec db = do
2098 kd <- maybeToList $ Map.lookup kk db
2099 subkeysForExport subspec kd
2100-}
2101
2102-- | If provided Nothing for the first argument, this function returns the
2103-- master key of the given identity. Otherwise, it returns all the subkeys of
2104-- the given identity which have a usage tag that matches the first argument.
2105subkeysForExport :: Maybe String -> KeyData -> [MappedPacket]
2106subkeysForExport subspec (KeyData key _ _ subkeys) = do
2107 let subs tag = do
2108 e <- Map.elems subkeys
2109 guard $ doSearch key tag e
2110 return $ subkeyMappedPacket e
2111 maybe [key] subs subspec
2112 where
2113 doSearch key tag (SubKey sub_mp sigtrusts) =
2114 let (_,v,_) = findTag [mkUsage tag]
2115 (packet key)
2116 (packet sub_mp)
2117 sigtrusts
2118 in fmap fst v==Just True
2119
2120writePEM :: String -> String -> String
2121writePEM typ dta = pem
2122 where
2123 pem = unlines . concat $
2124 [ ["-----BEGIN " <> typ <> "-----"]
2125 , split64s dta
2126 , ["-----END " <> typ <> "-----"] ]
2127 split64s :: String -> [String]
2128 split64s "" = []
2129 split64s dta = line : split64s rest where (line,rest) = splitAt 64 dta
2130
2131 -- 64 byte lines
2132
2133rsaPrivateKeyFromPacket :: Packet -> Maybe RSAPrivateKey
2134rsaPrivateKeyFromPacket pkt@(SecretKeyPacket {}) = do
2135 -- public fields...
2136 n <- lookup 'n' $ key pkt
2137 e <- lookup 'e' $ key pkt
2138 -- secret fields
2139 MPI d <- lookup 'd' $ key pkt
2140 MPI q <- lookup 'p' $ key pkt -- Note: p & q swapped
2141 MPI p <- lookup 'q' $ key pkt -- Note: p & q swapped
2142
2143 -- Note: Here we fail if 'u' key is missing.
2144 -- Ideally, it would be better to compute (inverse q) mod p
2145 -- see Algebra.Structures.EuclideanDomain.extendedEuclidAlg
2146 -- (package constructive-algebra)
2147 coefficient <- lookup 'u' $ key pkt
2148
2149 let dmodp1 = MPI $ d `mod` (p - 1)
2150 dmodqminus1 = MPI $ d `mod` (q - 1)
2151 return $ RSAPrivateKey
2152 { rsaN = n
2153 , rsaE = e
2154 , rsaD = MPI d
2155 , rsaP = MPI p
2156 , rsaQ = MPI q
2157 , rsaDmodP1 = dmodp1
2158 , rsaDmodQminus1 = dmodqminus1
2159 , rsaCoefficient = coefficient }
2160rsaPrivateKeyFromPacket _ = Nothing
2161
2162secretPemFromPacket packet = pemFromPacket Sec packet
2163
2164pemFromPacket Sec packet =
2165 case key_algorithm packet of
2166 RSA -> do
2167 rsa <- rsaPrivateKeyFromPacket packet -- RSAPrivateKey
2168 let asn1 = toASN1 rsa []
2169 bs = encodeASN1 DER asn1
2170 dta = Base64.encode (L.unpack bs)
2171 output = writePEM "RSA PRIVATE KEY" dta
2172 Just output
2173 algo -> Nothing
2174pemFromPacket Pub packet =
2175 case key_algorithm packet of
2176 RSA -> do
2177 rsa <- rsaKeyFromPacket packet
2178 let asn1 = toASN1 (pkcs8 rsa) []
2179 bs = encodeASN1 DER asn1
2180 dta = Base64.encode (L.unpack bs)
2181 output = writePEM "PUBLIC KEY" dta
2182 Just output
2183 algo -> Nothing
2184pemFromPacket AutoAccess p@(PublicKeyPacket {}) = pemFromPacket Pub p
2185pemFromPacket AutoAccess p@(SecretKeyPacket {}) = pemFromPacket Sec p
2186pemFromPacket AutoAccess _ = Nothing
2187
2188writeKeyToFile ::
2189 Bool -> StreamInfo -> InputFile -> Packet -> IO [(InputFile, KikiReportAction)]
2190writeKeyToFile False stream@(StreamInfo { typ = PEMFile }) fname packet = do
2191 case pemFromPacket (access stream) packet of
2192 Just output -> do
2193 let stamp = toEnum . fromEnum $ timestamp packet
2194 handleIO_ (return [(fname, FailedFileWrite)]) $ do
2195 saved_mask <- setFileCreationMask 0o077
2196 -- Note: The key's timestamp is included in it's fingerprint.
2197 -- Therefore, we should attempt to preserve it.
2198 writeStamped (InputFileContext "" "") fname stamp output
2199 setFileCreationMask saved_mask
2200 return [(fname, ExportedSubkey)]
2201 Nothing -> return [(fname, UnableToExport (key_algorithm packet) $ fingerprint packet)]
2202
2203writeKeyToFile False StreamInfo { typ = DNSPresentation } fname packet = do
2204 case key_algorithm packet of
2205 RSA -> do
2206 flip (maybe (return []))
2207 (rsaPrivateKeyFromPacket packet) -- RSAPrivateKey
2208 $ \rsa -> do
2209 let -- asn1 = toASN1 rsa []
2210 -- bs = encodeASN1 DER asn1
2211 -- dta = Base64.encode (L.unpack bs)
2212 b64 ac rsa = Base64.encode (S.unpack $ i2bs_unsized i)
2213 where
2214 MPI i = ac rsa
2215 i2bs_unsized :: Integer -> S.ByteString
2216 i2bs_unsized 0 = S.singleton 0
2217 i2bs_unsized i = S.reverse $ S.unfoldr go i
2218 where go i' = if i' <= 0 then Nothing
2219 else Just (fromIntegral i', (i' `shiftR` 8))
2220 output = unlines
2221 [ "Private-key-format: v1.2"
2222 , "Algorithm: 8 (RSASHA256)"
2223 , "Modulus: " ++ b64 rsaN rsa
2224 , "PublicExponent: " ++ b64 rsaE rsa
2225 , "PrivateExponent: " ++ b64 rsaD rsa
2226 , "Prime1: " ++ b64 rsaP rsa
2227 , "Prime2: " ++ b64 rsaQ rsa
2228 , "Exponent1: " ++ b64 rsaDmodP1 rsa
2229 , "Exponent2: " ++ b64 rsaDmodQminus1 rsa
2230 , "Coefficient: " ++ b64 rsaCoefficient rsa
2231 ]
2232 stamp = toEnum . fromEnum $ timestamp packet
2233 handleIO_ (return [(fname, FailedFileWrite)]) $ do
2234 saved_mask <- setFileCreationMask 0o077
2235 -- Note: The key's timestamp is included in it's fingerprint.
2236 -- Therefore, we should attempt to preserve it.
2237 writeStamped (InputFileContext "" "") fname stamp output
2238 setFileCreationMask saved_mask
2239 return [(fname, ExportedSubkey)]
2240 algo -> return [(fname, UnableToExport algo $ fingerprint packet)]
2241
2242writePEMKeys :: (MappedPacket -> IO (KikiCondition Packet))
2243 -> KeyDB
2244 -> [(FilePath,Maybe String,[MappedPacket],StreamInfo)]
2245 -> IO (KikiCondition [(FilePath,KikiReportAction)])
2246writePEMKeys doDecrypt db exports = do
2247 ds <- mapM decryptKeys exports
2248 let ds' = map functorToEither ds
2249 if null (lefts ds')
2250 then do
2251 rs <- mapM (\(f,stream,p) -> writeKeyToFile False stream (ArgFile f) p)
2252 (rights ds')
2253 return $ KikiSuccess (map (first $ resolveForReport Nothing) $ concat rs)
2254 else do
2255 return (head $ lefts ds')
2256 where
2257 decryptKeys (fname,subspec,[p],stream@(StreamInfo { access=Pub }))
2258 = return $ KikiSuccess (fname,stream,packet p) -- public keys are never encrypted.
2259 decryptKeys (fname,subspec,[p],stream) = do
2260 pun <- doDecrypt p
2261 try pun $ \pun -> do
2262 return $ KikiSuccess (fname,stream,pun)
2263
2264makeMemoizingDecrypter :: KeyRingOperation -> InputFileContext
2265 -> Map.Map KeyKey MappedPacket
2266 -> IO (MappedPacket -> IO (KikiCondition Packet))
2267makeMemoizingDecrypter operation ctx keys =
2268 if null chains then do
2269 -- (*) Notice we do not pass ctx to resolveForReport.
2270 -- This is because the merge function does not currently use a context
2271 -- and the pws map keys must match the MappedPacket locations.
2272 -- TODO: Perhaps these should both be of type InputFile rather than
2273 -- FilePath?
2274 -- pws :: Map.Map FilePath (IO S.ByteString)
2275 {-
2276 pws <-
2277 Traversable.mapM (cachedContents ctx . fromJust . pwfile . typ)
2278 (Map.mapKeys (resolveForReport Nothing) -- see note (*) note above
2279 $ Map.filter (isJust . pwfile . typ) $ opFiles operation)
2280 -}
2281 let prompt = Just "Enter possibly multi-line passphrase (Press CTRL-D when finished):\n"
2282 pws2 <-
2283 Traversable.mapM (cachedContents prompt ctx)
2284 $ Map.fromList $ mapMaybe
2285 (\spec -> (,passSpecPassFile spec) `fmap` do
2286 guard $ isNothing $ passSpecKeySpec spec
2287 passSpecRingFile spec)
2288 passspecs
2289 defpw <- do
2290 Traversable.mapM (cachedContents prompt ctx . passSpecPassFile)
2291 $ listToMaybe $ filter (\sp -> isNothing (passSpecRingFile sp)
2292 && isNothing (passSpecKeySpec sp))
2293 $ opPassphrases operation
2294 unkeysRef <- newIORef (Map.empty :: Map.Map KeyKey Packet)
2295 return $ doDecrypt unkeysRef ({- pws `Map.union` -} pws2) defpw
2296 else let PassphraseMemoizer f = head chains
2297 in return f
2298 where
2299 (chains,passspecs) = partition isChain $ opPassphrases operation
2300 where isChain (PassphraseMemoizer {}) = True
2301 isChain _ = False
2302 doDecrypt :: IORef (Map.Map KeyKey Packet)
2303 -> Map.Map FilePath (IO S.ByteString)
2304 -> Maybe (IO S.ByteString)
2305 -> MappedPacket
2306 -> IO (KikiCondition Packet)
2307 doDecrypt unkeysRef pws defpw mp0 = do
2308 unkeys <- readIORef unkeysRef
2309 let mp = fromMaybe mp0 $ do
2310 k <- Map.lookup kk keys
2311 return $ mergeKeyPacket "decrypt" mp0 k
2312 wk = packet mp0
2313 kk = keykey wk
2314 fs = Map.keys $ locations mp
2315
2316 decryptIt [] = return BadPassphrase
2317 decryptIt (getpw:getpws) = do
2318 -- TODO: This function should use mergeKeyPacket to
2319 -- combine the packet with it's unspilled version before
2320 -- attempting to decrypt it.
2321 pw <- getpw
2322 let wkun = fromMaybe wk $ decryptSecretKey pw (packet mp)
2323 case symmetric_algorithm wkun of
2324 Unencrypted -> do
2325 writeIORef unkeysRef (Map.insert kk wkun unkeys)
2326 return $ KikiSuccess wkun
2327 _ -> decryptIt getpws
2328
2329 getpws = mapMaybe (`Map.lookup` pws) fs ++ maybeToList defpw
2330
2331 case symmetric_algorithm wk of
2332 Unencrypted -> return (KikiSuccess wk)
2333 _ -> maybe (decryptIt getpws)
2334 (return . KikiSuccess)
2335 $ Map.lookup kk unkeys
2336
2337performManipulations ::
2338 (MappedPacket -> IO (KikiCondition Packet))
2339 -> KeyRingRuntime
2340 -> Maybe MappedPacket
2341 -> (KeyRingRuntime -> KeyData -> [PacketUpdate])
2342 -> IO (KikiCondition (KeyRingRuntime,KikiReport))
2343performManipulations doDecrypt rt wk manip = do
2344 let db = rtKeyDB rt
2345 performAll kd = foldM perform (KikiSuccess (kd,[])) $ manip rt kd
2346 r <- Traversable.mapM performAll db
2347 try (sequenceA r) $ \db -> do
2348 return $ KikiSuccess (rt { rtKeyDB = fmap fst db }, concatMap snd $ Map.elems db)
2349 where
2350 perform :: KikiCondition (KeyData,KikiReport) -> PacketUpdate -> IO (KikiCondition (KeyData,KikiReport))
2351 perform kd (InducerSignature uid subpaks) = do
2352 try kd $ \(kd,report) -> do
2353 flip (maybe $ return NoWorkingKey) wk $ \wk' -> do
2354 wkun' <- doDecrypt wk'
2355 try wkun' $ \wkun -> do
2356 let flgs = if keykey (keyPacket kd) == keykey wkun
2357 then keyFlags0 (keyPacket kd) (map (\(x,_,_)->x) selfsigs)
2358 else []
2359 sigOver = makeInducerSig (keyPacket kd)
2360 wkun
2361 (UserIDPacket uid)
2362 $ flgs ++ subpaks
2363 om = Map.singleton "--autosign" (origin p (-1)) where p = UserIDPacket uid
2364 toMappedPacket om p = (mappedPacket "" p) {locations=om}
2365 selfsigs = filter (\(sig,v,whosign) -> isJust (v >> Just wkun >>= guard
2366 . (== keykey whosign)
2367 . keykey)) vs
2368 keys = map keyPacket $ Map.elems (rtKeyDB rt)
2369 overs sig = signatures $ Message (keys++[keyPacket kd,UserIDPacket uid,sig])
2370 vs :: [ ( Packet -- signature
2371 , Maybe SignatureOver -- Nothing means non-verified
2372 , Packet ) -- key who signed
2373 ]
2374 vs = do
2375 x <- maybeToList $ Map.lookup uid (keyUids kd)
2376 sig <- map (packet . fst) (fst x)
2377 o <- overs sig
2378 k <- keys
2379 let ov = verify (Message [k]) $ o
2380 signatures_over ov
2381 return (sig,Just ov,k)
2382 additional new_sig = do
2383 new_sig <- maybeToList new_sig
2384 guard (null $ selfsigs)
2385 signatures_over new_sig
2386 sigr <- pgpSign (Message [wkun]) sigOver SHA1 (fingerprint wkun)
2387 let f ::([SigAndTrust],OriginMap) -> ([SigAndTrust],OriginMap)
2388 f x = ( map ( (,Map.empty) . toMappedPacket om) (additional sigr) ++ fst x
2389 , om `Map.union` snd x )
2390 -- XXX: Shouldn't this signature generation show up in the KikiReport ?
2391 return $ KikiSuccess $ ( kd { keyUids = Map.adjust f uid (keyUids kd) }, report )
2392
2393 perform kd (SubKeyDeletion topk subk) = do
2394 try kd $ \(kd,report) -> do
2395 let kk = keykey $ packet $ keyMappedPacket kd
2396 kd' | kk /= topk = kd
2397 | otherwise = kd { keySubKeys = Map.filterWithKey pred $ keySubKeys kd }
2398 pred k _ = k /= subk
2399 ps = concat $ maybeToList $ do
2400 SubKey mp sigs <- Map.lookup subk (keySubKeys kd)
2401 return $ packet mp : concatMap (\(p,ts) -> packet p : Map.elems ts) sigs
2402 ctx = InputFileContext (rtSecring rt) (rtPubring rt)
2403 rings = [HomeSec, HomePub] >>= resolveInputFile ctx
2404 return $ KikiSuccess (kd' , report ++ [ (f,DeletedPacket $ showPacket p) | f <- rings, p <- ps ])
2405
2406initializeMissingPEMFiles ::
2407 KeyRingOperation
2408 -> InputFileContext -> Maybe String
2409 -> (MappedPacket -> IO (KikiCondition Packet))
2410 -> KeyDB
2411 -> IO (KikiCondition ( (KeyDB,[( FilePath
2412 , Maybe String
2413 , [MappedPacket]
2414 , StreamInfo )])
2415 , [(FilePath,KikiReportAction)]))
2416initializeMissingPEMFiles operation ctx grip decrypt db = do
2417 nonexistents <-
2418 filterM (fmap not . doesFileExist . fst)
2419 $ do (f,t) <- Map.toList (opFiles operation)
2420 f <- resolveInputFile ctx f
2421 return (f,t)
2422
2423 let (missing,notmissing) = partition (\(_,_,ns,_)->null (ns >>= snd)) $ do
2424 (fname,stream) <- nonexistents
2425 guard $ isMutable stream
2426 guard $ isSecretKeyFile (typ stream)
2427 usage <- usageFromFilter (fill stream) -- TODO: Error if no result?
2428 let (topspec,subspec) = parseSpec (fromMaybe "" grip) usage
2429 -- ms will contain duplicates if a top key has multiple matching
2430 -- subkeys. This is intentional.
2431 -- ms = map (keykey . fst) $ selectAll True (topspec,subspec) db
2432 -- ms = filterMatches topspec $ Map.toList db
2433 ns = do
2434 (kk,kd) <- filterMatches topspec $ Map.toList db
2435 return (kk , subkeysForExport subspec kd)
2436 return (fname,subspec,ns,stream)
2437 (exports0,ambiguous) = partition (\(_,_,ns,_)->null $ drop 1 $ (ns>>=snd))
2438 notmissing
2439 exports = map (\(f,subspec,ns,stream) -> (f,subspec,ns >>= snd,stream)) exports0
2440
2441 ambiguity (f,topspec,subspec,_) = do
2442 return $ AmbiguousKeySpec f
2443
2444 ifnotnull (x:xs) f g = f x
2445 ifnotnull _ f g = g
2446
2447 ifnotnull ambiguous ambiguity $ do
2448
2449 -- create nonexistent files via external commands
2450 do
2451 let cmds = mapMaybe getcmd missing
2452 where
2453 getcmd (fname,subspec,ms,stream) = do
2454 cmd <- initializer stream
2455 return (fname,subspec,ms,stream,cmd)
2456 rs <- forM cmds $ \tup@(fname,subspec,ms,stream,cmd) -> do
2457 e <- systemEnv [ ("file",fname)
2458 , ("usage",fromMaybe "" subspec) ]
2459 cmd
2460 case e of
2461 ExitFailure num -> return (tup,FailedExternal num)
2462 ExitSuccess -> return (tup,ExternallyGeneratedFile)
2463
2464 v <- foldM (importSecretKey decrypt)
2465 (KikiSuccess (db,[])) $ do
2466 ((f,subspec,ms,stream,cmd),r) <- rs
2467 guard $ case r of
2468 ExternallyGeneratedFile -> True
2469 _ -> False
2470 return (f,subspec,map fst ms,stream,cmd)
2471
2472 try v $ \(db,import_rs) -> do
2473 return $ KikiSuccess ((db,exports), map (\((f,_,_,_,_),r)->(f,r)) rs
2474 ++ import_rs)
2475{-
2476interpretManip :: KeyData -> KeyRingAddress PacketUpdate -> IO KeyData
2477interpretManip kd (KeyRingAddress kk sk (InducerSignature ps)) = error "todo"
2478interpretManip kd manip = return kd
2479-}
2480
2481combineTransforms :: [Transform] -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2482combineTransforms trans rt kd = updates
2483 where
2484 updates = -- kManip operation rt kd ++
2485 concatMap (\t -> resolveTransform t rt kd) sanitized
2486 sanitized = group (sort trans) >>= take 1
2487
2488isSubkeySignature (SubkeySignature {}) = True
2489isSubkeySignature _ = False
2490
2491-- Returned data is simmilar to getBindings but the Word8 codes
2492-- are ORed together.
2493accBindings ::
2494 Bits t =>
2495 [(t, (Packet, Packet), [a], [a1], [a2])]
2496 -> [(t, (Packet, Packet), [a], [a1], [a2])]
2497accBindings bs = as
2498 where
2499 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
2500 as = map (foldl1 combine) gs
2501 bindingPair (_,p,_,_,_) = pub2 p
2502 where
2503 pub2 (a,b) = (pub a, pub b)
2504 pub a = fingerprint_material a
2505 samePair a b = bindingPair a == bindingPair b
2506 combine (ac,p,akind,ahashed,aclaimaints)
2507 (bc,_,bkind,bhashed,bclaimaints)
2508 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
2509
2510
2511
2512verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
2513 where
2514 verified = do
2515 sig <- signatures (Message nonkeys)
2516 let v = verify (Message keys) sig
2517 guard (not . null $ signatures_over v)
2518 return v
2519 (top,othersigs) = partition isSubkeySignature verified
2520 embedded = do
2521 sub <- top
2522 let sigover = signatures_over sub
2523 unhashed = sigover >>= unhashed_subpackets
2524 subsigs = mapMaybe backsig unhashed
2525 -- This should consist only of 0x19 values
2526 -- subtypes = map signature_type subsigs
2527 -- trace ("subtypes = "++show subtypes) (return ())
2528 -- trace ("issuers: "++show (map signature_issuer subsigs)) (return ())
2529 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
2530 let v = verify (Message [subkey sub]) sig
2531 guard (not . null $ signatures_over v)
2532 return v
2533
2534smallpr k = drop 24 $ fingerprint k
2535
2536disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
2537 where
2538 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
2539 samepr a b = smallpr a == smallpr b
2540
2541 {-
2542 -- useful for testing
2543 group2 :: [a] -> [[a]]
2544 group2 (x:y:ys) = [x,y]:group2 ys
2545 group2 [x] = [[x]]
2546 group2 [] = []
2547 -}
2548
2549
2550getBindings ::
2551 [Packet]
2552 ->
2553 ( [([Packet],[SignatureOver])] -- other signatures with key sets
2554 -- that were used for the verifications
2555 , [(Word8,
2556 (Packet, Packet), -- (topkey,subkey)
2557 [String], -- usage flags
2558 [SignatureSubpacket], -- hashed data
2559 [Packet])] -- binding signatures
2560 )
2561getBindings pkts = (sigs,bindings)
2562 where
2563 (sigs,concat->bindings) = unzip $ do
2564 let (keys,_) = partition isKey pkts
2565 keys <- disjoint_fp keys
2566 let (bs,sigs) = verifyBindings keys pkts
2567 return . ((keys,sigs),) $ do
2568 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
2569 i <- map signature_issuer (signatures_over b)
2570 i <- maybeToList i
2571 who <- maybeToList $ find_key fingerprint (Message keys) i
2572 let (code,claimants) =
2573 case () of
2574 _ | who == topkey b -> (1,[])
2575 _ | who == subkey b -> (2,[])
2576 _ -> (0,[who])
2577 let hashed = signatures_over b >>= hashed_subpackets
2578 kind = guard (code==1) >> hashed >>= maybeToList . usage
2579 return (code,(topkey b,subkey b), kind, hashed,claimants)
2580
2581resolveTransform :: Transform -> KeyRingRuntime -> KeyData -> [PacketUpdate]
2582resolveTransform Autosign rt kd@(KeyData k ksigs umap submap) = ops
2583 where
2584 ops = map (\u -> InducerSignature u []) us
2585 us = filter torStyle $ Map.keys umap
2586 torStyle str = and [ uid_topdomain parsed == "onion"
2587 , uid_realname parsed `elem` ["","Anonymous"]
2588 , uid_user parsed == "root"
2589 , fmap (match . fst) (lookup (packet k) torbindings)
2590 == Just True ]
2591 where parsed = parseUID str
2592 match = (==subdom) . take (fromIntegral len)
2593 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
2594 subdom = Char8.unpack subdom0
2595 len = T.length (uid_subdomain parsed)
2596 torbindings = getTorKeys (map packet $ flattenTop "" True kd)
2597 getTorKeys pub = do
2598 xs <- groupBindings pub
2599 (_,(top,sub),us,_,_) <- xs
2600 guard ("tor" `elem` us)
2601 let torhash = fromMaybe "" $ derToBase32 <$> derRSA sub
2602 return (top,(torhash,sub))
2603
2604 groupBindings pub = gs
2605 where (_,bindings) = getBindings pub
2606 bindings' = accBindings bindings
2607 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
2608 ownerkey (_,(a,_),_,_,_) = a
2609 sameMaster (ownerkey->a) (ownerkey->b)
2610 = fingerprint_material a==fingerprint_material b
2611 gs = groupBy sameMaster (sortBy (comparing code) bindings')
2612
2613
2614resolveTransform (DeleteSubKey fp) rt kd@(KeyData k ksigs umap submap) = fmap (SubKeyDeletion topk) subk
2615 where
2616 topk = keykey $ packet k -- key to master of key to be deleted
2617 subk = do
2618 (k,sub) <- Map.toList submap
2619 guard (map toUpper fp == fingerprint (packet (subkeyMappedPacket sub)))
2620 return k
2621
2622
2623-- | Load and update key files according to the specified 'KeyRingOperation'.
2624runKeyRing :: KeyRingOperation -> IO (KikiResult KeyRingRuntime)
2625runKeyRing operation = do
2626 homedir <- getHomeDir (opHome operation)
2627 let try' :: KikiCondition a -> (a -> IO (KikiResult b)) -> IO (KikiResult b)
2628 -- FIXME: try' should probably accept a list of KikiReportActions.
2629 -- This would be useful for reporting on disk writes that have already
2630 -- succeded prior to this termination.
2631 try' v body =
2632 case functorToEither v of
2633 Left e -> return $ KikiResult e []
2634 Right wkun -> body wkun
2635 try' homedir $ \(homedir,secring,pubring,grip0) -> do
2636 let ctx = InputFileContext secring pubring
2637 tolocks = filesToLock operation ctx
2638 secring <- return Nothing
2639 pubring <- return Nothing
2640 lks <- forM tolocks $ \f -> do
2641 lk <- dotlock_create f 0
2642 v <- flip (maybe $ return Nothing) lk $ \lk -> do
2643 e <- dotlock_take lk (-1)
2644 if e==0 then return $ Just lk
2645 else dotlock_destroy lk >> return Nothing
2646 return (v,f)
2647 let (lked, map snd -> failed_locks) = partition (isJust . fst) lks
2648 ret <-
2649 if not $ null failed_locks
2650 then return $ KikiResult (FailedToLock failed_locks) []
2651 else do
2652
2653 -- merge all keyrings, PEM files, and wallets
2654 bresult <- buildKeyDB ctx grip0 operation
2655 try' bresult $ \((db,grip,wk,hs,accs,decrypt,unspilled),report_imports) -> do
2656
2657 externals_ret <- initializeMissingPEMFiles operation
2658 ctx
2659 grip
2660 decrypt
2661 db
2662 try' externals_ret $ \((db,exports),report_externals) -> do
2663
2664 let rt = KeyRingRuntime
2665 { rtPubring = homepubPath ctx
2666 , rtSecring = homesecPath ctx
2667 , rtGrip = grip
2668 , rtWorkingKey = fmap packet wk
2669 , rtKeyDB = db
2670 , rtRingAccess = accs
2671 , rtPassphrases = decrypt
2672 }
2673
2674 r <- performManipulations decrypt
2675 rt
2676 wk
2677 (combineTransforms $ opTransforms operation)
2678 try' r $ \(rt,report_manips) -> do
2679
2680 r <- writeWalletKeys operation (rtKeyDB rt) (fmap packet wk)
2681 try' r $ \report_wallets -> do
2682
2683 r <- writeRingKeys operation rt unspilled report_manips
2684 try' r $ \report_rings -> do
2685
2686 r <- writePEMKeys decrypt (rtKeyDB rt) exports
2687 try' r $ \report_pems -> do
2688
2689 import_hosts <- writeHostsFiles operation ctx hs
2690
2691 return $ KikiResult (KikiSuccess rt)
2692 $ concat [ report_imports
2693 , report_externals
2694 , report_manips
2695 , report_wallets
2696 , report_rings
2697 , report_pems ]
2698
2699 forM_ lked $ \(Just lk, fname) -> dotlock_release lk
2700
2701 return ret
2702
2703parseOptionFile :: FilePath -> IO [String]
2704parseOptionFile fname = do
2705 xs <- fmap lines (readFile fname)
2706 let ys = filter notComment xs
2707 notComment ('#':_) = False
2708 notComment cs = not (all isSpace cs)
2709 return ys
2710
2711-- | returns ( home directory
2712-- , path to secret ring
2713-- , path to public ring
2714-- , fingerprint of working key
2715-- )
2716getHomeDir :: Maybe FilePath -> IO (KikiCondition (FilePath,FilePath,FilePath,Maybe String))
2717getHomeDir protohome = do
2718 homedir <- envhomedir protohome
2719 flip (maybe (return CantFindHome))
2720 homedir $ \homedir -> do
2721 -- putStrLn $ "homedir = " ++show homedir
2722 let secring = homedir ++ "/" ++ "secring.gpg"
2723 pubring = homedir ++ "/" ++ "pubring.gpg"
2724 -- putStrLn $ "secring = " ++ show secring
2725 workingkey <- getWorkingKey homedir
2726 return $ KikiSuccess (homedir,secring,pubring,workingkey)
2727 where
2728 envhomedir opt = do
2729 gnupghome <- fmap (mfilter (/="")) $ lookupEnv (homevar home)
2730 homed <- fmap (mfilter (/="") . Just) getHomeDirectory
2731 let homegnupg = (++('/':(appdir home))) <$> homed
2732 let val = (opt `mplus` gnupghome `mplus` homegnupg)
2733 return $ val
2734
2735 -- TODO: rename this to getGrip
2736 getWorkingKey homedir = do
2737 let o = Nothing
2738 h = Just homedir
2739 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
2740 let optfiles = map (second ((h++"/")++))
2741 (maybe optfile_alts' (:[]) o')
2742 optfile_alts' = zip (False:repeat True) (optfile_alts home)
2743 o' = fmap (False,) o
2744 in filterM (doesFileExist . snd) optfiles
2745 args <- flip (maybe $ return []) ofile $
2746 \(forgive,fname) -> parseOptionFile fname
2747 let config = map (topair . words) args
2748 where topair (x:xs) = (x,xs)
2749 return $ lookup "default-key" config >>= listToMaybe
2750
2751#if MIN_VERSION_base(4,6,0)
2752#else
2753lookupEnv :: String -> IO (Maybe String)
2754lookupEnv var =
2755 handleIO_ (return Nothing) $ fmap Just (getEnv var)
2756#endif
2757
2758isKey :: Packet -> Bool
2759isKey (PublicKeyPacket {}) = True
2760isKey (SecretKeyPacket {}) = True
2761isKey _ = False
2762
2763isUserID :: Packet -> Bool
2764isUserID (UserIDPacket {}) = True
2765isUserID _ = False
2766
2767isTrust :: Packet -> Bool
2768isTrust (TrustPacket {}) = True
2769isTrust _ = False
2770
2771sigpackets ::
2772 Monad m =>
2773 Word8 -> [SignatureSubpacket] -> [SignatureSubpacket] -> m Packet
2774sigpackets typ hashed unhashed = return $
2775 signaturePacket
2776 4 -- version
2777 typ -- 0x18 subkey binding sig, or 0x19 back-signature
2778 RSA
2779 SHA1
2780 hashed
2781 unhashed
2782 0 -- Word16 -- Left 16 bits of the signed hash value
2783 [] -- [MPI]
2784
2785secretToPublic :: Packet -> Packet
2786secretToPublic pkt@(SecretKeyPacket {}) =
2787 PublicKeyPacket { version = version pkt
2788 , timestamp = timestamp pkt
2789 , key_algorithm = key_algorithm pkt
2790 -- , ecc_curve = ecc_curve pkt
2791 , key = let seckey = key pkt
2792 pubs = public_key_fields (key_algorithm pkt)
2793 in filter (\(k,v) -> k `elem` pubs) seckey
2794 , is_subkey = is_subkey pkt
2795 , v3_days_of_validity = Nothing
2796 }
2797secretToPublic pkt = pkt
2798
2799
2800
2801slurpWIPKeys :: Posix.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
2802slurpWIPKeys stamp "" = ([],[])
2803slurpWIPKeys stamp cs =
2804 let (b58,xs) = Char8.span (`elem` base58chars) cs
2805 mb = decode_btc_key stamp (Char8.unpack b58)
2806 in if L.null b58
2807 then let (ys,xs') = Char8.break (`elem` base58chars) cs
2808 (ks,js) = slurpWIPKeys stamp xs'
2809 in (ks,ys:js)
2810 else let (ks,js) = slurpWIPKeys stamp xs
2811 in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb
2812
2813
2814decode_btc_key ::
2815 Enum timestamp => timestamp -> String -> Maybe (Word8, Message)
2816decode_btc_key timestamp str = do
2817 (network_id,us) <- base58_decode str
2818 return . (network_id,) $ Message $ do
2819 let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
2820 {-
2821 xy = secp256k1_G `pmul` d
2822 x = getx xy
2823 y = gety xy
2824 -- y² = x³ + 7 (mod p)
2825 y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
2826 y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
2827 -}
2828 secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
2829 ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
2830 -- pub = cannonical_eckey x y
2831 -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $ pub
2832 -- address = base58_encode hash
2833 -- pubstr = concatMap (printf "%02x") $ pub
2834 -- _ = pubstr :: String
2835 return $ {- trace (unlines ["pub="++show pubstr
2836 ,"add="++show address
2837 ,"y ="++show y
2838 ,"y' ="++show y'
2839 ,"y''="++show y'']) -}
2840 SecretKeyPacket
2841 { version = 4
2842 , timestamp = toEnum (fromEnum timestamp)
2843 , key_algorithm = ECDSA
2844 , key = [ -- public fields...
2845 ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
2846 ,('l',MPI 256)
2847 ,('x',MPI x)
2848 ,('y',MPI y)
2849 -- secret fields
2850 ,('d',MPI d)
2851 ]
2852 , s2k_useage = 0
2853 , s2k = S2K 100 ""
2854 , symmetric_algorithm = Unencrypted
2855 , encrypted_data = ""
2856 , is_subkey = True
2857 }
2858
2859rsaKeyFromPacket :: Packet -> Maybe RSAPublicKey
2860rsaKeyFromPacket p | isKey p = do
2861 n <- lookup 'n' $ key p
2862 e <- lookup 'e' $ key p
2863 return $ RSAKey n e
2864
2865rsaKeyFromPacket _ = Nothing
2866
2867
2868readPacketsFromWallet ::
2869 Maybe Packet
2870 -> InputFile
2871 -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
2872readPacketsFromWallet wk fname = do
2873 let ctx = InputFileContext "" ""
2874 timestamp <- getInputFileTime ctx fname
2875 input <- readInputFileL ctx fname
2876 let (ks,_) = slurpWIPKeys timestamp input
2877 unless (null ks) $ do
2878 -- decrypt wk
2879 -- create sigs
2880 -- return key/sig pairs
2881 return ()
2882 return $ do
2883 wk <- maybeToList wk
2884 guard (not $ null ks)
2885 let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
2886 where tag = CryptoCoins.nameFromSecretByte tagbyte
2887 (wk,MarkerPacket,(MarkerPacket,Map.empty))
2888 :map prep ks
2889
2890readPacketsFromFile :: InputFileContext -> InputFile -> IO Message
2891readPacketsFromFile ctx fname = do
2892 -- warn $ fname ++ ": reading..."
2893 input <- readInputFileL ctx fname
2894#if MIN_VERSION_binary(0,7,0)
2895 return $
2896 case decodeOrFail input of
2897 Right (_,_,msg ) -> msg
2898 Left (_,_,_) ->
2899 -- FIXME
2900 -- trace (fname++": read fail") $
2901 Message []
2902#else
2903 return $ decode input
2904#endif
2905
2906-- | Get the time stamp of a signature.
2907--
2908-- Warning: This function checks unhashed_subpackets if no timestamp occurs in
2909-- the hashed section. TODO: change this?
2910--
2911signature_time :: SignatureOver -> Word32
2912signature_time ov = case (if null cs then ds else cs) of
2913 [] -> minBound
2914 xs -> maximum xs
2915 where
2916 ps = signatures_over ov
2917 ss = filter isSignaturePacket ps
2918 cs = concatMap (concatMap creationTime . hashed_subpackets) ss
2919 ds = concatMap (concatMap creationTime . unhashed_subpackets) ss
2920 creationTime (SignatureCreationTimePacket t) = [t]
2921 creationTime _ = []
2922
2923splitAtMinBy :: (t -> t -> Ordering) -> [t] -> ([t], [t])
2924splitAtMinBy comp xs = minimumBy comp' xxs
2925 where
2926 xxs = zip (inits xs) (tails xs)
2927 comp' (_,as) (_,bs) = compM (listToMaybe as) (listToMaybe bs)
2928 compM (Just a) (Just b) = comp a b
2929 compM Nothing mb = GT
2930 compM _ _ = LT
2931
2932
2933
2934-- | Given list of subpackets, a master key, one of its subkeys and a
2935-- list of signatures on that subkey, yields:
2936--
2937-- * preceding list of signatures
2938--
2939-- * The most recent valid signature made by the master key along with a
2940-- flag that indicates whether or not all of the supplied subpackets occur in
2941-- it or, if no valid signature from the working key is present, Nothing.
2942--
2943-- * following list of signatures
2944--
2945findTag ::
2946 [SignatureSubpacket]
2947 -> Packet
2948 -> Packet
2949 -> [(MappedPacket, b)]
2950 -> ([(MappedPacket, b)],
2951 Maybe (Bool, (MappedPacket, b)),
2952 [(MappedPacket, b)])
2953findTag tag topk subkey subsigs = (xs',minsig,ys')
2954 where
2955 vs = map (\sig ->
2956 (sig, do
2957 sig <- Just (packet . fst $ sig)
2958 guard (isSignaturePacket sig)
2959 guard $ flip isSuffixOf
2960 (fingerprint topk)
2961 . fromMaybe "%bad%"
2962 . signature_issuer
2963 $ sig
2964 listToMaybe $
2965 map (signature_time . verify (Message [topk]))
2966 (signatures $ Message [topk,subkey,sig])))
2967 subsigs
2968 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
2969 xs' = map fst xs
2970 ys' = map fst $ if isNothing minsig then ys else drop 1 ys
2971 minsig = do
2972 (sig,ov) <- listToMaybe ys
2973 ov
2974 let hshed = hashed_subpackets $ packet $ fst sig
2975 return ( null $ tag \\ hshed, sig)
2976
2977mkUsage :: String -> SignatureSubpacket
2978mkUsage tag = NotationDataPacket
2979 { human_readable = True
2980 , notation_name = "usage@"
2981 , notation_value = tag
2982 }
2983
2984makeSig ::
2985 (MappedPacket -> IO (KikiCondition Packet))
2986 -> MappedPacket
2987 -> [Char]
2988 -> MappedPacket
2989 -> [SignatureSubpacket]
2990 -> Maybe (MappedPacket, Map.Map k a)
2991 -> IO (KikiCondition ((MappedPacket, Map.Map k a), [KikiReportAction]))
2992makeSig doDecrypt top fname subkey_p tags mbsig = do
2993 let wk = packet top
2994 wkun <- doDecrypt top
2995 try wkun $ \wkun -> do
2996 let grip = fingerprint wk
2997 addOrigin new_sig =
2998 flip (maybe $ return FailedToMakeSignature)
2999 (new_sig >>= listToMaybe . signatures_over)
3000 $ \new_sig -> do
3001 let mp' = mappedPacket fname new_sig
3002 return $ KikiSuccess (mp', Map.empty)
3003 parsedkey = [packet subkey_p]
3004 hashed0 = KeyFlagsPacket
3005 { certify_keys = False
3006 , sign_data = False
3007 , encrypt_communication = False
3008 , encrypt_storage = False
3009 , split_key = False
3010 , authentication = True
3011 , group_key = False }
3012 : tags
3013 -- implicitly added:
3014 -- , SignatureCreationTimePacket (fromIntegral timestamp)
3015 subgrip = fingerprint (head parsedkey)
3016
3017 back_sig <- pgpSign (Message parsedkey)
3018 (SubkeySignature wk
3019 (head parsedkey)
3020 (sigpackets 0x19
3021 hashed0
3022 [IssuerPacket subgrip]))
3023 (if key_algorithm (head parsedkey)==ECDSA
3024 then SHA256
3025 else SHA1)
3026 subgrip
3027 let iss = IssuerPacket (fingerprint wk)
3028 cons_iss back_sig = iss : map EmbeddedSignaturePacket (signatures_over back_sig)
3029 unhashed0 = maybe [iss] cons_iss back_sig
3030
3031 new_sig <- pgpSign (Message [wkun])
3032 (SubkeySignature wk
3033 (head parsedkey)
3034 (sigpackets 0x18
3035 hashed0
3036 unhashed0))
3037 SHA1
3038 grip
3039 let newSig = do
3040 r <- addOrigin new_sig
3041 return $ fmap (,[]) r
3042 flip (maybe newSig) mbsig $ \(mp,trustmap) -> do
3043 let sig = packet mp
3044 isCreation (SignatureCreationTimePacket {}) = True
3045 isCreation _ = False
3046 isExpiration (SignatureExpirationTimePacket {}) = True
3047 isExpiration _ = False
3048 (cs,ps) = partition isCreation (hashed_subpackets sig)
3049 (es,qs) = partition isExpiration ps
3050 stamp = listToMaybe . sortBy (comparing Down) $
3051 map unwrap cs where unwrap (SignatureCreationTimePacket x) = x
3052 exp = listToMaybe $ sort $
3053 map unwrap es where unwrap (SignatureExpirationTimePacket x) = x
3054 expires = liftA2 (+) stamp exp
3055 timestamp <- now
3056 if fmap ( (< timestamp) . fromIntegral) expires == Just True then
3057 return $ KikiSuccess ((mp,trustmap), [ UnableToUpdateExpiredSignature ] )
3058 else do
3059 let times = (:) (SignatureExpirationTimePacket (fromIntegral timestamp))
3060 $ maybeToList $ do
3061 e <- expires
3062 return $ SignatureExpirationTimePacket (e - fromIntegral timestamp)
3063 sig' = sig { hashed_subpackets = times ++ (qs `union` tags) }
3064 new_sig <- pgpSign (Message [wkun])
3065 (SubkeySignature wk
3066 (packet subkey_p)
3067 [sig'] )
3068 SHA1
3069 (fingerprint wk)
3070 newsig <- addOrigin new_sig
3071 return $ fmap (,[]) newsig
3072
3073
3074
3075data OriginFlags = OriginFlags {
3076 originallyPublic :: Bool,
3077 originalNum :: Int
3078 }
3079 deriving Show
3080type OriginMap = Map.Map FilePath OriginFlags
3081data MappedPacket = MappedPacket
3082 { packet :: Packet
3083 , locations :: OriginMap
3084 } deriving Show
3085
3086type TrustMap = Map.Map FilePath Packet
3087type SigAndTrust = ( MappedPacket
3088 , TrustMap ) -- trust packets
3089
3090type KeyKey = [ByteString]
3091data SubKey = SubKey MappedPacket [SigAndTrust] deriving Show
3092
3093-- | This is a GPG Identity which includes a master key and all its UIDs and
3094-- subkeys and associated signatures.
3095data KeyData = KeyData { keyMappedPacket :: MappedPacket -- main key
3096 , keySigAndTrusts :: [SigAndTrust] -- sigs on main key
3097 , keyUids :: (Map.Map String ([SigAndTrust],OriginMap)) -- uids
3098 , keySubKeys :: (Map.Map KeyKey SubKey) -- subkeys
3099 } deriving Show
3100
3101type KeyDB = Map.Map KeyKey KeyData
3102
3103origin :: Packet -> Int -> OriginFlags
3104origin p n = OriginFlags ispub n
3105 where
3106 ispub = case p of
3107 SecretKeyPacket {} -> False
3108 _ -> True
3109
3110mappedPacket :: FilePath -> Packet -> MappedPacket
3111mappedPacket filename p = MappedPacket
3112 { packet = p
3113 , locations = Map.singleton filename (origin p (-1))
3114 }
3115
3116mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
3117mappedPacketWithHint filename p hint = MappedPacket
3118 { packet = p
3119 , locations = Map.singleton filename (origin p hint)
3120 }
3121
3122keykey :: Packet -> KeyKey
3123keykey key =
3124 -- Note: The key's timestamp is normally included in it's fingerprint.
3125 -- This is undesirable for kiki because it causes the same
3126 -- key to be imported multiple times and show as apparently
3127 -- distinct keys with different fingerprints.
3128 -- Thus, we will remove the timestamp.
3129 fingerprint_material (key {timestamp=0}) -- TODO: smaller key?
3130
3131uidkey :: Packet -> String
3132uidkey (UserIDPacket str) = str
3133
3134merge :: KeyDB -> InputFile -> Message -> KeyDB
3135merge db inputfile (Message ps) = merge_ db filename qs
3136 where
3137 filename = resolveForReport Nothing inputfile
3138
3139 qs = scanPackets filename ps
3140
3141 scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
3142 scanPackets filename [] = []
3143 scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
3144 where
3145 ret p = (p,Map.empty)
3146 doit (top,sub,prev) p =
3147 case p of
3148 _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
3149 _ | isKey p && is_subkey p -> (top,p,ret p)
3150 _ | isUserID p -> (top,p,ret p)
3151 _ | isTrust p -> (top,sub,updateTrust top sub prev p)
3152 _ -> (top,sub,ret p)
3153
3154 updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
3155 updateTrust (PublicKeyPacket {}) _ (pre,t) p = (pre,Map.insert filename p t) -- public
3156 updateTrust _ _ (pre,t) p = (pre,Map.insert filename p t) -- secret
3157
3158
3159{-
3160onionName :: KeyData -> (SockAddr,L.ByteString)
3161onionName kd = (addr,name)
3162 where
3163 (addr,(name:_,_)) = getHostnames kd
3164-}
3165keyCompare :: String -> Packet -> Packet -> Ordering
3166keyCompare what (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
3167keyCompare what (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
3168keyCompare what a b | keykey a==keykey b = EQ
3169keyCompare what a b = error $ unlines ["Unable to merge "++what++":"
3170 , fingerprint a
3171 , PP.ppShow a
3172 , fingerprint b
3173 , PP.ppShow b
3174 ]
3175
3176mergeKeyPacket :: String -> MappedPacket -> MappedPacket -> MappedPacket
3177mergeKeyPacket what key p =
3178 key { packet = minimumBy (keyCompare what) [packet key,packet p]
3179 , locations = Map.union (locations key) (locations p)
3180 }
3181
3182
3183merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
3184 -> KeyDB
3185merge_ db filename qs = foldl mergeit db (zip [0..] qs)
3186 where
3187 asMapped n p = mappedPacketWithHint filename p n
3188 asSigAndTrust n (p,tm) = (asMapped n p,tm)
3189 emptyUids = Map.empty
3190 -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
3191 mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
3192 mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
3193 where
3194 -- NOTE:
3195 -- if a keyring file has both a public key packet and a secret key packet
3196 -- for the same key, then only one of them will survive, which ever is
3197 -- later in the file.
3198 --
3199 -- This is due to the use of statements like
3200 -- (Map.insert filename (origin p n) (locations key))
3201 --
3202 update :: Maybe KeyData -> Maybe KeyData
3203 update v | isKey p && not (is_subkey p)
3204 = case v of
3205 Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
3206 Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
3207 -> Just $ KeyData (mergeKeyPacket "master keys" key $ asMapped n p)
3208 sigs
3209 uids
3210 subkeys
3211 _ -> error . concat $ ["Unexpected master key merge error: "
3212 ,show (fingerprint top, fingerprint p)]
3213 update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
3214 = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
3215 update (Just (KeyData key sigs uids subkeys)) | isUserID p
3216 = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
3217 subkeys
3218 update (Just (KeyData key sigs uids subkeys))
3219 = case sub of
3220 MarkerPacket -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
3221 UserIDPacket {} -> Just $ KeyData key
3222 sigs
3223 (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
3224 subkeys
3225 _ | isKey sub -> Just $ KeyData key
3226 sigs
3227 uids
3228 (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
3229 _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
3230 update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)
3231
3232 mergeit _ (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p
3233
3234 mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
3235 mergeSubkey n p Nothing = Just $ SubKey (asMapped n p) []
3236 mergeSubkey n p (Just (SubKey key sigs)) = Just $
3237 SubKey (mergeKeyPacket "subs" key $ asMapped n p)
3238 sigs
3239
3240 mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
3241 mergeUid n (UserIDPacket s,_) Nothing = Just ([],Map.singleton filename (origin MarkerPacket n))
3242 mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
3243 mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p
3244
3245 whatP (a,_) = concat . take 1 . words . show $ a
3246
3247
3248 mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
3249 mergeSig n sig sigs =
3250 let (xs,ys) = break (isSameSig sig) sigs
3251 in if null ys
3252 then sigs++[first (asMapped n) sig]
3253 else let y:ys'=ys
3254 in xs ++ (mergeSameSig n sig y : ys')
3255 where
3256 isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
3257 a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
3258 isSameSig (a,_) (MappedPacket {packet=b},_) = a==b
3259
3260 mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
3261 mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb)
3262 | isSignaturePacket a && isSignaturePacket b =
3263 ( m { packet = b { unhashed_subpackets =
3264 union (unhashed_subpackets b) (unhashed_subpackets a)
3265 }
3266 , locations = Map.insert filename (origin a n) locs }
3267 -- TODO: when merging items, we should delete invalidated origins
3268 -- from the orgin map.
3269 , tb `Map.union` ta )
3270
3271 mergeSameSig n a b = b -- trace ("discarding dup "++show a) b
3272
3273 mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
3274 mergeUidSig n sig Nothing = Just ([asSigAndTrust n sig],Map.empty)
3275
3276 mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
3277 mergeSubSig n sig Nothing = error $
3278 "Unable to merge subkey signature: "++(words (show sig) >>= take 1)
3279
3280unsig :: FilePath -> Bool -> SigAndTrust -> [MappedPacket]
3281unsig fname isPublic (sig,trustmap) =
3282 sig : map (asMapped (-1)) ( take 1 . Map.elems $ Map.filterWithKey f trustmap)
3283 where
3284 f n _ = n==fname -- && trace ("fname=n="++show n) True
3285 asMapped n p = let m = mappedPacket fname p
3286 in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
3287
3288concatSort ::
3289 FilePath -> ([a] -> MappedPacket) -> (b -> [a]) -> [b] -> [a]
3290concatSort fname getp f = concat . sortByHint fname getp . map f
3291
3292sortByHint :: FilePath -> (a -> MappedPacket) -> [a] -> [a]
3293sortByHint fname f = sortBy (comparing gethint)
3294 where
3295 gethint = maybe defnum originalNum . Map.lookup fname . locations . f
3296 defnum = -1
3297
3298flattenKeys :: Bool -> KeyDB -> Message
3299flattenKeys isPublic db = Message $ concatMap (map packet . flattenTop "" isPublic . snd) (prefilter . Map.assocs $ db)
3300 where
3301 prefilter = if isPublic then id else filter isSecret
3302 where
3303 isSecret (_,(KeyData
3304 (MappedPacket { packet=(SecretKeyPacket {})})
3305 _
3306 _
3307 _)) = True
3308 isSecret _ = False
3309
3310
3311flattenTop :: FilePath -> Bool -> KeyData -> [MappedPacket]
3312flattenTop fname ispub (KeyData key sigs uids subkeys) =
3313 unk ispub key :
3314 ( flattenAllUids fname ispub uids
3315 ++ concatSort fname head (flattenSub fname ispub) (Map.elems subkeys))
3316
3317flattenSub :: FilePath -> Bool -> SubKey -> [MappedPacket]
3318flattenSub fname ispub (SubKey key sigs) = unk ispub key: concatSort fname head (unsig fname ispub) sigs
3319
3320unk :: Bool -> MappedPacket -> MappedPacket
3321unk isPublic = if isPublic then toPacket secretToPublic else id
3322 where toPacket f mp@(MappedPacket {packet=p}) = mp {packet=(f p)}
3323
3324flattenAllUids :: FilePath -> Bool -> Map.Map String ([SigAndTrust],OriginMap) -> [MappedPacket]
3325flattenAllUids fname ispub uids =
3326 concatSort fname head (flattenUid fname ispub) (Map.assocs uids)
3327
3328flattenUid :: FilePath -> Bool -> (String,([SigAndTrust],OriginMap)) -> [MappedPacket]
3329flattenUid fname ispub (str,(sigs,om)) =
3330 (mappedPacket "" $ UserIDPacket str) {locations=om} : concatSort fname head (unsig fname ispub) sigs
3331
3332getCrossSignedSubkeys :: Packet -> Map.Map KeyKey SubKey -> String -> [Packet]
3333getCrossSignedSubkeys topk subs tag = do
3334 SubKey k sigs <- Map.elems subs
3335 let subk = packet k
3336 let sigs' = do
3337 torsig <- filter (has_tag tag) $ map (packet . fst) sigs
3338 sig <- (signatures $ Message [topk,subk,torsig])
3339 let v = verify (Message [topk]) sig
3340 -- Require parent's signature
3341 guard (not . null $ signatures_over v)
3342 let unhashed = unhashed_subpackets torsig
3343 subsigs = mapMaybe backsig unhashed
3344 -- This should consist only of 0x19 values
3345 -- subtypes = map signature_type subsigs
3346 sig' <- signatures . Message $ [topk,subk]++subsigs
3347 let v' = verify (Message [subk]) sig'
3348 -- Require subkey's signature
3349 guard . not . null $ signatures_over v'
3350 return torsig
3351 guard (not $ null sigs')
3352 return subk
3353 where
3354 has_tag tag p = isSignaturePacket p
3355 && or [ tag `elem` mapMaybe usage (hashed_subpackets p)
3356 , tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) ]
3357
3358
3359-- |
3360-- Returns (ip6 fingerprint address,(onion names,other host names))
3361--
3362-- Requires a validly cross-signed tor key for each onion name returned.
3363-- (Signature checks are performed.)
3364getHostnames :: KeyData -> (SockAddr, ([L.ByteString],[L.ByteString]))
3365getHostnames (KeyData topmp _ uids subs) = (addr,(onames,othernames))
3366 where
3367 othernames = do
3368 mp <- flattenAllUids "" True uids
3369 let p = packet mp
3370 guard $ isSignaturePacket p
3371 uh <- unhashed_subpackets p
3372 case uh of
3373 NotationDataPacket True "hostname@" v
3374 -> return $ Char8.pack v
3375 _ -> mzero
3376
3377 addr = fingerdress topk
3378 -- name = fromMaybe "" $ listToMaybe onames -- TODO: more than one tor key?
3379 topk = packet topmp
3380 torkeys = getCrossSignedSubkeys topk subs "tor"
3381
3382 -- subkeyPacket (SubKey k _ ) = k
3383 onames :: [L.ByteString]
3384 onames = map ( (<> ".onion")
3385 . Char8.pack
3386 . take 16
3387 . torhash )
3388 torkeys
3389
3390hasFingerDress :: KeyDB -> SockAddr -> Bool
3391hasFingerDress db addr | socketFamily addr/=AF_INET6 = False
3392hasFingerDress db addr = pre=="fd" && isJust (selectPublicKey (KeyGrip g',Nothing) db)
3393 where
3394 (pre,g) = splitAt 2 $ filter (/=':') $ Hosts.inet_ntop addr
3395 g' = map toUpper g
3396
3397-- We return into IO in case we want to make a signature here.
3398setHostnames :: (SockAddr -> Bool) -> Hosts.Hosts -> KeyData -> IO KeyData
3399setHostnames pred hosts kd@(KeyData topmp topsigs uids subs) =
3400 -- TODO: we are removing the origin from the UID OriginMap,
3401 -- when we should be removing origins from the locations
3402 -- field of the sig's MappedPacket records.
3403 -- Call getHostnames and compare to see if no-op.
3404 if not (pred addr) || names0 == names \\ onions
3405 then {- trace (unlines [ "setHostnames NO-OP: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
3406 , " file: "++show (map Char8.unpack names)
3407 , " pred: "++show (pred addr)]) -}
3408 (return kd)
3409 else do
3410 -- We should be sure to remove origins so that the data is written
3411 -- (but only if something changed).
3412 -- Filter all hostnames present in uids
3413 -- Write notations into first uid
3414 {-
3415 trace (unlines [ "setHostnames ACTION: gpg: "++show (map Char8.unpack onions, map Char8.unpack names0)
3416 , " file: "++show (map Char8.unpack names) ]) $ do
3417 -}
3418 return $ KeyData topmp topsigs uids1 subs
3419 where
3420 topk = packet topmp
3421 addr = fingerdress topk
3422 names :: [Char8.ByteString]
3423 names = Hosts.namesForAddress addr hosts
3424 (_,(onions,names0)) = getHostnames kd
3425 notations = map (NotationDataPacket True "hostname@" . Char8.unpack) (names \\ onions)
3426 isName (NotationDataPacket True "hostname@" _) = True
3427 isName _ = False
3428 uids0 = fmap zapIfHasName uids
3429 fstuid = head $ do
3430 p <- map packet $ flattenAllUids "" True uids
3431 guard $ isUserID p
3432 return $ uidkey p
3433 uids1 = Map.adjust addnames fstuid uids0
3434 addnames (sigs,om) = (fmap f ss ++ ts, om ) -- XXX: removed om=Map.empty, preserve UserId origin
3435 where
3436 (ss,ts) = splitAt 1 sigs
3437 f (sig,tm) = if isSignaturePacket (packet sig) then (sig { packet = p', locations=Map.empty }, tm)
3438 else (sig, tm)
3439 where p' = (packet sig) { unhashed_subpackets=uh }
3440 uh = unhashed_subpackets (packet sig) ++ notations
3441 zapIfHasName (sigs,om) = if or bs then (sigs',om) -- XXX: removed om=Map.empty to preserve UserID origin
3442 else (sigs,om)
3443 where
3444 (bs, sigs') = unzip $ map unhash sigs
3445
3446 unhash (sig,tm) = ( not (null ns)
3447 , ( sig { packet = p', locations = Map.empty }
3448 , tm ) )
3449 where
3450 psig = packet sig
3451 p' = if isSignaturePacket psig then psig { unhashed_subpackets = ps }
3452 else psig
3453 uh = unhashed_subpackets psig
3454 (ns,ps) = partition isName uh
3455
3456fingerdress :: Packet -> SockAddr
3457fingerdress topk = fromMaybe zero $ Hosts.inet_pton addr_str
3458 where
3459 zero = SockAddrInet 0 0
3460 addr_str = colons $ "fd" ++ drop 10 (map toLower $ fingerprint topk)
3461 colons (a:b:c:d:xs@(_:_)) = [a,b,c,d,':'] ++ colons xs
3462 colons xs = xs
3463
3464backsig :: SignatureSubpacket -> Maybe Packet
3465backsig (EmbeddedSignaturePacket s) = Just s
3466backsig _ = Nothing
3467
3468socketFamily :: SockAddr -> Family
3469socketFamily (SockAddrInet _ _) = AF_INET
3470socketFamily (SockAddrInet6 {}) = AF_INET6
3471socketFamily (SockAddrUnix _) = AF_UNIX
3472
3473#if ! MIN_VERSION_unix(2,7,0)
3474setFdTimesHiRes :: Posix.Fd -> POSIXTime -> POSIXTime -> IO ()
3475setFdTimesHiRes (Posix.Fd fd) atime mtime =
3476 withArray [toCTimeSpec atime, toCTimeSpec mtime] $ \times ->
3477 throwErrnoIfMinus1_ "setFdTimesHiRes" (c_futimens fd times)
3478
3479data CTimeSpec = CTimeSpec Posix.EpochTime CLong
3480instance Storable CTimeSpec where
3481 sizeOf _ = (16)
3482 alignment _ = alignment (undefined :: CInt)
3483 poke p (CTimeSpec sec nsec) = do
3484 ((\hsc_ptr -> pokeByteOff hsc_ptr 0)) p sec
3485 ((\hsc_ptr -> pokeByteOff hsc_ptr 8)) p nsec
3486 peek p = do
3487 sec <- (\hsc_ptr -> peekByteOff hsc_ptr 0) p
3488 nsec <- (\hsc_ptr -> peekByteOff hsc_ptr 8) p
3489 return $ CTimeSpec sec nsec
3490
3491toCTimeSpec :: POSIXTime -> CTimeSpec
3492toCTimeSpec t = CTimeSpec (CTime sec) (truncate $ 10^(9::Int) * frac)
3493 where
3494 (sec, frac) = if (frac' < 0) then (sec' - 1, frac' + 1) else (sec', frac')
3495 (sec', frac') = properFraction $ toRational t
3496
3497foreign import ccall unsafe "futimens"
3498 c_futimens :: CInt -> Ptr CTimeSpec -> IO CInt
3499#endif
3500
3501onionNameForContact :: KeyKey -> KeyDB -> Maybe String
3502onionNameForContact kk db = do
3503 contact <- Map.lookup kk db
3504 let (_,(name:_,_)) = getHostnames contact
3505 return $ Char8.unpack name
generated by cgit v1.2.3 (git 2.39.1) at 2024-11-05 04:51:51 +0000