summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--ControlMaybe.hs8
-rw-r--r--KeyRing.hs39
2 files changed, 46 insertions, 1 deletions
diff --git a/ControlMaybe.hs b/ControlMaybe.hs
index 69a38f7..659dab7 100644
--- a/ControlMaybe.hs
+++ b/ControlMaybe.hs
@@ -4,9 +4,12 @@ module ControlMaybe where
4-- import GHC.IO.Exception (IOException(..)) 4-- import GHC.IO.Exception (IOException(..))
5import Control.Exception as Exception (IOException(..),catch) 5import Control.Exception as Exception (IOException(..),catch)
6 6
7
8withJust :: Monad m => Maybe x -> (x -> m ()) -> m ()
7withJust (Just x) f = f x 9withJust (Just x) f = f x
8withJust Nothing f = return () 10withJust Nothing f = return ()
9 11
12whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m ()
10whenJust acn f = do 13whenJust acn f = do
11 x <- acn 14 x <- acn
12 withJust x f 15 withJust x f
@@ -18,6 +21,9 @@ catchIO_ a h = Exception.catch a (\(_ :: IOException) -> h)
18catchIO :: IO a -> (IOException -> IO a) -> IO a 21catchIO :: IO a -> (IOException -> IO a) -> IO a
19catchIO body handler = Exception.catch body handler 22catchIO body handler = Exception.catch body handler
20 23
24handleIO_ :: IO a -> IO a -> IO a
21handleIO_ = flip catchIO_ 25handleIO_ = flip catchIO_
22handleIO = flip catchIO
23 26
27
28handleIO :: (IOException -> IO a) -> IO a -> IO a
29handleIO = flip catchIO
diff --git a/KeyRing.hs b/KeyRing.hs
index 229348f..e57861f 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -4,6 +4,8 @@
4{-# LANGUAGE OverloadedStrings #-} 4{-# LANGUAGE OverloadedStrings #-}
5{-# LANGUAGE DeriveFunctor #-} 5{-# LANGUAGE DeriveFunctor #-}
6{-# LANGUAGE DoAndIfThenElse #-} 6{-# LANGUAGE DoAndIfThenElse #-}
7{-# LANGUAGE RankNTypes #-}
8{-# LANGUAGE KindSignatures #-}
7module KeyRing 9module KeyRing
8 ( InputFile(..) 10 ( InputFile(..)
9 , backsig 11 , backsig
@@ -112,6 +114,7 @@ import ProcessUtils (systemEnv, ExitCode(ExitFailure, ExitSuccess) )
112 114
113-- DER-encoded elliptic curve ids 115-- DER-encoded elliptic curve ids
114-- nistp256_id = 0x2a8648ce3d030107 116-- nistp256_id = 0x2a8648ce3d030107
117secp256k1_id :: Integer
115secp256k1_id = 0x2b8104000a 118secp256k1_id = 0x2b8104000a
116-- "\x2a\x86\x48\xce\x3d\x03\x01\x07" 119-- "\x2a\x86\x48\xce\x3d\x03\x01\x07"
117{- OID Curve description Curve name 120{- OID Curve description Curve name
@@ -137,6 +140,7 @@ data HomeDir =
137 , optfile_alts :: [String] 140 , optfile_alts :: [String]
138 } 141 }
139 142
143home :: HomeDir
140home = HomeDir 144home = HomeDir
141 { homevar = "GNUPGHOME" 145 { homevar = "GNUPGHOME"
142 , appdir = ".gnupg" 146 , appdir = ".gnupg"
@@ -171,21 +175,28 @@ data RefType = ConstRef
171 -- Initializer is a shell command that creates 175 -- Initializer is a shell command that creates
172 -- the file; eg, ssh-keygen 176 -- the file; eg, ssh-keygen
173 177
178isMutable :: RefType -> Bool
174isMutable (MutableRef {}) = True 179isMutable (MutableRef {}) = True
175isMutable _ = False 180isMutable _ = False
176 181
182isring :: FileType -> Bool
177isring (KeyRingFile {}) = True 183isring (KeyRingFile {}) = True
178isring _ = False 184isring _ = False
179 185
186pwfile :: FileType -> Maybe PassWordFile
180pwfile (KeyRingFile f) = f 187pwfile (KeyRingFile f) = f
181pwfile _ = Nothing 188pwfile _ = Nothing
182 189
190iswallet :: FileType -> Bool
183iswallet (WalletFile {}) = True 191iswallet (WalletFile {}) = True
184iswallet _ = False 192iswallet _ = False
185 193
194initializer :: RefType -> Maybe Initializer
186initializer (MutableRef x) = x 195initializer (MutableRef x) = x
187initializer _ = Nothing 196initializer _ = Nothing
188 197
198getUsage ::
199 forall (m :: * -> *). MonadPlus m => FileType -> m UsageTag
189getUsage (PEMFile usage) = return usage 200getUsage (PEMFile usage) = return usage
190getUsage _ = mzero 201getUsage _ = mzero
191 202
@@ -230,6 +241,8 @@ resolveInputFile secring pubring = resolve
230 resolve _ = [] 241 resolve _ = []
231 242
232 243
244filesToLock ::
245 KeyRingOperation -> FilePath -> FilePath -> [FilePath]
233filesToLock k secring pubring = do 246filesToLock k secring pubring = do
234 (f,(rtyp,ftyp)) <- Map.toList (kFiles k) 247 (f,(rtyp,ftyp)) <- Map.toList (kFiles k)
235 case rtyp of 248 case rtyp of
@@ -243,6 +256,7 @@ filesToLock k secring pubring = do
243data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) 256data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show)
244data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show 257data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show
245 258
259pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey
246pkcs8 (RSAKey n e) = RSAKey8 n e 260pkcs8 (RSAKey n e) = RSAKey8 n e
247 261
248instance ASN1Object RSAPublicKey where 262instance ASN1Object RSAPublicKey where
@@ -386,12 +400,15 @@ data KikiResult a = KikiResult
386 , kikiReport :: [ (FilePath, KikiReportAction) ] 400 , kikiReport :: [ (FilePath, KikiReportAction) ]
387 } 401 }
388 402
403keyPacket :: KeyData -> Packet
389keyPacket (KeyData k _ _ _) = packet k 404keyPacket (KeyData k _ _ _) = packet k
390 405
391-- subkeyPacket (SubKey k _ ) = packet k 406-- subkeyPacket (SubKey k _ ) = packet k
407subkeyMappedPacket :: SubKey -> MappedPacket
392subkeyMappedPacket (SubKey k _ ) = k 408subkeyMappedPacket (SubKey k _ ) = k
393 409
394 410
411usage :: SignatureSubpacket -> Maybe String
395usage (NotationDataPacket 412usage (NotationDataPacket
396 { human_readable = True 413 { human_readable = True
397 , notation_name = "usage@" 414 , notation_name = "usage@"
@@ -441,6 +458,7 @@ makeInducerSig topk wkun uid extras
441 echar c = [c] 458 echar c = [c]
442 459
443 460
461keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags
444keyflags flgs@(KeyFlagsPacket {}) = 462keyflags flgs@(KeyFlagsPacket {}) =
445 Just . toEnum $ 463 Just . toEnum $
446 ( bit 0x1 certify_keys 464 ( bit 0x1 certify_keys
@@ -474,6 +492,9 @@ data PGPKeyFlags =
474 | SignEncrypt 492 | SignEncrypt
475 | VouchSignEncrypt 493 | VouchSignEncrypt
476 deriving (Eq,Show,Read,Enum) 494 deriving (Eq,Show,Read,Enum)
495
496
497usageString :: PGPKeyFlags -> String
477usageString flgs = 498usageString flgs =
478 case flgs of 499 case flgs of
479 Special -> "special" 500 Special -> "special"
@@ -498,9 +519,13 @@ usageString flgs =
498 519
499-- matchpr computes the fingerprint of the given key truncated to 520-- matchpr computes the fingerprint of the given key truncated to
500-- be the same lenght as the given fingerprint for comparison. 521-- be the same lenght as the given fingerprint for comparison.
522matchpr :: String -> Packet -> String
501matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp 523matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp
502 524
525keyFlags :: t -> [Packet] -> [SignatureSubpacket]
503keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) 526keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids)
527
528keyFlags0 :: t -> [Packet] -> [SignatureSubpacket]
504keyFlags0 wkun uidsigs = concat 529keyFlags0 wkun uidsigs = concat
505 [ keyflags 530 [ keyflags
506 , preferredsym 531 , preferredsym
@@ -559,6 +584,7 @@ keyFlags0 wkun uidsigs = concat
559 isfeatures _ = False 584 isfeatures _ = False
560 585
561 586
587matchSpec :: KeySpec -> (t, KeyData) -> Bool
562matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 588matchSpec (KeyGrip grip) (_,KeyData p _ _ _)
563 | matchpr grip (packet p)==grip = True 589 | matchpr grip (packet p)==grip = True
564 | otherwise = False 590 | otherwise = False
@@ -588,6 +614,7 @@ data UserIDRecord = UserIDRecord {
588} 614}
589 deriving Show 615 deriving Show
590 616
617parseUID :: String -> UserIDRecord
591parseUID str = UserIDRecord { 618parseUID str = UserIDRecord {
592 uid_full = str, 619 uid_full = str,
593 uid_realname = realname, 620 uid_realname = realname,
@@ -748,6 +775,12 @@ cachedContents secring pubring fd = do
748 let fname = resolveInputFile secring pubring inp 775 let fname = resolveInputFile secring pubring inp
749 fmap S.concat $ mapM S.readFile fname 776 fmap S.concat $ mapM S.readFile fname
750 777
778importPEMKey ::
779 (MappedPacket -> IO (KikiCondition Packet))
780 -> KikiCondition
781 (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)])
782 -> ([Char], Maybe [Char], [KeyKey], t)
783 -> IO (KikiCondition (Map.Map KeyKey KeyData, [(FilePath, KikiReportAction)]))
751importPEMKey doDecrypt db' tup = do 784importPEMKey doDecrypt db' tup = do
752 try db' $ \(db',report0) -> do 785 try db' $ \(db',report0) -> do
753 r <- doImport doDecrypt 786 r <- doImport doDecrypt
@@ -937,10 +970,13 @@ buildKeyDB doDecrypt secring pubring grip0 keyring = do
937 970
938 return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs ) 971 return $ KikiSuccess ( (db, grip, mwk, hs), reportWallets ++ reportPEMs )
939 972
973torhash :: Packet -> String
940torhash key = maybe "" id $ derToBase32 <$> derRSA key 974torhash key = maybe "" id $ derToBase32 <$> derRSA key
941 975
976derToBase32 :: ByteString -> String
942derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy 977derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy
943 978
979derRSA :: Packet -> Maybe ByteString
944derRSA rsa = do 980derRSA rsa = do
945 k <- rsaKeyFromPacket rsa 981 k <- rsaKeyFromPacket rsa
946 return $ encodeASN1 DER (toASN1 k []) 982 return $ encodeASN1 DER (toASN1 k [])
@@ -951,6 +987,7 @@ try x body =
951 Left e -> return e 987 Left e -> return e
952 Right x -> body x 988 Right x -> body x
953 989
990readKeyFromFile :: Bool -> String -> FilePath -> IO Message
954readKeyFromFile False "PEM" fname = do 991readKeyFromFile False "PEM" fname = do
955 -- warn $ fname ++ ": reading ..." 992 -- warn $ fname ++ ": reading ..."
956 -- Note: The key's timestamp is included in it's fingerprint. 993 -- Note: The key's timestamp is included in it's fingerprint.
@@ -991,6 +1028,7 @@ readKeyFromFile False "PEM" fname = do
991 } 1028 }
992readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) 1029readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt)
993 1030
1031extractPEM :: ByteString -> ByteString -> ByteString
994extractPEM typ pem = dta 1032extractPEM typ pem = dta
995 where 1033 where
996 dta = case ys of 1034 dta = case ys of
@@ -1106,6 +1144,7 @@ doImportG doDecrypt db m0 tag fname key = do
1106 , report ) 1144 , report )
1107 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag 1145 Just (False,sig) -> doInsert (Just sig) db -- We have a sig, but is missing usage@ tag
1108 1146
1147isCryptoCoinKey :: Packet -> Bool
1109isCryptoCoinKey p = 1148isCryptoCoinKey p =
1110 and [ isKey p 1149 and [ isKey p
1111 , key_algorithm p == ECDSA 1150 , key_algorithm p == ECDSA