summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
-rw-r--r--KeyRing.hs55
-rw-r--r--PEM.hs5
-rw-r--r--kiki.hs24
3 files changed, 70 insertions, 14 deletions
diff --git a/KeyRing.hs b/KeyRing.hs
index 68ec843..8864df4 100644
--- a/KeyRing.hs
+++ b/KeyRing.hs
@@ -84,6 +84,8 @@ module KeyRing
84 , parseCertBlob 84 , parseCertBlob
85 , packetFromPublicRSAKey 85 , packetFromPublicRSAKey
86 , decodeBlob 86 , decodeBlob
87 , selectPublicKeyAndSigs
88 , x509cert
87 ) where 89 ) where
88 90
89import System.Environment 91import System.Environment
@@ -643,6 +645,14 @@ usage (NotationDataPacket
643 }) = Just u 645 }) = Just u
644usage _ = Nothing 646usage _ = Nothing
645 647
648x509cert :: SignatureSubpacket -> Maybe Char8.ByteString
649x509cert (NotationDataPacket
650 { human_readable = False
651 , notation_name = "x509cert@"
652 , notation_value = u
653 }) = Just (Char8.pack u)
654x509cert _ = Nothing
655
646makeInducerSig 656makeInducerSig
647 :: Packet 657 :: Packet
648 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver 658 -> Packet -> Packet -> [SignatureSubpacket] -> SignatureOver
@@ -811,12 +821,12 @@ keyFlags0 wkun uidsigs = concat
811 isfeatures _ = False 821 isfeatures _ = False
812 822
813 823
814matchSpec :: KeySpec -> (t, KeyData) -> Bool 824matchSpec :: KeySpec -> KeyData -> Bool
815matchSpec (KeyGrip grip) (_,KeyData p _ _ _) 825matchSpec (KeyGrip grip) (KeyData p _ _ _)
816 | matchpr grip (packet p)==grip = True 826 | matchpr grip (packet p)==grip = True
817 | otherwise = False 827 | otherwise = False
818 828
819matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps 829matchSpec (KeyTag key tag) (KeyData _ sigs _ _) = not . null $ filter match ps
820 where 830 where
821 ps = map (packet .fst) sigs 831 ps = map (packet .fst) sigs
822 match p = isSignaturePacket p 832 match p = isSignaturePacket p
@@ -828,7 +838,7 @@ matchSpec (KeyTag key tag) (_,KeyData _ sigs _ _) = not . null $ filter match ps
828 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p) 838 has_tag tag p = tag `elem` mapMaybe usage (hashed_subpackets p)
829 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p)) 839 || tag `elem` map usageString (mapMaybe keyflags (hashed_subpackets p))
830 840
831matchSpec (KeyUidMatch pat) (_,KeyData _ _ uids _) = not $ null us 841matchSpec (KeyUidMatch pat) (KeyData _ _ uids _) = not $ null us
832 where 842 where
833 us = filter (isInfixOf pat) $ Map.keys uids 843 us = filter (isInfixOf pat) $ Map.keys uids
834 844
@@ -895,6 +905,7 @@ parseSpec grip spec = (topspec,subspec)
895 "fp" | top=="" -> Nothing 905 "fp" | top=="" -> Nothing
896 "" | top=="" && is40digitHex sub -> Nothing 906 "" | top=="" && is40digitHex sub -> Nothing
897 "" -> listToMaybe sub >> Just sub 907 "" -> listToMaybe sub >> Just sub
908 -- "fp" -> ??? TODO: non-ehaustive patterns in case: fp:7/fp:
898 909
899 is40digitHex xs = ys == xs && length ys==40 910 is40digitHex xs = ys == xs && length ys==40
900 where 911 where
@@ -913,7 +924,7 @@ parseSpec grip spec = (topspec,subspec)
913 924
914 925
915filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)] 926filterMatches :: KeySpec -> [(KeyKey,KeyData)] -> [(KeyKey,KeyData)]
916filterMatches spec ks = filter (matchSpec spec) ks 927filterMatches spec ks = filter (matchSpec spec . snd) ks
917 928
918filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData 929filterNewSubs :: FilePath -> (KeySpec,Maybe String) -> KeyData -> KeyData
919filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs' 930filterNewSubs fname spec (KeyData p sigs uids subs) = KeyData p sigs uids subs'
@@ -948,6 +959,31 @@ selectSecretKey (spec,mtag) db = selectKey0 False (spec,mtag) db
948selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 959selectPublicKey :: (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
949selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db 960selectPublicKey (spec,mtag) db = selectKey0 True (spec,mtag) db
950 961
962selectPublicKeyAndSigs :: (KeySpec,Maybe String) -> KeyDB -> [(Packet,[Packet])]
963selectPublicKeyAndSigs (spec,mtag) db =
964 case mtag of
965 Nothing -> concat $ Map.elems $ fmap (findbyspec spec) db
966 Just tag -> Map.elems (Map.filter (matchSpec spec) db) >>= findsubs tag
967 where
968 topresult kd = (keyPacket kd, map (packet .fst) $ keySigAndTrusts kd)
969
970 findbyspec (KeyGrip g) kd = do
971 filter ismatch $
972 topresult kd
973 : map (\(SubKey sub sigs)-> (packet sub, map (packet . fst) sigs))
974 (Map.elems $ keySubKeys kd)
975 where
976 ismatch (p,sigs) = matchpr g p ==g
977 findbyspec spec kd = if matchSpec spec kd then [topresult kd] else []
978
979 findsubs tag (KeyData topk _ _ subs) = Map.elems subs >>= gettag
980 where
981 gettag (SubKey sub sigs) = do
982 let (_,mb,_) = findTag [mkUsage tag] (packet topk) (packet sub) sigs
983 (hastag,_) <- maybeToList mb
984 guard hastag
985 return $ (packet sub, map (packet . fst) sigs)
986
951selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet 987selectKey0 :: Bool -> (KeySpec,Maybe String) -> KeyDB -> Maybe Packet
952selectKey0 wantPublic (spec,mtag) db = do 988selectKey0 wantPublic (spec,mtag) db = do
953 let Message ps = flattenKeys wantPublic db 989 let Message ps = flattenKeys wantPublic db
@@ -1395,6 +1431,7 @@ data ParsedCert = ParsedCert
1395 } 1431 }
1396 deriving (Show,Eq) 1432 deriving (Show,Eq)
1397data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert 1433data SecretPEMData = PEMPacket Packet | PEMCertificate ParsedCert
1434 deriving (Show,Eq)
1398 1435
1399spemPacket (PEMPacket p) = Just p 1436spemPacket (PEMPacket p) = Just p
1400spemPacket _ = Nothing 1437spemPacket _ = Nothing
@@ -1465,7 +1502,7 @@ readSecretPEMFile fname = do
1465 let dta = catMaybes $ scanAndParse (pkcs1 <> cert) $ Char8.lines input 1502 let dta = catMaybes $ scanAndParse (pkcs1 <> cert) $ Char8.lines input
1466 pkcs1 = fmap (parseRSAPrivateKey . pemBlob) 1503 pkcs1 = fmap (parseRSAPrivateKey . pemBlob)
1467 $ pemParser $ Just "RSA PRIVATE KEY" 1504 $ pemParser $ Just "RSA PRIVATE KEY"
1468 cert = fmap (fmap (PEMPacket . pcertKey) . parseCertBlob False . pemBlob) 1505 cert = fmap (fmap PEMCertificate . parseCertBlob False . pemBlob)
1469 $ pemParser $ Just "CERTIFICATE" 1506 $ pemParser $ Just "CERTIFICATE"
1470 parseRSAPrivateKey dta = do 1507 parseRSAPrivateKey dta = do
1471 let e = decodeASN1 DER dta 1508 let e = decodeASN1 DER dta
@@ -1729,9 +1766,9 @@ isauth rt keydata = dont_have keydata && maybe False (`has_good_sig` keydata) wk
1729 1766
1730 workingKey grip use_db = listToMaybe $ do 1767 workingKey grip use_db = listToMaybe $ do
1731 fp <- maybeToList grip 1768 fp <- maybeToList grip
1732 elm <- Map.toList use_db 1769 elm <- Map.elems use_db
1733 guard $ matchSpec (KeyGrip fp) elm 1770 guard $ matchSpec (KeyGrip fp) elm
1734 return $ keyPacket (snd elm) 1771 return $ keyPacket elm
1735 1772
1736writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message 1773writeRingKeys :: KeyRingOperation -> KeyRingRuntime -> Map.Map InputFile Message
1737 {- 1774 {-
@@ -2583,7 +2620,7 @@ findTag tag topk subkey subsigs = (xs',minsig,ys')
2583 $ sig 2620 $ sig
2584 listToMaybe $ 2621 listToMaybe $
2585 map (signature_time . verify (Message [topk])) 2622 map (signature_time . verify (Message [topk]))
2586 (signatures $ Message [wk,subkey,sig]))) 2623 (signatures $ Message [topk,subkey,sig])))
2587 subsigs 2624 subsigs
2588 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs 2625 (xs,ys) = splitAtMinBy (comparing (Down . snd)) vs
2589 xs' = map fst xs 2626 xs' = map fst xs
diff --git a/PEM.hs b/PEM.hs
index e6c8259..7b27e04 100644
--- a/PEM.hs
+++ b/PEM.hs
@@ -1,7 +1,6 @@
1{-# LANGUAGE OverloadedStrings #-} 1{-# LANGUAGE OverloadedStrings #-}
2module PEM where 2module PEM where
3 3
4import Data.Maybe
5import Data.Monoid 4import Data.Monoid
6import qualified Data.ByteString.Lazy as LW 5import qualified Data.ByteString.Lazy as LW
7import qualified Data.ByteString.Lazy.Char8 as L 6import qualified Data.ByteString.Lazy.Char8 as L
@@ -30,5 +29,5 @@ pemParser mtyp = ScanningParser (maybe fndany fndtyp mtyp) pbdy
30 (ys,rs) = span (/="-----END " <> typ <> "-----") xs 29 (ys,rs) = span (/="-----END " <> typ <> "-----") xs
31 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta) 30 mblob = PEMBlob typ <$> LW.pack <$> Base64.decode (L.unpack dta)
32 dta = case ys of 31 dta = case ys of
33 _:dta_lines -> L.concat dta_lines 32 [] -> ""
34 [] -> "" 33 dta_lines -> L.concat dta_lines
diff --git a/kiki.hs b/kiki.hs
index 063c42c..f1568aa 100644
--- a/kiki.hs
+++ b/kiki.hs
@@ -39,7 +39,7 @@ import Data.Binary.Put (putWord32be,runPut,putByteString)
39import Data.X509 -- (Certificate,SignedCertificate, decodeSignedObject, decodeSignedCertificate ) 39import Data.X509 -- (Certificate,SignedCertificate, decodeSignedObject, decodeSignedCertificate )
40import Crypto.PubKey.RSA as RSA 40import Crypto.PubKey.RSA as RSA
41import qualified Codec.Compression.GZip as GZip 41import qualified Codec.Compression.GZip as GZip
42import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds ) 42import Data.Time.Clock.POSIX ( utcTimeToPOSIXSeconds, posixSecondsToUTCTime )
43import Data.Time.Clock ( UTCTime ) 43import Data.Time.Clock ( UTCTime )
44import Data.Monoid ( (<>) ) 44import Data.Monoid ( (<>) )
45 45
@@ -343,7 +343,26 @@ show_torhash pubkey _ = do
343 keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs 343 keys = catMaybes $ scanAndParse (pkcs1 <> pkcs8 <> cert) $ Char8.lines bs
344 mapM_ (putStrLn . addy . torhash) keys 344 mapM_ (putStrLn . addy . torhash) keys
345 345
346show_cert keyspec wkgrip db = do
347 let s = parseSpec wkgrip keyspec
348 putStrLn $ "parsed spec: "++show s
349 case selectPublicKeyAndSigs s db of
350 [] -> void $ warn (keyspec ++ ": not found")
351 [(k,sigs)] -> do
352 {-
353 let rsa = pkcs8 . fromJust $ rsaKeyFromPacket k
354 der = encodeASN1 DER (toASN1 rsa [])
355 qq = Base64.encode (L.unpack der)
356 putStrLn $ writePEM "PUBLIC KEY (TODO: CERT)" qq -- ("TODO "++show keyspec)
357 -}
358 let cs = mapMaybe x509cert $ (sigs >>= hashed_subpackets)
359 ds = map decodeBlob $ map (ParsedCert k (posixSecondsToUTCTime $ fromIntegral $ timestamp k)) cs
360 qqs = map (Base64.encode . L.unpack) ds
361 pems = map (writePEM "CERTIFICATE") qqs
362 forM_ pems putStrLn
363 _ -> void $ warn (keyspec ++ ": ambiguous")
346 364
365{-
347show_cert certfile _ = do 366show_cert certfile _ = do
348 bs <- Char8.readFile certfile 367 bs <- Char8.readFile certfile
349 let dta = scanAndParse (fmap pemBlob $ pemParser $ Just "CERTIFICATE") $ Char8.lines bs 368 let dta = scanAndParse (fmap pemBlob $ pemParser $ Just "CERTIFICATE") $ Char8.lines bs
@@ -385,6 +404,7 @@ show_cert certfile _ = do
385 putStrLn "" 404 putStrLn ""
386 putStrLn $ "prefix = " ++ hexL v 405 putStrLn $ "prefix = " ++ hexL v
387 return () 406 return ()
407-}
388 408
389cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8] 409cannonical_eckey x y = 0x4:pad32(numToBytes x) ++ pad32(numToBytes y) :: [Word8]
390 where 410 where
@@ -935,7 +955,7 @@ kiki "show" args = do
935 ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip) 955 ,("--pem",\[x] -> show_pem x $ fromMaybe "" grip)
936 ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip) 956 ,("--ssh",\[x] -> show_ssh x $ fromMaybe "" grip)
937 ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip) 957 ,("--wip",\[x] -> show_wip x $ fromMaybe "" grip)
938 ,("--cert",\[x] -> show_cert x) 958 ,("--cert",\[x] -> show_cert x $ fromMaybe "" grip)
939 ,("--torhash",\[x] -> show_torhash x) 959 ,("--torhash",\[x] -> show_torhash x)
940 ] 960 ]
941 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs 961 shargs = mapMaybe (\(x:xs) -> (,xs) <$> Map.lookup x shspec) sargs