rhbzquery-0.3: src/ParseArg.hs

module ParseArg (
  argHelp,
  readBzQueryArg,
  ArgType(..),
  Operator(..),
  operators,
  showOp,
  showOpHelp,
  ProductVersion(..),
  statusList
  )
where

import Control.Applicative ((<|>))
import Data.Char
import Data.List.Extra as L
import Data.Version.Extra
import Numeric.Natural

import Common

argHelp :: String
argHelp = "[COMPONENT|STATUS|PRODUCTVERSION|FIELD=VALUE|FIELDopVALUE]..."

data Operator = Equals | NotEqual
              | Regexp |NotRegexp
              | Substring | NotSubstring
              | CaseSubstring
              | AllWordsSubstr | NoWordsSubstr
              | AllWords | NoWords
              | IsEmpty | IsNotEmpty
              -- | ContentMatches | ContentNotMatch
  deriving (Eq,Show,Enum,Bounded)

showOp :: Operator -> String
showOp = lower . show

operators :: [Operator]
operators = enumFromTo minBound maxBound

data OperatorData = OpUnary String | OpNull String
  deriving Eq

opSyntax :: OperatorData -> String
opSyntax (OpUnary s) = s
opSyntax (OpNull s) = s

showOpHelp :: Operator -> String
showOpHelp op =
  "'" ++ opSyntax (opData op) ++ "'(" ++ showOp op ++ ")"

instance Ord OperatorData where
  compare op1 op2 =
    let sop1 = opSyntax op1
        sop2 = opSyntax op2
    in
      if sop1 `isInfixOf` sop2 then GT
      else if sop2 `isInfixOf` sop1 then LT
           else if sop1 == sop2
                then error' $ sop1 ++ " listed twice in 'operators'"
                else compare (reverse sop1) (reverse sop2)

-- FIXME check all unique
opData :: Operator -> OperatorData
opData Equals = OpUnary "="
opData NotEqual = OpUnary "!="
opData Substring = OpUnary "~"
opData NotSubstring = OpUnary "!~"
opData CaseSubstring = OpUnary "~c~"
opData Regexp = OpUnary "=~"
opData NotRegexp = OpUnary "!=~"
opData AllWordsSubstr = OpUnary "~a~"
opData NoWordsSubstr = OpUnary "!a~"
opData AllWords = OpUnary "~w~"
opData NoWords = OpUnary "!w~"
opData IsEmpty = OpNull "~e~"
opData IsNotEmpty = OpNull "!e~"
-- -- only for 'content':
-- opData Matches = OpUnary "~m~"
-- opData NotMatches = OpUnary "!m~"

data ArgType = ArgProdVer ProductVersion
             | ArgStatusAll
             | ArgParameter String Operator String
             | ArgParameterEmpty String Bool
             | ArgComponent String

readBzQueryArg :: String -> Maybe ArgType
readBzQueryArg s =
  ArgProdVer <$> readProductVersion s <|>
  parseStatus s <|>
  parseField s <|>
  parseComponent s

data ProductVersion = Fedora (Maybe Natural)
                    | Rawhide
                    | EPEL (Maybe Natural)
                    | RHEL Version

readProductVersion :: String -> Maybe ProductVersion
readProductVersion "fedora" = Just (Fedora Nothing)
readProductVersion "rawhide" = Just Rawhide
readProductVersion ('f':ver) | all isDigit ver = Just $ Fedora (Just (read ver :: Natural))
readProductVersion "epel" = Just (EPEL Nothing)
readProductVersion ('e':'p':'e':'l':v) | all isDigit v = Just (EPEL (Just (read v :: Natural)))
readProductVersion ('r':'h':'e':'l':ver) = Just $ RHEL (readVersion ver)
readProductVersion _ = Nothing

statusList :: [String]
statusList = ["NEW", "ASSIGNED", "POST", "MODIFIED", "ON_QA", "VERIFIED", "RELEASE_PENDING", "CLOSED"]

parseStatus :: String -> Maybe ArgType
parseStatus s =
  let caps = upper s in
    if caps == "ALL"
    then Just ArgStatusAll
    else
      ArgParameter "bug_status" Equals <$> find (== upper s) statusList

parseField :: String -> Maybe ArgType
parseField ps =
  foldr ((<|>) . parseParam) Nothing $ sortOn opData operators
  where
    parseParam :: Operator -> Maybe ArgType
    parseParam oper =
      case opData oper of
        OpUnary op ->
          if op `isInfixOf` ps then
            case splitOn op ps of
              (f:val) -> Just (ArgParameter f oper (intercalate op val))
              _ -> Nothing
          else Nothing
        OpNull op ->
          case stripSuffix op ps of
            Just a ->
              if null a
              then error' $ "bad parameter: " ++ ps
              else Just (ArgParameterEmpty a (oper == IsEmpty))
            _ -> Nothing

-- https://fedoraproject.org/wiki/Packaging:Naming?rd=Packaging:NamingGuidelines#Common_Character_Set_for_Package_Naming
-- abcdefghijklmnopqrstuvwxyz
-- ABCDEFGHIJKLMNOPQRSTUVWXYZ
-- 0123456789-._+
parseComponent :: String -> Maybe ArgType
parseComponent ps =
  if all isPackageChar ps
  then Just (ArgComponent ps)
  else error' $ "Invalid component name: " ++ ps
  where
    isPackageChar :: Char -> Bool
    isPackageChar c =
      -- Bugzilla components can contain a space though
      isAsciiUpper c || isAsciiLower c || isDigit c || c `elem` " -._+"