summaryrefslogtreecommitdiff
path: root/keys.hs
blob: 73d3192ba55cce84655fd770b3ef52cb7ed80ec5 (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
{-# LANGUAGE ViewPatterns  #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE OverloadedStrings #-}
module Main where

import Debug.Trace
import Data.Binary
import Data.OpenPGP
import qualified Data.ByteString.Lazy as L
import qualified Data.ByteString.Lazy.Char8 as Char8
import qualified Data.ByteString      as S
import Control.Monad
import Text.Show.Pretty
import Data.List
import Data.OpenPGP.CryptoAPI
import Data.Ord
import Data.Maybe
import Data.Bits
import qualified Data.Text as T
import Data.Text.Encoding
import qualified Codec.Binary.Base32 as Base32
import qualified Crypto.Hash.SHA1 as SHA1
import Data.Char (toLower)
import qualified Crypto.PubKey.RSA as RSA
import Data.ASN1.Types
import Data.ASN1.Encoding
import Data.ASN1.BinaryEncoding
import System.Console.CmdTheLine as CmdTheLine
import System.Console.CmdTheLine.GetOpt
import System.Console.GetOpt
import Control.Applicative
import System.Environment
import System.Directory
import System.Exit
import ControlMaybe
import Data.Char
import Control.Arrow (second)

data RSAPublicKey = RSAKey MPI MPI

instance ASN1Object RSAPublicKey where
    toASN1 (RSAKey (MPI n) (MPI e))
                  = \xs -> Start Sequence
                         : IntVal n
                         : IntVal e
                         : End Sequence
                         : xs
    fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
        Right (RSAKey (MPI modulus) (MPI pubexp) , xs)
    fromASN1 _ =
        Left "fromASN1: RSAPublicKey: unexpected format"

rsaKeyFromPacket p@(PublicKeyPacket {}) = do
    n <- lookup 'n' $ key p
    e <- lookup 'e' $ key p
    return $ RSAKey n e
rsaKeyFromPacket p@(SecretKeyPacket {}) = do
    n <- lookup 'n' $ key p
    e <- lookup 'e' $ key p
    return $ RSAKey n e
rsaKeyFromPacket _ = Nothing
derRSA rsa = do
    k <- rsaKeyFromPacket rsa
    return $ encodeASN1 DER (toASN1 k [])

getPackets :: IO [Packet]
getPackets = do
    input <- L.getContents
    case decodeOrFail input of
        Right (_,_,Message pkts) -> return pkts
        Left  (_,_,_)            -> return []


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

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

isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
isEmbeddedSignature _                            = False

isCertificationSig (CertificationSignature {}) = True
isCertificationSig _                           = True

issuer (IssuerPacket issuer) = Just issuer
issuer _                     = Nothing
backsig (EmbeddedSignaturePacket s) = Just s
backsig _                           = Nothing

isSubkeySignature (SubkeySignature {}) = True
isSubkeySignature _                    = False

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

verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
 where
    verified = do
        sig <- signatures (Message nonkeys)
        let v = verify (Message keys) sig
        guard (not . null $ signatures_over v)
        return v
    (top,othersigs) = partition isSubkeySignature verified
    embedded = do
        sub <- top
        let sigover = signatures_over sub
            unhashed = sigover >>= unhashed_subpackets
            subsigs = mapMaybe backsig unhashed
        sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
        let v = verify (Message [subkey sub]) sig
        guard (not . null $ signatures_over v)
        return v

grip k = drop 32 $ fingerprint k

smallpr k = drop 24 $ fingerprint k

disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
 where
    grouped    = groupBy samepr . sortBy (comparing smallpr) $ ks
    samepr a b = smallpr a == smallpr b

    {-
    -- useful for testing
    group2 :: [a] -> [[a]]
    group2 (x:y:ys) = [x,y]:group2 ys
    group2 [x]      = [[x]]
    group2 []       = []
    -}

getBindings ::
  [Packet]
  -> 
    ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
                                   --   that were used for the verifications
    , [(Word8,
       (Packet, Packet),
       [String],
       [SignatureSubpacket],
       [Packet])] -- ^ binding signatures
    )
getBindings pkts = (sigs,bindings)
 where
    (sigs,concat->bindings) = unzip $ do
        let (keys,nonkeys) = partition isKey pkts
        keys <- disjoint_fp keys
        let (bs,sigs) = verifyBindings keys pkts
        return . ((keys,sigs),) $ do
            b <- bs
            i <- map signature_issuer (signatures_over b)
            i <- maybeToList i
            who <- maybeToList $ find_key fingerprint (Message keys) i
            let (code,claimants) = 
                    case () of
                        _ | who == topkey b -> (1,[])
                        _ | who == subkey b -> (2,[])
                        _                   -> (0,[who])
            let hashed = signatures_over b >>= hashed_subpackets
                kind = guard (code==1) >> hashed >>= maybeToList . usage
            return (code,(topkey b,subkey b), kind, hashed,claimants)

accBindings ::
  Bits t =>
  [(t, (Packet, Packet), [a], [a1], [a2])]
  -> [(t, (Packet, Packet), [a], [a1], [a2])]
accBindings bs = as
  where
    gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
    as = map (foldl1 combine) gs
    bindingPair (_,p,_,_,_) = pub2 p
      where
        pub2 (a,b) = (pub a, pub b)
        pub a = fingerprint_material a
    samePair a b = bindingPair a == bindingPair b
    combine (ac,p,akind,ahashed,aclaimaints)
            (bc,_,bkind,bhashed,bclaimaints)
        = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)


