module Sos.Rule
( Rule(..)
, RawRule(..)
, RawPattern
, buildRule
, buildRawRule
) where
import Sos.Exception
import Sos.Template
import Control.Applicative
import Control.Monad.Catch (MonadThrow, throwM)
import Data.Aeson.Types
import Data.ByteString (ByteString)
import Data.ByteString.Internal (c2w)
import Data.Either
import Data.Foldable (asum)
import Data.Text (Text)
import Text.Regex.TDFA
import Text.Regex.TDFA.ByteString (compile)
import qualified Data.ByteString as ByteString (intercalate, singleton)
import qualified Data.Text.Encoding as Text
type RawPattern = ByteString
data Rule = Rule
{ rulePattern :: Regex
, ruleExclude :: Maybe Regex
, ruleTemplates :: [Template]
}
buildRule
:: forall m.
MonadThrow m
=> RawPattern -> [RawPattern] -> [RawTemplate] -> m Rule
buildRule pattrn excludes templates0 = do
templates <- mapM parseTemplate templates0
regex <-
case concatMap lefts templates of
[] ->
compileRegex
(CompOption
{ caseSensitive = True
, multiline = False
, rightAssoc = True
, newSyntax = True
, lastStarGreedy = True
})
(ExecOption
{ captureGroups = False })
pattrn
_ -> compileRegex defaultCompOpt defaultExecOpt pattrn
case excludes of
[] ->
pure (Rule
{ rulePattern = regex
, ruleExclude = Nothing
, ruleTemplates = templates
})
_ -> do
exclude <-
compileRegex defaultCompOpt defaultExecOpt
(ByteString.intercalate (ByteString.singleton (c2w '|')) excludes)
pure (Rule
{ rulePattern = regex
, ruleExclude = Just exclude
, ruleTemplates = templates
})
where
compileRegex :: CompOption -> ExecOption -> RawPattern -> m Regex
compileRegex co eo patt =
case compile co eo patt of
Left err -> throwM (SosRegexException patt err)
Right x -> pure x
data RawRule = RawRule [RawPattern] [RawPattern] [RawTemplate]
instance FromJSON RawRule where
parseJSON (Object o) =
RawRule <$> parsePatterns <*> parseExcludes <*> parseCommands
where
parsePatterns :: Parser [RawPattern]
parsePatterns = go ["pattern", "patterns"]
parseExcludes :: Parser [RawPattern]
parseExcludes = go ["exclude", "excludes", "excluding"] <|> pure []
parseCommands :: Parser [RawTemplate]
parseCommands = go ["command", "commands"]
go :: [Text] -> Parser [ByteString]
go = fmap (map Text.encodeUtf8 . listify) . asum . map (o .:)
parseJSON v = typeMismatch "command" v
buildRawRule :: MonadThrow m => RawRule -> m [Rule]
buildRawRule (RawRule patterns excludes templates) =
mapM (\pattrn -> buildRule pattrn excludes templates) patterns
data OneOrList a
= One a
| List [a]
deriving Functor
instance FromJSON a => FromJSON (OneOrList a) where
parseJSON v@(String _) = One <$> parseJSON v
parseJSON v@(Array _) = List <$> parseJSON v
parseJSON v = typeMismatch "element or list of elements" v
listify :: OneOrList a -> [a]
listify (One x) = [x]
listify (List xs) = xs