hopenpgp-tools 0.2 → 0.3
raw patch · 2 files changed
+47/−31 lines, 2 filesdep +base16-bytestringdep +cryptohashdep ~hOpenPGP
Dependencies added: base16-bytestring, cryptohash
Dependency ranges changed: hOpenPGP
Files
- hokey.hs +42/−28
- hopenpgp-tools.cabal +5/−3
hokey.hs view
@@ -21,29 +21,31 @@ import HOpenPGP.Tools.Common (banner, versioner, warranty) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (keySize)-import Codec.Encryption.OpenPGP.Signatures (verifyTK)+import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Applicative ((<$>),(<*>)) import Control.Arrow ((***), second) import Control.Lens ((^.), (^?!), ix) import Control.Monad.Trans.Writer.Lazy (execWriter, tell)+import qualified Crypto.Hash.SHA3 as SHA3 import qualified Data.Aeson as A import qualified Data.ByteString as B+import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL+import qualified Data.ByteString.Base16 as Base16 import Data.Conduit (($=),($$), runResourceT) import qualified Data.Conduit.Binary as CB import Data.Conduit.Cereal (conduitGet) import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) import Data.IxSet (empty, insert)-import Data.List (unfoldr, elemIndex, findIndex, sortBy)-import Data.Map (Map)-import qualified Data.Map as Map+import Data.List (unfoldr, elemIndex, findIndex, sortBy, intercalate) import Data.Maybe (fromMaybe) import Data.Monoid ((<>), mconcat) import Data.Ord (comparing, Down(..)) import Data.Serialize (get)-import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime)+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Data.Time.Format (formatTime) import GHC.Generics @@ -54,7 +56,7 @@ import System.IO (Handle, hFlush, hPutStrLn, stderr, stdin, hSetBuffering, BufferMode(..)) import System.Locale (defaultTimeLocale) -import Text.PrettyPrint.ANSI.Leijen (colon, green, indent, linebreak, list, putDoc, red, text, yellow, (<+>)) -- need 0.6.7 for hardline+import Text.PrettyPrint.ANSI.Leijen (colon, green, indent, linebreak, list, putDoc, red, text, yellow, (<+>), Doc) -- need 0.6.7 for hardline data KAS = KAS { pubkeyalgo :: PubKeyAlgorithm@@ -67,13 +69,18 @@ , keyVer :: KeyVersion , keyCreationTime :: TimeStamp , keyAlgorithmAndSize :: KAS- , keySelfSigHashAlgorithms :: Map String [HashAlgorithm]- , keyPreferredHashAlgorithms :: Map String [[HashAlgorithm]]- , keyExpirationTimes :: Map String [[TimeStamp]]+ , keyUIDsAndUAts :: [(String, UIDReport)] } deriving Generic +data UIDReport = UIDReport {+ uidSelfSigHashAlgorithms :: [HashAlgorithm]+ , uidPreferredHashAlgorithms :: [[HashAlgorithm]]+ , uidKeyExpirationTimes :: [[TimeStamp]]+} deriving Generic+ instance A.ToJSON KAS instance A.ToJSON KeyReport+instance A.ToJSON UIDReport instance A.ToJSON HashAlgorithm where toJSON = A.toJSON . show instance A.ToJSON PubKeyAlgorithm where@@ -84,11 +91,11 @@ instance A.ToJSON TwentyOctetFingerprint where toJSON = A.toJSON . show -checkKey :: TK -> IO KeyReport-checkKey key = getPOSIXTime >>= \cpt -> return (KeyReport (either (const "not-good") (const "good") (processedTK cpt)) (fingerprint $ key^.tkPKP) (key^.tkPKP^.keyVersion) (key^.tkPKP^.timestamp) (KAS (key^.tkPKP^.pkalgo) (keySize (key^.tkPKP^.pubkey))) (Map.fromList (map (second has) ((processedOrOrig cpt)^.tkUIDs) ++ map (const "<uat>" *** has) ((processedOrOrig cpt)^.tkUAts))) (Map.fromList (map (second (map phas . alleged)) ((processedOrOrig cpt)^.tkUIDs) ++ map (const "<uat>" *** (map phas . alleged)) ((processedOrOrig cpt)^.tkUAts))) (Map.fromList (map (second (map kets . alleged)) ((processedOrOrig cpt)^.tkUIDs) ++ map (const "<uat>" *** (map kets . alleged)) ((processedOrOrig cpt)^.tkUAts))))+checkKey :: Maybe UTCTime -> TK -> KeyReport+checkKey mct key = KeyReport (either (const "not-good") (const "good") processedTK) (fingerprint $ key^.tkPKP) (key^.tkPKP^.keyVersion) (key^.tkPKP^.timestamp) (KAS (key^.tkPKP^.pkalgo) (keySize (key^.tkPKP^.pubkey))) (map (second uidr) (processedOrOrig^.tkUIDs) ++ map (uatspsToString *** uidr) (processedOrOrig^.tkUAts)) where- processedOrOrig = either (const key) id . processedTK- processedTK t = verifyTK (insert key empty) (Just (posixSecondsToUTCTime t)) . stripOlderSigs . stripOtherSigs $ key+ processedOrOrig = either (const key) id processedTK+ processedTK = verifyTKWith (verifySigWith (verifyAgainstKeys [key])) mct . stripOlderSigs . stripOtherSigs $ key sigissuer (SigVOther 2 _) = OtherSigSub 666 B.empty -- this is dumb sigissuer (SigV3 {}) = OtherSigSub 666 B.empty -- this is dumb sigissuer (SigV4 _ _ _ _ xs _ _) = xs^?!ix 0^.sspPayload -- this is a horrible stack of stupid assumptions@@ -116,26 +123,32 @@ _tkUIDs = map (second newest) (_tkUIDs tk) , _tkUAts = map (second newest) (_tkUAts tk) }+ uatspsToString us = "<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>"+ uaspToString (ImageAttribute hdr d) = hdrToString hdr ++ ':':show (B.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hash 48 d))+ uaspToString (OtherUASub t d) = "other-" ++ show t ++ ':':show (B.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hash 48 d))+ hdrToString (ImageHV1 JPEG) = "jpeg"+ hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)+ uidr sps = UIDReport (has sps) (map phas sps) (map kets sps) -prettyKeyReport :: TK -> IO ()-prettyKeyReport key = getPOSIXTime >>= \cpt -> checkKey key >>= \keyReport -> putDoc . execWriter $ tell+prettyKeyReport :: POSIXTime -> TK -> Doc+prettyKeyReport cpt key = do+ let keyReport = checkKey (Just (posixSecondsToUTCTime cpt)) key+ execWriter $ tell ( linebreak <> text "Key has potential validity:" <+> text (keyStatus keyReport) <> linebreak <> text "Key has fingerprint:" <+> text (show (keyFingerprint keyReport)) <> linebreak <> text "Checking to see if key is OpenPGPv4:" <+> colorIf (green,red) (==V4) (keyVer keyReport) <> linebreak <> (\kas -> text "Checking to see if key is RSA or DSA (>= 2048-bit):" <+> colorIf (green,yellow) (==RSA) (pubkeyalgo kas) <+> colorIf3 (green,yellow,red) (>= 3072) (>=2048) (pubkeysize kas)) (keyAlgorithmAndSize keyReport)- <> linebreak <> text "Checking self-sig hash algorithms (poorly):"- <> mconcat (map (\(x,ys) -> slpair x (listHAs ys)) (Map.toList (keySelfSigHashAlgorithms keyReport)))- <> linebreak <> text "Checking preferred hash algorithms (poorly):" -- FIXME- <> mconcat (map (\(x,ys) -> mlpair x listPHAs ys) (Map.toList (keyPreferredHashAlgorithms keyReport)))- <> linebreak <> text "Checking key expiration times based on" <+> text (formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime . realToFrac $ (key^.tkPKP^.timestamp))) <+> text "(creation) and" <+> text (formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime cpt)) <+> text "(current) times (poorly):" -- FIXME- <> mconcat (map (\(x,ys) -> mlpair x (listKETs cpt (keyCreationTime keyReport)) ys) (Map.toList (keyExpirationTimes keyReport)))+ <> linebreak <> text "Checking user-ID- and user-attribute-related items:"+ <> mconcat (map (uidtrip (keyCreationTime keyReport)) (keyUIDsAndUAts keyReport)) <> linebreak ) where colorIf (y,n) p x = ((if p x then y else n) . text . show) x colorIf3 (g,y,r) p1 p2 x = ((if p1 x then g else (if p2 x then y else r)) . text . show) x- slpair x y = linebreak <> indent 2 (text x <> colon <+> y)- mlpair x f ys = linebreak <> indent 2 (text x) <> colon <> mconcat (map ((linebreak <>) . indent 4 . f) ys)+ uidtrip ts (u, ur) = linebreak <> indent 2 (text u) <> colon+ <> linebreak <> indent 4 (text "Self-sig hash algorithms" <> colon <+> (listHAs . uidSelfSigHashAlgorithms) ur)+ <> linebreak <> indent 4 (text "Preferred hash algorithms" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . listPHAs) (uidPreferredHashAlgorithms ur)))+ <> linebreak <> indent 4 (text "Key expiration times" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . listKETs cpt ts) (uidKeyExpirationTimes ur))) listHAs = list . map (\x -> ((if x `elem` [DeprecatedMD5, SHA1] then red else id) . text . show) x) listPHAs x = (if fSHA2Family x < ei DeprecatedMD5 x && fSHA2Family x < ei SHA1 x then green else red) . list . map (text . show) $ x listKETs ct ts x = colorExpiration ct ts x . list . map (text . keyExp ts) $ x@@ -149,8 +162,8 @@ | otherwise = green keyExp ts ke = durationPrettyPrinter ke ++ " = " ++ formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime (realToFrac ts + realToFrac ke)) -jsonReport :: TK -> IO ()-jsonReport key = checkKey key >>= \keyReport -> BL.putStr (A.encode keyReport)+jsonReport :: POSIXTime -> TK -> BL.ByteString+jsonReport _ key = A.encode (checkKey Nothing key) -- FIXME: pass time when it matters in the JSON -- this does not have the same sense of calendar anyone else might durationPrettyPrinter :: TimeStamp -> String@@ -195,11 +208,12 @@ doLint :: Options -> IO () doLint o = do+ cpt <- getPOSIXTime keys <- runResourceT $ CB.sourceHandle stdin $= conduitGet get $= conduitToTKsDropping $$ CL.consume- mapM_ (output (outputFormat o)) keys+ output (outputFormat o) cpt keys where- output Pretty = prettyKeyReport- output JSON = jsonReport+ output Pretty cpt = mapM_ (putDoc . prettyKeyReport cpt)+ output JSON cpt = BL.putStr . BL.concat . map (jsonReport cpt) banner' :: Handle -> IO () banner' h = hPutStrLn h (banner "hokey" ++ "\n" ++ warranty "hokey")
hopenpgp-tools.cabal view
@@ -1,5 +1,5 @@ name: hopenpgp-tools-version: 0.2+version: 0.3 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools@@ -37,14 +37,16 @@ build-depends: base > 4 && < 5 , aeson , ansi-wl-pprint+ , base16-bytestring , bytestring , cereal , cereal-conduit , conduit , containers , crypto-pubkey+ , cryptohash >= 0.7.7 , directory- , hOpenPGP >= 0.10.2+ , hOpenPGP >= 0.12 , ixset , lens , old-locale@@ -80,4 +82,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.2+ tag: hopenpgp-tools/0.3