diff options
-rw-r--r-- | ControlMaybe.hs | 8 | ||||
-rw-r--r-- | KeyRing.hs | 39 |
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(..)) |
5 | import Control.Exception as Exception (IOException(..),catch) | 5 | import Control.Exception as Exception (IOException(..),catch) |
6 | 6 | ||
7 | |||
8 | withJust :: Monad m => Maybe x -> (x -> m ()) -> m () | ||
7 | withJust (Just x) f = f x | 9 | withJust (Just x) f = f x |
8 | withJust Nothing f = return () | 10 | withJust Nothing f = return () |
9 | 11 | ||
12 | whenJust :: Monad m => m (Maybe x) -> (x -> m ()) -> m () | ||
10 | whenJust acn f = do | 13 | whenJust 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) | |||
18 | catchIO :: IO a -> (IOException -> IO a) -> IO a | 21 | catchIO :: IO a -> (IOException -> IO a) -> IO a |
19 | catchIO body handler = Exception.catch body handler | 22 | catchIO body handler = Exception.catch body handler |
20 | 23 | ||
24 | handleIO_ :: IO a -> IO a -> IO a | ||
21 | handleIO_ = flip catchIO_ | 25 | handleIO_ = flip catchIO_ |
22 | handleIO = flip catchIO | ||
23 | 26 | ||
27 | |||
28 | handleIO :: (IOException -> IO a) -> IO a -> IO a | ||
29 | handleIO = flip catchIO | ||
@@ -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 #-} | ||
7 | module KeyRing | 9 | module 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 |
117 | secp256k1_id :: Integer | ||
115 | secp256k1_id = 0x2b8104000a | 118 | secp256k1_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 | ||
143 | home :: HomeDir | ||
140 | home = HomeDir | 144 | home = 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 | ||
178 | isMutable :: RefType -> Bool | ||
174 | isMutable (MutableRef {}) = True | 179 | isMutable (MutableRef {}) = True |
175 | isMutable _ = False | 180 | isMutable _ = False |
176 | 181 | ||
182 | isring :: FileType -> Bool | ||
177 | isring (KeyRingFile {}) = True | 183 | isring (KeyRingFile {}) = True |
178 | isring _ = False | 184 | isring _ = False |
179 | 185 | ||
186 | pwfile :: FileType -> Maybe PassWordFile | ||
180 | pwfile (KeyRingFile f) = f | 187 | pwfile (KeyRingFile f) = f |
181 | pwfile _ = Nothing | 188 | pwfile _ = Nothing |
182 | 189 | ||
190 | iswallet :: FileType -> Bool | ||
183 | iswallet (WalletFile {}) = True | 191 | iswallet (WalletFile {}) = True |
184 | iswallet _ = False | 192 | iswallet _ = False |
185 | 193 | ||
194 | initializer :: RefType -> Maybe Initializer | ||
186 | initializer (MutableRef x) = x | 195 | initializer (MutableRef x) = x |
187 | initializer _ = Nothing | 196 | initializer _ = Nothing |
188 | 197 | ||
198 | getUsage :: | ||
199 | forall (m :: * -> *). MonadPlus m => FileType -> m UsageTag | ||
189 | getUsage (PEMFile usage) = return usage | 200 | getUsage (PEMFile usage) = return usage |
190 | getUsage _ = mzero | 201 | getUsage _ = mzero |
191 | 202 | ||
@@ -230,6 +241,8 @@ resolveInputFile secring pubring = resolve | |||
230 | resolve _ = [] | 241 | resolve _ = [] |
231 | 242 | ||
232 | 243 | ||
244 | filesToLock :: | ||
245 | KeyRingOperation -> FilePath -> FilePath -> [FilePath] | ||
233 | filesToLock k secring pubring = do | 246 | filesToLock 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 | |||
243 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) | 256 | data RSAPublicKey = RSAKey MPI MPI deriving (Eq,Show) |
244 | data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show | 257 | data PKCS8_RSAPublicKey = RSAKey8 MPI MPI deriving Show |
245 | 258 | ||
259 | pkcs8 :: RSAPublicKey -> PKCS8_RSAPublicKey | ||
246 | pkcs8 (RSAKey n e) = RSAKey8 n e | 260 | pkcs8 (RSAKey n e) = RSAKey8 n e |
247 | 261 | ||
248 | instance ASN1Object RSAPublicKey where | 262 | instance ASN1Object RSAPublicKey where |
@@ -386,12 +400,15 @@ data KikiResult a = KikiResult | |||
386 | , kikiReport :: [ (FilePath, KikiReportAction) ] | 400 | , kikiReport :: [ (FilePath, KikiReportAction) ] |
387 | } | 401 | } |
388 | 402 | ||
403 | keyPacket :: KeyData -> Packet | ||
389 | keyPacket (KeyData k _ _ _) = packet k | 404 | keyPacket (KeyData k _ _ _) = packet k |
390 | 405 | ||
391 | -- subkeyPacket (SubKey k _ ) = packet k | 406 | -- subkeyPacket (SubKey k _ ) = packet k |
407 | subkeyMappedPacket :: SubKey -> MappedPacket | ||
392 | subkeyMappedPacket (SubKey k _ ) = k | 408 | subkeyMappedPacket (SubKey k _ ) = k |
393 | 409 | ||
394 | 410 | ||
411 | usage :: SignatureSubpacket -> Maybe String | ||
395 | usage (NotationDataPacket | 412 | usage (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 | ||
461 | keyflags :: SignatureSubpacket -> Maybe PGPKeyFlags | ||
444 | keyflags flgs@(KeyFlagsPacket {}) = | 462 | keyflags 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 | |||
497 | usageString :: PGPKeyFlags -> String | ||
477 | usageString flgs = | 498 | usageString 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. |
522 | matchpr :: String -> Packet -> String | ||
501 | matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp | 523 | matchpr fp k = reverse $ zipWith const (reverse (fingerprint k)) fp |
502 | 524 | ||
525 | keyFlags :: t -> [Packet] -> [SignatureSubpacket] | ||
503 | keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) | 526 | keyFlags wkun uids = keyFlags0 wkun (filter isSignaturePacket uids) |
527 | |||
528 | keyFlags0 :: t -> [Packet] -> [SignatureSubpacket] | ||
504 | keyFlags0 wkun uidsigs = concat | 529 | keyFlags0 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 | ||
587 | matchSpec :: KeySpec -> (t, KeyData) -> Bool | ||
562 | matchSpec (KeyGrip grip) (_,KeyData p _ _ _) | 588 | matchSpec (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 | ||
617 | parseUID :: String -> UserIDRecord | ||
591 | parseUID str = UserIDRecord { | 618 | parseUID 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 | ||
778 | importPEMKey :: | ||
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)])) | ||
751 | importPEMKey doDecrypt db' tup = do | 784 | importPEMKey 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 | ||
973 | torhash :: Packet -> String | ||
940 | torhash key = maybe "" id $ derToBase32 <$> derRSA key | 974 | torhash key = maybe "" id $ derToBase32 <$> derRSA key |
941 | 975 | ||
976 | derToBase32 :: ByteString -> String | ||
942 | derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy | 977 | derToBase32 = map toLower . Base32.encode . S.unpack . SHA1.hashlazy |
943 | 978 | ||
979 | derRSA :: Packet -> Maybe ByteString | ||
944 | derRSA rsa = do | 980 | derRSA 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 | ||
990 | readKeyFromFile :: Bool -> String -> FilePath -> IO Message | ||
954 | readKeyFromFile False "PEM" fname = do | 991 | readKeyFromFile 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 | } |
992 | readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) | 1029 | readKeyFromFile is_public fmt filename = error ("unimplemented key type: "++fmt) |
993 | 1030 | ||
1031 | extractPEM :: ByteString -> ByteString -> ByteString | ||
994 | extractPEM typ pem = dta | 1032 | extractPEM 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 | ||
1147 | isCryptoCoinKey :: Packet -> Bool | ||
1109 | isCryptoCoinKey p = | 1148 | isCryptoCoinKey p = |
1110 | and [ isKey p | 1149 | and [ isKey p |
1111 | , key_algorithm p == ECDSA | 1150 | , key_algorithm p == ECDSA |