-- KeySelection.hs: OpenPGP (RFC9580) ways to ask for keys
-- Copyright © 2014-2026  Clint Adams
-- This software is released under the terms of the Expat license.
-- (See the LICENSE file).
{-# LANGUAGE OverloadedStrings #-}

module Codec.Encryption.OpenPGP.KeySelection
    ( parseEightOctetKeyId
    , parseFingerprint
    ) where

import Control.Applicative (optional, (<|>))
import Crypto.Number.Serialize (i2osp)
import Data.Attoparsec.Text
    ( Parser
    , asciiCI
    , count
    , hexadecimal
    , inClass
    , parseOnly
    , satisfy
    )
import Data.Bifunctor (bimap)
import qualified Data.ByteString as B
import Data.Text (Text, toUpper)
import qualified Data.Text as T

import Codec.Encryption.OpenPGP.Types

parseEightOctetKeyId
    :: Text -> Either KeySelectionError EightOctetKeyId
parseEightOctetKeyId :: Text -> Either KeySelectionError EightOctetKeyId
parseEightOctetKeyId Text
input =
    let upper :: Text
upper = Text -> Text
toUpper Text
input
     in (String -> KeySelectionError)
-> (ByteString -> EightOctetKeyId)
-> Either String ByteString
-> Either KeySelectionError EightOctetKeyId
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
            (KeySelectionError -> String -> KeySelectionError
forall a b. a -> b -> a
const (Text -> KeySelectionError
KeySelectionParseError Text
upper))
            ByteString -> EightOctetKeyId
EightOctetKeyId
            (Parser Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
parseOnly (Parser (Maybe Text)
hexPrefix Parser (Maybe Text) -> Parser Text -> Parser Text
forall a b. Parser Text a -> Parser Text b -> Parser Text b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Int -> Parser Text
hexen Int
16) Text
upper Either String Text
-> (Text -> Either String ByteString) -> Either String ByteString
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser ByteString -> Text -> Either String ByteString
forall a. Parser a -> Text -> Either String a
parseOnly Parser ByteString
hexes)

parseFingerprint :: Text -> Either KeySelectionError Fingerprint
parseFingerprint :: Text -> Either KeySelectionError Fingerprint
parseFingerprint Text
input =
    let filtered :: Text
filtered = Text -> Text
toUpper ((Char -> Bool) -> Text -> Text
T.filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
' ') Text
input)
     in (String -> KeySelectionError)
-> (ByteString -> Fingerprint)
-> Either String ByteString
-> Either KeySelectionError Fingerprint
forall a b c d. (a -> b) -> (c -> d) -> Either a c -> Either b d
forall (p :: * -> * -> *) a b c d.
Bifunctor p =>
(a -> b) -> (c -> d) -> p a c -> p b d
bimap
            (KeySelectionError -> String -> KeySelectionError
forall a b. a -> b -> a
const (Text -> KeySelectionError
KeySelectionParseError Text
filtered))
            ByteString -> Fingerprint
Fingerprint
            ( Parser Text -> Text -> Either String Text
forall a. Parser a -> Text -> Either String a
parseOnly (Int -> Parser Text
hexen Int
64 Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Text
hexen Int
40 Parser Text -> Parser Text -> Parser Text
forall a. Parser Text a -> Parser Text a -> Parser Text a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Int -> Parser Text
hexen Int
32) Text
filtered
                Either String Text
-> (Text -> Either String ByteString) -> Either String ByteString
forall a b.
Either String a -> (a -> Either String b) -> Either String b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Parser ByteString -> Text -> Either String ByteString
forall a. Parser a -> Text -> Either String a
parseOnly Parser ByteString
hexes
            )

hexPrefix :: Parser (Maybe Text)
hexPrefix :: Parser (Maybe Text)
hexPrefix = Parser Text -> Parser (Maybe Text)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional (Text -> Parser Text
asciiCI Text
"0x")

hexen :: Int -> Parser Text
hexen :: Int -> Parser Text
hexen Int
n = String -> Text
T.pack (String -> Text) -> Parser Text String -> Parser Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Int -> Parser Text Char -> Parser Text String
forall (m :: * -> *) a. Monad m => Int -> m a -> m [a]
count Int
n ((Char -> Bool) -> Parser Text Char
satisfy (String -> Char -> Bool
inClass String
"A-F0-9"))

hexes :: Parser B.ByteString
hexes :: Parser ByteString
hexes = Integer -> ByteString
forall ba. ByteArray ba => Integer -> ba
i2osp (Integer -> ByteString) -> Parser Text Integer -> Parser ByteString
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser Text Integer
forall a. (Integral a, Bits a) => Parser a
hexadecimal