summaryrefslogtreecommitdiff
path: root/KeyRing.hs
blob: 554767322013f1542795179b225561e879e563dc (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
808
809
810
811
812
813
814
815
816
817
818
819
820
821
822
823
824
825
826
827
828
829
830
831
832
833
834
835
836
837
838
839
840
841
842
843
844
845
846
847
848
849
850
851
852
853
854
855
856
857
858
859
860
861
862
863
864
865
866
867
868
869
870
871
872
873
874
875
876
877
878
879
880
881
882
883
884
885
886
887
888
889
890
891
892
893
894
895
896
897
898
899
900
901
902
903
904
905
906
907
908
909
910
911
912
913
914
915
916
917
918
919
920
921
922
923
924
925
926
927
928
929
930
931
932
933
934
935
936
937
938
939
940
{-# LANGUAGE CPP #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE OverloadedStrings #-}
module KeyRing where

import System.Environment
import Control.Monad
import Data.Maybe
import Data.Char
import Data.List
import Data.OpenPGP
import Data.Functor
import Data.Bits              ( (.|.) )
-- import Control.Applicative    ( (<$>) )
import System.Directory       ( getHomeDirectory, doesFileExist )
import Control.Arrow          ( first, second )
import Data.OpenPGP.Util      ( fingerprint )
import Data.ByteString.Lazy   ( ByteString )
import Text.Show.Pretty as PP ( ppShow )
import Data.Word ( Word8 )
import Data.Binary ( decode )
import ControlMaybe ( handleIO_ )
import qualified Data.Map as Map
import qualified Data.ByteString.Lazy as L ( null, readFile, ByteString )
import qualified Data.ByteString.Lazy.Char8 as Char8 ( span, unpack, break ) 
import qualified Crypto.Types.PubKey.ECC as ECC
import System.Posix.Types (EpochTime)
import System.Posix.Files ( modificationTime, getFileStatus )

import qualified CryptoCoins as CryptoCoins
import Base58
import FunctorToMaybe
import DotLock

-- DER-encoded elliptic curve ids
nistp256_id  = 0x2a8648ce3d030107
secp256k1_id = 0x2b8104000a

data HomeDir =
    HomeDir { homevar :: String
            , appdir :: String
            , optfile_alts :: [String]
            }

home = HomeDir
    { homevar = "GNUPGHOME"
    , appdir  = ".gnupg"
    , optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
    }

data InputFile = HomeSec | HomePub | ArgFile FilePath | FileDesc Int

type UsageTag = String
type Initializer = String
type PassWordFile = InputFile

data FileType = KeyRingFile PassWordFile | PEMFile UsageTag | WalletFile

data RefType = ConstRef | MutableRef (Maybe Initializer)


data KeyRingRuntime = KeyRingRuntime
                        { rtPubring :: FilePath
                        , rtSecring :: FilePath
                        , rtRings :: [FilePath]
                        , rtWallets :: [FilePath]
                        , rtGrip :: Maybe String
                        , rtKeyDB :: KeyDB
                        }

data KeyRingAction a = KeyRingAction a | RunTimeAction (KeyRingRuntime -> a)

data KeyRingData = KeyRingData
    { kFiles :: Map.Map InputFile (RefType,FileType)
    , kImports :: Map.Map String (KeyData -> Bool)
    , homeSpec :: Maybe String
    }

resolveInputFile secring pubring = resolve
 where
    resolve HomeSec = return secring
    resolve HomePub = return pubring
    resolve (ArgFile f) = return f
    resolve _ = []

filesToLock k secring pubring = do
    (f,(rtyp,ftyp)) <- Map.toList (kFiles k)
    case rtyp of
        ConstRef -> []
        MutableRef {} -> resolveInputFile secring pubring f


-- kret :: a -> KeyRingData a
-- kret x = KeyRingData Map.empty Nothing (KeyRingAction x)

todo = error "unimplemented"

data KikiCondition a = KikiSuccess a | FailedToLock [FilePath]

#define TRIVIAL(OP) fmap _ (OP) = OP
instance Functor KikiCondition where
    fmap f (KikiSuccess a) = KikiSuccess (f a)
    TRIVIAL( FailedToLock x )
instance FunctorToMaybe KikiCondition where
    functorToMaybe (KikiSuccess a) = Just a
    functorToMaybe _               = Nothing

data KikiReportAction =
        NewPacket String
        | MissingPacket String
        | ExportedSubkey
        | GeneratedSubkeyFile
        | NewWalletKey String
        | YieldSignature
        | YieldSecretKeyPacket String

data KikiResult a = KikiResult
    { kikiCondition :: KikiCondition a
    , kikiReport :: [ (FilePath, KikiReportAction) ]
    }

keyPacket (KeyData k _ _ _) = packet k

usage (NotationDataPacket
        { human_readable = True
        , notation_name  = "usage@"
        , notation_value = u
        }) = Just u
usage _    = Nothing

keyflags flgs@(KeyFlagsPacket {}) =
    Just . toEnum $
        (   bit 0x1 certify_keys
        .|. bit 0x2 sign_data
        .|. bit 0x4 encrypt_communication
        .|. bit 0x8 encrypt_storage )     :: Maybe PGPKeyFlags
    -- other flags:
    --  split_key
    --  authentication (ssh-client)
    --  group_key
 where
    bit v f = if f flgs then v else 0
keyflags _ = Nothing


data PGPKeyFlags =
    Special
    | Vouch -- Signkey
    | Sign
    | VouchSign
    | Communication
    | VouchCommunication
    | SignCommunication
    | VouchSignCommunication
    | Storage
    | VouchStorage
    | SignStorage
    | VouchSignStorage
    | Encrypt
    | VouchEncrypt
    | SignEncrypt
    | VouchSignEncrypt
 deriving (Eq,Show,Read,Enum)
usageString flgs =
 case flgs of
    Special -> "special"
    Vouch -> "vouch" -- signkey
    Sign -> "sign"
    VouchSign -> "vouch-sign"
    Communication -> "communication"
    VouchCommunication -> "vouch-communication"
    SignCommunication -> "sign-communication"
    VouchSignCommunication -> "vouch-sign-communication"
    Storage -> "storage"
    VouchStorage -> "vouch-storage"
    SignStorage -> "sign-storage"
    VouchSignStorage -> "vouch-sign-storage"
    Encrypt -> "encrypt"
    VouchEncrypt -> "vouch-encrypt"
    SignEncrypt -> "sign-encrypt"
    VouchSignEncrypt -> "vouch-sign-encrypt"




-- matchpr computes the fingerprint of the given key truncated to
-- be the same lenght as the given fingerprint for comparison.
matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp

keyFlags  wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
keyFlags0 wkun uidsigs = concat
                      [ keyflags
                      , preferredsym
                      , preferredhash
                      , preferredcomp
                      , features ]

 where
    subs = concatMap hashed_subpackets uidsigs
    keyflags = filterOr isflags subs $
               KeyFlagsPacket { certify_keys = True
                              , sign_data = True
                              , encrypt_communication = False
                              , encrypt_storage = False
                              , split_key = False
                              , authentication = False
                              , group_key = False
                              }
    preferredsym = filterOr ispreferedsym subs $
               PreferredSymmetricAlgorithmsPacket
                              [ AES256
                              , AES192
                              , AES128
                              , CAST5
                              , TripleDES
                              ]
    preferredhash = filterOr ispreferedhash subs $
               PreferredHashAlgorithmsPacket
                              [ SHA256
                              , SHA1
                              , SHA384
                              , SHA512
                              , SHA224
                              ]
    preferredcomp = filterOr ispreferedcomp subs $
               PreferredCompressionAlgorithmsPacket
                              [ ZLIB
                              , BZip2
                              , ZIP
                              ]
    features = filterOr isfeatures subs $
               FeaturesPacket { supports_mdc = True
                              }

    filterOr pred xs def = if null rs then [def] else rs where rs=filter pred xs

    isflags (KeyFlagsPacket {}) = True
    isflags _ = False
    ispreferedsym (PreferredSymmetricAlgorithmsPacket {}) = True
    ispreferedsym _ = False
    ispreferedhash (PreferredHashAlgorithmsPacket {}) = True
    ispreferedhash _ = False
    ispreferedcomp (PreferredCompressionAlgorithmsPacket {}) = True
    ispreferedcomp _ = False
    isfeatures (FeaturesPacket {}) = True
    isfeatures _ = False


matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 
    | matchpr grip (packet p)==grip = True
    | otherwise                     = False

matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps
 where
    ps = map (packet .fst) sigs
    match p = isSignaturePacket p
                && has_tag tag p
                && has_issuer key p
    has_issuer key p = isJust $ do
        issuer <- signature_issuer p
        guard $ matchpr issuer key == issuer
    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))

matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us
  where
    us = filter (isInfixOf pat) $ Map.keys uids


data KeySpec =
      KeyGrip String
    | KeyTag Packet String
    | KeyUidMatch String
 deriving Show


buildKeyDB :: FilePath -> FilePath -> Maybe String -> KeyRingData
              -> IO ((KeyDB,Maybe String),[(FilePath,KikiReportAction)])
buildKeyDB secring pubring grip0 keyring = do
    let isring (KeyRingFile {}) = True
        isring _                = False

        iswallet WalletFile = True
        iswallet _          = False

        files isring = do
            (f,(rtyp,ftyp)) <- Map.toList (kFiles keyring)
            guard (isring ftyp)
            resolveInputFile secring pubring f

        readp n = fmap (n,) (readPacketsFromFile n)

        readw wk n = fmap (n,) (readPacketsFromWallet wk n)

    ms <- mapM readp (files isring)
    let grip = grip0 `mplus` (fingerprint <$> fstkey)
          where
            fstkey = listToMaybe $ mapMaybe isSecringKey ms 
                      where isSecringKey (fn,Message ps)
                                | fn==secring = listToMaybe ps
                            isSecringKey _  = Nothing
        wk = listToMaybe $ do
                fp <- maybeToList grip
                elm <- Map.toList db0
                guard $ matchSpec (KeyGrip fp) elm
                return $ keyPacket (snd elm)
        db0 = foldl' (uncurry . merge) Map.empty ms

    wms <- mapM (readw wk) (files iswallet)

    (db,report)  <- return (db0,[]) -- todo

    return ( (db, grip), report )

