summaryrefslogtreecommitdiff
path: root/lib/KeyRing/Types.hs
blob: 5318b310150ba65064e2ac0545901fcac575f226 (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
{-# LANGUAGE DeriveFunctor     #-}
{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE PatternSynonyms   #-}
module KeyRing.Types where

import           Data.Bits
import           Data.Char (isLower,toLower)
import           Data.Functor
import           Data.List (groupBy,find,isInfixOf)
import           Data.Map as Map (Map)
import qualified Data.Map as Map
import           Data.Maybe (maybeToList,isJust,fromJust,mapMaybe)
import           Data.OpenPGP
import           Data.OpenPGP.Util
import           Data.Time.Clock
import           FunctorToMaybe
import qualified Data.ByteString.Lazy as L
import qualified System.Posix.Types as Posix

-- | This type describes an idempotent transformation (merge or import) on a
-- set of GnuPG keyrings and other key files.
data KeyRingOperation = KeyRingOperation
    { opFiles :: Map InputFile StreamInfo
    -- ^ Indicates files to be read or updated.
    , opPassphrases :: [PassphraseSpec]
    -- ^ Indicates files or file descriptors where passphrases can be found.
    , opTransforms :: [Transform]
    -- ^ Transformations to be performed on the key pool after all files have
    -- been read and before any have been written.
    , opHome :: Maybe FilePath
    -- ^ If provided, this is the directory where the 'HomeSec' and 'HomePub'
    -- files reside.  Otherwise, the evironment variable $GNUPGHOME is consulted
    -- and if that is not set, it falls back to $HOME/.gnupg.
    }
  deriving (Eq,Show)
instance Semigroup KeyRingOperation where
  KeyRingOperation f p t h <> KeyRingOperation f' p' t' h' =
    KeyRingOperation (f <> f') (p <> p') (t <> t') (h <> h')
instance Monoid KeyRingOperation where
  mempty = KeyRingOperation Map.empty [] [] Nothing

data InputFile = HomeSec
               -- ^ A file named secring.gpg located in the home directory.
               -- See 'opHome'.
               | HomePub
               -- ^ A file named pubring.gpg located in the home directory.
               -- See 'opHome'.
               | ArgFile FilePath
               -- ^ Contents will be read or written from the specified path.
               | FileDesc Posix.Fd
               -- ^ Contents will be read or written from the specified file
               -- descriptor.
               | Pipe Posix.Fd Posix.Fd
               -- ^ Contents will be read from the first descriptor and updated
               -- content will be writen to the second. Note: Don't use Pipe
               -- for 'Wallet' files. (TODO: Wallet support)
               | Generate Int GenerateKeyParams
               -- ^ New key packets will be generated if there is no
               -- matching content already in the key pool. The integer is
               -- a unique id number so that multiple generations can be
               -- inserted into 'opFiles'
 deriving (Eq,Ord,Show)

-- | This type describes how 'runKeyRing' will treat a file.
data StreamInfo = StreamInfo
    { access :: Access
    -- ^ Indicates whether the file is allowed to contain secret information.
    , typ :: FileType
    -- ^ Indicates the format and content type of the file.
    , fill :: KeyFilter
    -- ^ This filter controls what packets will be inserted into a file.
    , spill :: KeyFilter
    --
    -- ^ Use this to indicate whether or not a file's contents should be
    -- available for updating other files.  Note that although its type is
    -- 'KeyFilter', it is usually interpretted as a boolean flag.  Details
    -- depend on 'typ' and are as follows:
    --
    -- 'KeyRingFile':
    --
    --  * 'KF_None' - The file's contents will not be shared.
    --
    --  * otherwise - The file's contents will be shared.
    --
    -- 'PEMFile':
    --
    --  * 'KF_None'  - The file's contents will not be shared.
    --
    --  * 'KF_Match' - The file's key will be shared with the specified owner
    --  key and usage tag.  If 'fill' is also a 'KF_Match', then it must be
    --  equal to this value; changing the usage or owner of a key is not
    --  supported via the fill/spill mechanism.
    --
    --  * otherwise  - Unspecified.  Do not use.
    --
    -- 'WalletFile':
    --
    --  * The 'spill' setting is ignored and the file's contents are shared.
    --  (TODO)
    --
    -- 'Hosts': 
    --
    --  * The 'spill' setting is ignored and the file's contents are shared.
    --  (TODO)
    --
    , initializer :: Initializer
    -- ^ If 'typ' is 'PEMFile' and an 'External' 'initializer' string is set,
    -- then it is interpretted as a shell command that may be used to create
    -- the key if it does not exist.
    , transforms :: [Transform]
    -- ^ Per-file transformations that occur before the contents of a file are
    -- spilled into the common pool.
    }
 deriving (Eq,Show)


-- | This type is used to indicate where to obtain passphrases.
data PassphraseSpec = PassphraseSpec
    { passSpecRingFile :: Maybe FilePath
    -- ^ If not Nothing, the passphrase is to be used for packets
    -- from this file.
    , passSpecKeySpec :: Maybe String
    -- ^ Non-Nothing value reserved for future use.
    -- (TODO: Use this to implement per-key passphrase associations).
    , passSpecPassFile :: InputFile
    -- ^ The passphrase will be read from this file or file descriptor.
    }
    -- | Use this to carry pasphrases from a previous run.
    | PassphraseMemoizer { passSpecTranscoder :: PacketTranscoder }
    | PassphraseAgent

instance Show PassphraseSpec where
    show (PassphraseSpec a b c) = "PassphraseSpec "++show (a,b,c)
    show (PassphraseMemoizer _) = "PassphraseMemoizer"
instance Eq PassphraseSpec where
    PassphraseSpec a b c == PassphraseSpec d e f
        = and [a==d,b==e,c==f]
    _ == _
        = False

-- Ord instance for PassphraseSpec generally orders by generality with the most
-- general being greatest and the least general being least.  The one exception
-- is the 'PassphraseMemoizer' which is considered least of all even though it
-- is very general.  This is so an existing memoizer will be tried first, and
-- if there is none, one will be created that tries the others in order of
-- increasing generality.  Key-specialization is considered less general than
-- file-specialization.
instance Ord PassphraseSpec where
    compare (PassphraseMemoizer _) (PassphraseMemoizer _) = EQ
    compare PassphraseAgent PassphraseAgent               = EQ
    compare (PassphraseMemoizer _) _                      = LT
    compare (PassphraseSpec a b c) (PassphraseSpec d e f)
        | fmap (const ()) a == fmap (const ()) d
          && fmap (const ()) b == fmap (const ()) e       = compare (a,b,c) (d,e,f)
    compare (PassphraseSpec (Just _) (Just _) _)  _       = LT
    compare (PassphraseSpec Nothing (Just _) _) _         = LT
    compare (PassphraseSpec (Just _) _  _) _              = LT
    compare PassphraseAgent _                             = GT

data Transform =
        Autosign
        -- ^ This operation will make signatures for any tor-style UID
        -- that matches a tor subkey and thus can be authenticated without
        -- requring the judgement of a human user.
        --
        -- A tor-style UID is one of the following form:
        --
        -- > Anonymous <root@HOSTNAME.onion>
        | DeleteSubkeyByFingerprint String
        -- ^ Delete the subkey specified by the given fingerprint and any
        -- associated signatures on that key.
        | DeleteSubkeyByUsage String
        -- ^ Delete the subkey specified by the given usage tag and any
        -- associated signatures on that key.
        | RenameSubkeys String String
        -- ^ Replace all subkey signatures matching the first usage tag with
        -- fresh signatures that match the second usage tag.
 deriving (Eq,Ord,Show)

-- | Use this type to indicate whether a file of type 'KeyRingFile' is expected
-- to contain secret or public PGP key packets.  Note that it is not supported
-- to mix both in the same file and that the secret key packets include all of
-- the information contained in their corresponding public key packets.
data Access = AutoAccess -- ^ secret or public as appropriate based on existing content.
                         --   (see 'rtRingAccess')
            | Sec        -- ^ secret information
            | Pub        -- ^ public information
 deriving (Eq,Ord,Show)


data PacketsCodec = DetectAscii | BinaryPackets | AsciiArmor
 deriving (Eq,Ord,Show)

data FileType = PGPPackets PacketsCodec
              | PEMFile
              | WalletFile
              | DNSPresentation
              | Hosts
              | SshFile
 deriving (Eq,Ord,Show)

pattern KeyRingFile :: FileType
pattern KeyRingFile = PGPPackets DetectAscii

-- type UsageTag = String
data Initializer = NoCreate | Internal GenerateKeyParams | External String | WarnMissing String
 deriving (Eq,Ord,Show)



type PacketTranscoder = (SymmetricAlgorithm,S2K) -> MappedPacket -> IO (KikiCondition Packet)
type PacketDecrypter = MappedPacket -> IO (KikiCondition Packet)

-- | Note that the documentation here is intended for when this value is
-- assigned to 'fill'.  For other usage, see 'spill'.
data KeyFilter = KF_None -- ^ No keys will be imported.
               | KF_Match String -- ^ Only the key that matches the spec will be imported.
               | KF_Subkeys   -- ^ Subkeys will be imported if their owner key is
                              -- already in the ring.  TODO: Even if their signatures
                              -- are bad?
               | KF_Authentic -- ^ Keys are imported if they belong to an authenticated
                              -- identity (signed or self-authenticating).
               | KF_All -- ^ All keys will be imported.
  deriving (Eq,Ord,Show)

-- | The position and acces a packet had before the operation
data OriginFlags = OriginFlags
        { originallyPublic :: Bool
        -- ^ false if SecretKeyPacket
        , originalNum :: Int
        -- ^ packets are numbered, starting from 1..
        } deriving Show

type OriginMap = Map FilePath OriginFlags

type MappedPacket = OriginMapped Packet
data OriginMapped a = MappedPacket
        { packet :: a
        , locations :: OriginMap
        } deriving Show
instance Functor OriginMapped where
    fmap f (MappedPacket x ls) = MappedPacket (f x) ls

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

mappedPacket :: FilePath -> Packet -> MappedPacket
mappedPacket filename p = MappedPacket
    { packet = p
    , locations = Map.singleton filename (origin p (-1))
    }

mappedPacketWithHint :: FilePath -> Packet -> Int -> MappedPacket
mappedPacketWithHint filename p hint = MappedPacket
    { packet = p
    , locations = Map.singleton filename (origin p hint)
    }


-- | This type is used to indicate success or failure
-- and in the case of success, return the computed object.
-- The 'FunctorToMaybe' class is implemented to facilitate
-- branching on failture.
data KikiCondition a = KikiSuccess a
    | FailedToLock [FilePath]
    | BadPassphrase
    | FailedToMakeSignature
    | CantFindHome
    | AmbiguousKeySpec FilePath
    | CannotImportMasterKey
    | NoWorkingKey
    | AgentConnectionFailure
    | OperationCanceled
 deriving ( Functor, Foldable, Traversable, Show )

instance FunctorToMaybe KikiCondition where
    functorToMaybe (KikiSuccess a) = Just a
    functorToMaybe _               = Nothing

instance Applicative KikiCondition where
    pure a  = KikiSuccess a
    f <*> a =
        case functorToEither f of
            Right f  -> case functorToEither a of
                            Right a  -> pure (f a)
                            Left err -> err
            Left err -> err

instance Monad KikiCondition where
    return = pure
    KikiSuccess a >>= f = f a
    kikiCondition >>= f = kikiCondition <&> error (show (const () <$> kikiCondition) ++ " >>= f")

uncamel :: String -> String
uncamel str = unwords $ firstWord ++ (toLower .: otherWords) ++ args
  where
    (.:) = fmap . fmap
    ( firstWord  ,
      otherWords ) = splitAt 1 ws
    ws             = camel >>= groupBy (\_ c -> isLower c)
    ( camel, args) = splitAt 1 $ words str

errorString :: KikiCondition a -> String
errorString (KikiSuccess {}) = "success"
errorString e = uncamel . show $ fmap (const ()) e



data InputFileContext = InputFileContext
    { homesecPath :: FilePath
    , homepubPath :: FilePath
    }


-- | The 'KeyKey'-type is used to store the information of a key
--   which is used for finger-printing and as a lookup key into
--   maps.  This type may be changed to an actual fingerprint in
--   in the future.
newtype KeyKey = KeyKey [(Char,MPI)]
 deriving (Eq,Ord,Show)

keykey :: Packet -> KeyKey
keykey k = KeyKey $ concatMap (\c -> (maybeToList $ find (\(f,x) -> f==c) (key k))) (public_key_fields $ key_algorithm k)

isKey :: Packet -> Bool
isKey (PublicKeyPacket {}) = True
isKey (SecretKeyPacket {}) = True
isKey _                    = False

isSecretKey :: Packet -> Bool
isSecretKey (SecretKeyPacket {}) = True
isSecretKey _                    = False


isUserID :: Packet -> Maybe String
isUserID (UserIDPacket str) = Just str
isUserID _                  = Nothing

isTrust :: Packet -> Bool
isTrust (TrustPacket {}) = True
isTrust _                = False

-- matchpr computes the fingerprint of the given key truncated to
-- be the same lenght as the given fingerprint for comparison.
--
-- matchpr fp = Data.List.Extra.takeEnd (length fp)
--
matchpr :: String -> Packet -> String
matchpr fp k = reverse $ zipWith const (reverse (show $ fingerprint k)) fp




data KeySpec =
      KeyGrip String       -- fp:
    | KeyTag Packet String -- fp:????/t:
    | KeyUidMatch String   -- u:
 deriving Show

{-
RSAPrivateKey ::= SEQUENCE {
  version           Version,
  modulus           INTEGER,  -- n
  publicExponent    INTEGER,  -- e
  privateExponent   INTEGER,  -- d
  prime1            INTEGER,  -- p
  prime2            INTEGER,  -- q
  exponent1         INTEGER,  -- d mod (p1) -- ?? d mod (p-1)
  exponent2         INTEGER,  -- d mod (q-1)
  coefficient       INTEGER,  -- (inverse of q) mod p
  otherPrimeInfos   OtherPrimeInfos OPTIONAL
  }
-}
data RSAPrivateKey = RSAPrivateKey
    { rsaN :: MPI
    , rsaE :: MPI
    , rsaD :: MPI
    , rsaP :: MPI
    , rsaQ :: MPI
    , rsaDmodP1 :: MPI
    , rsaDmodQminus1 :: MPI
    , rsaCoefficient :: MPI
    }
 deriving Show

data ParsedCert = ParsedCert
    { pcertKey :: Packet
    , pcertTimestamp :: UTCTime
    , pcertBlob :: L.ByteString
    }
 deriving (Show,Eq)

data SubkeyStatus = Unsigned | OwnerSigned | CrossSigned
 deriving (Eq,Ord,Enum,Show,Read)

data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
 deriving (Show,Eq)

data MatchingField = KeyTypeField | UserIDField | GroupIDField deriving (Show,Eq,Ord,Enum)

data SingleKeySpec = FingerprintMatch String
                   | SubstringMatch (Maybe MatchingField) String
                   | EmptyMatch
                   | AnyMatch
                   | WorkingKeyMatch
 deriving (Show,Eq,Ord)

secretToPublic :: Packet -> Packet
secretToPublic pkt@(SecretKeyPacket {}) =
    PublicKeyPacket { version = version pkt
                    , timestamp = timestamp pkt
                    , key_algorithm = key_algorithm pkt
                    -- , ecc_curve = ecc_curve pkt
                    , key = let seckey = key pkt
                                pubs = public_key_fields (key_algorithm pkt)
                            in filter (\(k,v) -> k `elem` pubs) seckey
                    , is_subkey = is_subkey pkt
                    , v3_days_of_validity = Nothing
                    }
secretToPublic pkt = pkt

seek_key :: KeySpec -> [Packet] -> ([Packet],[Packet])
seek_key (KeyGrip grip) sec = (pre, subs)
  where
    (pre,subs) = break pred sec
    pred p@(SecretKeyPacket {}) = matchpr grip p == grip
    pred p@(PublicKeyPacket {}) = matchpr grip p == grip
    pred _                      = False

seek_key (KeyTag key tag) ps
    | null bs = (ps, [])
    | null qs =
      let (as', bs') = seek_key (KeyTag key tag) (tail bs) in
        (as ++ (head bs : as'), bs')
    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
  where
    (as,bs) = break (\p -> isSignaturePacket p
                        && has_tag tag p
                        && isJust (signature_issuer p)
                        && matchpr (fromJust $ signature_issuer p) key == fromJust (signature_issuer p) )
                    ps
    (rs,qs) = break isKey (reverse as)

    has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
                    || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))

seek_key (KeyUidMatch pat) ps
    | null bs = (ps, [])
    | null qs = let (as', bs') = seek_key (KeyUidMatch pat) (tail bs) in
                    (as ++ (head bs : as'), bs')
    | otherwise = (reverse (tail qs), head qs : reverse rs ++ bs)
  where
    (as,bs) = break (isInfixOf pat . uidStr) ps
    (rs,qs) = break isKey (reverse as)

    uidStr (UserIDPacket s) = s
    uidStr _                = ""

usageString :: PGPKeyFlags -> String
usageString flgs =
 case flgs of
    Special                -> "special"
    Vouch                  -> "vouch" -- signkey
    Sign                   -> "sign"
    VouchSign              -> "vouch-sign"
    Communication          -> "communication"
    VouchCommunication     -> "vouch-communication"
    SignCommunication      -> "sign-communication"
    VouchSignCommunication -> "vouch-sign-communication"
    Storage                -> "storage"
    VouchStorage           -> "vouch-storage"
    SignStorage            -> "sign-storage"
    VouchSignStorage       -> "vouch-sign-storage"
    Encrypt                -> "encrypt"
    VouchEncrypt           -> "vouch-encrypt"
    SignEncrypt            -> "sign-encrypt"
    VouchSignEncrypt       -> "vouch-sign-encrypt"

usage :: SignatureSubpacket -> Maybe String
usage (NotationDataPacket
        { human_readable = True
        , notation_name  = "usage@"
        , notation_value = u
        }) = Just u
usage _    = Nothing

data PGPKeyFlags =
    Special
    | Vouch                  -- 0001 C -- Signkey
    | Sign                   -- 0010 S
    | VouchSign              -- 0011
    | Communication          -- 0100 E
    | VouchCommunication     -- 0101
    | SignCommunication      -- 0110
    | VouchSignCommunication -- 0111
    | Storage                -- 1000 E
    | VouchStorage           -- 1001
    | SignStorage            -- 1010
    | VouchSignStorage       -- 1011
    | Encrypt                -- 1100 E
    | VouchEncrypt           -- 1101
    | SignEncrypt            -- 1110
    | VouchSignEncrypt       -- 1111
 deriving (Eq,Show,Read,Enum)

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