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-2015 Clint Adams +-- Copyright © 2012-2016 Clint Adams -- -- vim: softtabstop=4:shiftwidth=4:expandtab -- diff --git a/HOpenPGP/Tools/HKP.hs b/HOpenPGP/Tools/HKP.hs new file mode 100644 --- /dev/null +++ b/HOpenPGP/Tools/HKP.hs @@ -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 . + +{-# 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) diff --git a/HOpenPGP/Tools/TKUtils.hs b/HOpenPGP/Tools/TKUtils.hs new file mode 100644 --- /dev/null +++ b/HOpenPGP/Tools/TKUtils.hs @@ -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 . + +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 + diff --git a/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs b/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs --- a/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs +++ b/dist/build/hkt/hkt-tmp/HOpenPGP/Tools/Lexer.hs @@ -89,6 +89,11 @@ + + + + + {-# LINE 9 "" #-} {-# 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 + + + + + diff --git a/dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs b/dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs --- a/dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs +++ b/dist/build/hot/hot-tmp/HOpenPGP/Tools/Lexer.hs @@ -89,6 +89,11 @@ + + + + + {-# LINE 9 "" #-} {-# 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 + + + + + diff --git a/hokey.hs b/hokey.hs --- a/hokey.hs +++ b/hokey.hs @@ -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 = "" 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) 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.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