summaryrefslogtreecommitdiff
path: root/kiki.hs
diff options
context:
space:
mode:
Diffstat (limited to 'kiki.hs')
-rw-r--r--kiki.hs1195
1 files changed, 1195 insertions, 0 deletions
diff --git a/kiki.hs b/kiki.hs
new file mode 100644
index 0000000..c9483a0
--- /dev/null
+++ b/kiki.hs
@@ -0,0 +1,1195 @@
1{-# LANGUAGE ViewPatterns #-}
2{-# LANGUAGE TupleSections #-}
3{-# LANGUAGE OverloadedStrings #-}
4{-# LANGUAGE RankNTypes #-}
5{-# LANGUAGE FlexibleInstances #-}
6{-# LANGUAGE DeriveDataTypeable #-}
7{-# LANGUAGE CPP #-}
8module Main where
9
10import Debug.Trace
11import Data.Binary
12import Data.OpenPGP
13import qualified Data.ByteString.Lazy as L
14import qualified Data.ByteString.Lazy.Char8 as Char8
15import qualified Data.ByteString as S
16import qualified Data.ByteString.Char8 as S8
17import Control.Monad
18import qualified Text.Show.Pretty as PP
19import Text.PrettyPrint as PP hiding ((<>))
20import Data.List
21import Data.OpenPGP.CryptoAPI
22import Data.Ord
23import Data.Maybe
24import Data.Bits
25import qualified Data.Text as T
26import Data.Text.Encoding
27import qualified Codec.Binary.Base32 as Base32
28import qualified Codec.Binary.Base64 as Base64
29import qualified Crypto.Hash.SHA1 as SHA1
30import Data.Char (toLower)
31import qualified Crypto.PubKey.RSA as RSA
32import Crypto.Random (newGenIO,SystemRandom)
33import Data.ASN1.Types
34import Data.ASN1.Encoding
35import Data.ASN1.BinaryEncoding
36import Control.Applicative
37import System.Environment
38import System.Directory
39import System.Exit
40import ControlMaybe
41import Data.Char
42import Control.Arrow (second)
43import Data.Traversable
44import System.Console.CmdArgs
45-- import System.Posix.Time
46import Data.Time.Clock.POSIX
47import System.Posix.IO (fdToHandle,fdRead)
48import System.Posix.Files
49import Data.Monoid ((<>))
50-- import Data.X509
51
52data RSAPublicKey = RSAKey MPI MPI deriving Show
53
54instance ASN1Object RSAPublicKey where
55 toASN1 (RSAKey (MPI n) (MPI e))
56 = \xs -> Start Sequence
57 : IntVal n
58 : IntVal e
59 : End Sequence
60 : xs
61 fromASN1 (Start Sequence:IntVal modulus:IntVal pubexp:End Sequence:xs) =
62 Right (RSAKey (MPI modulus) (MPI pubexp) , xs)
63 fromASN1 _ =
64 Left "fromASN1: RSAPublicKey: unexpected format"
65
66data RSAPrivateKey = RSAPrivateKey
67 { rsaN :: MPI
68 , rsaE :: MPI
69 , rsaD :: MPI
70 , rsaP :: MPI
71 , rsaQ :: MPI
72 , rsaDmodP1 :: MPI
73 , rsaDmodQminus1 :: MPI
74 , rsaCoefficient :: MPI
75 }
76 deriving Show
77
78{-
79RSAPrivateKey ::= SEQUENCE {
80 version Version,
81 modulus INTEGER, -- n
82 publicExponent INTEGER, -- e
83 privateExponent INTEGER, -- d
84 prime1 INTEGER, -- p
85 prime2 INTEGER, -- q
86 exponent1 INTEGER, -- d mod (p1)
87 exponent2 INTEGER, -- d mod (q-1)
88 coefficient INTEGER, -- (inverse of q) mod p
89 otherPrimeInfos OtherPrimeInfos OPTIONAL
90}
91-}
92
93instance ASN1Object RSAPrivateKey where
94 toASN1 rsa@(RSAPrivateKey {})
95 = \xs -> Start Sequence
96 : IntVal 0
97 : mpiVal rsaN
98 : mpiVal rsaE
99 : mpiVal rsaD
100 : mpiVal rsaP
101 : mpiVal rsaQ
102 : mpiVal rsaDmodP1
103 : mpiVal rsaDmodQminus1
104 : mpiVal rsaCoefficient
105 : End Sequence
106 : xs
107 where mpiVal f = IntVal x where MPI x = f rsa
108
109 fromASN1 ( Start Sequence
110 : IntVal _ -- version
111 : IntVal n
112 : IntVal e
113 : IntVal d
114 : IntVal p
115 : IntVal q
116 : IntVal dmodp1
117 : IntVal dmodqminus1
118 : IntVal coefficient
119 : ys) =
120 Right ( privkey, tail $ dropWhile notend ys)
121 where
122 notend (End Sequence) = False
123 notend _ = True
124 privkey = RSAPrivateKey
125 { rsaN = MPI n
126 , rsaE = MPI e
127 , rsaD = MPI d
128 , rsaP = MPI p
129 , rsaQ = MPI q
130 , rsaDmodP1 = MPI dmodp1
131 , rsaDmodQminus1 = MPI dmodqminus1
132 , rsaCoefficient = MPI coefficient
133 }
134 fromASN1 _ =
135 Left "fromASN1: RSAPrivateKey: unexpected format"
136
137rsaKeyFromPacket p@(PublicKeyPacket {}) = do
138 n <- lookup 'n' $ key p
139 e <- lookup 'e' $ key p
140 return $ RSAKey n e
141rsaKeyFromPacket p@(SecretKeyPacket {}) = do
142 n <- lookup 'n' $ key p
143 e <- lookup 'e' $ key p
144 return $ RSAKey n e
145rsaKeyFromPacket _ = Nothing
146derRSA rsa = do
147 k <- rsaKeyFromPacket rsa
148 return $ encodeASN1 DER (toASN1 k [])
149
150getPackets :: IO [Packet]
151getPackets = do
152 input <- L.getContents
153 case decodeOrFail input of
154 Right (_,_,Message pkts) -> return pkts
155 Left (_,_,_) -> return []
156
157
158secretToPublic pkt@(SecretKeyPacket {}) =
159 PublicKeyPacket { version = version pkt
160 , timestamp = timestamp pkt
161 , key_algorithm = key_algorithm pkt
162 , key = let seckey = key pkt
163 pubs = public_key_fields (key_algorithm pkt)
164 in filter (\(k,v) -> k `elem` pubs) seckey
165 , is_subkey = is_subkey pkt
166 , v3_days_of_validity = Nothing
167 }
168secretToPublic pkt = pkt
169
170
171extractPEM typ pem = dta
172 where
173 dta = case ys of
174 _:dta_lines -> Char8.concat dta_lines
175 [] -> ""
176 xs = dropWhile (/="-----BEGIN " <> typ <> "-----") (Char8.lines pem)
177 ys = takeWhile (/="-----END " <> typ <> "-----") xs
178
179isKey (PublicKeyPacket {}) = True
180isKey (SecretKeyPacket {}) = True
181isKey _ = False
182
183isUserID (UserIDPacket {}) = True
184isUserID _ = False
185
186isEmbeddedSignature (EmbeddedSignaturePacket {}) = True
187isEmbeddedSignature _ = False
188
189isCertificationSig (CertificationSignature {}) = True
190isCertificationSig _ = True
191
192issuer (IssuerPacket issuer) = Just issuer
193issuer _ = Nothing
194backsig (EmbeddedSignaturePacket s) = Just s
195backsig _ = Nothing
196
197isSubkeySignature (SubkeySignature {}) = True
198isSubkeySignature _ = False
199
200isMasterKey k@(PublicKeyPacket {}) = not $ is_subkey k
201isMasterKey _ = False
202
203now = floor <$> Data.Time.Clock.POSIX.getPOSIXTime
204
205usage (NotationDataPacket
206 { human_readable = True
207 , notation_name = "usage@"
208 , notation_value = u
209 }) = Just u
210usage _ = Nothing
211
212verifyBindings keys nonkeys = (top ++ filter isSubkeySignature embedded,othersigs)
213 where
214 verified = do
215 sig <- signatures (Message nonkeys)
216 let v = verify (Message keys) sig
217 guard (not . null $ signatures_over v)
218 return v
219 (top,othersigs) = partition isSubkeySignature verified
220 embedded = do
221 sub <- top
222 let sigover = signatures_over sub
223 unhashed = sigover >>= unhashed_subpackets
224 subsigs = mapMaybe backsig unhashed
225 sig <- signatures (Message ([topkey sub,subkey sub]++subsigs))
226 let v = verify (Message [subkey sub]) sig
227 guard (not . null $ signatures_over v)
228 return v
229
230grip k = drop 32 $ fingerprint k
231
232smallpr k = drop 24 $ fingerprint k
233
234-- matchpr computes the fingerprint of the given key truncated to
235-- be the same lenght as the given fingerprint for comparison.
236matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
237
238
239disjoint_fp ks = {- concatMap group2 $ -} transpose grouped
240 where
241 grouped = groupBy samepr . sortBy (comparing smallpr) $ ks
242 samepr a b = smallpr a == smallpr b
243
244 {-
245 -- useful for testing
246 group2 :: [a] -> [[a]]
247 group2 (x:y:ys) = [x,y]:group2 ys
248 group2 [x] = [[x]]
249 group2 [] = []
250 -}
251
252verifyBindingsEx :: [Packet] -> ([SignatureOver], [SignatureOver]) -- ^ (binding signatures, other signatures)
253verifyBindingsEx pkts = bicat . unzip $ do
254 let (keys,_) = partition isKey pkts
255 keys <- disjoint_fp keys
256 return $ verifyBindings keys pkts
257 where
258 bicat (xs,ys) = (concat xs,concat ys)
259
260getBindings ::
261 [Packet]
262 ->
263 ( [([Packet],[SignatureOver])] -- ^ other signatures with key sets
264 -- that were used for the verifications
265 , [(Word8,
266 (Packet, Packet), -- (topkey,subkey)
267 [String], -- usage flags
268 [SignatureSubpacket], -- hashed data
269 [Packet])] -- ^ binding signatures
270 )
271getBindings pkts = (sigs,bindings)
272 where
273 (sigs,concat->bindings) = unzip $ do
274 let (keys,nonkeys) = partition isKey pkts
275 keys <- disjoint_fp keys
276 let (bs,sigs) = verifyBindings keys pkts
277 return . ((keys,sigs),) $ do
278 b <- bs -- trace ("sigs = "++show (map (map signature_issuer . signatures_over) sigs)) bs
279 i <- map signature_issuer (signatures_over b)
280 i <- maybeToList i
281 who <- maybeToList $ find_key fingerprint (Message keys) i
282 let (code,claimants) =
283 case () of
284 _ | who == topkey b -> (1,[])
285 _ | who == subkey b -> (2,[])
286 _ -> (0,[who])
287 let hashed = signatures_over b >>= hashed_subpackets
288 kind = guard (code==1) >> hashed >>= maybeToList . usage
289 return (code,(topkey b,subkey b), kind, hashed,claimants)
290
291-- Returned data is simmilar to getBindings but the Word8 codes
292-- are ORed together.
293accBindings ::
294 Bits t =>
295 [(t, (Packet, Packet), [a], [a1], [a2])]
296 -> [(t, (Packet, Packet), [a], [a1], [a2])]
297accBindings bs = as
298 where
299 gs = groupBy samePair . sortBy (comparing bindingPair) $ bs
300 as = map (foldl1 combine) gs
301 bindingPair (_,p,_,_,_) = pub2 p
302 where
303 pub2 (a,b) = (pub a, pub b)
304 pub a = fingerprint_material a
305 samePair a b = bindingPair a == bindingPair b
306 combine (ac,p,akind,ahashed,aclaimaints)
307 (bc,_,bkind,bhashed,bclaimaints)
308 = (ac .|. bc,p,akind++bkind,ahashed++bhashed,aclaimaints++bclaimaints)
309
310
311data UserIDRecord = UserIDRecord {
312 uid_full :: String,
313 uid_realname :: T.Text,
314 uid_user :: T.Text,
315 uid_subdomain :: T.Text,
316 uid_topdomain :: T.Text
317}
318 deriving Show
319
320isBracket '<' = True
321isBracket '>' = True
322isBracket _ = False
323
324parseUID str = UserIDRecord {
325 uid_full = str,
326 uid_realname = realname,
327 uid_user = user,
328 uid_subdomain = subdomain,
329 uid_topdomain = topdomain
330 }
331 where
332 text = T.pack str
333 (T.strip-> realname, T.dropAround isBracket-> email)
334 = T.break (=='<') text
335 (user, T.tail-> hostname) = T.break (=='@') email
336 ( T.reverse -> topdomain,
337 T.reverse . T.drop 1 -> subdomain)
338 = T.break (=='.') . T.reverse $ hostname
339
340
341derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
342
343fpmatch grip key =
344 (==) Nothing
345 (fmap (backend (fingerprint key)) grip >>= guard . not)
346 where
347 backend xs ys = and $ zipWith (==) (reverse xs) (reverse ys)
348
349listKeys pkts = listKeysFiltered [] pkts
350
351listKeysFiltered grips pkts = do
352 let (certs,bs) = getBindings pkts
353 as = accBindings bs
354 defaultkind (k:_) hs = k
355 defaultkind [] hs = maybe "subkey"
356 id
357 ( listToMaybe
358 . mapMaybe (fmap usageString . keyflags)
359 $ hs)
360 kinds = map (\(_,_,k,h,_)->defaultkind k h) as
361 kindwidth = maximum $ map length kinds
362 kindcol = min 20 kindwidth
363 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
364 ownerkey (_,(a,_),_,_,_) = a
365 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
366 matchgrip _ | null grips = True
367 matchgrip ((code,(top,sub), kind, hashed,claimants):_) | any (flip fpmatch top . Just) grips = True
368 matchgrip _ = False
369 gs = filter matchgrip $ groupBy sameMaster (sortBy (comparing code) as)
370 subs <- gs
371 let (code,(top,sub), kind, hashed,claimants):_ = subs
372 subkeys = do
373 (code,(top,sub), kind, hashed,claimants) <- subs
374 let ar = case code of
375 0 -> " ??? "
376 1 -> " --> "
377 2 -> " <-- "
378 3 -> " <-> "
379 formkind = take kindcol $ defaultkind kind hashed ++ repeat ' '
380 -- torhash = maybe "" id $ derToBase32 <$> derRSA sub
381 concat [ " "
382 -- , grip top
383 , (if not (null claimants)
384 then trace ("claimants: "++show (map fingerprint claimants))
385 else id) ar
386 , formkind
387 , " "
388 , fingerprint sub
389 -- , " " ++ torhash
390 , "\n" ]
391 -- ++ ppShow hashed
392 torkeys = do
393 (code,(top,sub), kind, hashed,claimants) <- subs
394 guard ("tor" `elem` kind)
395 guard (code .&. 0x2 /= 0)
396 maybeToList $ derToBase32 <$> derRSA sub
397 uid = {- maybe "" id . listToMaybe $ -} do
398 (keys,sigs) <- certs
399 sig <- sigs
400 guard (isCertificationSig sig)
401 guard (topkey sig == top)
402 let issuers = do
403 sig_over <- signatures_over sig
404 i <- maybeToList $ signature_issuer sig_over
405 maybeToList $ find_key (matchpr i) (Message keys) (reverse (take 16 (reverse i)))
406 (primary,secondary) = partition (==top) issuers
407
408 -- trace ("PRIMARY: "++show (map fingerprint primary)) $ return ()
409 -- trace ("SECONDARY: "++show (map fingerprint secondary)) $ return ()
410 guard (not (null primary))
411
412 let UserIDPacket uid = user_id sig
413 parsed = parseUID uid
414 ar = maybe " --> " (const " <-> ") $ do
415 guard (uid_topdomain parsed == "onion" )
416 guard ( uid_realname parsed `elem` ["","Anonymous"])
417 guard ( uid_user parsed == "root" )
418 let subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
419 len = L.length subdom0
420 subdom = Char8.unpack subdom0
421 match = ( (==subdom) . take (fromIntegral len))
422 guard (len >= 16)
423 listToMaybe $ filter match torkeys
424 unlines $ [ " " ++ ar ++ "@" ++ " " ++ uid_full parsed ]
425 ++ map (\k -> " " ++ "^ signed: " ++ fingerprint k) secondary
426 (_,sigs) = unzip certs
427 "master-key " ++ fingerprint top ++ "\n" ++ uid ++" ...\n" ++ subkeys ++ "\n"
428
429
430data PGPKeyFlags =
431 Special
432 | Vouch -- Signkey
433 | Sign
434 | VouchSign
435 | Communication
436 | VouchCommunication
437 | SignCommunication
438 | VouchSignCommunication
439 | Storage
440 | VouchStorage
441 | SignStorage
442 | VouchSignStorage
443 | Encrypt
444 | VouchEncrypt
445 | SignEncrypt
446 | VouchSignEncrypt
447 deriving (Eq,Show,Read,Enum)
448
449usageString flgs =
450 case flgs of
451 Special -> "special"
452 Vouch -> "vouch" -- signkey
453 Sign -> "sign"
454 VouchSign -> "vouch-sign"
455 Communication -> "communication"
456 VouchCommunication -> "vouch-communication"
457 SignCommunication -> "sign-communication"
458 VouchSignCommunication -> "vouch-sign-communication"
459 Storage -> "storage"
460 VouchStorage -> "vouch-storage"
461 SignStorage -> "sign-storage"
462 VouchSignStorage -> "vouch-sign-storage"
463 Encrypt -> "encrypt"
464 VouchEncrypt -> "vouch-encrypt"
465 SignEncrypt -> "sign-encrypt"
466 VouchSignEncrypt -> "vouch-sign-encrypt"
467
468
469keyflags flgs@(KeyFlagsPacket {}) =
470 Just . toEnum $
471 ( bit 0x1 certify_keys
472 .|. bit 0x2 sign_data
473 .|. bit 0x4 encrypt_communication
474 .|. bit 0x8 encrypt_storage ) :: Maybe PGPKeyFlags
475 -- other flags:
476 -- split_key
477 -- authentication (ssh-client)
478 -- group_key
479 where
480 bit v f = if f flgs then v else 0
481keyflags _ = Nothing
482
483
484modifyUID (UserIDPacket str) = UserIDPacket str'
485 where
486 (fstname,rst) = break (==' ') str
487 str' = mod fstname ++ rst
488 mod "Bob" = "Bob Fucking"
489 mod x = x
490modifyUID other = other
491
492todo = error "unimplemented"
493
494-- TODO: switch to System.Environment.lookupEnv
495-- when linking against newer base libraries.
496lookupEnv var =
497 handleIO_ (return Nothing) $ fmap Just (getEnv var)
498
499unmaybe def = fmap (maybe def id)
500
501expandPath path (c:cs) | c/='/' = path ++ "/" ++ (c:cs)
502 | otherwise = c:cs
503expandPath path [] = []
504
505
506readPacketsFromFile :: FilePath -> IO Message
507readPacketsFromFile fname = do
508 input <- L.readFile fname
509 return $
510 case decodeOrFail input of
511 Right (_,_,msg ) -> msg
512 Left (_,_,_) -> Message []
513
514
515parseOptionFile fname = do
516 xs <- fmap lines (readFile fname)
517 let ys = filter notComment xs
518 notComment ('#':_) = False
519 notComment cs = not (all isSpace cs)
520 return ys
521
522{-
523options_from_file ::
524 (forall a. [String] -> Term a -> IO (Either EvalExit a))
525 -> Term b
526 -> (String,String,Term (Maybe String))
527 -> ([String],Term (Maybe String))
528 -> IO [String]
529options_from_file unwrapCmd term (homevar,appdir,home) (optfile_alts,options_file) = doit
530 where
531 homedir = envhomedir <$> home
532 envhomedir opt = do
533 gnupghome <- lookupEnv homevar >>=
534 \d -> return $ d >>= guard . (/="") >> d
535 home <- flip fmap getHomeDirectory $
536 \d -> fmap (const d) $ guard (d/="")
537 let homegnupg = (++('/':appdir)) <$> home
538 let val = (opt `mplus` gnupghome `mplus` homegnupg)
539 return $ val
540
541 doit = do
542 args <- getArgs
543 {-
544 let wants_help =
545 not . null $ filter cryForHelp args
546 where cryForHelp "--help" = True
547 cryForHelp "--version" = True
548 cryForHelp x =
549 and (zipWith (==) x "--help=")
550 -}
551 (o,h) <- do
552 val <- unwrapCmd args (liftA2 (,) options_file homedir)
553 case val of
554 Left e -> return (Nothing,Nothing)
555 Right (o,h) -> (o,) <$> h
556 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
557 let optfiles = map (second ((h++"/")++))
558 (maybe optfile_alts' (:[]) o')
559 optfile_alts' = zip (False:repeat True) optfile_alts
560 o' = fmap (False,) o
561 in filterM (doesFileExist . snd) optfiles
562 args <- flip (maybe $ return args) ofile $ \(forgive,fname) -> do
563 let h' = fromJust h
564 newargs <- (:) <$> pure ("homedir "++h') <*> parseOptionFile fname
565 let toArgs = toHead ("--"++) . words
566 toHead f (x:xs) = f x : xs
567 toHead f [] = []
568 voidTerm = fmap (const ())
569 appendArgs as [] = return as
570 appendArgs as (configline:cs) = do
571 let xs = toArgs configline
572 w <-unwrap (xs++as) (voidTerm term,defTI)
573 case w of
574 Left _ -> appendArgs as cs
575 Right _ -> appendArgs (xs++as) cs
576 -- TODO: check errors if forgive = False
577 appendArgs args newargs
578 return args
579
580runWithOptionsFile :: (Term (IO b), TermInfo) -> IO b
581runWithOptionsFile (term,ti) = do
582 as <- options_from_file unwrapCmd
583 term
584 ("GNUPGHOME",".gnupg",opt_homedir)
585 (["keys.conf","gpg.conf-2","gpg.conf"]
586 ,opt_options)
587 q <- eval as (term , ti)
588 q
589 where
590 unwrapCmd args term = unwrap args (term,defTI)
591
592runChoiceWithOptionsFile ::
593 (Term (IO b), TermInfo) -> [(Term (IO b), TermInfo)] -> IO b
594runChoiceWithOptionsFile (realterm,ti) choices = do
595 as <- options_from_file unwrapCmd
596 realterm
597 ("GNUPGHOME",".gnupg",opt_homedir)
598 (["keys.conf","gpg.conf-2","gpg.conf"]
599 ,opt_options)
600 -- putStrLn $ "as = " ++ show as
601 q <- evalChoice as (realterm , ti) choices
602 q
603 where
604 unwrapCmd args t =
605 unwrapChoice args (realterm <:> t,ti) (map (neuter t) choices)
606 neuter term (t,ti) = (t <:> term, ti)
607
608data Command =
609 List
610 | Autosign
611 deriving (Eq,Show,Read,Enum)
612
613capitolizeFirstLetter (x:xs) = toUpper x : xs
614capitolizeFirstLetter xs = xs
615
616instance ArgVal Command where
617 converter =
618 ( maybe (Left $ text "unknown command") Right
619 . fmap fst . listToMaybe . reads
620 . capitolizeFirstLetter . map toLower
621 , text . map toLower . show
622 )
623class AutoMaybe a
624instance AutoMaybe Command
625instance (ArgVal a, AutoMaybe a) => ArgVal (Maybe a) where
626 converter =
627 ( toRight Just . fst converter
628 , maybe (text "(unspecified)") id . fmap (snd converter)
629 )
630
631toRight f (Right x) = Right (f x)
632toRight f (Left y) = Left y
633
634cmd :: Term Command
635cmd = required . pos 0 Nothing $ posInfo
636 { posName = "command"
637 , posDoc = "What action to perform."
638 }
639
640a <:> b = flip const <$> a <*> b
641infixr 2 <:>
642
643selectAction cmd actions = actions !! fromEnum cmd
644
645cmdInfo :: ArgVal cmd =>
646 cmd -> String -> Term a -> (cmd, (Term a, TermInfo))
647cmdInfo cmd doc action =
648 ( cmd
649 , ( action
650 , defTI { termName = print cmd
651 , termDoc = doc } ) )
652 where
653 print = show . snd converter
654
655cmdlist :: (Command, (Term (IO ()), TermInfo))
656cmdlist = cmdInfo List "list key pairs for which secrets are known" $
657 (>>= putStrLn . listKeys . unMessage) <$> secret_packets
658 where unMessage (Message pkts) = pkts
659
660cmdautosign = cmdInfo Autosign "auto-sign tor-style uids" $
661 pure (putStrLn "autosign")
662
663
664multiCommand ::
665 TermInfo
666 -> [(Command, (Term a, TermInfo))]
667 -> ( (Term a, TermInfo)
668 , [(Term a, TermInfo)] )
669multiCommand ti choices =
670 ( ( selectAction <$> cmd <*> sequenceA (map strip choices)
671 , ti )
672 , map snd choices )
673 where
674 selectAction cmd choices =
675 fromJust $ lookup (cmd::Command) choices
676 strip (cmd,(action,_)) = fmap (cmd,) action
677-}
678
679
680trimCR bs = fst $ S.spanEnd (\x -> x==10 || x==13) bs
681
682guessKeyFormat 'P' "ssh-client" = "SSH"
683guessKeyFormat 'S' "ssh-client" = "PEM"
684guessKeyFormat 'S' "ssh-host" = "PEM"
685guessKeyFormat _ _ = "PEM" -- "PGP"
686
687readKeyFromFile False "PEM" fname = do
688 timestamp <- modificationTime <$> getFileStatus fname
689 input <- L.readFile fname
690 let dta = extractPEM "RSA PRIVATE KEY" input
691 -- Char8.putStrLn $ "dta = " <> dta
692 let rsa = do
693 e <- decodeASN1 DER . L.pack <$> Base64.decode (Char8.unpack dta)
694 asn1 <- either (const Nothing) Just e
695 k <- either (const Nothing) (Just . fst) (fromASN1 asn1)
696 let _ = k :: RSAPrivateKey
697 return k
698 -- putStrLn $ "rsa = "++ show rsa
699 return . Message $ do
700 rsa <- maybeToList rsa
701 return $ SecretKeyPacket
702 { version = 4
703 , timestamp = toEnum (fromEnum timestamp)
704 , key_algorithm = RSA
705 , key = [ -- public fields...
706 ('n',rsaN rsa)
707 ,('e',rsaE rsa)
708 -- secret fields
709 ,('d',rsaD rsa)
710 ,('p',rsaQ rsa) -- Note: p & q swapped
711 ,('q',rsaP rsa) -- Note: p & q swapped
712 ,('u',rsaCoefficient rsa)
713 ]
714 , s2k_useage = 0
715 , s2k = S2K 100 ""
716 , symmetric_algorithm = Unencrypted
717 , encrypted_data = ""
718 , is_subkey = True
719 }
720readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
721
722data Arguments =
723 List { homedir :: Maybe FilePath }
724 | WorkingKey { homedir :: Maybe FilePath }
725 | AutoSign { homedir :: Maybe FilePath
726 , passphrase_fd :: Maybe Int
727 , input :: FilePath
728 , output :: FilePath}
729 | Public { homedir :: Maybe FilePath
730 , output :: FilePath}
731 | Add { homedir :: Maybe FilePath
732 , passphrase_fd :: Maybe Int
733 , key_usage :: String
734 , seckey :: String
735 , output :: FilePath }
736 | PemFP { homedir :: Maybe FilePath
737 , seckey :: String }
738 | CatPub { homedir :: Maybe FilePath
739 , catpub_args :: [String] }
740 {-
741 | Decrypt { homedir :: Maybe FilePath
742 , passphrase_fd :: Maybe Int
743 , output :: FilePath }
744 -}
745 deriving (Show, Data, Typeable)
746
747getPassphrase cmd =
748 case passphrase_fd cmd of
749 Just fd -> do pwh <- fdToHandle (toEnum fd)
750 fmap trimCR $ S.hGetContents pwh
751 Nothing -> return ""
752
753
754#define HOMEOPTION (def &= explicit &= name "homedir" &= typDir )
755
756main = do
757 args <- cmdArgs $ modes
758 [ List HOMEOPTION
759 &= help "List key pairs in the secret keyring."
760 &= auto
761 , WorkingKey HOMEOPTION
762 &= help "Shows the current working key set that will be used to make signatures."
763 , Public HOMEOPTION
764 (def &= argPos 1 &= typFile )
765 &= help "Extract public keys into the given file."
766 , AutoSign HOMEOPTION
767 (def &= opt ("passphrase"::String)
768 &= typ "FD"
769 &= (help . concat) ["file descriptor from "
770 ,"which to read passphrase"])
771 (def &= argPos 1 &= typFile )
772 (def &=argPos 2 &= typFile)
773 &= (help . concat)
774 [ "Copies the first file to the second while adding"
775 , " signatures for tor-style uids that match"
776 , " cross-certified keys." ]
777 {-
778 , Decrypt HOMEOPTION
779 (def &= opt ("passphrase"::String)
780 &= typ "FD"
781 &= (help . concat) ["file descriptor from "
782 ,"which to read passphrase"])
783 (def &= argPos 1 &= typFile )
784 -- (def &= argPos 3 &= typ "PUBLIC-KEY")
785 &= (help . concat)
786 [ "Remove password protection from the working keyring"
787 , " and save the result into the given file."]
788 -}
789 , CatPub HOMEOPTION
790 (def &= args &= typ "KEYSPEC FILES")
791 &= help "Extract a public subkey to stdout."
792 , Add HOMEOPTION
793 (def &= opt ("passphrase"::String)
794 &= typ "FD"
795 &= (help . concat) ["file descriptor from "
796 ,"which to read passphrase"])
797 (def &= argPos 1 &= typ "USAGE")
798 (def &= argPos 2 &= typ "PRIVATE-KEY")
799 (def &= argPos 3 &= typFile)
800 -- (def &= argPos 3 &= typ "PUBLIC-KEY")
801 &= (help . concat)
802 [ "Add a subkey."
803 , " USAGE is the usage@ annotation of the subkey."
804 , " Keys are specified as FMT:FILE where"
805 , " FMT may be one of following: PEM."
806 , " Results are written to the given file." ]
807
808 , PemFP HOMEOPTION
809 (def &= argPos 1 &= typFile )
810 &= (help . concat)
811 [ "Display the fingerprint of a PEM key pair."]
812 ]
813 &= program "kiki"
814 &= summary "kiki - a pgp key editing utility"
815 doCmd args
816 where
817 envhomedir opt = do
818 gnupghome <- lookupEnv homevar >>=
819 \d -> return $ d >>= guard . (/="") >> d
820 home <- flip fmap getHomeDirectory $
821 \d -> fmap (const d) $ guard (d/="")
822 let homegnupg = (++('/':appdir)) <$> home
823 let val = (opt `mplus` gnupghome `mplus` homegnupg)
824 return $ val
825
826 homevar = "GNUPGHOME"
827 appdir = ".gnupg"
828 optfile_alts = ["keys.conf","gpg.conf-2","gpg.conf"]
829
830 getHomeDir cmd = do
831 homedir <- envhomedir (homedir cmd)
832 flip (maybe (error "Could not determine home directory."))
833 homedir $ \homedir -> do
834 -- putStrLn $ "homedir = " ++show homedir
835 let secring = homedir ++ "/" ++ "secring.gpg"
836 -- putStrLn $ "secring = " ++ show secring
837 workingkey <- getWorkingKey homedir
838 return (homedir,secring,workingkey)
839
840 getWorkingKey homedir = do
841 let o = Nothing
842 h = Just homedir
843 args = ["hi"]
844 ofile <- fmap listToMaybe . flip (maybe (return [])) h $ \h ->
845 let optfiles = map (second ((h++"/")++))
846 (maybe optfile_alts' (:[]) o')
847 optfile_alts' = zip (False:repeat True) optfile_alts
848 o' = fmap (False,) o
849 in filterM (doesFileExist . snd) optfiles
850 args <- flip (maybe $ return []) ofile $
851 \(forgive,fname) -> parseOptionFile fname
852 let config = map (topair . words) args
853 where topair (x:xs) = (x,xs)
854 return $ lookup "default-key" config >>= listToMaybe
855
856 getPGPEnviron cmd = do
857 (homedir,secring,grip) <- getHomeDir cmd
858 (Message sec) <- readPacketsFromFile secring
859 let (keys,_) = partition (\k -> case k of
860 { SecretKeyPacket {} -> True
861 ; _ -> False })
862 sec
863 return (homedir,sec, grip `mplus` fmap fingerprint (listToMaybe keys))
864
865 getTorKeys pub = do
866 xs <- groupBindings pub
867 (_,(top,sub),us,_,_) <- xs
868 guard ("tor" `elem` us)
869 let torhash = maybe "" id $ derToBase32 <$> derRSA sub
870 return (top,(torhash,sub))
871
872 uidScan pub = scanl (\(mkey,u) w ->
873 case () of
874 _ | isMasterKey w -> (w,u)
875 _ | isUserID w -> (mkey,w)
876 _ | otherwise -> (mkey,u)
877 )
878 (w0,w0)
879 ws
880 where
881 w0:ws = pub
882
883 signSelfAuthTorKeys pw g sec grip timestamp xs = ys
884 where
885 keys = filter isKey sec
886 selfkey = find_key fingerprint (Message keys) (fromJust grip) >>= decryptKey
887 where
888 decryptKey k = decryptSecretKey pw k
889 mainpubkey = fst (head xs)
890 uid:xs' = map snd xs
891 (sigs, xs'') = span isSignaturePacket xs'
892 overs sig = signatures $ Message (keys++[uid,sig])
893 vs :: [ ( Packet -- signature
894 , Maybe SignatureOver) -- Nothing means non-verified
895 ]
896 vs = do
897 sig <- sigs
898 let vs = overs sig >>= return . verify (Message keys)
899 ws = filter (not . null . signatures_over) vs
900 ws' = if null ws then [Nothing] else map Just ws
901 v <- ws'
902 return (sig,v)
903 has_self = not . null $ filter (\(sig,v) -> fmap topkey v == selfkey) vs
904 sigs' = if has_self
905 then sigs
906 {-
907 else trace ( "key params: "++params (fromJust selfkey)++"\n"
908 ++traceSig (topkey new_sig) (user_id new_sig) (signatures_over new_sig)) sigs ++ map modsig (signatures_over new_sig)
909 -}
910 else sigs ++ signatures_over new_sig
911 modsig sig = sig { signature = map id (signature sig) }
912 where plus1 (MPI x) = MPI (x+1)
913 params newtop = public ++ map fst (key newtop) ++ "}"
914 where
915 public = case newtop of
916 PublicKeyPacket {} -> "public{"
917 SecretKeyPacket {} -> if L.null (encrypted_data newtop )
918 then "secret{"
919 else "encrypted{"
920 _ -> "??????{"
921 traceSig newtop newuid new_sig = (unlines ["mainpubkey:"++ show (fingerprint mainpubkey)
922 ,"new_sig topkey:"++ (show . fingerprint $ newtop)
923 ,"new_sig topkey params: "++ params newtop
924 ,"new_sig user_id:"++ (show newuid)
925 ,"new_sig |over| = " ++ (show . length $ new_sig)
926 ,"new_sig hashed = " ++ (PP.ppShow . concatMap hashed_subpackets $ new_sig)
927 ,"new_sig unhashed = " ++ (show . concatMap unhashed_subpackets $ new_sig)
928 ,"new_sig type: " ++ (show . map signature_type $ new_sig)
929 ,"new_sig signature:" ++ (show . concatMap signature $ new_sig)
930 ,"new_sig isSignaturePacket(over) = " ++ (show . map isSignaturePacket $ new_sig)
931 ,"issuer = " ++ show (map signature_issuer new_sig)
932 ])
933 new_sig = fst $ sign (Message (maybeToList selfkey))
934 (CertificationSignature mainpubkey
935 uid
936 []) --fromJust selfkey, uid])
937 SHA1
938 (fromJust grip)
939 timestamp
940 g
941 ys = uid:sigs'++xs''
942
943 doCmd cmd@(List {}) = do
944 (homedir,secring,grip) <- getHomeDir cmd
945 (Message sec) <- readPacketsFromFile secring
946 putStrLn $ listKeys sec
947
948 doCmd cmd@(WorkingKey {}) = do
949 (homedir,secring,grip) <- getHomeDir cmd
950 (Message sec) <- readPacketsFromFile secring
951 -- let s2k' = map s2k (filter isKey sec)
952 -- putStrLn $ "s2k = " ++ show s2k'
953 putStrLn $ listKeysFiltered (maybeToList grip) sec
954 return ()
955
956 doCmd cmd@(AutoSign {}) = do
957 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
958 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
959 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
960 ) <- getPGPEnviron cmd
961 S8.putStrLn $ "pasphrase_fd = " <> S8.pack (show (passphrase_fd cmd))
962 pw <- getPassphrase cmd
963 -- putStrLn $ "getPGPEnviron -> " ++ show (homedir,length sec,grip)
964 (Message pub) <- readPacketsFromFile (input cmd)
965 putStrLn $ listKeys pub
966 -- forM_ (zip [1..] pub) $ \(i,k) -> do
967 -- putStrLn $ show i ++ ": " ++ show k
968 let torbindings = getTorKeys pub
969 keyed = uidScan pub
970 marked = zipWith doit keyed pub
971 doit (mkey,u) packet = (isTorID packet, (mkey,u,packet))
972 where
973 isTorID (UserIDPacket str) =
974 and [ uid_topdomain parsed == "onion"
975 , uid_realname parsed `elem` ["","Anonymous"]
976 , uid_user parsed == "root"
977 , fmap (match . fst) (lookup mkey torbindings)
978 == Just True ]
979 where parsed = parseUID str
980 match = ( (==subdom) . take (fromIntegral len))
981 subdom0 = L.fromChunks [encodeUtf8 (uid_subdomain parsed)]
982 subdom = Char8.unpack subdom0
983 len = T.length (uid_subdomain parsed)
984
985 isTorID _ = False
986
987 g <- newGenIO
988 timestamp <- now
989 -- timestamp <- epochTime
990 let xs:xss = groupBy (\_ (b,_)->not b) marked
991 pub' = map (snd . cleanup) xs
992 ++ concatMap (signSelfAuthTorKeys pw (g::SystemRandom) sec grip timestamp)
993 (map (map cleanup) xss)
994 cleanup (_,(topkey,_,pkt)) = (topkey,pkt)
995 putStrLn $ "-------- signed ------> " -- ++ show (length pub, length pub')
996 putStrLn ""
997 putStrLn $ listKeysFiltered (map fingerprint (filter isMasterKey pub')) (sec++pub')
998
999 let signed_bs = encode (Message pub')
1000 L.writeFile (output cmd) signed_bs
1001
1002 doCmd cmd@(Public {}) = do
1003 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
1004 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
1005 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
1006 ) <- getPGPEnviron cmd
1007 let pub = map secretToPublic sec
1008 bs = encode (Message pub)
1009 L.writeFile (output cmd) bs
1010
1011 {-
1012 doCmd cmd@(Decrypt {}) = do
1013 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
1014 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
1015 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
1016 ) <- getPGPEnviron cmd
1017 pw <- getPassphrase cmd
1018
1019 let sec' = map decrypt sec
1020 decrypt k@(SecretKeyPacket {}) = k -- TODO
1021
1022 L.writeFile (output cmd) (encode $ Message sec')
1023
1024 {-
1025 let wk = grip >>= find_key fingerprint (Message sec)
1026 case wk of
1027 Nothing -> error "No working key?"
1028 Just wk -> do
1029 putStrLn $ "wk = " ++ fingerprint wk
1030 -}
1031 -}
1032
1033 doCmd cmd@(CatPub {}) = do
1034 let spec:files = catpub_args cmd
1035 putStrLn $ "spec = " ++show spec
1036 putStrLn $ "files = " ++ show files
1037 return ()
1038
1039 doCmd cmd@(Add {}) = do
1040 ( homedir -- e3ozbhvej4jvlu43.onion/gpg/gnupghome
1041 , sec -- e3ozbhvej4jvlu43.onion/gpg/gnupghome/secring.gpg
1042 , grip -- Just "AD1CA892FCF4ED9829C762269BDEA5B4D5643321"
1043 ) <- getPGPEnviron cmd
1044 pw <- getPassphrase cmd
1045
1046 flip (maybe (error "No working key?")) grip $ \grip -> do
1047
1048 let (pre, wk:subs) = seek_key grip sec
1049 wkun = if symmetric_algorithm wk == Unencrypted
1050 then Just wk
1051 else do
1052 k <- decryptSecretKey pw wk
1053 guard (symmetric_algorithm k == Unencrypted)
1054 return k
1055
1056 flip (maybe (error "Bad passphrase?")) wkun$ \wkun -> do
1057
1058 let (uids,subkeys) = break isSubkey subs
1059 isSubkey p = isKey p && is_subkey p
1060
1061 let parseKeySpec hint spec = case break (==':') spec of
1062 (fmt,_:file) -> (fmt,file)
1063 (file,"") -> (guessKeyFormat hint (key_usage cmd), file)
1064 (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd
1065 -- (pubfmt,pubfile) = parseKeySpec 'P' $ pubkey cmd
1066 Message parsedkey <- readKeyFromFile False secfmt secfile
1067 -- -- Message pubkey <- readKeyFromFile True pubfmt pubfile
1068
1069 -- putStrLn $ "parsedkey = " ++ show (head parsedkey)
1070 -- putStrLn $ "----------"
1071
1072 {-
1073 let seckeys = filter isSecretKey sec
1074 isSecretKey (SecretKeyPacket {}) = True
1075 isSecretKey _ = False
1076 algos = map symmetric_algorithm seckeys
1077 putStrLn $ show $ symmetric_algorithm wk
1078 putStrLn $ show $ s2k wk
1079 putStrLn $ show $ s2k_useage wk
1080 putStrLn $ PP.ppShow sec
1081 let -- e = encryptSecretKey wk pw (head seckey)
1082 e = head seckey
1083 d = if symmetric_algorithm e /= Unencrypted
1084 then maybeToList $ decryptSecretKey pw e
1085 else [e]
1086 putStrLn $ "e = " ++ show (e)
1087 -}
1088 -- putStrLn $ "wkun = " ++ show wkun
1089 -- putStrLn $ "head subkeys = " ++ show (head subkeys)
1090
1091 g <- newGenIO
1092 timestamp <- now
1093
1094 let
1095 new_sig = fst $ sign (Message [wkun])
1096 (SubkeySignature wk
1097 (head parsedkey)
1098 (sigpackets 0x18
1099 hashed0
1100 ( IssuerPacket (fingerprint wk)
1101 : map EmbeddedSignaturePacket (signatures_over back_sig))))
1102 SHA1
1103 grip
1104 timestamp
1105 (g::SystemRandom)
1106 sigpackets typ hashed unhashed = return $
1107 signaturePacket
1108 4 -- version
1109 typ -- 0x18 subkey binding sig, or 0x19 back-signature
1110 RSA
1111 SHA1
1112 hashed
1113 unhashed
1114 0 -- Word16 -- Left 16 bits of the signed hash value
1115 [] -- [MPI]
1116
1117 hashed0 =
1118 [ KeyFlagsPacket
1119 { certify_keys = False
1120 , sign_data = False
1121 , encrypt_communication = False
1122 , encrypt_storage = False
1123 , split_key = False
1124 , authentication = True
1125 , group_key = False }
1126 , NotationDataPacket
1127 { human_readable = True
1128 , notation_name = "usage@"
1129 , notation_value = key_usage cmd
1130 }
1131 ]
1132
1133 subgrip = fingerprint (head parsedkey)
1134
1135 back_sig = fst $ sign (Message parsedkey)
1136 (SubkeySignature wk
1137 (head parsedkey)
1138 (sigpackets 0x19
1139 hashed0
1140 [IssuerPacket subgrip]))
1141 SHA1
1142 subgrip
1143 timestamp
1144 (g::SystemRandom)
1145
1146 let sec' = pre ++ [wk] ++ uids ++ parsedkey ++ signatures_over new_sig ++ subkeys
1147 putStrLn $ listKeys sec'
1148
1149 L.writeFile (output cmd) (encode (Message sec'))
1150
1151 {-
1152 let backsigs = do
1153 sig <- signatures (Message sec')
1154 sigover <- signatures_over sig
1155 subp <- unhashed_subpackets sigover
1156 -- guard (isEmbeddedSignature subp)
1157 subp <- maybeToList (backsig subp)
1158 over <- signatures (Message (filter isKey sec ++ [subp]))
1159 return over
1160
1161 -- putStrLn $ PP.ppShow backsigs
1162 -}
1163
1164 return ()
1165
1166 doCmd cmd@(PemFP {}) = do
1167 let parseKeySpec hint spec = case break (==':') spec of
1168 (fmt,_:file) -> (fmt,file)
1169 (file,"") -> (guessKeyFormat hint ("ssh-host"), file)
1170 (secfmt,secfile) = parseKeySpec 'S' $ seckey cmd
1171 Message seckey <- readKeyFromFile False secfmt secfile
1172 -- Message pubkey <- readKeyFromFile True pubfmt pubfile
1173 putStrLn $ fingerprint (head seckey)
1174
1175
1176
1177
1178groupBindings pub =
1179 let (sigs,bindings) = getBindings pub
1180 bindings' = accBindings bindings
1181 code (c,(m,s),_,_,_) = (fingerprint_material m,-c)
1182 ownerkey (_,(a,_),_,_,_) = a
1183 sameMaster (ownerkey->a) (ownerkey->b) = fingerprint_material a==fingerprint_material b
1184 -- matchgrip ((code,(top,sub), kind, hashed,claimants):_) | fpmatch grip top = True
1185 -- matchgrip _ = False
1186 gs = {- filter matchgrip $ -} groupBy sameMaster (sortBy (comparing code) bindings')
1187 in gs
1188
1189
1190seek_key :: String -> [Packet] -> ([Packet],[Packet])
1191seek_key grip sec = (pre, subs)
1192 where
1193 (pre,subs) = break pred sec
1194 pred p@(SecretKeyPacket {}) = matchpr grip p == grip
1195 pred _ = False
generated by cgit v1.2.3 (git 2.39.1) at 2024-07-01 09:01:52 +0000