-- Common.hs: hOpenPGP-tools common functions
-- Copyright © 2012-2022  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/>.
module HOpenPGP.Tools.Common
  ( banner
  , versioner
  , warranty
  , prependAuto
  , keyMatchesFingerprint
  , keyMatchesEightOctetKeyId
  , keyMatchesExactUIDString
  , keyMatchesUIDSubString
  , keyMatchesPKPred
  -- hmm
  , pkpGetPKVersion
  , pkpGetPKAlgo
  , pkpGetKeysize
  , pkpGetTimestamp
  , pkpGetFingerprint
  , pkpGetEOKI
  , tkUsingPKP
  , pUsingPKP
  , pUsingSP
  , tkGetUIDs
  , tkGetSubs
  , anyOrAll
  , anyReader
  , oGetTag
  , oGetLength
  , spGetSigVersion
  , spGetSigType
  , spGetPKAlgo
  , spGetHashAlgo
  , spGetSCT
  , maybeR
  ) where

import Data.Version (showVersion)
import Paths_hopenpgp_tools (version)

import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.SignatureQualities (sigCT)
import Codec.Encryption.OpenPGP.Types
import Control.Lens ((^..))
import Data.Binary (put)
import Data.Binary.Put (runPut)
import qualified Data.ByteString.Lazy as BL
import Data.Data.Lens (biplate)
import Data.Text (Text)
import qualified Data.Text as T
import Options.Applicative.Builder (auto, help, hidden, infoOption, long, short)
import Options.Applicative.Types (Parser, ReadM(..))
import Prettyprinter (Doc, (<+>), hardline, pretty)

import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Control.Error.Util (hush)
import Control.Monad.Trans.Reader
  ( Reader
  , ReaderT
  , ask
  , local
  , reader
  , runReader
  , withReader
  )
-- hmm --
import Data.Maybe (fromMaybe, mapMaybe)

