diff --git a/HOpenPGP/Tools/Common.hs b/HOpenPGP/Tools/Common.hs --- a/HOpenPGP/Tools/Common.hs +++ b/HOpenPGP/Tools/Common.hs @@ -46,7 +46,6 @@ , spGetSigType , spGetPKAlgo , spGetHashAlgo - , spGetSCT , maybeR ) where @@ -54,7 +53,6 @@ import Data.Version (showVersion) 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) @@ -190,9 +188,6 @@ 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 diff --git a/HOpenPGP/Tools/Lexer.x b/HOpenPGP/Tools/Lexer.x --- a/HOpenPGP/Tools/Lexer.x +++ b/HOpenPGP/Tools/Lexer.x @@ -33,7 +33,6 @@ any { lex' TokenAny } every { lex' TokenEvery } not { lex' TokenNot } - now { lex' TokenNow } one { lex' TokenOne } or { lex' TokenOr } subkey { lex' TokenSubkey } @@ -86,7 +85,6 @@ timestamp { lex' TokenTimestamp } fingerprint { lex' TokenFingerprint } keyid { lex' TokenKeyID } - [Ss]ig[Cc]reation[Tt]ime { lex' TokenSigCreationTime } $hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read) } 0x$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{9}$hexdigit{4} { lex (TokenFpr . read . drop 2) } $hexdigit{8}$hexdigit{8} { lex (TokenLongID . Right . read) } @@ -99,12 +97,9 @@ { data Token = TokenTag - | TokenAfter | TokenAnd | TokenAny - | TokenBefore | TokenNot - | TokenNow | TokenOr | TokenInt Integer | TokenEq @@ -161,7 +156,6 @@ | TokenStr String | TokenA | TokenSubkey - | TokenSigCreationTime deriving (Eq,Show) alexEOF = return TokenEOF diff --git a/HOpenPGP/Tools/Parser.y b/HOpenPGP/Tools/Parser.y --- a/HOpenPGP/Tools/Parser.y +++ b/HOpenPGP/Tools/Parser.y @@ -3,7 +3,7 @@ module HOpenPGP.Tools.Parser( parseTKExp, parsePExp ) where import Codec.Encryption.OpenPGP.Types -- import Data.Conduit.OpenPGP.Filter (Expr(..), UPredicate(..), UOp(..), OVar(..), OValue(..), SPVar(..), SPValue(..), PKPVar(..), PKPValue(..)) -import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, spGetSCT, pUsingPKP, pUsingSP, maybeR) +import HOpenPGP.Tools.Common (pkpGetPKVersion, pkpGetPKAlgo, pkpGetKeysize, pkpGetTimestamp, pkpGetFingerprint, pkpGetEOKI, tkUsingPKP, tkGetUIDs, tkGetSubs, anyOrAll, anyReader, oGetTag, oGetLength, spGetSigVersion, spGetSigType, spGetPKAlgo, spGetHashAlgo, pUsingPKP, pUsingSP, maybeR) import HOpenPGP.Tools.Lexer @@ -32,7 +32,6 @@ contains { TokenContains } every { TokenEvery } not { TokenNot } - now { TokenNow } of { TokenOf } one { TokenOne } or { TokenOr } @@ -81,7 +80,6 @@ timestamp { TokenTimestamp } fingerprint { TokenFingerprint } keyid { TokenKeyID } - sigcreationtime { TokenSigCreationTime } fpr { TokenFpr $$ } longid { TokenLongID $$ } length { TokenLength } @@ -150,7 +148,6 @@ | sigtype SIOp Ssigtypes { $2 (reader spGetSigType) (return (Just $3)) } | sigpkalgo SIOp Spkalgos { $2 (reader spGetPKAlgo) (return (Just $3)) } | hashalgo SIOp Shashalgos { $2 (reader spGetHashAlgo) (return (Just $3)) } - | sigcreationtime SIOp Stimespec { $2 (reader spGetSCT) (return (Just $3)) } SIOp : '=' { liftA2 (==) } | '<' { liftA2 (<) } @@ -188,9 +185,6 @@ | sha512 { fromIntegral (fromFVal SHA512) } | sha224 { fromIntegral (fromFVal SHA224) } | int { fromIntegral $1 } - -Stimespec : now { 0 } - | int { fromIntegral $1 } { lexwrap :: (Token -> Alex a) -> Alex a diff --git a/HOpenPGP/Tools/TKUtils.hs b/HOpenPGP/Tools/TKUtils.hs --- a/HOpenPGP/Tools/TKUtils.hs +++ b/HOpenPGP/Tools/TKUtils.hs @@ -20,7 +20,7 @@ processTK ) where -import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID) +import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint) import Codec.Encryption.OpenPGP.Signatures (verifyTKWith, verifySigWith, verifyAgainstKeys) import Codec.Encryption.OpenPGP.Types import Control.Error.Util (hush) @@ -46,17 +46,26 @@ } newest = take 1 . sortOn (Down . take 1 . sigcts) -- FIXME: this is terrible sigcts (SigV4 _ _ _ xs _ _ _) = map (\(SigSubPacket _ (SigCreationTime x)) -> x) $ filter isCT xs - alleged = filter (\x -> ((==) <$> sigissuer x <*> eoki (key^.tkKey._1)) == Just True) + pkp = key^.tkKey._1 + alleged = filter (\x -> assI x || assIFP x) isCT (SigSubPacket _ (SigCreationTime _)) = True isCT _ = False sigissuer (SigVOther 2 _) = Nothing sigissuer SigV3{} = Nothing sigissuer (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuer . _sspPayload) $ (ys++xs) -- FIXME: what should this be if there are multiple matches? sigissuer (SigVOther _ _) = error "We're in the future." -- FIXME - eoki pkp + sigissuerfp (SigV4 _ _ _ ys xs _ _) = listToMaybe . mapMaybe (getIssuerFP . _sspPayload) $ (ys++xs) -- FIXME: what should this be if there are multiple matches? + sigissuerfp _ = Nothing + eoki | pkp^.keyVersion == V4 = hush . eightOctetKeyID $ pkp | pkp^.keyVersion == DeprecatedV3 && elem (pkp^.pkalgo) [RSA,DeprecatedRSASignOnly] = hush . eightOctetKeyID $ pkp | otherwise = Nothing + fp + | pkp^.keyVersion == V4 = Just . fingerprint $ pkp + | otherwise = Nothing getIssuer (Issuer i) = Just i getIssuer _ = Nothing - + getIssuerFP (IssuerFingerprint 4 i) = Just i + getIssuerFP _ = Nothing + assI x = ((==) <$> sigissuer x <*> eoki) == Just True + assIFP x = ((==) <$> sigissuerfp x <*> fp) == Just True diff --git a/hop.hs b/hop.hs --- a/hop.hs +++ b/hop.hs @@ -15,28 +15,31 @@ -- -- You should have received a copy of the GNU Affero General Public License -- along with this program. If not, see . - {-# 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.Fingerprint (eightOctetKeyID, fingerprint) +import Codec.Encryption.OpenPGP.Ontology (isKUF) import Codec.Encryption.OpenPGP.Serialize () -import Codec.Encryption.OpenPGP.Signatures (crossSignSubkeyWithRSA, signUserIDwithRSA, verifyTKWith, verifySigWith, verifyAgainstKeyring) +import Codec.Encryption.OpenPGP.Signatures + ( crossSignSubkeyWithRSA + , signDataWithRSA + , signUserIDwithRSA + , verifyAgainstKeyring + , verifySigWith + , verifyTKWith + ) import Codec.Encryption.OpenPGP.Types -import Control.Error.Util (note) -import Control.Applicative (optional, some, (<|>)) +import Control.Applicative ((<|>), optional, some) import Control.Arrow ((&&&)) -import Control.Lens ((^.), _1, _2, (^..)) -import Control.Monad.IO.Class (liftIO, MonadIO) +import Control.Error.Util (note) +import Control.Lens ((^.), (^..), _1, _2) +import Control.Monad ((>=>), forM_) +import Control.Monad.IO.Class (MonadIO, liftIO) +import Control.Monad.State.Lazy (MonadState, StateT, evalStateT, get, modify) 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 @@ -45,148 +48,234 @@ 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 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.Keyring + ( conduitToTKs + , conduitToTKsDropping + , sinkKeyringMap + ) import Data.Conduit.OpenPGP.Verify (conduitVerify) +import Data.Conduit.Serialization.Binary (conduitGet) import Data.Data.Lens (biplate) import Data.Either (fromRight, isRight, rights) -import Data.Maybe (fromMaybe, mapMaybe, listToMaybe) +import Data.List (find) +import Data.Maybe (catMaybes, fromJust, fromMaybe, listToMaybe, mapMaybe) 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.Text.Encoding as TE +import qualified Data.Text.Lazy as TL +import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime, posixSecondsToUTCTime) import qualified Data.Vector as V import Data.Version (showVersion) import qualified Data.Yaml as Y import GHC.Generics -import System.Directory (getHomeDirectory) +import HOpenPGP.Tools.Armor (doDeArmor) +import HOpenPGP.Tools.Common + ( banner + , keyMatchesEightOctetKeyId + , keyMatchesFingerprint + , keyMatchesUIDSubString + , versioner + , warranty + ) +import HOpenPGP.Tools.Parser (parseTKExp) +import HOpenPGP.Tools.TKUtils (processTK) +import Paths_hopenpgp_tools (version) 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.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) +import Data.Text.Prettyprint.Doc + ( (<+>) + , fillSep + , hardline + , list + , pretty + , softline + ) +import Data.Text.Prettyprint.Doc.Render.Text (hPutDoc, putDoc) +import System.IO (BufferMode(..), Handle, hFlush, hSetBuffering, stderr, stdin) -data Command = VersionC - | GenerateKeyC KeyGenOptions - | ExtractCertC ExtractCertOptions - | DeArmorC - | ArmorC ArmoringOptions +data Command + = VersionC + | GenerateKeyC KeyGenOptions + | ExtractCertC ExtractCertOptions + | SignC SignOptions + | DeArmorC + | ArmorC ArmoringOptions -data Options = Options { - keyrings :: [String] - , outputFormat :: OutputFormat - , sigFilter :: String - , sigFile :: String - , blobFile :: String -} +data Options = + Options + { keyrings :: [String] + , outputFormat :: OutputFormat + , sigFilter :: String + , sigFile :: String + , blobFile :: String + } -data OutputFormat = Unstructured | JSON | YAML - deriving (Eq, Read, Show) +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" +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 + where + dispatch' _ VersionC = doVersion + dispatch' t (GenerateKeyC o) = doGenerateKey t o + dispatch' _ (ExtractCertC o) = doExtractCert o + dispatch' t (SignC o) = doSign t 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 + 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) +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 + 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" )) - ) +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 + "sign" + (info + (SignC <$> soP) + (progDesc "Create detached signatures and output them to stdout")) <> + command + "version" + (info (pure VersionC) (progDesc "output hop version to stdout"))) armorTypes :: [(String, Maybe ArmorType)] -armorTypes = [ - ("auto", Nothing) +armorTypes = + [ ("auto", Nothing) , ("sig", Just ArmorSignature) , ("key", Just ArmorPrivateKeyBlock) , ("cert", Just ArmorPublicKeyBlock) @@ -197,135 +286,325 @@ 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) +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 -} +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 +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") +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 -} +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 +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) [] [] [] [] + 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 + (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 + 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)) - ] + tk <- get + (SecretKey subpkp subska) <- liftIO $ generateSecretKey ts RSA + let (pkp, Just ska) = _tkKey tk + Right crossig = + crossSignSubkeyWithRSA + pkp + subpkp + (hashedwithflags pkp) + (unhashed pkp) + (hashed subpkp) + (unhashed subpkp) + (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)) + ] + hashedwithflags pkp = + hashed pkp ++ [SigSubPacket False (KeyFlags (S.fromList keyflags))] + unhashed pkp = + [SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))] ecoP :: Parser ExtractCertOptions -ecoP = ExtractCertOptions - <$> switch (long "armor" <> help "armor the output") - <*> switch (long "no-armor" <> help "don't armor the output") +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 -} +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)) +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) - 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) +soP :: Parser SignOptions +soP = + SignOptions <$> switch (long "armor" <> help "armor the output") <*> + switch (long "no-armor" <> help "don't armor the output") <*> + option + (eitherReader asTypeReader) + (long "as" <> metavar "DATATYPE" <> astypeHelp <> value AsBinary) <*> + some + (strArgument + (metavar "KEYS..." <> + help "paths to at least one secret key, one key per filename")) + where + astypeHelp = + helpDoc . Just . toAnsiWlPprint $ + pretty "what to treat the input as" <> softline <> + list (map (pretty . fst) asTypes) +data SignOptions = + SignOptions + { sArmor :: Bool + , sNoArmor :: Bool + , sAs :: AsBinaryText + , sKeyFiles :: [String] + } +asTypes :: [(String, AsBinaryText)] +asTypes = [("binary", AsBinary), ("text", AsText)] + +data AsBinaryText + = AsBinary + | AsText + deriving (Eq) + +asTypeReader :: String -> Either String AsBinaryText +asTypeReader = note "unknown as type" . flip lookup asTypes + +doSign :: POSIXTime -> SignOptions -> IO () +doSign pt SignOptions {..} = do + mbs <- runConduitRes $ CB.sourceHandle stdin .| CL.consume + ks <- mapM grabKey sKeyFiles + let ts = ThirtyTwoBitTimeStamp (floor pt) + payload' = BL.fromChunks mbs + payload = + if sAs == AsText + then canonicalize payload' + else payload' + funkeys = concatMap tkToFunKeys . rights . map (processTK (Just pt)) $ ks + allSigningCapableKeys = filter (isSigner . fkufs) funkeys + forM_ allSigningCapableKeys $ \k -> do + let Right sig = signData sAs ts k payload + sigpkt = SignaturePkt sig + output = runPut (Bin.put sigpkt) + BL.putStr $ + if not sArmor && not sNoArmor + then AA.encodeLazy [Armor ArmorSignature [] output] + else output + where + signData :: + AsBinaryText + -> ThirtyTwoBitTimeStamp + -> FunKey + -> BL.ByteString + -> Either String SignaturePayload + signData AsBinary t k = + signDataWithRSA + BinarySig + (skey (fromJust (fmska k))) + (hashed (fpkp k) t) + (unhashed (fpkp k)) + signData AsText t k = + signDataWithRSA + CanonicalTextSig + (skey (fromJust (fmska k))) + (hashed (fpkp k) t) + (unhashed (fpkp k)) + skey (SUUnencrypted (RSAPrivateKey (RSA_PrivateKey k)) _) = + k {RSA.private_p = 0, RSA.private_q = 0} -- FIXME: why is this necessary? + hashed pkp ct = + [ SigSubPacket False (SigCreationTime ct) + , SigSubPacket False (IssuerFingerprint 4 (fingerprint pkp)) + ] + unhashed pkp = + [SigSubPacket False (Issuer (fromRight undefined (eightOctetKeyID pkp)))] + isSigner = S.member SignDataKey + canonicalize :: BL.ByteString -> BL.ByteString + canonicalize = + BL.fromStrict . + TE.encodeUtf8 . + T.intercalate (T.pack "\r\n") . T.lines . TE.decodeUtf8 . BL.toStrict + +grabKey :: String -> IO TK +grabKey fp = do + kbs <- runConduitRes $ CB.sourceFile fp .| 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 + Just k <- + runConduitRes $ + CL.sourceList (BL.toChunks lbs') .| conduitGet Bin.get .| conduitToTKs .| + CL.head + return k + +data FunKey = + FunKey + { fpkp :: PKPayload + , fmska :: Maybe SKAddendum + , fkufs :: S.Set KeyFlag + } + deriving (Show) + +tkToFunKeys :: TK -> [FunKey] +tkToFunKeys (TK (pkp, mska) revs uids uats subs) = + catMaybes (mainKey : map extract subs) + where + mainKey = grabASig uids >>= sig2KUFs >>= \kf -> return (FunKey pkp mska kf) + sig2KUFs = getHasheds >=> find isKUF >=> getKUFs + grabASig :: [(a, [b])] -> Maybe b + grabASig = (listToMaybe >=> listToMaybe) . map snd -- FIXME: this should grab the "best" sig + getHasheds :: SignaturePayload -> Maybe [SigSubPacket] + getHasheds (SigV4 _ _ _ hasheds _ _ _) = Just hasheds + getHasheds _ = Nothing + getKUFs :: SigSubPacket -> Maybe (S.Set KeyFlag) + getKUFs (SigSubPacket _ (KeyFlags kfs)) = Just kfs + getKUFs _ = Nothing + extract ((SecretSubkeyPkt spkp sska), sigs) = + listToMaybe sigs >>= sig2KUFs >>= \kf -> + return (FunKey spkp (Just sska) kf) + extract ((PublicSubkeyPkt spkp), sigs) = + listToMaybe sigs >>= sig2KUFs >>= \kf -> return (FunKey spkp Nothing kf) + extract _ = Nothing diff --git a/hopenpgp-tools.cabal b/hopenpgp-tools.cabal --- a/hopenpgp-tools.cabal +++ b/hopenpgp-tools.cabal @@ -1,5 +1,5 @@ name: hopenpgp-tools -version: 0.22 +version: 0.23 synopsis: hOpenPGP-based command-line tools description: command-line tools for performing some OpenPGP-related operations homepage: https://salsa.debian.org/clint/hOpenPGP @@ -137,7 +137,7 @@ , cryptonite , directory , errors - , hOpenPGP >= 2.8 && < 3 + , hOpenPGP >= 2.9 && < 3 , lens , monad-loops , mtl @@ -162,4 +162,4 @@ source-repository this type: git location: https://salsa.debian.org/clint/hOpenPGP.git - tag: hopenpgp-tools/0.22 + tag: hopenpgp-tools/0.23