hopenpgp-tools-0.21: HOpenPGP/Tools/Parser.y

{
{-# OPTIONS -w #-}
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, pUsingPKP, pUsingSP, maybeR)

import HOpenPGP.Tools.Lexer

import Control.Applicative (liftA2)
import Codec.Encryption.OpenPGP.Fingerprint (eightOctetKeyID, fingerprint)
import Codec.Encryption.OpenPGP.KeyInfo (pubkeySize)
import Control.Error.Util (hush)
import Control.Monad.Loops (allM, anyM)
import Control.Monad.Trans.Reader (ask, reader, Reader, withReader)
import Data.List (isInfixOf)
import qualified Data.Text as T
import Data.Text.Prettyprint.Doc (pretty)

}

%name parseTK Exp
%name parseP CFExp
%tokentype { Token }
%monad { Alex }
%lexer { lexwrap } { TokenEOF }
%error { happyError }
%token
    a { TokenA }
    and { TokenAnd }
    any { TokenAny }
    contains { TokenContains }
    every { TokenEvery }
    not { TokenNot }
    of { TokenOf }
    one { TokenOne }
    or { TokenOr }
    subkey { TokenSubkey }
    tag { TokenTag }
    int { TokenInt $$ }
    '=' { TokenEq }
    '<' { TokenLt }
    '>' { TokenGt }
    '(' { TokenLParen }
    ')' { TokenRParen }
    pkversion { TokenPKVersion }
    sigversion { TokenSigVersion }
    sigtype { TokenSigType }
    pkalgo { TokenPKAlgo }
    sigpkalgo { TokenSigPKAlgo }
    hashalgo { TokenHashAlgo }
    rsa { TokenRSA }
    dsa { TokenDSA }
    elgamal { TokenElgamal }
    ecdsa { TokenECDSA }
    ecdh { TokenECDH }
    dh { TokenDH }
    binary { TokenBinary }
    canonicaltext { TokenCanonicalText }
    standalone { TokenStandalone }
    genericcert { TokenGenericCert }
    personacert { TokenPersonaCert }
    casualcert { TokenCasualCert }
    positivecert { TokenPositiveCert }
    subkeybindingsig { TokenSubkeyBindingSig }
    primarykeybindingsig { TokenPrimaryKeyBindingSig }
    signaturedirectlyonakey { TokenSignatureDirectlyOnAKey }
    keyrevocationsig { TokenKeyRevocationSig }
    subkeyrevocationsig { TokenSubkeyRevocationSig }
    certrevocationsig { TokenCertRevocationSig }
    timestampsig { TokenTimestampSig }
    md5 { TokenMD5 }
    sha1 { TokenSHA1 }
    ripemd160 { TokenRIPEMD160 }
    sha256 { TokenSHA256 }
    sha384 { TokenSHA384 }
    sha512 { TokenSHA512 }
    sha224 { TokenSHA224 }
    keysize { TokenKeysize }
    timestamp { TokenTimestamp }
    fingerprint { TokenFingerprint }
    keyid { TokenKeyID }
    fpr { TokenFpr $$ }
    longid { TokenLongID $$ }
    length { TokenLength }
    str { TokenStr $$ }
    uids { TokenUids }

%%

Exp : any { return True }
    | not Exp { fmap not $2 }
    | Exp and Exp { liftA2 (&&) $1 $3 }
    | Exp or Exp { liftA2 (||) $1 $3 }
    | PExp { tkUsingPKP $1 }
    | TExp { $1 }

PExp : pkversion PIOp int { $2 (reader pkpGetPKVersion) (return $3) }
     | pkalgo PIOp Ppkalgos { $2 (reader pkpGetPKAlgo) (return $3) }
     | keysize PIOp int { $2 (reader pkpGetKeysize) (return $3) }
     | timestamp PIOp int { $2 (reader pkpGetTimestamp) (return $3) }
     | fingerprint PSOp Pfingerprint { $2 (reader (show . pretty . pkpGetFingerprint)) (return $3) }
     | keyid PSOp Plongid { $2 (reader pkpGetEOKI) (return $3) }

TExp : every one of uids AATOp str { withReader tkGetUIDs (anyOrAll allM ($5 (return (T.pack $6)))) }
     | any one of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($5 (return (T.pack $6)))) }
     | any of uids AATOp str { withReader tkGetUIDs (anyOrAll anyM ($4 (return (T.pack $5)))) }
     | a subkey PExp { withReader tkGetSubs (anyReader $3) }

PIOp : '=' { liftA2 (==) }
     | '<' { liftA2 (<) }
     | '>' { liftA2 (>) }

PSOp : '=' { liftA2 (==) }
     | contains { liftA2 (flip isInfixOf) }

