hopenpgp-tools 0.18 → 0.19
raw patch · 7 files changed
+257/−42 lines, 7 filesdep +http-clientdep +http-client-tlsdep +http-typesdep ~openpgp-asciiarmor
Dependencies added: http-client, http-client-tls, http-types
Dependency ranges changed: openpgp-asciiarmor
Files
- HOpenPGP/Tools/Common.hs +1/−1
- HOpenPGP/Tools/HKP.hs +93/−0
- HOpenPGP/Tools/TKUtils.hs +60/−0
- dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs +25/−13
- dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs +25/−13
- hokey.hs +45/−13
- hopenpgp-tools.cabal +8/−2
HOpenPGP/Tools/Common.hs view
@@ -1,5 +1,5 @@ -- Common.hs: hOpenPGP-tools common functions--- Copyright © 2012-2015 Clint Adams+-- Copyright © 2012-2016 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab --
+ HOpenPGP/Tools/HKP.hs view
@@ -0,0 +1,93 @@+-- HKP.hs: hOpenPGP key tool+-- Copyright © 2016 Clint Adams+--+-- vim: softtabstop=4:shiftwidth=4:expandtab+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as+-- published by the Free Software Foundation, either version 3 of the+-- License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++{-# LANGUAGE OverloadedStrings #-}++module HOpenPGP.Tools.HKP (+ fetchKeys+ , FetchValidationMethod(..)+ , rearmorKeys+) where++import HOpenPGP.Tools.TKUtils (processTK)+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA+import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(Armor), ArmorType(ArmorPublicKeyBlock))+import Codec.Encryption.OpenPGP.Fingerprint (fingerprint)+import Codec.Encryption.OpenPGP.Types (Block(..), TK(..), TwentyOctetFingerprint)+import Control.Applicative (liftA2)+import Control.Arrow ((&&&))+import Control.Lens ((^..))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT(..), throwE)+import Control.Monad.Trans.Resource (runResourceT)+import Data.Binary (get, put)+import qualified Data.ByteString.Char8 as BC8+import Data.Conduit (($=),($$))+import qualified Data.Conduit.Binary as CB+import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)+import Data.Conduit.Serialization.Binary (conduitGet, conduitPut)+import qualified Data.Conduit.List as CL+import Data.Binary.Put (runPut)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Data.Lens (biplate)+import Data.Either (rights)+import Data.Monoid ((<>), mempty)+import Data.Time.Clock.POSIX (getPOSIXTime)+import Network.HTTP.Client (httpLbs, newManager, parseUrl, Response(..), setQueryString)+import Network.HTTP.Client.TLS (tlsManagerSettings)+import Network.HTTP.Types.Status (ok200)+import Text.PrettyPrint.Free (pretty)++data FetchValidationMethod = MatchPrimaryKeyFingerprint | MatchPrimaryOrAnySubkeyFingerprint | AnySelfSigned+ deriving (Bounded, Enum, Eq, Read, Show)++fetchKeys :: String -> FetchValidationMethod -> TwentyOctetFingerprint -> ExceptT String IO [TK]+fetchKeys ks fvm q = do+ manager <- liftIO $ newManager tlsManagerSettings++ request <- liftIO $ parseUrl (ks <> basereq)+ let newreq = setQueryString (newqs q) request+ response <- liftIO $ httpLbs newreq manager++ processedKeys <- if responseStatus response == ok200 then validateKeys (responseBody response) else throwE ("HTTP status: " ++ show (responseStatus response))+ return $ map fst $ filter (fvp fvm . fst . _tkKey . snd) processedKeys+ where+ fvp MatchPrimaryKeyFingerprint k = fingerprint k == q+ fvp MatchPrimaryOrAnySubkeyFingerprint k = any (\k -> fingerprint k == q) (k^.. biplate)+ fvp AnySelfSigned k = True+ basereq = "/pks/lookup"+ newqs q = [+ ("op", Just "get")+ , ("options", Just "mr")+ , ("exact", Just "on")+ , ("search", Just (BC8.pack ("0x" <> show (pretty q)))) -- FIXME: butter+ ]++validateKeys :: BL.ByteString -> ExceptT String IO [(TK,TK)] -- FIXME: conduit fail+validateKeys larmors = do+ bytestrings <- ExceptT $ return $ fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)+ keys <- runResourceT $ CB.sourceLbs bytestrings $= conduitGet get $= conduitToTKsDropping $$ CL.consume+ cpt <- liftIO $ getPOSIXTime+ return . rights $ map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys+ where+ armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs+ armorToBS _ = mempty++rearmorKeys :: [TK] -> B.ByteString+rearmorKeys keys = if (null keys) then mempty else (AA.encode . return . Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")] . runPut . put . Block $ keys)
+ HOpenPGP/Tools/TKUtils.hs view
@@ -0,0 +1,60 @@+-- TKUtils.hs: hOpenPGP-tools TK-related common functions+-- Copyright © 2013-2016 Clint Adams+--+-- vim: softtabstop=4:shiftwidth=4:expandtab+--+-- This program is free software: you can redistribute it and/or modify+-- it under the terms of the GNU Affero General Public License as+-- published by the Free Software Foundation, either version 3 of the+-- License, or (at your option) any later version.+--+-- This program is distributed in the hope that it will be useful,+-- but WITHOUT ANY WARRANTY; without even the implied warranty of+-- MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the+-- GNU Affero General Public License for more details.+--+-- You should have received a copy of the GNU Affero General Public License+-- along with this program. If not, see <http://www.gnu.org/licenses/>.++module HOpenPGP.Tools.TKUtils (+ processTK+) where++import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID)+import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys)+import Codec.Encryption.OpenPGP.Types+import Control.Error.Util (hush)+import Control.Arrow (second)+import Control.Lens ((^.), (&), _1, _2, mapped, over)+import Data.List (sortBy)+import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)+import Data.Ord (comparing, Down(..))+import Data.Time.Clock.POSIX (posixSecondsToUTCTime, POSIXTime)++processTK :: Maybe POSIXTime -> TK -> Either String TK+processTK mpt key = verifyTKWith (verifySigWith (verifyAgainstKeys [key])) (fmap posixSecondsToUTCTime mpt) . stripOlderSigs . stripOtherSigs $ key+ where+ stripOtherSigs tk = tk {+ _tkUIDs = map (second alleged) (_tkUIDs tk)+ , _tkUAts = map (second alleged) (_tkUAts tk)+ }+ stripOlderSigs tk = tk {+ _tkUIDs = map (second newest) (_tkUIDs tk)+ , _tkUAts = map (second newest) (_tkUAts tk)+ }+ newest = take 1 . sortBy (comparing (Down . take 1 . sigcts)) -- FIXME: this is terrible+ sigcts (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs+ alleged = filter (\x -> ((==) <$> sigissuer x <*> eoki (key^.tkKey._1)) == Just True)+ isCT (SigSubPacket _ (SigCreationTime _)) = True+ isCT _ = False+ sigissuer (SigVOther 2 _) = Nothing+ sigissuer (SigV3 {}) = Nothing+ sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys++xs) -- FIXME: what should this be if there are multiple matches?+ sigissuer (SigVOther _ _) = error "We're in the future." -- FIXME+ eoki pkp+ | pkp^.keyVersion == V4 = hush . eightOctetKeyID $ pkp+ | pkp^.keyVersion == DeprecatedV3 && elem (pkp^.pkalgo) [RSA,DeprecatedRSASignOnly] = hush . eightOctetKeyID $ pkp+ | otherwise = Nothing+ getIssuer (Issuer i) = Just i+ getIssuer _ = Nothing+
dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs view
@@ -89,6 +89,11 @@ +++++ {-# LINE 9 "<command-line>" #-} {-# LINE 1 "/usr/lib/ghc/include/ghcversion.h" #-} @@ -116,11 +121,13 @@ -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. -import Control.Applicative (Applicative (..))++import Control.Applicative as App (Applicative (..)) import qualified Control.Monad (ap)++ import Data.Word (Word8)-import Data.Int (Int64)-{-# LINE 25 "templates/wrappers.hs" #-}+{-# LINE 28 "templates/wrappers.hs" #-} import Data.Char (ord) import qualified Data.Bits@@ -173,11 +180,11 @@ in p' `seq` Just (b, (p', c, bs, s)) -{-# LINE 98 "templates/wrappers.hs" #-}+{-# LINE 101 "templates/wrappers.hs" #-} -{-# LINE 116 "templates/wrappers.hs" #-}+{-# LINE 119 "templates/wrappers.hs" #-} -{-# LINE 134 "templates/wrappers.hs" #-}+{-# LINE 137 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions@@ -250,7 +257,7 @@ m >>= k = Alex $ \s -> case unAlex m s of Left msg -> Left msg Right (s',a) -> unAlex (k a) s'- return a = Alex $ \s -> Right (s,a)+ return = App.pure alexGetInput :: Alex AlexInput alexGetInput@@ -317,21 +324,21 @@ -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 371 "templates/wrappers.hs" #-}+{-# LINE 374 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 398 "templates/wrappers.hs" #-}+{-# LINE 401 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 418 "templates/wrappers.hs" #-}+{-# LINE 421 "templates/wrappers.hs" #-} -{-# LINE 434 "templates/wrappers.hs" #-}+{-# LINE 437 "templates/wrappers.hs" #-} -- -----------------------------------------------------------------------------@@ -339,13 +346,13 @@ -- Adds text positions to the basic model. -{-# LINE 451 "templates/wrappers.hs" #-}+{-# LINE 454 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 467 "templates/wrappers.hs" #-}+{-# LINE 470 "templates/wrappers.hs" #-} -- -----------------------------------------------------------------------------@@ -515,6 +522,11 @@ # 1 "/usr/include/stdc-predef.h" 1 3 4 # 17 "/usr/include/stdc-predef.h" 3 4+++++
dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs view
@@ -89,6 +89,11 @@ +++++ {-# LINE 9 "<command-line>" #-} {-# LINE 1 "/usr/lib/ghc/include/ghcversion.h" #-} @@ -116,11 +121,13 @@ -- This code is in the PUBLIC DOMAIN; you may copy it freely and use -- it for any purpose whatsoever. -import Control.Applicative (Applicative (..))++import Control.Applicative as App (Applicative (..)) import qualified Control.Monad (ap)++ import Data.Word (Word8)-import Data.Int (Int64)-{-# LINE 25 "templates/wrappers.hs" #-}+{-# LINE 28 "templates/wrappers.hs" #-} import Data.Char (ord) import qualified Data.Bits@@ -173,11 +180,11 @@ in p' `seq` Just (b, (p', c, bs, s)) -{-# LINE 98 "templates/wrappers.hs" #-}+{-# LINE 101 "templates/wrappers.hs" #-} -{-# LINE 116 "templates/wrappers.hs" #-}+{-# LINE 119 "templates/wrappers.hs" #-} -{-# LINE 134 "templates/wrappers.hs" #-}+{-# LINE 137 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Token positions@@ -250,7 +257,7 @@ m >>= k = Alex $ \s -> case unAlex m s of Left msg -> Left msg Right (s',a) -> unAlex (k a) s'- return a = Alex $ \s -> Right (s,a)+ return = App.pure alexGetInput :: Alex AlexInput alexGetInput@@ -317,21 +324,21 @@ -- ----------------------------------------------------------------------------- -- Monad (with ByteString input) -{-# LINE 371 "templates/wrappers.hs" #-}+{-# LINE 374 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper -{-# LINE 398 "templates/wrappers.hs" #-}+{-# LINE 401 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Basic wrapper, ByteString version -{-# LINE 418 "templates/wrappers.hs" #-}+{-# LINE 421 "templates/wrappers.hs" #-} -{-# LINE 434 "templates/wrappers.hs" #-}+{-# LINE 437 "templates/wrappers.hs" #-} -- -----------------------------------------------------------------------------@@ -339,13 +346,13 @@ -- Adds text positions to the basic model. -{-# LINE 451 "templates/wrappers.hs" #-}+{-# LINE 454 "templates/wrappers.hs" #-} -- ----------------------------------------------------------------------------- -- Posn wrapper, ByteString version -{-# LINE 467 "templates/wrappers.hs" #-}+{-# LINE 470 "templates/wrappers.hs" #-} -- -----------------------------------------------------------------------------@@ -515,6 +522,11 @@ # 1 "/usr/include/stdc-predef.h" 1 3 4 # 17 "/usr/include/stdc-predef.h" 3 4+++++
hokey.hs view
@@ -19,9 +19,13 @@ {-# LANGUAGE DeriveFunctor, DeriveGeneric, FlexibleInstances #-} import HOpenPGP.Tools.Common (banner, versioner, warranty)+import HOpenPGP.Tools.HKP (fetchKeys, FetchValidationMethod(..), rearmorKeys)+import HOpenPGP.Tools.TKUtils (processTK)+import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA import Codec.Encryption.OpenPGP.Expirations (getKeyExpirationTimesFromSignature) import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID) import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize, pkalgoAbbrev)+import Codec.Encryption.OpenPGP.KeySelection (parseFingerprint) import Codec.Encryption.OpenPGP.Serialize () import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types@@ -29,6 +33,7 @@ import Control.Arrow ((***), second) import Control.Error.Util (hush) import Control.Lens ((^.), (&), _1, _2, mapped, over)+import Control.Monad.Trans.Except (runExceptT) import Control.Monad.Trans.Resource (runResourceT) import Control.Monad.Trans.Writer.Lazy (execWriter, tell) import qualified Crypto.Hash.SHA3 as SHA3@@ -57,11 +62,11 @@ import qualified Data.Yaml as Y import GHC.Generics -import Options.Applicative.Builder (auto, command, footerDoc, headerDoc, helpDoc, info, long, metavar, prefs, progDesc, showDefault, showHelpOnError, option, subparser, value)+import Options.Applicative.Builder (argument, auto, command, eitherReader, footerDoc, headerDoc, help, helpDoc, info, long, metavar, prefs, progDesc, showDefault, showHelpOnError, option, subparser, str, value) import Options.Applicative.Extra (customExecParser, helper) import Options.Applicative.Types (Parser) -import System.IO (Handle, hFlush, stderr, stdin, stdout, hSetBuffering, BufferMode(..))+import System.IO (Handle, hFlush, hPutStrLn, stderr, stdin, stdout, hSetBuffering, BufferMode(..)) import Data.Time.Locale.Compat (defaultTimeLocale) import qualified Text.PrettyPrint.ANSI.Leijen as PPAL@@ -155,7 +160,7 @@ } where processedOrOrig = either (const key) id processedTK- processedTK = verifyTKWith (verifySigWith (verifyAgainstKeys [key])) (fmap posixSecondsToUTCTime mpt) . stripOlderSigs . stripOtherSigs $ key+ processedTK = processTK mpt key kasIt :: PKPayload -> KAS kasIt pkp = KAS { pubkeyalgo = pkp^.pkalgo & colorizePKA@@ -193,15 +198,6 @@ isCT _ = False sigcts (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs alleged = filter (\x -> ((==) <$> sigissuer x <*> eoki (key^.tkKey._1)) == Just True)- newest = take 1 . sortBy (comparing (Down . take 1 . sigcts)) -- FIXME: this is terrible- stripOtherSigs tk = tk {- _tkUIDs = map (second alleged) (_tkUIDs tk)- , _tkUAts = map (second alleged) (_tkUAts tk)- }- stripOlderSigs tk = tk {- _tkUIDs = map (second newest) (_tkUIDs tk)- , _tkUAts = map (second newest) (_tkUAts tk)- } uatspsToText = T.pack . uatspsToString uatspsToString us = "<uat:[" ++ intercalate "," (map uaspToString us) ++ "]>" uaspToString (ImageAttribute hdr d) = hdrToString hdr ++ ':':show (BL.length d) ++ ':':BC8.unpack (Base16.encode (SHA3.hashlazy 48 d))@@ -327,8 +323,14 @@ lintOutputFormat :: LintOutputFormat } -data Command = CmdLint LintOptions | CmdCanonicalize+data FetchOptions = FetchOptions {+ keyServer :: String+ , fetchValidation :: FetchValidationMethod+ , fetchQuery :: TwentyOctetFingerprint+} +data Command = CmdLint LintOptions | CmdCanonicalize | CmdFetch FetchOptions+ lintO :: Parser LintOptions lintO = LintOptions <$> option auto@@ -342,8 +344,30 @@ ofHelp = helpDoc . Just $ PPAL.text "output format" <> PPAL.hardline <> PPAL.list (map (PPAL.text . show) ofchoices) ofchoices = [minBound..maxBound] :: [LintOutputFormat] +fetchO :: Parser FetchOptions+fetchO = FetchOptions+ <$> option str+ ( long "keyserver"+ <> metavar "URL"+ <> value "http://pool.sks-keyservers.net:11371"+ <> showDefault+ <> help "HKP server"+ )+ <*> option auto+ ( long "validation-method"+ <> metavar "METHOD"+ <> value MatchPrimaryKeyFingerprint+ <> showDefault+ <> vmHelp+ )+ <*> argument (eitherReader strToFP) ( metavar "FINGERPRINT" )+ where+ vmHelp = helpDoc . Just $ PPAL.text "validation method" <> PPAL.hardline <> PPAL.list (map (PPAL.text . show) vmchoices)+ vmchoices = [minBound..maxBound] :: [FetchValidationMethod]+ strToFP = parseFingerprint . T.pack dispatch :: Command -> IO ()+dispatch (CmdFetch o) = banner' stderr >> hFlush stderr >> doFetch o dispatch (CmdLint o) = banner' stderr >> hFlush stderr >> doLint o dispatch (CmdCanonicalize) = banner' stderr >> hFlush stderr >> doCanonicalize @@ -355,6 +379,7 @@ cmd :: Parser Command cmd = subparser ( command "canonicalize" (info ( pure CmdCanonicalize) ( progDesc "arrange key components in a canonical ordering" ))+ <> command "fetch" (info ( CmdFetch <$> fetchO) ( progDesc "fetch key(s) from keyserver" )) <> command "lint" (info ( CmdLint <$> lintO) ( progDesc "check key(s) for 'best practices'" )) ) @@ -381,6 +406,13 @@ (indepthsort s) indepthsort :: (Ord a, Ord b) => [(a,[b])] -> [(a,[b])] indepthsort = nub . sort . over (mapped._2) sort++doFetch :: FetchOptions -> IO ()+doFetch o = do+ ekeys <- runExceptT $ fetchKeys (keyServer o) (fetchValidation o) (fetchQuery o)+ case ekeys of+ Left e -> hPutStrLn stderr $ "error fetching keys: " ++ e+ Right ks -> B.putStr $ rearmorKeys ks banner' :: Handle -> IO () banner' h = PPAL.hPutDoc h (banner "hokey" <> PPAL.hardline <> warranty "hokey" <> PPAL.hardline)
hopenpgp-tools.cabal view
@@ -1,5 +1,5 @@ name: hopenpgp-tools-version: 0.18+version: 0.19 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: http://floss.scru.org/hopenpgp-tools@@ -46,6 +46,8 @@ main-is: hokey.hs ghc-options: -Wall other-modules: HOpenPGP.Tools.Common+ , HOpenPGP.Tools.HKP+ , HOpenPGP.Tools.TKUtils build-depends: base > 4 && < 5 , aeson , ansi-wl-pprint >= 0.6.7@@ -61,9 +63,13 @@ , directory , errors , hOpenPGP >= 2.4.1+ , http-client+ , http-client-tls+ , http-types , ixset-typed , lens , monad-loops+ , openpgp-asciiarmor , optparse-applicative >= 0.11.0 , resourcet , text@@ -120,4 +126,4 @@ source-repository this type: git location: git://git.debian.org/users/clint/hopenpgp-tools.git- tag: hopenpgp-tools/0.18+ tag: hopenpgp-tools/0.19