-- hop.hs: hOpenPGP-stateless OpenPGP (sop) tool
-- Copyright © 2019 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 DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE RecordWildCards #-}
import Paths_hopenpgp_tools (version)
import HOpenPGP.Tools.Common (banner, versioner, warranty, keyMatchesFingerprint, keyMatchesEightOctetKeyId, keyMatchesUIDSubString)
import HOpenPGP.Tools.Armor (doDeArmor)
import HOpenPGP.Tools.Parser (parseTKExp)
import qualified Codec.Encryption.OpenPGP.ASCIIArmor as AA
import Codec.Encryption.OpenPGP.ASCIIArmor.Types (Armor(..), ArmorType(..))
import Codec.Encryption.OpenPGP.Fingerprint (fingerprint, eightOctetKeyID)
import Codec.Encryption.OpenPGP.Serialize ()
import Codec.Encryption.OpenPGP.Signatures (crossSignSubkeyWithRSA, signUserIDwithRSA, verifyTKWith, verifySigWith, verifyAgainstKeyring)
import Codec.Encryption.OpenPGP.Types
import Control.Error.Util (note)
import Control.Applicative (optional, some, (<|>))
import Control.Arrow ((&&&))
import Control.Lens ((^.), _1, _2, (^..))
import Control.Monad.IO.Class (liftIO, MonadIO)
import Control.Monad.Trans.Resource (MonadResource, MonadThrow)
import Control.Monad.State.Lazy (evalStateT, get, modify, MonadState, StateT)
import qualified Crypto.PubKey.RSA as RSA
import qualified Data.Aeson as A
import qualified Data.Binary as Bin
import Data.Binary.Get (runGet)
import Data.Binary.Put (runPut)
import qualified Data.ByteString as B
import qualified Data.ByteString.Lazy as BL
import qualified Data.ByteString.Lazy.Char8 as BLC8
import Data.Conduit ((.|), ConduitM, runConduitRes)
import qualified Data.Conduit.Binary as CB
import qualified Data.Conduit.Combinators as CC
import qualified Data.Conduit.List as CL
import Data.Conduit.Serialization.Binary (conduitGet)
import Data.Conduit.OpenPGP.Keyring (conduitToTKs, conduitToTKsDropping, sinkKeyringMap)
import Data.Conduit.OpenPGP.Verify (conduitVerify)
import Data.Data.Lens (biplate)
import Data.Either (fromRight, isRight, rights)
import Data.Maybe (fromMaybe, mapMaybe, listToMaybe)
import Data.Monoid ((<>))
import qualified Data.Set as S
import Data.Text (Text)
import qualified Data.Text as T
import qualified Data.Text.Lazy.IO as TLIO
import Data.Time.Clock.POSIX (getPOSIXTime, posixSecondsToUTCTime, POSIXTime)
import qualified Data.Vector as V
import Data.Version (showVersion)
import qualified Data.Yaml as Y
import GHC.Generics
import System.Directory (getHomeDirectory)
import System.Exit (exitFailure, exitSuccess)
import Options.Applicative.Builder (argument, auto, command, eitherReader, footerDoc, headerDoc, help, helpDoc, info, long, metavar, option, prefs, progDesc, short, showDefault, showHelpOnError, str, strArgument, strOption, switch, value)
import Options.Applicative.Extra (customExecParser, helper, hsubparser)
import Options.Applicative.Types (Parser)
import System.IO (BufferMode(..), Handle, hFlush, hSetBuffering, stderr, stdin)
import Data.Text.Prettyprint.Doc ((<+>), fillSep, hardline, list, pretty, softline)
import Data.Text.Prettyprint.Doc.Render.Text (putDoc, hPutDoc)
import Data.Text.Prettyprint.Convert.AnsiWlPprint (toAnsiWlPprint)
data Command = VersionC
| GenerateKeyC KeyGenOptions
| ExtractCertC ExtractCertOptions
| DeArmorC
| ArmorC ArmoringOptions
data Options = Options {
keyrings :: [String]
, outputFormat :: OutputFormat
, sigFilter :: String
, sigFile :: String
, blobFile :: String
}
data OutputFormat = Unstructured | JSON | YAML
deriving (Eq, Read, Show)
o :: Parser Options
o = Options
<$> some (strOption
( long "keyring"
<> short 'k'
<> metavar "FILE"
<> help "file containing keyring" ))
<*> option auto
( long "output-format"
<> metavar "FORMAT"
<> value Unstructured
<> showDefault
<> help "output format" )
<*> option auto
( long "signature-filter"
<> metavar "SIGFILTER"
<> value "sigcreationtime < now"
<> showDefault
<> help "verify only signatures which match filter spec" )
<*> argument str ( metavar "SIGNATURE" <> sigHelp )
<*> argument str ( metavar "BLOB" <> blobHelp )
where
sigHelp = helpDoc . Just . toAnsiWlPprint $ pretty "file containing OpenPGP binary signatures"
blobHelp = helpDoc . Just . toAnsiWlPprint $ pretty "file containing binary blob to be validated"
dispatch :: POSIXTime -> Command -> IO ()
dispatch cpt o = banner' stderr >> hFlush stderr >> dispatch' cpt o
where
dispatch' _ VersionC = doVersion
dispatch' t (GenerateKeyC o) = doGenerateKey t o
dispatch' _ (ExtractCertC o) = doExtractCert o
dispatch' _ DeArmorC = doDeArmor
dispatch' _ (ArmorC o) = doArmor o
main :: IO ()
main = do
hSetBuffering stderr LineBuffering
cpt <- getPOSIXTime
customExecParser (prefs showHelpOnError)
(info (helper <*> versioner "hop" <*> cmd)
(headerDoc (Just (toAnsiWlPprint (banner "hop")))
<> progDesc "hOpenPGP Validator Tool"
<> footerDoc (Just (toAnsiWlPprint (warranty "hop"))))) >>= dispatch cpt
banner' :: Handle -> IO ()
banner' h = hPutDoc h (banner "hop" <> hardline <> warranty "hop" <> hardline)
data Vrf = Vrf {
_vrfmsg :: String
, _vrfmfpr :: Maybe TwentyOctetFingerprint
} deriving (Eq, Generic, Show)
instance A.ToJSON Vrf
doV :: POSIXTime -> Options -> IO ()
doV cpt o = do
let allkfiles = sequence_ (map CC.sourceFile (keyrings o))
krs <- runConduitRes $ allkfiles .| conduitGet Bin.get .| conduitToTKsDropping .| sinkKeyringMap
sigs <- runConduitRes $ CC.sourceFile (sigFile o) .| conduitGet Bin.get .| CC.filter v4b .| CC.sinkVector
blob <- runConduitRes $ CC.sourceFile (blobFile o) .| CC.sinkLazy
verifications <- runConduitRes $ CC.yieldMany (V.cons (LiteralDataPkt BinaryData mempty 0 blob) sigs) .| conduitVerify krs Nothing .| CC.sinkList
let verifications' = map v2v verifications
case outputFormat o of
Unstructured -> mapM_ print verifications'
JSON -> BL.putStr . A.encode $ verifications'
YAML -> B.putStr . Y.encode $ verifications'
putStrLn ""
case any isRight verifications of
True -> exitSuccess
_ -> exitFailure
where
v4b (SignaturePkt s@(SigV4 BinarySig _ _ _ _ _ _)) = sf s
v4b _ = False
v2v (Left l) = Vrf l Nothing
v2v (Right v) = Vrf "verified signature" (Just (fingerprint (_verificationSigner v)))
sf = const True
cmd :: Parser Command
cmd = hsubparser
( command "armor" (info ( ArmorC <$> aoP ) ( progDesc "Armor stdin to stdout" ))
<> command "dearmor" (info ( pure DeArmorC ) ( progDesc "Dearmor stdin to stdout" ))
<> command "extract-cert" (info ( ExtractCertC <$> ecoP ) ( progDesc "Extract a certificate from a secret key and output it to stdout" ))
<> command "generate-key" (info ( GenerateKeyC <$> gkoP ) ( progDesc "Generate a secret key and output it to stdout" ))
<> command "version" (info ( pure VersionC ) ( progDesc "output hop version to stdout" ))
)
armorTypes :: [(String, Maybe ArmorType)]
armorTypes = [
("auto", Nothing)
, ("sig", Just ArmorSignature)
, ("key", Just ArmorPrivateKeyBlock)
, ("cert", Just ArmorPublicKeyBlock)
, ("message", Just ArmorMessage)
]
armorTypeReader :: String -> Either String (Maybe ArmorType)
armorTypeReader = note "unknown armor type" . flip lookup armorTypes
aoP :: Parser ArmoringOptions
aoP = ArmoringOptions
<$> option (eitherReader armorTypeReader) (long "label" <> metavar "LABEL" <> armortypeHelp)
<*> switch (long "allow-nested" <> help "do the sane thing and unconditionally armor the output")
where
armortypeHelp = helpDoc . Just . toAnsiWlPprint $ pretty "ASCII armor type" <> softline <> list (map (pretty . fst) armorTypes)
data ArmoringOptions = ArmoringOptions {
label :: Maybe ArmorType
, allowNested :: Bool
}
doArmor :: ArmoringOptions -> IO ()
doArmor ArmoringOptions{..} = do
m <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
let lbs = BL.fromChunks m
armoredAlready = BLC8.pack "-----BEGIN PGP" == BL.take 14 lbs
label' = guessLabel label (decodeFirstPacket lbs)
a = Armor label' [] lbs
BL.putStr $ if armoredAlready && not allowNested then lbs else AA.encodeLazy [a]
where
decodeFirstPacket = runGet Bin.get
guessLabel (Just l) _ = l
guessLabel Nothing (SignaturePkt _) = ArmorSignature
guessLabel Nothing (SecretKeyPkt _ _) = ArmorPrivateKeyBlock
guessLabel Nothing (PublicKeyPkt _) = ArmorPublicKeyBlock
guessLabel Nothing _ = ArmorMessage
doVersion :: IO ()
doVersion = putStrLn $ "hop " ++ showVersion version
gkoP :: Parser KeyGenOptions
gkoP = KeyGenOptions
<$> switch (long "armor" <> help "armor the output")
<*> switch (long "no-armor" <> help "don't armor the output")
<*> strArgument (metavar "USERID" <> help "User ID associated with this key")
data KeyGenOptions = KeyGenOptions {
armor :: Bool
, noArmor :: Bool
, userId :: String
}
doGenerateKey :: POSIXTime -> KeyGenOptions -> IO ()
doGenerateKey pt KeyGenOptions{..} = do
let ts = ThirtyTwoBitTimeStamp (floor pt)
sk <- generateSecretKey ts RSA
s <- buildKeyWith sk $ do
addUserId ts True (T.pack userId)
addSubkey ts [EncryptStorageKey, EncryptCommunicationsKey]
addSubkey ts [SignDataKey]
addSubkey ts [AuthKey]
newkey <- get
return newkey
let lbs = runPut $ Bin.put s
BL.putStr $ if not armor && not noArmor then AA.encodeLazy [Armor ArmorPrivateKeyBlock [] lbs] else lbs
type KeyBuilder = StateT TK IO
buildKeyWith :: SecretKey -> KeyBuilder a -> IO a
buildKeyWith sk a = evalStateT a (bareTK sk)
where
bareTK (SecretKey pkp ska) = TK (pkp, Just ska) [] [] [] []
generateSecretKey :: ThirtyTwoBitTimeStamp -> PubKeyAlgorithm -> IO SecretKey
generateSecretKey ts RSA = do
(pub, priv) <- liftIO $ RSA.generate 512 0x10001
return $ SecretKey (pkp pub) (ska priv)
where
pkp pub = PKPayload V4 ts 0 RSA (RSAPubKey (RSA_PublicKey pub))
ska priv = SUUnencrypted (RSAPrivateKey (RSA_PrivateKey priv)) 0 -- FIXME: calculate checksum
addUserId :: ThirtyTwoBitTimeStamp -> Bool -> Text -> KeyBuilder ()
addUserId ts primary userid = modify (newUID userid)
where
newUID u tk = tk { _tkUIDs = _tkUIDs tk ++ [selfsign (_tkKey tk) u] }
selfsign (pkp, Just ska) u = (u, [fromRight undefined (signUserIDwithRSA pkp (UserId u) (hashed pkp) (unhashed pkp) (skey ska))])
hashed pkp = [
SigSubPacket False (SigCreationTime ts)
, SigSubPacket False (IssuerFingerprint 4 (fingerprint pkp))
, SigSubPacket False (KeyFlags (S.singleton CertifyKeysKey))
, SigSubPacket False (PrimaryUserId primary)
, SigSubPacket False (PreferredHashAlgorithms [SHA512, SHA256, SHA384, SHA224])
, SigSubPacket False (PreferredSymmetricAlgorithms [AES256, AES192, AES128])
]
unhashed pkp = [
SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))
]
skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = k
addSubkey :: ThirtyTwoBitTimeStamp -> [KeyFlag] -> KeyBuilder ()
addSubkey ts keyflags = do
tk <- get
(SecretKey subpkp subska) <- liftIO $ generateSecretKey ts RSA
let (pkp, Just ska) = _tkKey tk
Right crossig = crossSignSubkeyWithRSA pkp subpkp (hashed pkp) [] [] [] (skey ska) (skey subska)
modify (addIt subpkp subska crossig)
where
skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = k
addIt sp ss cross tk = tk { _tkSubs = _tkSubs tk ++ [(SecretSubkeyPkt sp ss, [cross])] }
hashed pkp = [
SigSubPacket False (SigCreationTime ts)
, SigSubPacket False (IssuerFingerprint 4 (fingerprint pkp))
, SigSubPacket False (KeyFlags (S.fromList keyflags))
]
ecoP :: Parser ExtractCertOptions
ecoP = ExtractCertOptions
<$> switch (long "armor" <> help "armor the output")
<*> switch (long "no-armor" <> help "don't armor the output")
data ExtractCertOptions = ExtractCertOptions {
ecArmor :: Bool
, ecNoArmor :: Bool
}
doExtractCert :: ExtractCertOptions -> IO ()
doExtractCert ExtractCertOptions{..} = do
kbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume
let lbs = BL.fromChunks kbs
isArmored = BLC8.pack "-----BEGIN PGP PRIVATE KEY BLOCK-----" == BL.take 37 lbs
Right [Armor ArmorPrivateKeyBlock _ decoded] = AA.decodeLazy lbs :: Either String [Armor]
lbs' = if isArmored then decoded else lbs
k <- runConduitRes $ CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToTKs .| CL.take 1
let output = runPut $ Bin.put (pubToSecret (head k))
BL.putStr $ if not ecArmor && not ecNoArmor then AA.encodeLazy [Armor ArmorPublicKeyBlock [] output] else output
where
pubToSecret tk = tk { _tkKey = pToS (_tkKey tk), _tkSubs = map subPToS (_tkSubs tk) }
pToS (pkp, _) = (pkp, Nothing)
subPToS (SecretSubkeyPkt pkp _, sigs) = (PublicSubkeyPkt pkp, sigs)