AATOp : '=' { liftA2 (==) }
      | contains { liftA2 T.isInfixOf }

Ppkalgos : rsa { fromIntegral (fromFVal RSA) }
         | dsa { fromIntegral (fromFVal DSA) }
         | elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
         | ecdsa { fromIntegral (fromFVal ECDSA) }
         | ecdh { fromIntegral (fromFVal ECDH) }
         | dh { fromIntegral (fromFVal DH) }
         | int { fromIntegral $1 }

Pfingerprint : fpr { (show . pretty) $1 }

Plongid : longid { either (const "BROKEN") show $1 }

CFExp : any { return True }
      | not CFExp { fmap not $2 }
      | CFExp and CFExp { liftA2 (&&) $1 $3 }
      | CFExp or CFExp { liftA2 (||) $1 $3 }
      | OExp { $1 }
      | SPExp { $1 }
      | PExp { pUsingPKP (maybeR True $1) }

OExp : tag OIOp int { $2 (reader oGetTag) (return $3) }
     | length OIOp int { $2 (reader oGetLength) (return $3) }

OIOp : '=' { liftA2 (==) }
     | '<' { liftA2 (<) }
     | '>' { liftA2 (>) }

SPExp : sigversion SIOp int { $2 (reader spGetSigVersion) (return (Just $3)) }
      | 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)) }

SIOp : '=' { liftA2 (==) }
     | '<' { liftA2 (<) }
     | '>' { liftA2 (>) }

Ssigtypes : binary { fromIntegral (fromFVal BinarySig) }
          | canonicaltext { fromIntegral (fromFVal CanonicalTextSig) }
          | standalone { fromIntegral (fromFVal StandaloneSig) }
          | genericcert { fromIntegral (fromFVal GenericCert) }
          | personacert { fromIntegral (fromFVal PersonaCert) }
          | casualcert { fromIntegral (fromFVal CasualCert) }
          | positivecert { fromIntegral (fromFVal PositiveCert) }
          | subkeybindingsig { fromIntegral (fromFVal SubkeyBindingSig) }
          | primarykeybindingsig { fromIntegral (fromFVal PrimaryKeyBindingSig) }
          | signaturedirectlyonakey { fromIntegral (fromFVal SignatureDirectlyOnAKey) }
          | keyrevocationsig { fromIntegral (fromFVal KeyRevocationSig) }
          | subkeyrevocationsig { fromIntegral (fromFVal SubkeyRevocationSig) }
          | certrevocationsig { fromIntegral (fromFVal CertRevocationSig) }
          | timestampsig { fromIntegral (fromFVal TimestampSig) }
          | int { fromIntegral $1 }

Spkalgos : rsa { fromIntegral (fromFVal RSA) }
         | dsa { fromIntegral (fromFVal DSA) }
         | elgamal { fromIntegral (fromFVal ElgamalEncryptOnly) }
         | ecdsa { fromIntegral (fromFVal ECDSA) }
         | ecdh { fromIntegral (fromFVal ECDH) }
         | dh { fromIntegral (fromFVal DH) }
         | int { fromIntegral $1 }

Shashalgos : md5 { fromIntegral (fromFVal DeprecatedMD5) }
           | sha1 { fromIntegral (fromFVal SHA1) }
           | ripemd160 { fromIntegral (fromFVal RIPEMD160) }
           | sha256 { fromIntegral (fromFVal SHA256) }
           | sha384 { fromIntegral (fromFVal SHA384) }
           | sha512 { fromIntegral (fromFVal SHA512) }
           | sha224 { fromIntegral (fromFVal SHA224) }
           | int { fromIntegral $1 }

{
lexwrap :: (Token -> Alex a) -> Alex a
lexwrap cont = do
    t <- alexMonadScan'
    cont t

alexMonadScan' = do
    inp <- alexGetInput
    sc <- alexGetStartCode
    case alexScan inp sc of
        AlexEOF -> alexEOF
        AlexError (pos, _, _, _) -> alexError (show pos)
        AlexSkip inp' len -> do
            alexSetInput inp'
            alexMonadScan'
        AlexToken inp' len action -> do
            alexSetInput inp'
            action (ignorePendingBytes inp) len

getPosn :: Alex (Int,Int)
getPosn = do
    (AlexPn _ l c,_,_,_) <- alexGetInput
    return (l,c)

happyError :: Token -> Alex a
happyError t = do
    (l,c) <- getPosn
    fail (show l ++ ":" ++ show c ++ ": Parse error on Token: " ++ show t ++ "\n")

parseTKExp :: String -> Either String (Reader TK Bool)
parseTKExp s = runAlex s parseTK

parsePExp :: String -> Either String (Reader Pkt Bool)
parsePExp s = runAlex s parseP
}