ExpressionParsing.hs

-- ExpressionParsing.hs: hOpenPGP tools expression parsing
-- Copyright © 2013-2014  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 OverloadedStrings #-}

module HOpenPGP.Tools.ExpressionParsing (pPE) where
import Codec.Encryption.OpenPGP.Types
import Control.Applicative ((<$>), (<*>), (*>), (<|>), pure)
import Control.Monad (replicateM)
import qualified Data.Attoparsec.Text as A
import Data.Conduit.OpenPGP.Filter (conduitFilter, Expr(..), FilterPredicates(..), PKPPredicate(..), PKPVar(..), PKPOp(..), PKPValue(..), SPPredicate(..), SPVar(..), SPOp(..), SPValue(..), OPredicate(..), OVar(..), OOp(..), OValue(..))

pPE :: A.Parser (Expr PKPPredicate)
pPE = complex (anyP <|> simplePE)

complex :: A.Parser (Expr a) -> A.Parser (Expr a)
complex p = andP p <|> orP p <|> notP p <|> p

notP :: A.Parser (Expr a) -> A.Parser (Expr a)
notP p = ENot <$> (A.skipSpace *> A.string "not" *> A.skipSpace *> p)

andP :: A.Parser (Expr a) -> A.Parser (Expr a)
andP p = EAnd <$> p <*> (A.skipSpace *> A.string "and" *> A.skipSpace *> p)

orP :: A.Parser (Expr a) -> A.Parser (Expr a)
orP p = EAnd <$> p <*> (A.skipSpace *> A.string "or" *> A.skipSpace *> p)

anyP :: A.Parser (Expr a)
anyP = A.string "any" *> pure EAny

simplePE :: A.Parser (Expr PKPPredicate)
simplePE = do
    _ <- A.skipSpace
    lhs <- pVarToken
    _ <- A.skipSpace
    op <- pOpToken
    _ <- A.skipSpace
    rhs <- pValToken
    return (E (PKPPredicate lhs op rhs))
    where
        pVarToken = (A.string "version" *> pure PKPVVersion)
                <|> (A.string "pkalgo" *> pure PKPVPKA)
                <|> (A.string "keysize" *> pure PKPVKeysize)
                <|> (A.string "timestamp" *> pure PKPVTimestamp)
                <|> (A.string "fingerprint" *> pure PKPVTOF)
        pOpToken = (A.string "==" *> pure PKEquals)
               <|> (A.string "=" *> pure PKEquals)
               <|> (A.string "<" *> pure PKLessThan)
               <|> (A.string ">" *> pure PKGreaterThan)
        pValToken = (A.asciiCI "rsa" *> pure (PKPPKA RSA))
                <|> (A.asciiCI "dsa" *> pure (PKPPKA DSA))
                <|> (A.asciiCI "elgamal" *> pure (PKPPKA ElgamalEncryptOnly))
                <|> (A.asciiCI "ecdsa" *> pure (PKPPKA ECDSA))
                <|> (A.asciiCI "ecdh" *> pure (PKPPKA ECDH))
                <|> (A.asciiCI "dh" *> pure (PKPPKA DH))
                <|> (PKPTOF . read <$> fixedLengthHex 40)
                <|> (PKPEOKI . read <$> fixedLengthHex 16)
                <|> (PKPInt <$> hexordec)

hexordec :: A.Parser Int
hexordec = (A.string "0x" *> A.hexadecimal) <|> A.decimal

fixedLengthHex :: Int -> A.Parser String
fixedLengthHex len = (A.string "0x" *> flh len) <|> flh len
  where
      flh l = replicateM l (A.satisfy isHexDigit)
      isHexDigit c = (c >= '0' && c <= '9') ||
                     (c >= 'a' && c <= 'f') ||
                     (c >= 'A' && c <= 'F')