runKeyRing :: KeyRingData -> (KeyRingRuntime -> a) -> IO (KikiResult a)
runKeyRing keyring op = do
    (homedir,secring,pubring,grip0) <- getHomeDir (homeSpec keyring)
    let tolocks = filesToLock keyring secring pubring
    lks <- forM tolocks $ \f -> do
        lk <- dotlock_create f 0
        v <- flip (maybe $ return Nothing) lk $ \lk -> do
                e <- dotlock_take lk (-1)
                if e==0 then return $ Just lk
                        else dotlock_destroy lk >> return Nothing
        return (v,f)
    let (lked, map snd -> failed) = partition (isJust . fst) lks
        ret = if null failed then KikiSuccess () else FailedToLock failed
    ret <- case functorToEither ret of
      Right {} -> do
         ((db,grip), report1) <- buildKeyDB secring pubring grip0 keyring -- build db

         a <- return $ op KeyRingRuntime
                        { rtPubring = pubring
                        , rtSecring = secring
                        , rtRings = [] -- todo secring:pubring:keyringFiles keyring
                        , rtWallets = [] -- todo walletFiles keyring
                        , rtGrip = grip
                        , rtKeyDB = db
                        }
         report2 <- todo -- write files
        
         return $ KikiResult (KikiSuccess a) (report1 ++ report2)
      Left err -> return $ KikiResult err []

    forM_ lked $ \(Just lk, fname) -> do dotlock_release lk
                                         dotlock_destroy lk -- todo: verify we want this

    return ret


parseOptionFile fname = do
    xs <- fmap lines (readFile fname)
    let ys = filter notComment xs
        notComment ('#':_) = False
        notComment cs      = not (all isSpace cs)
    return ys

getHomeDir protohome = do
        homedir <- envhomedir protohome
        flip (maybe (error "Could not determine home directory."))
             homedir $ \homedir -> do
        -- putStrLn $ "homedir = " ++show homedir
        let secring = homedir ++ "/" ++ "secring.gpg"
            pubring = homedir ++ "/" ++ "pubring.gpg"
        -- putStrLn $ "secring = " ++ show secring
        workingkey <- getWorkingKey homedir
        return (homedir,secring,pubring,workingkey)
 where
    envhomedir opt = do
        gnupghome <- lookupEnv (homevar home) >>=
                  \d -> return $ d >>= guard . (/="") >> d
        homed <- flip fmap getHomeDirectory $
                  \d -> fmap (const d) $ guard (d/="")
        let homegnupg = (++('/':(appdir home))) <$> homed
        let val = (opt `mplus` gnupghome `mplus` homegnupg)
        return $ val
    
    -- TODO: rename this to getGrip
    getWorkingKey homedir = do
        let o = Nothing
            h = Just homedir
        ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
                let optfiles = map (second ((h++"/")++))
                                   (maybe optfile_alts' (:[]) o')
                    optfile_alts' = zip (False:repeat True) (optfile_alts home)
                    o' = fmap (False,) o
                in filterM (doesFileExist . snd) optfiles
        args <- flip (maybe $ return []) ofile $
            \(forgive,fname) -> parseOptionFile fname
        let config = map (topair . words) args
                        where topair (x:xs) = (x,xs)
        return $ lookup "default-key" config >>= listToMaybe

