HKP.hs

-- HKP.hs: hOpenPGP key tool
-- Copyright © 2016-2020  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 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 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 (conduitToTKsDropping)
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Data.Lens (biplate)
import Data.Either (rights)
import Data.Monoid ((<>), mempty)
import Data.Text.Prettyprint.Doc (pretty)
import Data.Time.Clock.POSIX (getPOSIXTime)
import HOpenPGP.Tools.TKUtils (processTK)
import Network.HTTP.Client
  ( Response(..)
  , httpLbs
  , newManager
  , parseUrlThrow
  , setQueryString
  )
import Network.HTTP.Client.TLS (tlsManagerSettings)
import Network.HTTP.Types.Status (ok200)

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