{-# LANGUAGE GeneralizedNewtypeDeriving #-} -- This file is part of the Wire Server implementation. -- -- Copyright (C) 2020 Wire Swiss GmbH -- -- 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 . -- | A query might specify a filter that should be applied to the results -- before returning them. This module implements a very limited subset of -- the specification: . -- -- Supported: -- -- * All comparison operators (@eq@, @le@, etc) -- * The @userName@ attribute -- -- Not supported: -- -- * The @pr@ operator -- * Boolean operators -- * Combined filters -- * Fully qualified attribute names (schema prefixes, attribute paths) module Web.Scim.Filter ( -- * Filter type Filter (..), parseFilter, renderFilter, -- * Constructing filters CompValue (..), CompareOp (..), AttrPath (..), ValuePath (..), SubAttr (..), pAttrPath, pValuePath, pSubAttr, pFilter, rAttrPath, rCompareOp, rValuePath, rSubAttr, compareStr, topLevelAttrPath, ) where import Control.Applicative (optional, (<|>)) import Data.Aeson as Aeson import Data.Aeson.Parser as Aeson import Data.Aeson.Text as Aeson import Data.Attoparsec.ByteString.Char8 import Data.Scientific import Data.String import Data.Text (Text, isInfixOf, isPrefixOf, isSuffixOf, pack) import Data.Text.Encoding (encodeUtf8) import Data.Text.Lazy (toStrict) import Lens.Micro import Web.HttpApiData import Web.Scim.AttrName import Web.Scim.Schema.Schema (Schema (User20), getSchemaUri, pSchema) import Prelude hiding (takeWhile) ---------------------------------------------------------------------------- -- Types -- NB: when extending these types, don't forget to update Test.FilterSpec -- | A value type. Attributes are compared against literal values. data CompValue = ValNull | ValBool Bool | ValNumber Scientific | ValString Text deriving (Eq, Ord, Show) -- | A comparison operator. data CompareOp = -- | Equal OpEq | -- | Not equal OpNe | -- | Contains OpCo | -- | Starts with OpSw | -- | Ends with OpEw | -- | Greater than OpGt | -- | Greater than or equal to OpGe | -- | Less than OpLt | -- | Less than or equal to OpLe deriving (Eq, Ord, Show, Enum, Bounded) -- | A filter. -- -- Our representation of filters is lax and doesn't attempt to ensure -- validity on the type level. If a filter does something silly (e.g. tries -- to compare a username with a boolean), it will be caught during filtering -- and an appropriate error message will be thrown (see 'filterUser'). -- -- TODO(arianvp): Implement the following grammar fully if we want to support -- more complex filters -- -- FILTER = attrExp / logExp / valuePath / *1"not" "(" FILTER ")" data Filter = -- | Compare the attribute value with a literal FilterAttrCompare AttrPath CompareOp CompValue deriving (Eq, Show) -- | valuePath = attrPath "[" valFilter "]" -- TODO(arianvp): This is a slight simplification at the moment as we -- don't support the complete Filter grammar. This should be a -- valFilter, not a FILTER. data ValuePath = ValuePath AttrPath Filter deriving (Eq, Show) -- | subAttr = "." ATTRNAME newtype SubAttr = SubAttr AttrName deriving (Eq, Show, IsString) -- | attrPath = [URI ":"] ATTRNAME *1subAtt data AttrPath = AttrPath (Maybe Schema) AttrName (Maybe SubAttr) deriving (Eq, Show) -- | Smart constructor that refers to a toplevel field with default schema topLevelAttrPath :: Text -> AttrPath topLevelAttrPath x = AttrPath Nothing (AttrName x) Nothing -- | PATH = attrPath / valuePath [subAttr] -- -- Currently we don't support matching on lists in paths as -- we currently don't support filtering on arbitrary attributes yet -- e.g. -- @ -- "path":"members[value eq -- \"2819c223-7f76-453a-919d-413861904646\"].displayName" -- @ -- is not supported ---------------------------------------------------------------------------- -- Parsing -- | Parse a filter. Spaces surrounding the filter will be stripped. -- -- If parsing fails, returns a 'Left' with an error description. -- -- Note: this parser is written with Attoparsec because I don't know how to -- lift an Attoparsec parser (from Aeson) to Megaparsec parseFilter :: [Schema] -> Text -> Either Text Filter parseFilter supportedSchemas = over _Left pack . parseOnly (skipSpace *> pFilter supportedSchemas <* skipSpace <* endOfInput) . encodeUtf8 -- | -- @ -- ATTRNAME = ALPHA *(nameChar) -- attrPath = [URI ":"] ATTRNAME *1subAtt -- @ pAttrPath :: [Schema] -> Parser AttrPath pAttrPath supportedSchemas = do schema <- (Just <$> (pSchema supportedSchemas <* char ':')) <|> pure Nothing AttrPath schema <$> pAttrName <*> optional pSubAttr -- | subAttr = "." ATTRNAME pSubAttr :: Parser SubAttr pSubAttr = char '.' *> (SubAttr <$> pAttrName) -- | valuePath = attrPath "[" valFilter "]" pValuePath :: [Schema] -> Parser ValuePath pValuePath supportedSchemas = ValuePath <$> pAttrPath supportedSchemas <*> (char '[' *> pFilter supportedSchemas <* char ']') -- | Value literal parser. pCompValue :: Parser CompValue pCompValue = choice [ ValNull <$ string "null", ValBool True <$ (stringCI "true"), ValBool False <$ (stringCI "false"), ValNumber <$> Aeson.scientific, ValString <$> Aeson.jstring ] -- | Comparison operator parser. pCompareOp :: Parser CompareOp pCompareOp = choice [ OpEq <$ stringCI "eq", OpNe <$ stringCI "ne", OpCo <$ stringCI "co", OpSw <$ stringCI "sw", OpEw <$ stringCI "ew", OpGt <$ stringCI "gt", OpGe <$ stringCI "ge", OpLt <$ stringCI "lt", OpLe <$ stringCI "le" ] -- | Filter parser. pFilter :: [Schema] -> Parser Filter pFilter supportedSchemas = FilterAttrCompare <$> pAttrPath supportedSchemas <*> (skipSpace1 *> pCompareOp) <*> (skipSpace1 *> pCompValue) -- | Utility parser for skipping one or more spaces. skipSpace1 :: Parser () skipSpace1 = space *> skipSpace ---------------------------------------------------------------------------- -- Rendering -- | Render a filter according to the SCIM spec. renderFilter :: Filter -> Text renderFilter filter_ = case filter_ of FilterAttrCompare attr op val -> rAttrPath attr <> " " <> rCompareOp op <> " " <> rCompValue val rAttrPath :: AttrPath -> Text rAttrPath (AttrPath schema attr subAttr) = maybe "" ((<> ":") . getSchemaUri) schema <> rAttrName attr <> maybe "" rSubAttr subAttr rSubAttr :: SubAttr -> Text rSubAttr (SubAttr x) = "." <> rAttrName x rValuePath :: ValuePath -> Text rValuePath (ValuePath attrPath filter') = rAttrPath attrPath <> "[" <> renderFilter filter' <> "]" -- | Value literal renderer. rCompValue :: CompValue -> Text rCompValue = \case ValNull -> "null" ValBool True -> "true" ValBool False -> "false" ValNumber n -> toStrict $ Aeson.encodeToLazyText (Aeson.Number n) ValString s -> toStrict $ Aeson.encodeToLazyText (Aeson.String s) -- | Comparison operator renderer. rCompareOp :: CompareOp -> Text rCompareOp = \case OpEq -> "eq" OpNe -> "ne" OpCo -> "co" OpSw -> "sw" OpEw -> "ew" OpGt -> "gt" OpGe -> "ge" OpLt -> "lt" OpLe -> "le" -- | Execute a comparison operator. compareStr :: CompareOp -> Text -> Text -> Bool compareStr = \case OpEq -> (==) -- equal OpNe -> (/=) -- not equal OpCo -> flip isInfixOf -- A contains B OpSw -> flip isPrefixOf -- A starts with B OpEw -> flip isSuffixOf -- A ends with B OpGt -> (>) -- greater than OpGe -> (>=) -- greater than or equal to OpLt -> (<) -- less than OpLe -> (<=) -- less than or equal to ---------------------------------------------------------------------------- -- Instances -- | We currently only support filtering on core user schema instance FromHttpApiData Filter where parseUrlPiece = parseFilter [User20] instance ToHttpApiData Filter where toUrlPiece = renderFilter