-- HKP.hs: hOpenPGP key tool
-- Copyright © 2016-2018 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 Data.Binary (get, put)
import qualified Data.ByteString.Char8 as BC8
import Data.Conduit ((.|), runConduitRes)
import qualified Data.Conduit.Binary as CB
import Data.Conduit.OpenPGP.Keyring (conduitToTKsDropping)
import Data.Conduit.Serialization.Binary (conduitGet)
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, parseUrlThrow, Response(..), setQueryString)
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
import Data.Text.Prettyprint.Doc (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 $ parseUrlThrow (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 <- liftIO . runConduitRes $ 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