data UserIDRecord = UserIDRecord {
    uid_full :: String,
    uid_realname :: T.Text,
    uid_user :: T.Text,
    uid_subdomain :: T.Text,
    uid_topdomain :: T.Text
}

isBracket '<' = True
isBracket '>' = True
isBracket _   = False

parseUID str = UserIDRecord {
                    uid_full = str,
                    uid_realname = realname,
                    uid_user = user,
                    uid_subdomain = subdomain,
                    uid_topdomain = topdomain
                }
 where
    text = T.pack str
    (T.strip-> realname, T.dropAround isBracket-> email) 
                              = T.break (=='<') text
    (user, T.tail-> hostname) = T.break (=='@') email
    ( T.reverse            -> topdomain,
      T.reverse . T.drop 1 -> subdomain)
                              = T.break (=='.') . T.reverse $ hostname


derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy

listKeys pkts = do
    let (certs,bs) = getBindings pkts
        as = accBindings bs
        defaultkind (k:_) hs = k
        defaultkind []    hs = maybe "subkey"
                                     id
                                     ( listToMaybe 
                                     . mapMaybe (fmap usageString . keyflags)
                                     $ hs)
        kinds = map (\(_,_,k,h,_)->defaultkind k h) as
        kindwidth = maximum $ map length kinds
        kindcol = min 20 kindwidth
        code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
        ownerkey (_,(a,_),_,_,_) = a
        sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
        gs = groupBy sameMaster (sortBy (comparing code) as)
    subs <- gs
    let (code,(top,sub), kind, hashed,claimants):_ = subs
        subkeys = do
            (code,(top,sub), kind, hashed,claimants) <- subs
            let ar = case code of
                        0 -> " ??? "
                        1 -> " --> "
                        2 -> " <-- "
                        3 -> " <-> "
                formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
                -- torhash = maybe "" id $ derToBase32 <$> derRSA sub
            concat  [ " "
                    -- , grip top
                    , ar
                    , formkind 
                    , " "
                    , fingerprint sub 
                    -- , " " ++ torhash
                    , "\n" ]
                -- ++ ppShow hashed
        torkeys = do
            (code,(top,sub), kind, hashed,claimants) <- subs
            guard ("tor" `elem` kind)
            guard (code .&. 0x2 /= 0)
            maybeToList $ derToBase32 <$> derRSA sub
        uid = {- maybe "" id . listToMaybe $ -} do
            (keys,sigs) <- certs
            sig <- sigs
            guard (isCertificationSig sig)
            guard (topkey sig == top)
            sig_over <- signatures_over sig
            guard (join (fmap (find_key smallpr (Message keys)) $ signature_issuer sig_over) == Just top)
            let UserIDPacket uid = user_id sig
                parsed = parseUID uid
                ar = maybe " --> " (const " <-> ") $ do
                        guard (uid_topdomain parsed == "onion" )
                        guard ( uid_realname parsed `elem` ["","Anonymous"])
                        guard (     uid_user parsed == "root" )
                        let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
                            len = L.length subdom0
                            subdom = Char8.unpack subdom0
                            match = ( (==subdom) . take (fromIntegral len))
                        guard (len >= 16)
                        listToMaybe $ filter match torkeys
            " " ++ ar ++ "@" ++ " " ++ uid_full parsed ++ "\n"
        (_,sigs) = unzip certs
    "master-key " ++ fingerprint top ++ "\n" ++ uid ++"  ...\n" ++ subkeys ++ "\n"
    

data PGPKeyFlags =
    Special
    | Vouch
    | 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"
    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"


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


modifyUID (UserIDPacket str) = UserIDPacket str'
 where
    (fstname,rst) = break (==' ') str
    str' = mod fstname ++ rst
    mod "Bob" = "Bob Fucking"
    mod x     = x
modifyUID other              = other

todo = error "unimplemented"

-- TODO: switch to System.Environment.lookupEnv
--       when linking against newer base libraries.
lookupEnv var = 
    handleIO_ (return Nothing) $ fmap Just (getEnv var)

homedir :: Term (IO String)
homedir = envhomedir <$> opt_homedir
 where
    envhomedir opt = do
        gnupghome <- lookupEnv "GNUPGHOME" >>=
                  \d -> return $ d >>= guard . (/="") >> d
        home <- lookupEnv "HOME" >>=
                  \d -> return $ d >>= guard . (/="") >> d
        {-
        home <- flip fmap getHomeDirectory $
                  \d -> fmap (const d) $ guard (d/="")
        -}
        let homegnupg = (++"/.gnupg") <$> home
        return $ maybe "" id (opt `mplus` gnupghome `mplus` homegnupg)

