HKP.hs

-- HKP.hs: hOpenPGP key tool
-- Copyright © 2016-2026  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.Common.HKP
    ( fetchKeys
    , FetchValidationMethod (..)
    , rearmorKeys
    ) where

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 (..)
    , Fingerprint
    , TKUnknown (..)
    )
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 Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Char8 as BC8
import qualified Data.ByteString.Lazy as BL
import Data.Conduit (runConduitRes, (.|))
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.List as CL
import Data.Conduit.OpenPGP.Keyring (conduitToTKsDroppingEither)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
import Data.Time.Clock.POSIX (getPOSIXTime)
import Network.HTTP.Client
    ( Response (..)
    , httpLbs
    , newManager
    , parseUrlThrow
    , setQueryString
    )
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)
import Prettyprinter (pretty)

import HOpenPGP.Tools.Common.TKUtils (processTK)

data FetchValidationMethod
    = MatchPrimaryKeyFingerprint
    | MatchPrimaryOrAnySubkeyFingerprint
    | AnySelfSigned
    deriving (Bounded, Enum, Eq, Read, Show)

fetchKeys
    :: String
    -> FetchValidationMethod
    -> Fingerprint
    -> ExceptT String IO [TKUnknown]
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 . _tkuKey . snd) processedKeys
  where
    fvp MatchPrimaryKeyFingerprint k = fingerprint k == q
    fvp MatchPrimaryOrAnySubkeyFingerprint k' =
        any (\k'' -> fingerprint k'' == q) (k' ^.. biplate)
    fvp AnySelfSigned _ = 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 [(TKUnknown, TKUnknown)] -- FIXME: conduit fail
validateKeys larmors = do
    bytestrings <-
        ExceptT $
            return $
                fmap (mconcat . map armorToBS) (AA.decodeLazy larmors)
    keys <-
        liftIO . runConduitRes $
            CB.sourceLbs bytestrings
                .| conduitGet get
                .| conduitToTKsDroppingEither
                .| CL.mapMaybe (either (const Nothing) id)
                .| CL.consume
    cpt <- liftIO getPOSIXTime
    return . rights $
        map (uncurry (liftA2 (,)) . (pure &&& processTK (Just cpt))) keys
  where
    armorToBS (Armor ArmorPublicKeyBlock _ bs) = bs
    armorToBS _ = mempty

rearmorKeys :: [TKUnknown] -> B.ByteString
rearmorKeys keys =
    if null keys
        then mempty
        else
            AA.encode
                . return
                . Armor ArmorPublicKeyBlock [("Comment", "filtered by hokey")]
                . runPut
                . put
                . Block
                $ keys