Common.hs

-- Common.hs: hOpenPGP-tools common functions
-- Copyright © 2012-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/>.

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
  , maybeR
) where

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

import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
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.Monoid ((<>))
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 Text.PrettyPrint.ANSI.Leijen (Doc, (<+>), hardline, text)

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


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

warranty :: String -> Doc
{-# INLINE warranty #-}
warranty name = text name <+> text "comes with ABSOLUTELY NO WARRANTY." <+>
     text "This is free software, and you are welcome to redistribute it" <+>
     text "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)
    where  -- FIXME: deduplicate this and hOpenPGP .Internal
        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

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))