banner :: String -> Doc ann
{-# INLINE banner #-}
banner name =
  pretty name <+>
  pretty "(hopenpgp-tools)" <+>
  pretty (showVersion version) <>
  hardline <> pretty "Copyright (C) 2012-2021  Clint Adams"

warranty :: String -> Doc ann
{-# INLINE warranty #-}
warranty name =
  pretty name <+>
  pretty "comes with ABSOLUTELY NO WARRANTY." <+>
  pretty "This is free software, and you are welcome to redistribute it" <+>
  pretty "under certain conditions."

versioner :: String -> Parser (a -> a)
{-# INLINE versioner #-}
versioner name =
  infoOption (name ++ " (hopenpgp-tools) " ++ showVersion version) $
  long "version" <> short 'V' <> help "Show version information" <> hidden

prependAuto :: Read a => String -> ReadM a
prependAuto s = ReadM (local (s ++) (unReadM auto))

keyMatchesFingerprint :: Bool -> TK -> TwentyOctetFingerprint -> Bool
keyMatchesFingerprint = keyMatchesPKPred fingerprint

keyMatchesEightOctetKeyId :: Bool -> TK -> Either String EightOctetKeyId -> Bool -- FIXME: refactor this somehow
keyMatchesEightOctetKeyId = keyMatchesPKPred eightOctetKeyID

keyMatchesExactUIDString :: Text -> TK -> Bool
keyMatchesExactUIDString uidstr = elem uidstr . map fst . _tkUIDs

keyMatchesUIDSubString :: Text -> TK -> Bool
keyMatchesUIDSubString uidstr =
  any (T.toLower uidstr `T.isInfixOf`) . map (T.toLower . fst) . _tkUIDs

keyMatchesPKPred :: Eq a => (PKPayload -> a) -> Bool -> TK -> a -> Bool
keyMatchesPKPred p False = (==) . p . fst . _tkKey
keyMatchesPKPred p True = \tk v -> elem v (map p (tk ^.. biplate))

-- The following should probably be moved elsewhere
tkUsingPKP :: Reader PKPayload a -> Reader TK a
tkUsingPKP = withReader (fst . _tkKey)

pkpGetPKVersion :: PKPayload -> Integer
pkpGetPKVersion t =
  if _keyVersion t == DeprecatedV3
    then 3
    else 4

pkpGetPKAlgo :: PKPayload -> Integer
pkpGetPKAlgo = fromIntegral . fromFVal . _pkalgo

pkpGetKeysize :: PKPayload -> Integer
pkpGetKeysize = fromIntegral . fromMaybe 0 . hush . pubkeySize . _pubkey

pkpGetTimestamp :: PKPayload -> Integer
pkpGetTimestamp = fromIntegral . _timestamp

pkpGetFingerprint :: PKPayload -> TwentyOctetFingerprint
pkpGetFingerprint = fingerprint

pkpGetEOKI :: PKPayload -> String
pkpGetEOKI = either (const "UNKNOWN") show . eightOctetKeyID

tkGetUIDs :: TK -> [Text]
tkGetUIDs = map fst . _tkUIDs

tkGetSubs :: TK -> [PKPayload]
tkGetSubs = mapMaybe (grabPKP . fst) . _tkSubs
  where
    grabPKP (PublicSubkeyPkt p) = Just p
    grabPKP (SecretSubkeyPkt p _) = Just p
    grabPKP _ = Nothing

anyOrAll ::
     (Monad m, Monad m1)
  => ((a1 -> c) -> a -> ReaderT a m b)
  -> (m1 a1 -> c)
  -> ReaderT a m b
anyOrAll aa op = ask >>= aa (op . return)

anyReader :: Reader a Bool -> Reader [a] Bool
anyReader p = any (runReader p) `fmap` ask

oGetTag :: Pkt -> Integer
oGetTag = fromIntegral . pktTag

oGetLength :: Pkt -> Integer
oGetLength = fromIntegral . BL.length . runPut . put -- FIXME: this should be a length that makes sense

spGetSigVersion :: Pkt -> Maybe Integer
spGetSigVersion (SignaturePkt s) = Just (sigVersion s)
  where
    sigVersion SigV3 {} = 3
    sigVersion SigV4 {} = 4
    sigVersion (SigVOther v _) = fromIntegral v
spGetSigVersion _ = Nothing

spGetSigType :: Pkt -> Maybe Integer
spGetSigType (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigType s)
           -- FIXME: deduplicate this and hOpenPGP .Internal
  where
    sigType :: SignaturePayload -> Maybe SigType
    sigType (SigV3 st _ _ _ _ _ _) = Just st
    sigType (SigV4 st _ _ _ _ _ _) = Just st
    sigType _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetSigType _ = Nothing

spGetPKAlgo :: Pkt -> Maybe Integer
spGetPKAlgo (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigPKA s)
  where
    sigPKA (SigV3 _ _ _ pka _ _ _) = Just pka
    sigPKA (SigV4 _ pka _ _ _ _ _) = Just pka
    sigPKA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetPKAlgo _ = Nothing

spGetHashAlgo :: Pkt -> Maybe Integer
spGetHashAlgo (SignaturePkt s) = fmap (fromIntegral . fromFVal) (sigHA s)
  where
    sigHA (SigV3 _ _ _ _ ha _ _) = Just ha
    sigHA (SigV4 _ _ ha _ _ _ _) = Just ha
    sigHA _ = Nothing -- this includes v2 sigs, which don't seem to be specified in the RFCs but exist in the wild
spGetHashAlgo _ = Nothing

spGetSCT :: Pkt -> Maybe Integer
spGetSCT (SignaturePkt s) = fmap fromIntegral (sigCT s)

pUsingPKP :: Reader (Maybe PKPayload) a -> Reader Pkt a
pUsingPKP = withReader grabPayload
  where
    grabPayload (SecretKeyPkt p _) = Just p
    grabPayload (PublicKeyPkt p) = Just p
    grabPayload (SecretSubkeyPkt p _) = Just p
    grabPayload (PublicSubkeyPkt p) = Just p
    grabPayload _ = Nothing

pUsingSP :: Reader (Maybe SignaturePayload) a -> Reader Pkt a
pUsingSP = withReader grabPayload
  where
    grabPayload (SignaturePkt s) = Just s
    grabPayload _ = Nothing

maybeR :: a -> Reader r a -> Reader (Maybe r) a
maybeR x r = reader (maybe x (runReader r))