hopenpgp-tools 0.14.1 → 0.15
raw patch · 4 files changed
+75/−28 lines, 4 filesdep ~hOpenPGP
Dependency ranges changed: hOpenPGP
Files
- dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs +24/−10
- dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs +24/−10
- hokey.hs +25/−6
- hopenpgp-tools.cabal +2/−2
dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs view
@@ -98,8 +98,9 @@ -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. +import Control.Applicative (Applicative (..)) import Data.Word (Word8)-{-# LINE 22 "templates/wrappers.hs" #-}+{-# LINE 23 "templates/wrappers.hs" #-} import qualified Data.Bits @@ -151,11 +152,11 @@ in p' `seq` Just (b, (p', c, bs, s)) -{-# LINE 92 "templates/wrappers.hs" #-}+{-# LINE 93 "templates/wrappers.hs" #-} -{-# LINE 106 "templates/wrappers.hs" #-}+{-# LINE 107 "templates/wrappers.hs" #-} -{-# LINE 121 "templates/wrappers.hs" #-}+{-# LINE 122 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions@@ -211,6 +212,19 @@ newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } +instance Functor Alex where+ fmap f a = Alex $ \s -> case unAlex a s of+ Left msg -> Left msg+ Right (s', a') -> Right (s', f a')++instance Applicative Alex where+ pure a = Alex $ \s -> Right (s, a)+ fa <*> a = Alex $ \s -> case unAlex fa s of+ Left msg -> Left msg+ Right (s', f) -> case unAlex a s' of+ Left msg -> Left msg+ Right (s'', b) -> Right (s'', f b)+ instance Monad Alex where m >>= k = Alex $ \s -> case unAlex m s of Left msg -> Left msg@@ -282,35 +296,35 @@ -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 333 "templates/wrappers.hs" #-}+{-# LINE 347 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 360 "templates/wrappers.hs" #-}+{-# LINE 374 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 378 "templates/wrappers.hs" #-}- {-# LINE 392 "templates/wrappers.hs" #-} +{-# LINE 406 "templates/wrappers.hs" #-} + -- ----------------------------------------------------------------------------- -- Posn wrapper -- Adds text positions to the basic model. -{-# LINE 409 "templates/wrappers.hs" #-}+{-# LINE 423 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 424 "templates/wrappers.hs" #-}+{-# LINE 438 "templates/wrappers.hs" #-} -- -----------------------------------------------------------------------------
dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs view
@@ -98,8 +98,9 @@ -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. +import Control.Applicative (Applicative (..)) import Data.Word (Word8)-{-# LINE 22 "templates/wrappers.hs" #-}+{-# LINE 23 "templates/wrappers.hs" #-} import qualified Data.Bits @@ -151,11 +152,11 @@ in p' `seq` Just (b, (p', c, bs, s)) -{-# LINE 92 "templates/wrappers.hs" #-}+{-# LINE 93 "templates/wrappers.hs" #-} -{-# LINE 106 "templates/wrappers.hs" #-}+{-# LINE 107 "templates/wrappers.hs" #-} -{-# LINE 121 "templates/wrappers.hs" #-}+{-# LINE 122 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions@@ -211,6 +212,19 @@ newtype Alex a = Alex { unAlex :: AlexState -> Either String (AlexState, a) } +instance Functor Alex where+ fmap f a = Alex $ \s -> case unAlex a s of+ Left msg -> Left msg+ Right (s', a') -> Right (s', f a')++instance Applicative Alex where+ pure a = Alex $ \s -> Right (s, a)+ fa <*> a = Alex $ \s -> case unAlex fa s of+ Left msg -> Left msg+ Right (s', f) -> case unAlex a s' of+ Left msg -> Left msg+ Right (s'', b) -> Right (s'', f b)+ instance Monad Alex where m >>= k = Alex $ \s -> case unAlex m s of Left msg -> Left msg@@ -282,35 +296,35 @@ -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 333 "templates/wrappers.hs" #-}+{-# LINE 347 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 360 "templates/wrappers.hs" #-}+{-# LINE 374 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 378 "templates/wrappers.hs" #-}- {-# LINE 392 "templates/wrappers.hs" #-} +{-# LINE 406 "templates/wrappers.hs" #-} + -- ----------------------------------------------------------------------------- -- Posn wrapper -- Adds text positions to the basic model. -{-# LINE 409 "templates/wrappers.hs" #-}+{-# LINE 423 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 424 "templates/wrappers.hs" #-}+{-# LINE 438 "templates/wrappers.hs" #-} -- -----------------------------------------------------------------------------
hokey.hs view
@@ -33,6 +33,7 @@ import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash.SHA3 as SHA3 import qualified Data.Aeson as A+import Data.Binary (get, put) import qualified Data.ByteString as B import qualified Data.ByteString.Char8 as BC8 import qualified Data.ByteString.Lazy as BL@@ -42,12 +43,13 @@ import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)+import Data.Foldable (find) import Data.List (elemIndex, findIndex, nub, sort, sortBy, intercalate) import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) import Data.Monoid ((<>), mconcat, Monoid(..)) import Data.Ord (comparing, Down(..))-import Data.Binary (get, put)+import qualified Data.Set as Set import Data.Text (Text) import qualified Data.Text as T import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime)@@ -96,6 +98,7 @@ uidSelfSigHashAlgorithms :: [Colored HashAlgorithm] , uidPreferredHashAlgorithms :: [Colored [HashAlgorithm]] , uidKeyExpirationTimes :: [Colored [ThirtyTwoBitDuration]]+ , uidKeyUsageFlags :: [Colored (Set.Set KeyFlag)] , uidRevocationStatus :: [RevocationStatus] } deriving Generic @@ -115,8 +118,8 @@ instance A.ToJSON RevocationStatus instance Monoid UIDReport where- mempty = UIDReport [] [] [] []- mappend (UIDReport a b c d) (UIDReport a' b' c' d') = UIDReport (a++a') (b++b') (c++c') (d <> d')+ mempty = UIDReport [] [] [] [] []+ mappend (UIDReport a b c d e) (UIDReport a' b' c' d' e') = UIDReport (a <> a') (b <> b') (c <> c') (d <> d') (e <> e') checkKey :: Maybe POSIXTime -> TK -> KeyReport checkKey mpt key = (\x -> x { keyBestOf = populateBestOf x }) KeyReport {@@ -181,9 +184,17 @@ uaspToString (OtherUASub t d) = "other-" ++ show t ++ ':':show (BL.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hashlazy 48 d)) hdrToString (ImageHV1 JPEG) = "jpeg" hdrToString (ImageHV1 fmt) = "image-" ++ show (fromFVal fmt)- uidr Nothing sps = Colored Nothing Nothing (UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) . getKeyExpirationTimesFromSignature) sps) (findRevocationReason sps)) -- should that be 0?- uidr (Just u) sps = colorizeUID u (UIDReport (has sps) (map phas sps) (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) . getKeyExpirationTimesFromSignature) sps) (findRevocationReason sps)) -- should that be 0?- populateBestOf krep = Just (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best . uidPreferredHashAlgorithms <*> best . uidKeyExpirationTimes <*> pure [] $ mconcat (justTheUIDRs krep))+ uidr Nothing sps = Colored Nothing Nothing (UIDReport (has sps)+ (map phas sps)+ (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0?+ (kufs sps)+ (findRevocationReason sps))+ uidr (Just u) sps = colorizeUID u (UIDReport (has sps)+ (map phas sps)+ (map (colorizeKETs (fromMaybe 0 mpt) (key^.tkKey._1.timestamp & unThirtyTwoBitTimeStamp) . getKeyExpirationTimesFromSignature) sps) -- should that be 0?+ (kufs sps)+ (findRevocationReason sps))+ populateBestOf krep = Just (UIDReport <$> best . uidSelfSigHashAlgorithms <*> best . uidPreferredHashAlgorithms <*> best . uidKeyExpirationTimes <*> best . uidKeyUsageFlags <*> pure [] $ mconcat (justTheUIDRs krep)) justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts best = take 1 . sortBy (comparing color) decolorize (Colored _ _ x) = x@@ -198,6 +209,13 @@ grabReasons _ = [] grabReasons' (ReasonForRevocation a b) = Just (RevocationStatus True (show a) b) grabReasons' _ = Nothing+ kufs = map (colorizeKUFs . (\(SigSubPacket _ (KeyFlags x)) -> x) . maybe undefined id . find isKUF . hasheds) . newestWith (any isKUF . hasheds)+ isKUF (SigSubPacket _ (KeyFlags _)) = True+ isKUF _ = False+ colorizeKUFs x = uncurry Colored (if (Set.member EncryptStorageKey x || Set.member EncryptCommunicationsKey x) && (Set.member SignDataKey x || Set.member CertifyKeysKey x) then (Just Yellow, Just "both signing & encryption") else (Just Green, Nothing)) x+ newestWith p = take 1 . sortBy (comparing (Down . take 1 . sigcts)) . filter p -- FIXME: this is terrible+ hasheds (SigV4 _ _ _ xs _ _ _) = xs+ hasheds _ = [] prettyKeyReport :: POSIXTime -> TK -> Doc prettyKeyReport cpt key = do@@ -221,6 +239,7 @@ <> linebreak <> indent 4 (text "Self-sig hash algorithms" <> colon <+> (list . map (coloredToColor (text . show)) . uidSelfSigHashAlgorithms) ur) <> linebreak <> indent 4 (text "Preferred hash algorithms" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . coloredToColor (text . show)) (uidPreferredHashAlgorithms ur))) <> linebreak <> indent 4 (text "Key expiration times" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . coloredToColor list . fmap (map (text . keyExp ts))) (uidKeyExpirationTimes ur)))+ <> linebreak <> indent 4 (text "Key usage flags" <> colon <+> mconcat (map ((linebreak <>) . indent 2 . coloredToColor (text . show . pretty . Set.toList)) (uidKeyUsageFlags ur))) | otherwise = linebreak <> indent 2 (coloredToColor text (fmap T.unpack u)) <> colon <+> text "[revoked]" <> linebreak <> indent 4 (text "Revocation code" <> colon <+> list (map (text . revocationCode) (uidRevocationStatus ur))) <> linebreak <> indent 4 (text "Revocation reason" <> colon <+> list (map (text . T.unpack . revocationReason) (uidRevocationStatus ur)))
hopenpgp-tools.cabal view
@@ -1,5 +1,5 @@ name: hopenpgp-tools-version: 0.14.1+version: 0.15 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools@@ -119,4 +119,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.13+ tag: hopenpgp-tools/0.15