hopenpgp-tools 0.22 → 0.23
raw patch · 6 files changed
+507/−236 lines, 6 filesdep ~hOpenPGP
Dependency ranges changed: hOpenPGP
Files
- HOpenPGP/Tools/Common.hs +0/−5
- HOpenPGP/Tools/Lexer.x +0/−6
- HOpenPGP/Tools/Parser.y +1/−7
- HOpenPGP/Tools/TKUtils.hs +13/−4
- hop.hs +490/−211
- hopenpgp-tools.cabal +3/−3
HOpenPGP/Tools/Common.hs view
@@ -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
HOpenPGP/Tools/Lexer.x view
@@ -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
HOpenPGP/Tools/Parser.y view
@@ -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
HOpenPGP/Tools/TKUtils.hs view
@@ -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
hop.hs view
@@ -15,28 +15,31 @@ -- -- 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.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
hopenpgp-tools.cabal view
@@ -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