opt_homedir = optDescrToTerm $ Option
                    "" ["homedir"]
                    (ReqArg id "dir")
                    (concat
                        [ "path to pubring.gpg"
                        , " and secring.gpg"
                        , " (default = ${GNUPGHOME:-$HOME/.gnupg})" ])

opt_options =  optDescrToTerm $ Option
                "" ["options"]
                (ReqArg id "file")
                $ concat
                    [ "Read options from file and do not try to read"
                    , " them from the default options file in the"
                    , " homedir (see --homedir). This option is"
                    , " ignored if used in an options file."
                    , " The default options file is the first existing"
                    , " out of keys.conf, gpg.conf-2, and gpg.conf."]

opt_default_key = optDescrToTerm $ Option
                "" ["default-key"]
                (ReqArg id "name")
                $ concat
                    [ "Use name as the default key to sign with. If"
                    , " this option is not used, the default key is"
                    , " the first key found in the secret keyring."]

opt_list_secret_keys = optDescrToTerm $ Option
                "K" ["list-secret-keys"]
                (NoArg ())
                $ concat
                    [ "List all keys from the secret keyrings." ]


unmaybe def = fmap (maybe def id)

opt_secret_keyring = expandPath <$> unmaybe "" opt_homedir <*> prim
 where
    -- TODO: alow multiple instances of --secret-keyring
    --       See: System.Console.CmdTheLine.Arg.vFlagAll
    prim = unmaybe "secring.gpg" . optDescrToTerm $ Option
                "" ["secret-keyring"]
                (ReqArg id "file")
                $ concat
                    [ "Utilize secret keys in the specified file."
                    , "(default: secring.gpg)" ]

expandPath path (c:cs) | c/='/'    = path ++ "/" ++ (c:cs)
                       | otherwise = c:cs
expandPath path []                 = []

secret_packets :: Term (IO Message)
secret_packets = readPacketsFromFile <$> opt_secret_keyring

readPacketsFromFile :: FilePath -> IO Message
readPacketsFromFile fname = do
    input <- L.readFile fname
    return $
      case decodeOrFail input of
        Right (_,_,msg ) -> msg
        Left  (_,_,_)    -> Message []


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

options_from_file :: Term a -> (String,String,Term (Maybe String)) -> ([String],Term (Maybe String)) -> IO [String]
options_from_file term (homevar,appdir,home) (optfile_alts,options_file) = doit
 where
    homedir = envhomedir <$> home
    envhomedir opt = do
        gnupghome <- lookupEnv homevar >>=
                  \d -> return $ d >>= guard . (/="") >> d
        home <- flip fmap getHomeDirectory $
                  \d -> fmap (const d) $ guard (d/="")
        let homegnupg = (++('/':appdir)) <$> home
        return $ (opt `mplus` gnupghome `mplus` homegnupg)

    doit = do
        args <- getArgs
        let wants_help = 
                not . null $ filter cryForHelp args
                        where cryForHelp "--help"    = True
                              cryForHelp "--version" = True
                              cryForHelp x = 
                                and (zipWith (==) x "--help=")
        (o,h) <- do
            val <- unwrap args (liftA2 (,) options_file homedir, defTI)
            case val of
                _ | wants_help -> return (Nothing,Nothing)
                {-
                Left e         -> putStrLn ("Unable to find home directory ")
                                  >> exitFailure
                -}
                Left e -> return (Nothing,Nothing)
                Right (o,h)    -> fmap (o,) h
        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
                    o' = fmap (False,) o
                in filterM (doesFileExist . snd) optfiles
        args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do
            let h' = fromJust h
            newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname
            let toArgs = toHead ("--"++) . words
                toHead f (x:xs) = f x : xs
                toHead f []     = []
                voidTerm = fmap (const ())
                appendArgs as [] = return as
                appendArgs as (configline:cs) = do
                    let xs = toArgs configline
                    w <-unwrap (xs++as) (voidTerm term,defTI)
                    case w of
                        Left  _ -> appendArgs as cs
                        Right _ -> appendArgs (xs++as) cs
            -- TODO: check errors if forgive = False
            appendArgs args newargs
        return args

runWithOptionsFile (term,ti) = do
    as <- options_from_file term
                            ("GNUPGHOME",".gnupg",opt_homedir)
                            (["keys.conf","gpg.conf-2","gpg.conf"]
                            ,opt_options)
    q <- eval as (term , ti)
    q

main = do
    q <- runWithOptionsFile (listSecretKeys, defTI { termName = "keys", CmdTheLine.version = "0.1" })
    return ()
 where
    -- showhome =  flip const <$> opt_options <*> ( (>>= putStrLn) <$> homedir )
    showhome =  opt_default_key <:> opt_options <:> ( (>>= putStrLn) <$> homedir )
    a <:> b = flip const <$> a <*> b
    infixr 2 <:>

    listSecretKeys = opt_options <:> (>>= list) <$> secret_packets

    list (Message pkts) = putStrLn $ listKeys pkts