#if MIN_VERSION_base(4,6,0)
#else
lookupEnv var =
    handleIO_ (return Nothing) $ fmap Just (getEnv var)
#endif

isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isUserID (UserIDPacket {}) = True
isUserID _                 = False

isTrust (TrustPacket {}) = True
isTrust _                = False

slurpWIPKeys :: System.Posix.Types.EpochTime -> L.ByteString -> ( [(Word8,Packet)], [L.ByteString])
slurpWIPKeys stamp "" = ([],[])
slurpWIPKeys stamp cs =
    let (b58,xs) = Char8.span (\x -> elem x base58chars) cs
        mb        = decode_btc_key stamp (Char8.unpack b58)
    in if L.null b58 
        then let (ys,xs') = Char8.break (\x -> elem x base58chars) cs
                 (ks,js)  = slurpWIPKeys stamp xs'
             in (ks,ys:js) 
        else let (ks,js) = slurpWIPKeys stamp xs
             in maybe (ks,b58:js) (\(net,Message [k])->((net,k):ks,js)) mb


decode_btc_key timestamp str = do
    (network_id,us) <- base58_decode str
    return . (network_id,) $ Message $ do
        let d = foldl' (\a b->a*256+b) 0 (map fromIntegral us :: [Integer])
            {-
            xy = secp256k1_G `pmul` d
            x = getx xy
            y = gety xy
            -- y² = x³ + 7 (mod p)
            y' = sqrtModP' (applyCurve secp256k1_curve x) (getp secp256k1_curve)
            y'' = sqrtModPList (applyCurve secp256k1_curve x) (getp secp256k1_curve)
            -}
            secp256k1 = ECC.getCurveByName ECC.SEC_p256k1
            ECC.Point x y = ECC.ecc_g $ ECC.common_curve secp256k1
            -- pub = cannonical_eckey x y
            -- hash = S.cons network_id . RIPEMD160.hash . SHA256.hash . S.pack $  pub
            -- address = base58_encode hash
            -- pubstr = concatMap (printf "%02x") $ pub
            -- _ = pubstr :: String
        return $ {- trace (unlines ["pub="++show pubstr
                                ,"add="++show address
                                ,"y  ="++show y
                                ,"y' ="++show y'
                                ,"y''="++show y'']) -}
            SecretKeyPacket 
            { version = 4
            , timestamp = toEnum (fromEnum timestamp)
            , key_algorithm = ECDSA
            , key = [ -- public fields...
                     ('c',MPI secp256k1_id) -- secp256k1 (bitcoin curve)
                    ,('l',MPI 256)
                    ,('x',MPI x)
                    ,('y',MPI y)
                    -- secret fields
                    ,('d',MPI d)
                    ]
            , s2k_useage = 0
            , s2k = S2K 100 ""
            , symmetric_algorithm = Unencrypted
            , encrypted_data = ""
            , is_subkey = True
            }

readPacketsFromWallet :: 
    Maybe Packet
    -> FilePath 
    -> IO [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
readPacketsFromWallet wk fname = do
    timestamp <- handleIO_ (error $ fname++": modificaiton time?") $ 
                    modificationTime <$> getFileStatus fname
    input <- L.readFile fname
    let (ks,_) = slurpWIPKeys timestamp input
    when (not (null ks)) $ do
        -- decrypt wk
        -- create sigs
        -- return key/sig pairs
        return ()
    return $ do
        wk <- maybeToList wk
        guard (not $ null ks)
        let prep (tagbyte,k) = (wk,k,(k,Map.singleton tag wk))
                                where tag = CryptoCoins.nameFromSecretByte tagbyte
        (wk,MarkerPacket,(MarkerPacket,Map.empty))
         :map prep ks

readPacketsFromFile :: FilePath -> IO Message
readPacketsFromFile fname = do
    -- warn $ fname ++ ": reading..."
    input <- L.readFile fname
#if MIN_VERSION_binary(0,6,4)
    return $
      case decodeOrFail input of
        Right (_,_,msg ) -> msg
        Left  (_,_,_)    -> trace (fname++": read fail") $ Message []
#else
    return $ decode input
#endif


data OriginFlags = OriginFlags {
        originallyPublic :: Bool,
        originalNum :: Int
    }
    deriving Show
type OriginMap = Map.Map FilePath OriginFlags
data MappedPacket = MappedPacket
        { packet :: Packet
        , usage_tag :: Maybe String
        , locations :: OriginMap
        }

type TrustMap = Map.Map FilePath Packet
type SigAndTrust = ( MappedPacket
                   , TrustMap     ) -- trust packets

type KeyKey = [ByteString]
data SubKey = SubKey MappedPacket [SigAndTrust]
data KeyData = KeyData MappedPacket    -- main key
                       [SigAndTrust]  -- sigs on main key
                       (Map.Map String ([SigAndTrust],OriginMap))  -- uids
                       (Map.Map KeyKey SubKey)    -- subkeys

type KeyDB = Map.Map KeyKey KeyData

origin :: Packet -> Int -> OriginFlags
origin p n = OriginFlags ispub n
 where
    ispub = case p of
                    SecretKeyPacket {} -> False
                    _                  -> True

mappedPacket filename p = MappedPacket 
    { packet = p
    , usage_tag = Nothing
    , locations = Map.singleton filename (origin p (-1))
    }

keykey key =
    -- Note: The key's timestamp is included in it's fingerprint.
    --       Therefore, the same key with a different timestamp is
    --       considered distinct using this keykey implementation.
    fingerprint_material (key {timestamp=0}) -- TODO: smaller key?

uidkey (UserIDPacket str) = str

merge :: KeyDB -> FilePath -> Message -> KeyDB
merge db filename (Message ps) = merge_ db filename qs
 where
    qs = scanPackets filename ps

    scanPackets :: FilePath -> [Packet] -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
    scanPackets filename [] = []
    scanPackets filename (p:ps) = scanl doit (doit (MarkerPacket,MarkerPacket,ret MarkerPacket) p) ps
     where
        ret p = (p,Map.empty)
        doit (top,sub,prev) p =
            case p of
                _ | isKey p && not (is_subkey p) -> (p,MarkerPacket,ret p)
                _ | isKey p && is_subkey p       -> (top,p,ret p)
                _ | isUserID p                   -> (top,p,ret p)
                _ | isTrust p                    -> (top,sub,updateTrust top sub prev p)
                _ | otherwise                    -> (top,sub,ret p)

        updateTrust top (PublicKeyPacket {}) (pre,t) p = (pre,Map.insert filename p t) -- public
        updateTrust (PublicKeyPacket {}) _   (pre,t) p = (pre,Map.insert filename p t) -- public
        updateTrust _                    _   (pre,t) p = (pre,Map.insert filename p t) -- secret




merge_ :: KeyDB -> FilePath -> [(Packet,Packet,(Packet,Map.Map FilePath Packet))]
                -> KeyDB
merge_ db filename qs = foldl mergeit db (zip [0..] qs)
 where
    keycomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
    keycomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
    keycomp a b | keykey a==keykey b = EQ
    keycomp a b = error $ unlines ["Unable to merge keys:"
                                  , fingerprint a
                                  , PP.ppShow a
                                  , fingerprint b
                                  , PP.ppShow b
                                  ]

    asMapped n p = let m = mappedPacket filename p
                   in m { locations = fmap (\x->x {originalNum=n}) (locations m) }
    asSigAndTrust n (p,tm) = (asMapped n p,tm)
    emptyUids = Map.empty
    -- mergeit db (_,_,TrustPacket {}) = db -- Filter TrustPackets
    mergeit :: KeyDB -> (Int,(Packet,Packet,(Packet,Map.Map FilePath Packet))) -> KeyDB
    mergeit db (n,(top,sub,ptt@(p,trustmap))) | isKey top = Map.alter update (keykey top) db
     where
        -- NOTE:
        --  if a keyring file has both a public key packet and a secret key packet
        --  for the same key, then only one of them will survive, which ever is 
        --  later in the file.
        -- 
        --  This is due to the use of statements like 
        --      (Map.insert filename (origin p n) (locations key))
        --
        update v | isKey p && not (is_subkey p)
          = case v of
             Nothing -> Just $ KeyData (asMapped n p) [] emptyUids Map.empty
             Just (KeyData key sigs uids subkeys) | keykey (packet key) == keykey p
                     -> Just $ KeyData ( (asMapped n (minimumBy keycomp [packet key,p]))
                                          { locations = Map.insert filename (origin p n) (locations key) } )
                                       sigs
                                       uids
                                       subkeys
             _       -> error . concat $ ["Unexpected master key merge error: "
                                         ,show (fingerprint top, fingerprint p)]
        update (Just (KeyData key sigs uids subkeys)) | isKey p && is_subkey p
          = Just $ KeyData key sigs uids (Map.alter (mergeSubkey n p) (keykey p) subkeys)
        update (Just (KeyData key sigs uids subkeys)) | isUserID p
          = Just $ KeyData key sigs (Map.alter (mergeUid n ptt) (uidkey p) uids)
                                    subkeys
        update (Just (KeyData key sigs uids subkeys))
          = case sub of
             MarkerPacket    -> Just $ KeyData key (mergeSig n ptt sigs) uids subkeys
             UserIDPacket {} -> Just $ KeyData key
                                               sigs
                                               (Map.alter (mergeUidSig n ptt) (uidkey sub) uids)
                                               subkeys
             _  | isKey sub  -> Just $ KeyData key
                                               sigs
                                               uids
                                               (Map.alter (mergeSubSig n ptt) (keykey sub) subkeys)
             _ -> error $ "Unexpected PGP packet 1: "++(words (show p) >>= take 1)
        update _ = error $ "Unexpected PGP packet 2: "++(words (show p) >>= take 1)

    mergeit _  (_,(_,_,p)) = error $ "Unexpected PGP packet 3: "++whatP p

    mergeSubkey :: Int -> Packet -> Maybe SubKey -> Maybe SubKey
    mergeSubkey n p Nothing                  = Just $ SubKey (asMapped n p) []
    mergeSubkey n p (Just (SubKey key sigs)) = Just $
        SubKey ((asMapped n (minimumBy subcomp [packet key,p]))
                 { locations = Map.insert filename (origin p n) (locations key) })
               sigs
     where
        -- Compare master keys, LT is prefered for merging
        -- Compare subkeys, LT is prefered for merging
        subcomp (SecretKeyPacket {}) (PublicKeyPacket {}) = LT
        subcomp (PublicKeyPacket {}) (SecretKeyPacket {}) = GT
        subcomp a b | keykey a==keykey b = EQ
        subcomp a b = error $ unlines ["Unable to merge subs:"
                                      , fingerprint a
                                      , PP.ppShow a
                                      , fingerprint b
                                      , PP.ppShow b
                                      ]
        subcomp_m a b = subcomp (packet a) (packet b)

    mergeUid :: Int ->(Packet,a) -> Maybe ([SigAndTrust],OriginMap) -> Maybe ([SigAndTrust],OriginMap)
    mergeUid n (UserIDPacket s,_) Nothing         = Just ([],Map.singleton filename (origin MarkerPacket n))
    mergeUid n (UserIDPacket s,_) (Just (sigs,m)) = Just (sigs, Map.insert filename (origin MarkerPacket n) m)
    mergeUid n p _ = error $ "Unable to merge into UID record: " ++whatP p

    whatP (a,_) = concat . take 1 . words . show $ a


    mergeSig :: Int -> (Packet,TrustMap) -> [SigAndTrust] -> [SigAndTrust]
    mergeSig n sig sigs =
      let (xs,ys) = break (isSameSig sig) sigs
      in if null ys
          then sigs++[first (asMapped n) sig]
          else let y:ys'=ys
               in xs ++ (mergeSameSig n sig y : ys')


    isSameSig (a,_) (MappedPacket {packet=b},_) | isSignaturePacket a && isSignaturePacket b =
        a { unhashed_subpackets=[] } == b { unhashed_subpackets = [] }
    isSameSig (a,_) (MappedPacket {packet=b},_) = a==b

    mergeSameSig :: Int -> (Packet,TrustMap) -> (MappedPacket,TrustMap) -> (MappedPacket, TrustMap)
    mergeSameSig n (a,ta) (m@(MappedPacket{packet=b,locations=locs}),tb) | isSignaturePacket a && isSignaturePacket b =
       ( m { packet = (b { unhashed_subpackets =
                            foldl mergeItem (unhashed_subpackets b) (unhashed_subpackets a) })
           , locations = Map.insert filename (origin a n) locs }
        , tb `Map.union` ta )

     where
        -- TODO: when merging items, we should delete invalidated origins
        -- from the orgin map.
        mergeItem ys x = if x `elem` ys then ys else ys++[x]

    mergeSameSig n a b = b -- trace ("discarding dup "++show a) b

    mergeUidSig n sig (Just (sigs,m)) = Just (mergeSig n sig sigs, m)
    mergeUidSig n sig Nothing     = Just ([asSigAndTrust n sig],Map.empty)

    mergeSubSig n sig (Just (SubKey key sigs)) = Just $ SubKey key (mergeSig n sig sigs)
    mergeSubSig n sig Nothing = error $
        "Unable to merge subkey signature: "++(words (show sig) >>= take 1)

 
{-
data Kiki a =
    SinglePass (KeyRingData -> KeyRingAction a)
    | forall b. MultiPass (KeyRingData -> KeyRingAction b)
                          (Kiki (b -> a))

fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
fmapWithRT g (SinglePass pass) = SinglePass pass'
 where
    pass' kd = case pass kd of
                KeyRingAction v -> RunTimeAction (\rt -> g rt v)
                RunTimeAction f -> RunTimeAction (\rt -> g rt (f rt))
fmapWithRT g (MultiPass pass0 k) = MultiPass pass0 k'
 where
    k' = fmapWithRT (\rt f -> g rt . f) k

instance Functor Kiki where fmap f k = fmapWithRT (const f) k

instance Monad Kiki where
    return x = SinglePass (const $ KeyRingAction x)
    
    k >>= f  = eval' $ fmapWithRT (\rt x -> eval rt (f x)) k
                where (.:) = (.) . (.)

eval :: KeyRingRuntime -> Kiki a -> KeyRingData -> a
eval rt (SinglePass f) kd =
    case f kd of KeyRingAction v -> v
                 RunTimeAction g -> g rt                       
eval rt (MultiPass p kk) kd = eval rt kk kd $ eval rt (SinglePass p) kd

eval' :: Kiki (KeyRingData -> a) -> Kiki a
eval' k@(SinglePass pass) = SinglePass pass'
 where
    pass' kd = case pass kd of
                KeyRingAction f -> KeyRingAction (f kd)
                RunTimeAction g -> RunTimeAction (\rt -> g rt kd)
eval' k@(MultiPass p kk) = MultiPass p kk'
 where
    kk' = fmap flip kk

-}



{-
fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
    = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f}))
    = SinglePass $ d { kAction = RunTimeAction f' }
    where f' rt = g rt (f rt)
fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
    where g' rt h = g rt . h
-}


data Kiki a =
    SinglePass { passInfo :: KeyRingData
               , rtAction :: KeyRingAction a }
    | forall b.
       MultiPass { passInfo :: KeyRingData
                 , passAction :: KeyRingAction b
                 , nextPass :: Kiki (b -> a)
                 }



evalAction :: KeyRingRuntime -> KeyRingAction a -> a
evalAction rt (KeyRingAction v) = v
evalAction rt (RunTimeAction g) = g rt

instance Monad KeyRingAction where
    return x = KeyRingAction x
    m >>= g  = case m of
        KeyRingAction v -> g v
        RunTimeAction f -> RunTimeAction $ \rt -> evalAction rt (g $ f rt)

instance Functor KeyRingAction where
    fmap g (KeyRingAction v) = KeyRingAction $ g v
    fmap g (RunTimeAction f) = RunTimeAction $ \rt -> g (f rt)

{-
argOut :: (KeyRingAction (a -> b)) -> a -> KeyRingAction b
argOut = todo
argIn :: (a -> KeyRingAction b) -> KeyRingAction (a->b)
-}

{-
fmapWithRT :: (a -> KeyRingAction b) -> Kiki a -> Kiki b
fmapWithRT g k@(SinglePass {}) = k { rtAction = action }
 where
    action = rtAction k >>= g
fmapWithRT g (MultiPass p atn next) = MultiPass p atn next'
 where
    next' = fmapWithRT g' next {- next :: Kiki (x -> a) -}
    -- g' :: ( (x->a) -> KeyRingAction b)
    g' h = RunTimeAction $
            \rt x -> case g (h x) of
                        KeyRingAction v -> v
                        RunTimeAction f -> f rt
-}

fmapWithRT :: KeyRingAction (a -> b) -> Kiki a -> Kiki b
fmapWithRT g (SinglePass pass atn) = SinglePass pass atn'
 where
    atn' = g >>= flip fmap atn
fmapWithRT g (MultiPass p atn next) = MultiPass p atn next'
 where
    next' = fmapWithRT g' next
    g' = fmap (\gf h -> gf . h) g

instance Functor Kiki where
    fmap f k = fmapWithRT (return f) k

instance Monad Kiki where
    return x = SinglePass todo (return x)
    k >>= f  = kjoin $ fmap f k

kikiAction :: Kiki a -> KeyRingAction a
kikiAction (SinglePass _ atn) = atn
kikiAction (MultiPass _ atn next) = do
        x <- atn
        g <- kikiAction next
        return $ g x

kjoin :: Kiki (Kiki a) -> Kiki a
kjoin k = fmapWithRT eval' k
 where
    eval' :: KeyRingAction (Kiki a -> a)
    eval' = RunTimeAction (\rt -> evalAction rt . kikiAction )

    {-
    kjoin :: Kiki (Kiki a) -> Kiki a
    kjoin k = kjoin' (fmap kikiAction k)
     where
        ev rt (KeyRingAction v) = v
        ev rt (RunTimeAction g) = g rt

        kjoin' :: Kiki (KeyRingAction a) -> Kiki a
        kjoin' (SinglePass pass atn) = SinglePass pass $ join atn
        kjoin' (MultiPass pass atn next) = MultiPass pass atn next'
            where
                next' = todo
    -}


{-
instance Functor Kiki where
    fmap f (SinglePass pass atn)
        = SinglePass pass (fmap f atn)
    fmap f (MultiPass pass atn next)
        = MultiPass pass atn (next >>= g)
     where
        g = todo
-}

{-
data Kiki a = SinglePass (KeyRingData a)
              | forall b. MultiPass (KeyRingData b) (Kiki (b -> a))

instance Functor Kiki where
    fmap f (SinglePass d) = SinglePass $ case kAction d of
                                  KeyRingAction v -> d { kAction = KeyRingAction (f v) }
                                  RunTimeAction g -> d { kAction = RunTimeAction (f . g) }
    fmap f (MultiPass p k)= MultiPass p (fmap (f .) k)

eval :: KeyRingRuntime -> Kiki a -> a
eval rt (SinglePass (KeyRingData { kAction = KeyRingAction v})) = v
eval rt (SinglePass (KeyRingData { kAction = RunTimeAction f})) = f rt
eval rt (MultiPass p kk) = eval rt kk $ eval rt (SinglePass p)

fmapWithRT :: (KeyRingRuntime -> a -> b) -> Kiki a -> Kiki b
fmapWithRT g (SinglePass d@(KeyRingData { kAction = KeyRingAction v}))
    = SinglePass $ d { kAction = RunTimeAction (\rt -> g rt v) }
fmapWithRT g (SinglePass d@(KeyRingData { kAction = RunTimeAction f}))
    = SinglePass $ d { kAction = RunTimeAction f' }
    where f' rt = g rt (f rt)
fmapWithRT g (MultiPass p kk) = MultiPass p (fmapWithRT g' kk)
    where g' rt h = g rt . h

kjoin :: Kiki (Kiki a) -> Kiki a
kjoin k = fmapWithRT eval k

passCount :: Kiki a -> Int
passCount (MultiPass _ k) = 1 + passCount k
passCount (SinglePass {}) = 1

instance Monad Kiki where
    return x = SinglePass (kret x)
    k >>= f  = kjoin (fmap f k)
-}


-- Kiki a -> a -> Kiki b

atRuntime :: (KeyRingRuntime -> IO (a,KeyRingRuntime)) -> Kiki a
atRuntime = todo

goHome :: Maybe FilePath -> Kiki ()
goHome p = todo -- SinglePass $ (kret ()) { homeSpec = p }

syncRing :: InputFile -> Kiki ()
syncRing = todo

syncSubKey :: String -> FilePath -> String -> Kiki ()
syncSubKey usage path cmd = todo

syncWallet :: FilePath -> Kiki ()
syncWallet = todo

usePassphraseFD :: Int -> Kiki ()
usePassphraseFD = todo

importAll :: Kiki ()
importAll = todo

importAllAuthentic :: Kiki ()
importAllAuthentic = todo

signSelfAuthorized :: Kiki ()
signSelfAuthorized = todo

showIdentity :: Message -> String
showIdentity = todo

identities :: Kiki [Message]
identities = todo

currentIdentity :: Kiki Message
currentIdentity = todo

identityBySpec :: String -> Kiki Message
identityBySpec = todo

identityBySSHKey :: String -> Kiki Message
identityBySSHKey = todo

keyBySpec :: String -> Kiki Packet
keyBySpec = todo

walletInputFormat :: Packet -> String
walletInputFormat = todo