diff --git a/HOpenPGP/Tools/Common.hs b/HOpenPGP/Tools/Common.hs --- a/HOpenPGP/Tools/Common.hs +++ b/HOpenPGP/Tools/Common.hs @@ -1,5 +1,5 @@ -- Common.hs: hOpenPGP-tools common functions --- Copyright © 2012-2014 Clint Adams +-- Copyright © 2012-2015 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -35,7 +35,6 @@ , tkUsingPKP , pUsingPKP , pUsingSP - , withReaderTK , tkGetUIDs , tkGetSubs , anyOrAll @@ -55,19 +54,19 @@ import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Types import Control.Lens ((^..)) -import Data.Char (toLower) +import Data.Binary (put) +import Data.Binary.Put (runPut) +import qualified Data.ByteString.Lazy as BL import Data.Data.Lens (biplate) -import Data.List (isInfixOf) import Data.Monoid ((<>)) +import Data.Text (Text) +import qualified Data.Text as T import Options.Applicative.Builder (help, infoOption, long, short) import Options.Applicative.Types (Parser) import Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), hardline, text) -- hmm -- -import qualified Data.ByteString as B -import Data.Conduit.OpenPGP.Filter (Exp(..)) import Data.Maybe (fromMaybe, mapMaybe) -import Data.Serialize (runPut, put) import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize) import Control.Error.Util (hush) import Control.Monad.Trans.Reader (ask, withReader, reader, Reader, runReader) @@ -76,7 +75,7 @@ banner :: String -> Doc {-# INLINE banner #-} banner name = text name <+> text "(hopenpgp-tools)" <+> text (showVersion version) <> hardline - <> text "Copyright (C) 2012-2014 Clint Adams" + <> text "Copyright (C) 2012-2015 Clint Adams" warranty :: String -> Doc {-# INLINE warranty #-} @@ -97,11 +96,11 @@ keyMatchesEightOctetKeyId :: Bool -> TK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID -keyMatchesExactUIDString :: String -> TK -> Bool +keyMatchesExactUIDString :: Text -> TK -> Bool keyMatchesExactUIDString uidstr = any (==uidstr) . map fst . _tkUIDs -keyMatchesUIDSubString :: String -> TK -> Bool -keyMatchesUIDSubString uidstr = any (map toLower uidstr `isInfixOf`) . map (map toLower . fst) . _tkUIDs +keyMatchesUIDSubString :: Text -> TK -> Bool +keyMatchesUIDSubString uidstr = any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkUIDs keyMatchesPKPred :: Eq a => (PKPayload -> a) -> Bool -> TK -> a -> Bool keyMatchesPKPred p False = (==) . p . fst . _tkKey @@ -130,10 +129,7 @@ pkpGetEOKI :: PKPayload -> String pkpGetEOKI = either (const "UNKNOWN") show . eightOctetKeyID -withReaderTK :: (TK -> c) -> Exp (Reader TK) c -withReaderTK x = Lift x `Ap` MA ask - -tkGetUIDs :: TK -> [String] +tkGetUIDs :: TK -> [Text] tkGetUIDs = map fst . _tkUIDs tkGetSubs :: TK -> [PKPayload] @@ -152,7 +148,7 @@ oGetTag = fromIntegral . pktTag oGetLength :: Pkt -> Integer -oGetLength = fromIntegral . B.length . runPut . put -- FIXME: this should be a length that makes sense +oGetLength = fromIntegral . BL.length . runPut . put -- FIXME: this should be a length that makes sense spGetSigVersion :: Pkt -> Maybe Integer spGetSigVersion (SignaturePkt s) = Just (sigVersion s) diff --git a/HOpenPGP/Tools/Parser.y b/HOpenPGP/Tools/Parser.y --- a/HOpenPGP/Tools/Parser.y +++ b/HOpenPGP/Tools/Parser.y @@ -2,8 +2,8 @@ {-# OPTIONS -w #-} module HOpenPGP.Tools.Parser( parseTKExp, parsePExp ) where import Codec.Encryption.OpenPGP.Types -import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) -import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, withReaderTK, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) +-- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) +import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) import HOpenPGP.Tools.Lexer @@ -14,6 +14,8 @@ import Control.Monad.Loops (allM, anyM) import Control.Monad.Trans.Reader (ask, reader, Reader, withReader) import Data.List (isInfixOf) +import qualified Data.Text as T +import Text.PrettyPrint.Free (pretty, text) } @@ -97,12 +99,12 @@ | pkalgo PIOp Ppkalgos { $2 (reader pkpGetPKAlgo) (return $3) } | keysize PIOp int { $2 (reader pkpGetKeysize) (return $3) } | timestamp PIOp int { $2 (reader pkpGetTimestamp) (return $3) } - | fingerprint PSOp Pfingerprint { $2 (reader (show . pkpGetFingerprint)) (return $3) } + | fingerprint PSOp Pfingerprint { $2 (reader (show . pretty . pkpGetFingerprint)) (return $3) } | keyid PSOp Plongid { $2 (reader pkpGetEOKI) (return $3) } -TExp : every one of uids AASOp str { withReader tkGetUIDs (anyOrAll allM ($5 (return $6))) } - | any one of uids AASOp str { withReader tkGetUIDs (anyOrAll anyM ($5 (return $6))) } - | any of uids AASOp str { withReader tkGetUIDs (anyOrAll anyM ($4 (return $5))) } +TExp : every one of uids AATOp str { withReader tkGetUIDs (anyOrAll allM ($5 (return (T.pack $6)))) } + | any one of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($5 (return (T.pack $6)))) } + | any of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($4 (return (T.pack $5)))) } | a subkey PExp { withReader tkGetSubs (anyReader $3) } PIOp : '=' { liftA2 (==) } @@ -112,8 +114,8 @@ PSOp : '=' { liftA2 (==) } | contains { liftA2 (flip isInfixOf) } -AASOp : '=' { liftA2 (==) } - | contains { liftA2 isInfixOf } +AATOp : '=' { liftA2 (==) } + | contains { liftA2 T.isInfixOf } Ppkalgos : rsa { fromIntegral (fromFVal RSA) } | dsa { fromIntegral (fromFVal DSA) } @@ -123,7 +125,7 @@ | dh { fromIntegral (fromFVal DH) } | int { fromIntegral $1 } -Pfingerprint : fpr { show $1 } +Pfingerprint : fpr { (show . pretty) $1 } Plongid : longid { either (const "BROKEN") show $1 } diff --git a/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Parser.hs b/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Parser.hs --- a/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Parser.hs +++ b/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Parser.hs @@ -3,8 +3,8 @@ {-# OPTIONS -w #-} module HOpenPGP.Tools.Parser( parseTKExp, parsePExp ) where import Codec.Encryption.OpenPGP.Types -import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) -import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, withReaderTK, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) +-- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) +import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) import HOpenPGP.Tools.Lexer @@ -15,6 +15,8 @@ import Control.Monad.Loops (allM, anyM) import Control.Monad.Trans.Reader (ask, reader, Reader, withReader) import Data.List (isInfixOf) +import qualified Data.Text as T +import Text.PrettyPrint.Free (pretty, text) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts import Control.Applicative(Applicative(..)) @@ -334,7 +336,7 @@ = case happyOut9 happy_x_2 of { happy_var_2 -> case happyOut12 happy_x_3 of { happy_var_3 -> happyIn6 - (happy_var_2 (reader (show . pkpGetFingerprint)) (return happy_var_3) + (happy_var_2 (reader (show . pretty . pkpGetFingerprint)) (return happy_var_3) )}} happyReduce_13 = happySpecReduce_3 1# happyReduction_13 @@ -358,7 +360,7 @@ = case happyOut10 happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { (TokenStr happy_var_6) -> happyIn7 - (withReader tkGetUIDs (anyOrAll allM (happy_var_5 (return happy_var_6))) + (withReader tkGetUIDs (anyOrAll allM (happy_var_5 (return (T.pack happy_var_6)))) ) `HappyStk` happyRest}} happyReduce_15 = happyReduce 6# 2# happyReduction_15 @@ -372,7 +374,7 @@ = case happyOut10 happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { (TokenStr happy_var_6) -> happyIn7 - (withReader tkGetUIDs (anyOrAll anyM (happy_var_5 (return happy_var_6))) + (withReader tkGetUIDs (anyOrAll anyM (happy_var_5 (return (T.pack happy_var_6)))) ) `HappyStk` happyRest}} happyReduce_16 = happyReduce 5# 2# happyReduction_16 @@ -385,7 +387,7 @@ = case happyOut10 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { (TokenStr happy_var_5) -> happyIn7 - (withReader tkGetUIDs (anyOrAll anyM (happy_var_4 (return happy_var_5))) + (withReader tkGetUIDs (anyOrAll anyM (happy_var_4 (return (T.pack happy_var_5)))) ) `HappyStk` happyRest}} happyReduce_17 = happySpecReduce_3 2# happyReduction_17 @@ -436,7 +438,7 @@ happyReduce_24 = happySpecReduce_1 5# happyReduction_24 happyReduction_24 happy_x_1 = happyIn10 - (liftA2 isInfixOf + (liftA2 T.isInfixOf ) happyReduce_25 = happySpecReduce_1 6# happyReduction_25 @@ -486,7 +488,7 @@ happyReduction_32 happy_x_1 = case happyOutTok happy_x_1 of { (TokenFpr happy_var_1) -> happyIn12 - (show happy_var_1 + ((show . pretty) happy_var_1 )} happyReduce_33 = happySpecReduce_1 8# happyReduction_33 diff --git a/dist/build/hot/hot-tmp/HOpenPGP/Tools/Parser.hs b/dist/build/hot/hot-tmp/HOpenPGP/Tools/Parser.hs --- a/dist/build/hot/hot-tmp/HOpenPGP/Tools/Parser.hs +++ b/dist/build/hot/hot-tmp/HOpenPGP/Tools/Parser.hs @@ -3,8 +3,8 @@ {-# OPTIONS -w #-} module HOpenPGP.Tools.Parser( parseTKExp, parsePExp ) where import Codec.Encryption.OpenPGP.Types -import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) -import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, withReaderTK, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) +-- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) +import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) import HOpenPGP.Tools.Lexer @@ -15,6 +15,8 @@ import Control.Monad.Loops (allM, anyM) import Control.Monad.Trans.Reader (ask, reader, Reader, withReader) import Data.List (isInfixOf) +import qualified Data.Text as T +import Text.PrettyPrint.Free (pretty, text) import qualified Data.Array as Happy_Data_Array import qualified GHC.Exts as Happy_GHC_Exts import Control.Applicative(Applicative(..)) @@ -334,7 +336,7 @@ = case happyOut9 happy_x_2 of { happy_var_2 -> case happyOut12 happy_x_3 of { happy_var_3 -> happyIn6 - (happy_var_2 (reader (show . pkpGetFingerprint)) (return happy_var_3) + (happy_var_2 (reader (show . pretty . pkpGetFingerprint)) (return happy_var_3) )}} happyReduce_13 = happySpecReduce_3 1# happyReduction_13 @@ -358,7 +360,7 @@ = case happyOut10 happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { (TokenStr happy_var_6) -> happyIn7 - (withReader tkGetUIDs (anyOrAll allM (happy_var_5 (return happy_var_6))) + (withReader tkGetUIDs (anyOrAll allM (happy_var_5 (return (T.pack happy_var_6)))) ) `HappyStk` happyRest}} happyReduce_15 = happyReduce 6# 2# happyReduction_15 @@ -372,7 +374,7 @@ = case happyOut10 happy_x_5 of { happy_var_5 -> case happyOutTok happy_x_6 of { (TokenStr happy_var_6) -> happyIn7 - (withReader tkGetUIDs (anyOrAll anyM (happy_var_5 (return happy_var_6))) + (withReader tkGetUIDs (anyOrAll anyM (happy_var_5 (return (T.pack happy_var_6)))) ) `HappyStk` happyRest}} happyReduce_16 = happyReduce 5# 2# happyReduction_16 @@ -385,7 +387,7 @@ = case happyOut10 happy_x_4 of { happy_var_4 -> case happyOutTok happy_x_5 of { (TokenStr happy_var_5) -> happyIn7 - (withReader tkGetUIDs (anyOrAll anyM (happy_var_4 (return happy_var_5))) + (withReader tkGetUIDs (anyOrAll anyM (happy_var_4 (return (T.pack happy_var_5)))) ) `HappyStk` happyRest}} happyReduce_17 = happySpecReduce_3 2# happyReduction_17 @@ -436,7 +438,7 @@ happyReduce_24 = happySpecReduce_1 5# happyReduction_24 happyReduction_24 happy_x_1 = happyIn10 - (liftA2 isInfixOf + (liftA2 T.isInfixOf ) happyReduce_25 = happySpecReduce_1 6# happyReduction_25 @@ -486,7 +488,7 @@ happyReduction_32 happy_x_1 = case happyOutTok happy_x_1 of { (TokenFpr happy_var_1) -> happyIn12 - (show happy_var_1 + ((show . pretty) happy_var_1 )} happyReduce_33 = happySpecReduce_1 8# happyReduction_33 diff --git a/hkt.hs b/hkt.hs --- a/hkt.hs +++ b/hkt.hs @@ -1,5 +1,5 @@ -- hkt.hs: hOpenPGP key tool --- Copyright © 2013-2014 Clint Adams +-- Copyright © 2013-2015 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -32,14 +32,16 @@ import Control.Monad.Trans.Resource (runResourceT, MonadResource) import qualified Control.Monad.Trans.State.Lazy as S import qualified Data.Aeson as A +import Data.Binary (get, put) +import Data.Binary.Put (runPut) import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Conduit (($=),($$), Source) import qualified Data.Conduit.Binary as CB -import Data.Conduit.Cereal (conduitGet) import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter (conduitTKFilter, FilterPredicates(RTKFilterPredicate)) import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping, sinkKeyringMap) +import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (rights) import qualified Data.IxSet as IxSet @@ -56,7 +58,7 @@ import qualified Data.Map as Map import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) import Data.Monoid ((<>), mconcat) -import Data.Serialize (get, put, runPut) +import Data.Text (Text) import qualified Data.Text as T import qualified Data.Text.Lazy.IO as TLIO import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime) @@ -73,19 +75,19 @@ import System.IO (Handle, hFlush, stderr, hSetBuffering, BufferMode(..)) import Text.PrettyPrint.ANSI.Leijen ((<+>), (), hardline, hPutDoc, list, putDoc, text) -grabMatchingKeysConduit :: MonadResource m => FilePath -> Bool -> String -> Source m TK +grabMatchingKeysConduit :: MonadResource m => FilePath -> Bool -> Text -> Source m TK grabMatchingKeysConduit fp filt srch = CB.sourceFile fp $= conduitGet get $= conduitToTKsDropping $= (if filt then conduitTKFilter ufp else CL.filter matchAny) where matchAny tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) efp <|> fmap (keyMatchesEightOctetKeyId True tk . Right) eeok <|> return (keyMatchesUIDSubString srch tk) - efp = parseFingerprint . T.pack $ srch - eeok = parseEightOctetKeyId . T.pack $ srch + efp = parseFingerprint srch + eeok = parseEightOctetKeyId srch ufp = RTKFilterPredicate (parseE srch) - parseE e = either (error . ("filter parse error: "++)) id (parseTKExp e) -- this should be more specialized + parseE = either (error . ("filter parse error: " ++)) id . parseTKExp . T.unpack -- this should be more specialized -grabMatchingKeys :: FilePath -> Bool -> String -> IO [TK] +grabMatchingKeys :: FilePath -> Bool -> Text -> IO [TK] grabMatchingKeys fp filt srch = runResourceT $ grabMatchingKeysConduit fp filt srch $$ CL.consume -grabMatchingKeysKeyring :: FilePath -> Bool -> String -> IO Keyring +grabMatchingKeysKeyring :: FilePath -> Bool -> Text -> IO Keyring grabMatchingKeysKeyring fp filt srch = runResourceT $ grabMatchingKeysConduit fp filt srch $$ sinkKeyringMap data Key = Key { @@ -98,7 +100,7 @@ data TKey = TKey { publickey :: Key - , uids :: [String] + , uids :: [Text] , subkeys :: [Key] } deriving Generic @@ -121,7 +123,7 @@ showTKey :: TKey -> IO () showTKey key = putDoc $ text "pub " <+> sizeabbrevkeyid (publickey key) <> hardline <> - mconcat (map (\x -> text "uid " <+> text x <> hardline) (uids key)) <> + mconcat (map (\x -> text "uid " <+> text (T.unpack x) <> hardline) (uids key)) <> mconcat (map (\x -> text "sub " <+> sizeabbrevkeyid x <> hardline) (subkeys key)) <> hardline where @@ -240,7 +242,8 @@ doList :: Options -> IO () doList o = do - keys' <- grabMatchingKeys (keyring o) (targetIsFilter o) (target1 o) + let ttarget1 = T.pack . target1 + keys' <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o) let keys = map tkToTKey keys' case pathsOutputFormat o of Unstructured -> mapM_ showTKey keys @@ -250,8 +253,9 @@ doExportPubkeys :: Options -> IO () doExportPubkeys o = do - keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (target1 o) - mapM_ (B.putStr . putTK') keys + let ttarget1 = T.pack . target1 + keys <- grabMatchingKeys (keyring o) (targetIsFilter o) (ttarget1 o) + mapM_ (BL.putStr . putTK') keys where putTK' key = runPut $ do put (PublicKey (key^.tkKey._1)) @@ -265,8 +269,9 @@ doGraph :: Options -> IO () doGraph o = do + let ttarget1 = T.pack . target1 cpt <- getPOSIXTime - kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (target1 o) + kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (ttarget1 o) let g = buildKeyGraph ((buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr)))) case graphOutputFormat o of LossyPretty -> prettyPrint g @@ -313,16 +318,17 @@ } deriving Generic instance A.ToJSON PaF -instance A.ToJSON TwentyOctetFingerprint where - toJSON = A.toJSON . show doFindPaths :: Options -> IO () doFindPaths o = do + let ttarget1 = T.pack . target1 + ttarget2 = T.pack . target2 + ttarget3 = T.pack . target3 cpt <- getPOSIXTime - kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (target1 o) + kr <- grabMatchingKeysKeyring (keyring o) (targetIsFilter o) (ttarget1 o) -- FIXME: clean this up - keys1 <- runResourceT $ CL.sourceList (IxSet.toList kr) $= (if filt then conduitTKFilter (ufpt (target2 o)) else CL.filter (matchAny (target2 o))) $$ CL.consume - keys2 <- runResourceT $ CL.sourceList (IxSet.toList kr) $= (if filt then conduitTKFilter (ufpt (target3 o)) else CL.filter (matchAny (target3 o))) $$ CL.consume + keys1 <- runResourceT $ CL.sourceList (IxSet.toList kr) $= (if filt then conduitTKFilter (ufpt (ttarget2 o)) else CL.filter (matchAny (ttarget2 o))) $$ CL.consume + keys2 <- runResourceT $ CL.sourceList (IxSet.toList kr) $= (if filt then conduitTKFilter (ufpt (ttarget3 o)) else CL.filter (matchAny (ttarget3 o))) $$ CL.consume let ((KeyMaps k2f f2i i2f, i), ks) = (buildMaps &&& id) (rights (map (verifyTKWith (verifySigWith (verifyAgainstKeyring kr)) (Just (posixSecondsToUTCTime cpt))) (IxSet.toList kr))) keygraph = buildKeyGraph ((KeyMaps k2f f2i i2f, i), ks) keysToIs = mapMaybe (\x -> HashMap.lookup (fingerprint (x^.tkKey._1)) f2i) @@ -341,10 +347,10 @@ where -- FIXME: deduplicate this filt = targetIsFilter o matchAny srch tk = either (const False) id $ fmap (keyMatchesFingerprint True tk) (efp srch) <|> fmap (keyMatchesEightOctetKeyId True tk . Right) (eeok srch) <|> return (keyMatchesUIDSubString srch tk) - efp srch = parseFingerprint . T.pack $ srch - eeok srch = parseEightOctetKeyId . T.pack $ srch + efp srch = parseFingerprint srch + eeok srch = parseEightOctetKeyId srch ufpt srch = RTKFilterPredicate (parseE srch) - parseE e = either (error . ("filter parse error: "++)) id (parseTKExp e) -- this should be more specialized + parseE e = either (error . ("filter parse error: "++)) id (parseTKExp (T.unpack e)) -- this should be more specialized -- FIXME: deduplicate the following code sigissuer :: SignaturePayload -> Maybe EightOctetKeyId diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -1,5 +1,5 @@ -- hokey.hs: hOpenPGP key tool --- Copyright © 2013-2014 Clint Adams +-- Copyright © 2013-2015 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -39,19 +39,17 @@ import qualified Data.ByteString.Base16 as Base16 import Data.Conduit (($=),($$)) import qualified Data.Conduit.Binary as CB -import Data.Conduit.Cereal (conduitGet, conduitPut) +import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping) -import Data.List (unfoldr, elemIndex, findIndex, nub, sort, sortBy, intercalate) +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.Serialize (get, put) +import Data.Binary (get, put) import Data.Text (Text) import qualified Data.Text as T -import Data.Text.Encoding (decodeUtf8With) -- FIXME: this should be made unnecessary by an API break in hOpenPGP -import Data.Text.Encoding.Error (lenientDecode) import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime) import Data.Time.Format (formatTime) import qualified Data.Yaml as Y @@ -65,6 +63,7 @@ import System.Locale (defaultTimeLocale) import Text.PrettyPrint.ANSI.Leijen (colon, green, hardline, hPutDoc, indent, linebreak, list, putDoc, red, text, yellow, (<+>), Doc) +import Text.PrettyPrint.Free (pretty) data KAS = KAS { pubkeyalgo :: Colored PubKeyAlgorithm @@ -87,16 +86,16 @@ keyStatus :: String , keyFingerprint :: TwentyOctetFingerprint , keyVer :: Colored KeyVersion - , keyCreationTime :: TimeStamp + , keyCreationTime :: ThirtyTwoBitTimeStamp , keyAlgorithmAndSize :: KAS - , keyUIDsAndUAts :: FakeMap String (Colored UIDReport) + , keyUIDsAndUAts :: FakeMap Text (Colored UIDReport) , keyBestOf :: Maybe UIDReport } deriving Generic data UIDReport = UIDReport { uidSelfSigHashAlgorithms :: [Colored HashAlgorithm] , uidPreferredHashAlgorithms :: [Colored [HashAlgorithm]] - , uidKeyExpirationTimes :: [Colored [TimeStamp]] + , uidKeyExpirationTimes :: [Colored [ThirtyTwoBitDuration]] , uidRevocationStatus :: [RevocationStatus] } deriving Generic @@ -111,17 +110,8 @@ instance (A.ToJSON a) => A.ToJSON (Colored a) instance A.ToJSON KeyReport instance A.ToJSON UIDReport -instance A.ToJSON b => A.ToJSON (FakeMap String b) where +instance A.ToJSON b => A.ToJSON (FakeMap Text b) where toJSON = A.toJSON . Map.fromList . unFakeMap -instance A.ToJSON HashAlgorithm where - toJSON = A.toJSON . show -instance A.ToJSON PubKeyAlgorithm where - toJSON = A.toJSON . show -instance A.ToJSON KeyVersion where - toJSON DeprecatedV3 = A.toJSON (3 :: Int) - toJSON V4 = A.toJSON (4 :: Int) -instance A.ToJSON TwentyOctetFingerprint where - toJSON = A.toJSON . show instance A.ToJSON RevocationStatus instance Monoid UIDReport where @@ -139,7 +129,7 @@ , pubkeysize = key^.tkKey._1.pubkey & colorizePKS . pubkeySize , stringrep = (key^.tkKey._1.pubkey & either (const "unknown") show . pubkeySize) ++ (key^.tkKey._1.pkalgo & pkalgoAbbrev) } - , keyUIDsAndUAts = FakeMap (map (\(x,y) -> (x, uidr (Just x) y)) (processedOrOrig^.tkUIDs) ++ map (uatspsToString *** uidr Nothing) (processedOrOrig^.tkUAts)) + , keyUIDsAndUAts = FakeMap (map (\(x,y) -> (x, uidr (Just x) y)) (processedOrOrig^.tkUIDs) ++ map (uatspsToText *** uidr Nothing) (processedOrOrig^.tkUAts)) , keyBestOf = Nothing } where @@ -185,27 +175,28 @@ _tkUIDs = map (second newest) (_tkUIDs tk) , _tkUAts = map (second newest) (_tkUAts tk) } + uatspsToText = T.pack . uatspsToString uatspsToString 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)) + uaspToString (ImageAttribute hdr d) = hdrToString hdr ++ ':':show (BL.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hashlazy 48 d)) + 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) . 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) . getKeyExpirationTimesFromSignature) sps) (findRevocationReason sps)) -- should that be 0? + 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)) justTheUIDRs = map (decolorize . snd) . unFakeMap . keyUIDsAndUAts best = take 1 . sortBy (comparing color) decolorize (Colored _ _ x) = x colorizeUID u - | '(' `elem` u = Colored (Just Yellow) (Just "parenthesis in uid") -- FIXME: be more discerning - | not ('<' `elem` u) = Colored (Just Yellow) (Just "no left angle bracket in uid") -- FIXME: be more discerning + | '(' `elem` T.unpack u = Colored (Just Yellow) (Just "parenthesis in uid") -- FIXME: be more discerning + | not ('<' `elem` T.unpack u) = Colored (Just Yellow) (Just "no left angle bracket in uid") -- FIXME: be more discerning | otherwise = Colored Nothing Nothing findRevocationReason = concatMap grabReasons . filter isCertRevocationSig isCertRevocationSig (SigV4 CertRevocationSig _ _ _ _ _ _) = True isCertRevocationSig _ = False grabReasons (SigV4 CertRevocationSig _ _ has _ _ _) = mapMaybe (grabReasons' . _sspPayload) has grabReasons _ = [] - grabReasons' (ReasonForRevocation a b) = Just (RevocationStatus True (show a) (decodeUtf8With lenientDecode b)) + grabReasons' (ReasonForRevocation a b) = Just (RevocationStatus True (show a) b) grabReasons' _ = Nothing prettyKeyReport :: POSIXTime -> TK -> Doc @@ -213,7 +204,7 @@ let keyReport = checkKey (Just cpt) key execWriter $ tell ( linebreak <> text "Key has potential validity:" <+> text (keyStatus keyReport) - <> linebreak <> text "Key has fingerprint:" <+> text (show (SpacedFingerprint (keyFingerprint keyReport))) + <> linebreak <> text "Key has fingerprint:" <+> text (show (pretty (SpacedFingerprint (keyFingerprint keyReport)))) <> linebreak <> text "Checking to see if key is OpenPGPv4:" <+> coloredToColor (text . show) (keyVer keyReport) <> linebreak <> (\kas -> text "Checking to see if key is RSA or DSA (>= 2048-bit):" <+> coloredToColor (text . show) (pubkeyalgo kas) <+> coloredToColor (text . maybe "unknown" show) (pubkeysize kas)) (keyAlgorithmAndSize keyReport) <> linebreak <> text "Checking user-ID- and user-attribute-related items:" @@ -226,14 +217,14 @@ coloredToColor f (Colored (Just Red) _ x) = red (f x) coloredToColor f (Colored Nothing _ x) = f x uidtrip ts (u, ur) - | null (uidRevocationStatus ur) = linebreak <> indent 2 (coloredToColor text u) <> colon + | null (uidRevocationStatus ur) = linebreak <> indent 2 (coloredToColor text (fmap T.unpack u)) <> colon <> 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))) - | otherwise = linebreak <> indent 2 (coloredToColor text u) <> colon <+> text "[revoked]" + | 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))) - keyExp ts ke = durationPrettyPrinter ke ++ " = " ++ formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime (realToFrac ts + realToFrac ke)) + keyExp ts ke = (show . pretty) ke ++ " = " ++ formatTime defaultTimeLocale "%c" (posixSecondsToUTCTime (realToFrac ts + realToFrac ke)) gottabeabetterway (a, Colored x y z) = (Colored x y a, z) jsonReport :: POSIXTime -> TK -> BL.ByteString @@ -242,17 +233,6 @@ yamlReport :: POSIXTime -> TK -> B.ByteString yamlReport ps = Y.encode . (:[]) . checkKey (Just ps) --- this does not have the same sense of calendar anyone else might -durationPrettyPrinter :: TimeStamp -> String -durationPrettyPrinter = concat . unfoldr durU - where - durU x - | x >= 31557600 = Just ((++"y") . show $ x `div` 31557600, x `mod` 31557600) - | x >= 2629800 = Just ((++"m") . show $ x `div` 2629800, x `mod` 2629800) - | x >= 86400 = Just ((++"d") . show $ x `div` 86400, x `mod` 86400) - | x > 0 = Just ((++"s") . show $ x, 0) - | otherwise = Nothing - data LintOutputFormat = Pretty | JSON | YAML deriving (Bounded, Enum, Eq, Read, Show) @@ -305,7 +285,7 @@ doCanonicalize = do runResourceT $ CB.sourceHandle stdin $= conduitGet get $= conduitToTKsDropping $= CL.map canonicalize $= - conduitPut put $$ CB.sinkHandle stdout + CL.map put $= conduitPut $$ CB.sinkHandle stdout where canonicalize (TK k r ui ua s) = TK k (sort r) diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,5 +1,5 @@ name: hopenpgp-tools -version: 0.13 +version: 0.14 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools @@ -7,7 +7,7 @@ license-file: LICENSE author: Clint Adams maintainer: Clint Adams -copyright: 2012-2014 Clint Adams +copyright: 2012-2015 Clint Adams category: Codec, Data build-type: Simple cabal-version: >=1.10 @@ -19,15 +19,16 @@ , HOpenPGP.Tools.Lexer , HOpenPGP.Tools.Parser build-depends: base > 4 && < 5 + , aeson , ansi-wl-pprint >= 0.6.7 , array + , binary >= 0.6.4.0 + , binary-conduit , bytestring - , cereal - , cereal-conduit , conduit >= 1.1 , conduit-extra >= 1.1 , errors - , hOpenPGP >= 1.11 + , hOpenPGP >= 2.0 , lens , monad-loops , openpgp-asciiarmor >= 0.1 @@ -35,6 +36,8 @@ , resourcet , text , transformers + , wl-pprint-extras + , yaml build-tools: alex , happy default-language: Haskell2010 @@ -47,9 +50,9 @@ , aeson , ansi-wl-pprint >= 0.6.7 , base16-bytestring + , binary >= 0.6.4.0 + , binary-conduit , bytestring - , cereal - , cereal-conduit , conduit >= 1.1 , conduit-extra >= 1.1 , containers @@ -57,7 +60,7 @@ , cryptohash >= 0.7.7 , directory , errors - , hOpenPGP >= 1.10 + , hOpenPGP >= 2.0 , ixset , lens , monad-loops @@ -67,6 +70,7 @@ , text , time , transformers + , wl-pprint-extras , yaml default-language: Haskell2010 @@ -81,9 +85,9 @@ , ansi-wl-pprint >= 0.6.7 , array , attoparsec >= 0.10.0.0 + , binary >= 0.6.4.0 + , binary-conduit , bytestring - , cereal - , cereal-conduit , conduit >= 1.1 , conduit-extra >= 1.1 , containers @@ -92,7 +96,7 @@ , errors , fgl , graphviz - , hOpenPGP >= 1.11 + , hOpenPGP >= 2.0 , ixset , lens , monad-loops @@ -102,6 +106,7 @@ , time , transformers , unordered-containers + , wl-pprint-extras , yaml build-tools: alex , happy diff --git a/hot.hs b/hot.hs --- a/hot.hs +++ b/hot.hs @@ -1,7 +1,7 @@ {-# LANGUAGE OverloadedStrings, RecordWildCards #-} -- hot.hs: hOpenPGP Tool --- Copyright © 2012-2014 Clint Adams +-- Copyright © 2012-2015 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- @@ -29,27 +29,34 @@ import Control.Error.Util (note) import Control.Monad.IO.Class (MonadIO, liftIO) import Control.Monad.Trans.Resource (runResourceT) +import qualified Data.Aeson as A import qualified Data.ByteString as B import qualified Data.ByteString.Lazy as BL import Data.Conduit (($=), ($$), Sink) -import Data.Conduit.Cereal (conduitGet, conduitPut) +import Data.Conduit.Serialization.Binary (conduitGet, conduitPut) import qualified Data.Conduit.Binary as CB import qualified Data.Conduit.List as CL import Data.Conduit.OpenPGP.Filter (conduitPktFilter, FilterPredicates(RPFilterPredicate)) -import Data.Serialize (get, put) -import Data.Serialize.Get (Get) +import Data.Binary (get, put) +import Data.Binary.Get (Get) import Data.Monoid ((<>)) import Data.Version (showVersion) +import qualified Data.Yaml as Y import System.IO (stdin, stderr, stdout, Handle, hFlush, hPutStrLn, hSetBuffering, BufferMode(..)) -import Options.Applicative.Builder (argument, command, footerDoc, headerDoc, help, helpDoc, info, long, metavar, option, eitherReader, prefs, progDesc, showHelpOnError, str, strOption, subparser) +import Options.Applicative.Builder (auto, argument, command, footerDoc, headerDoc, help, helpDoc, info, long, metavar, option, eitherReader, prefs, progDesc, showDefaultWith, showHelpOnError, str, strOption, subparser, value) import Options.Applicative.Extra (customExecParser, helper) import Options.Applicative.Types (Parser) import Text.PrettyPrint.ANSI.Leijen ((<+>), hardline, hPutDoc, list, softline, text) +import Text.PrettyPrint.Free (Pretty, pretty) -data Command = DumpC | DeArmorC | ArmorC ArmoringOptions | FilterC FilteringOptions +data Command = DumpC DumpOptions | DeArmorC | ArmorC ArmoringOptions | FilterC FilteringOptions +data DumpOptions = DumpOptions { + outputformat :: DumpOutputFormat +} + data ArmoringOptions = ArmoringOptions { comment :: Maybe String , armortype :: ArmorType @@ -59,13 +66,28 @@ fExpression :: String } -doDump :: IO () -doDump = runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $$ printer +data DumpOutputFormat = DumpPretty | DumpJSON | DumpYAML + deriving (Bounded, Enum, Read, Show) +doDump :: DumpOptions -> IO () +doDump DumpOptions{..} = runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $$ case outputformat of + DumpPretty -> prettyPrinter + DumpJSON -> jsonSink + DumpYAML -> yamlSink + -- Print every input value to standard output. -printer :: (Show a, MonadIO m) => Sink a m () -printer = CL.mapM_ (liftIO . print) +-- printer :: (Show a, MonadIO m) => Sink a m () +-- printer = CL.mapM_ (liftIO . print) +prettyPrinter :: (Pretty a, MonadIO m) => Sink a m () +prettyPrinter = CL.mapM_ (liftIO . putStrLn . show . pretty) + +jsonSink :: (A.ToJSON a, MonadIO m) => Sink a m () +jsonSink = CL.mapM_ (liftIO . BL.putStr . flip BL.snoc 0x0a . A.encode) + +yamlSink :: (Y.ToJSON a, MonadIO m) => Sink a m () +yamlSink = CL.mapM_ (liftIO . B.putStr . flip B.snoc 0x0a . Y.encode) + doDeArmor :: IO () doDeArmor = do a <- runResourceT $ CB.sourceHandle stdin $$ CL.consume @@ -91,8 +113,20 @@ armorTypeReader = note "unknown armor type" . flip lookup armorTypes doFilter :: FilteringOptions -> IO () -doFilter fo = runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $= conduitPktFilter (parseExpressions fo) $= conduitPut put $$ CB.sinkHandle stdout +doFilter fo = runResourceT $ CB.sourceHandle stdin $= conduitGet (get :: Get Pkt) $= conduitPktFilter (parseExpressions fo) $= CL.map put $= conduitPut $$ CB.sinkHandle stdout +doP :: Parser DumpOptions +doP = DumpOptions + <$> option (auto <$> ("Dump"++)) + ( long "output-format" + <> metavar "FORMAT" + <> value DumpPretty + <> showDefaultWith (drop 4 . show) + <> ofHelp ) + where + ofHelp = helpDoc . Just $ text "output format" <> hardline <> list (map (text . drop 4 . show) ofchoices) + ofchoices = [minBound..maxBound] :: [DumpOutputFormat] + aoP :: Parser ArmoringOptions aoP = ArmoringOptions <$> optional (strOption (long "comment" <> metavar "COMMENT" <> help "ASCII armor Comment field")) @@ -109,7 +143,7 @@ dispatch :: Command -> IO () dispatch c = (banner' stderr >> hFlush stderr) >> dispatch' c where - dispatch' DumpC = doDump + dispatch' (DumpC o) = doDump o dispatch' DeArmorC = doDeArmor dispatch' (ArmorC o) = doArmor o dispatch' (FilterC o) = doFilter o @@ -123,7 +157,7 @@ cmd = subparser ( command "armor" (info ( ArmorC <$> aoP ) ( progDesc "Armor stdin to stdout" )) <> command "dearmor" (info ( pure DeArmorC ) ( progDesc "Dearmor stdin to stdout" )) - <> command "dump" (info ( pure DumpC ) ( progDesc "Dump OpenPGP packets from stdin" )) + <> command "dump" (info ( DumpC <$> doP ) ( progDesc "Dump OpenPGP packets from stdin" )) <> command "filter" (info ( FilterC <$> foP ) ( progDesc "Filter some packets from stdin to stdout" )) )