{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2020 Wire Swiss GmbH <opensource@wire.com>
--
-- 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 <https://www.gnu.org/licenses/>.

-- | 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: <https://tools.ietf.org/html/rfc7644#section-3.4.2.2>.
--
-- 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 (CompValue -> CompValue -> Bool
(CompValue -> CompValue -> Bool)
-> (CompValue -> CompValue -> Bool) -> Eq CompValue
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompValue -> CompValue -> Bool
$c/= :: CompValue -> CompValue -> Bool
== :: CompValue -> CompValue -> Bool
$c== :: CompValue -> CompValue -> Bool
Eq, Eq CompValue
Eq CompValue
-> (CompValue -> CompValue -> Ordering)
-> (CompValue -> CompValue -> Bool)
-> (CompValue -> CompValue -> Bool)
-> (CompValue -> CompValue -> Bool)
-> (CompValue -> CompValue -> Bool)
-> (CompValue -> CompValue -> CompValue)
-> (CompValue -> CompValue -> CompValue)
-> Ord CompValue
CompValue -> CompValue -> Bool
CompValue -> CompValue -> Ordering
CompValue -> CompValue -> CompValue
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CompValue -> CompValue -> CompValue
$cmin :: CompValue -> CompValue -> CompValue
max :: CompValue -> CompValue -> CompValue
$cmax :: CompValue -> CompValue -> CompValue
>= :: CompValue -> CompValue -> Bool
$c>= :: CompValue -> CompValue -> Bool
> :: CompValue -> CompValue -> Bool
$c> :: CompValue -> CompValue -> Bool
<= :: CompValue -> CompValue -> Bool
$c<= :: CompValue -> CompValue -> Bool
< :: CompValue -> CompValue -> Bool
$c< :: CompValue -> CompValue -> Bool
compare :: CompValue -> CompValue -> Ordering
$ccompare :: CompValue -> CompValue -> Ordering
$cp1Ord :: Eq CompValue
Ord, Int -> CompValue -> ShowS
[CompValue] -> ShowS
CompValue -> String
(Int -> CompValue -> ShowS)
-> (CompValue -> String)
-> ([CompValue] -> ShowS)
-> Show CompValue
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompValue] -> ShowS
$cshowList :: [CompValue] -> ShowS
show :: CompValue -> String
$cshow :: CompValue -> String
showsPrec :: Int -> CompValue -> ShowS
$cshowsPrec :: Int -> CompValue -> ShowS
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 (CompareOp -> CompareOp -> Bool
(CompareOp -> CompareOp -> Bool)
-> (CompareOp -> CompareOp -> Bool) -> Eq CompareOp
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CompareOp -> CompareOp -> Bool
$c/= :: CompareOp -> CompareOp -> Bool
== :: CompareOp -> CompareOp -> Bool
$c== :: CompareOp -> CompareOp -> Bool
Eq, Eq CompareOp
Eq CompareOp
-> (CompareOp -> CompareOp -> Ordering)
-> (CompareOp -> CompareOp -> Bool)
-> (CompareOp -> CompareOp -> Bool)
-> (CompareOp -> CompareOp -> Bool)
-> (CompareOp -> CompareOp -> Bool)
-> (CompareOp -> CompareOp -> CompareOp)
-> (CompareOp -> CompareOp -> CompareOp)
-> Ord CompareOp
CompareOp -> CompareOp -> Bool
CompareOp -> CompareOp -> Ordering
CompareOp -> CompareOp -> CompareOp
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: CompareOp -> CompareOp -> CompareOp
$cmin :: CompareOp -> CompareOp -> CompareOp
max :: CompareOp -> CompareOp -> CompareOp
$cmax :: CompareOp -> CompareOp -> CompareOp
>= :: CompareOp -> CompareOp -> Bool
$c>= :: CompareOp -> CompareOp -> Bool
> :: CompareOp -> CompareOp -> Bool
$c> :: CompareOp -> CompareOp -> Bool
<= :: CompareOp -> CompareOp -> Bool
$c<= :: CompareOp -> CompareOp -> Bool
< :: CompareOp -> CompareOp -> Bool
$c< :: CompareOp -> CompareOp -> Bool
compare :: CompareOp -> CompareOp -> Ordering
$ccompare :: CompareOp -> CompareOp -> Ordering
$cp1Ord :: Eq CompareOp
Ord, Int -> CompareOp -> ShowS
[CompareOp] -> ShowS
CompareOp -> String
(Int -> CompareOp -> ShowS)
-> (CompareOp -> String)
-> ([CompareOp] -> ShowS)
-> Show CompareOp
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CompareOp] -> ShowS
$cshowList :: [CompareOp] -> ShowS
show :: CompareOp -> String
$cshow :: CompareOp -> String
showsPrec :: Int -> CompareOp -> ShowS
$cshowsPrec :: Int -> CompareOp -> ShowS
Show, Int -> CompareOp
CompareOp -> Int
CompareOp -> [CompareOp]
CompareOp -> CompareOp
CompareOp -> CompareOp -> [CompareOp]
CompareOp -> CompareOp -> CompareOp -> [CompareOp]
(CompareOp -> CompareOp)
-> (CompareOp -> CompareOp)
-> (Int -> CompareOp)
-> (CompareOp -> Int)
-> (CompareOp -> [CompareOp])
-> (CompareOp -> CompareOp -> [CompareOp])
-> (CompareOp -> CompareOp -> [CompareOp])
-> (CompareOp -> CompareOp -> CompareOp -> [CompareOp])
-> Enum CompareOp
forall a.
(a -> a)
-> (a -> a)
-> (Int -> a)
-> (a -> Int)
-> (a -> [a])
-> (a -> a -> [a])
-> (a -> a -> [a])
-> (a -> a -> a -> [a])
-> Enum a
enumFromThenTo :: CompareOp -> CompareOp -> CompareOp -> [CompareOp]
$cenumFromThenTo :: CompareOp -> CompareOp -> CompareOp -> [CompareOp]
enumFromTo :: CompareOp -> CompareOp -> [CompareOp]
$cenumFromTo :: CompareOp -> CompareOp -> [CompareOp]
enumFromThen :: CompareOp -> CompareOp -> [CompareOp]
$cenumFromThen :: CompareOp -> CompareOp -> [CompareOp]
enumFrom :: CompareOp -> [CompareOp]
$cenumFrom :: CompareOp -> [CompareOp]
fromEnum :: CompareOp -> Int
$cfromEnum :: CompareOp -> Int
toEnum :: Int -> CompareOp
$ctoEnum :: Int -> CompareOp
pred :: CompareOp -> CompareOp
$cpred :: CompareOp -> CompareOp
succ :: CompareOp -> CompareOp
$csucc :: CompareOp -> CompareOp
Enum, CompareOp
CompareOp -> CompareOp -> Bounded CompareOp
forall a. a -> a -> Bounded a
maxBound :: CompareOp
$cmaxBound :: CompareOp
minBound :: CompareOp
$cminBound :: CompareOp
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 (Filter -> Filter -> Bool
(Filter -> Filter -> Bool)
-> (Filter -> Filter -> Bool) -> Eq Filter
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Filter -> Filter -> Bool
$c/= :: Filter -> Filter -> Bool
== :: Filter -> Filter -> Bool
$c== :: Filter -> Filter -> Bool
Eq, Int -> Filter -> ShowS
[Filter] -> ShowS
Filter -> String
(Int -> Filter -> ShowS)
-> (Filter -> String) -> ([Filter] -> ShowS) -> Show Filter
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Filter] -> ShowS
$cshowList :: [Filter] -> ShowS
show :: Filter -> String
$cshow :: Filter -> String
showsPrec :: Int -> Filter -> ShowS
$cshowsPrec :: Int -> Filter -> ShowS
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 (ValuePath -> ValuePath -> Bool
(ValuePath -> ValuePath -> Bool)
-> (ValuePath -> ValuePath -> Bool) -> Eq ValuePath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ValuePath -> ValuePath -> Bool
$c/= :: ValuePath -> ValuePath -> Bool
== :: ValuePath -> ValuePath -> Bool
$c== :: ValuePath -> ValuePath -> Bool
Eq, Int -> ValuePath -> ShowS
[ValuePath] -> ShowS
ValuePath -> String
(Int -> ValuePath -> ShowS)
-> (ValuePath -> String)
-> ([ValuePath] -> ShowS)
-> Show ValuePath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [ValuePath] -> ShowS
$cshowList :: [ValuePath] -> ShowS
show :: ValuePath -> String
$cshow :: ValuePath -> String
showsPrec :: Int -> ValuePath -> ShowS
$cshowsPrec :: Int -> ValuePath -> ShowS
Show)

-- | subAttr   = "." ATTRNAME
newtype SubAttr = SubAttr AttrName
  deriving (SubAttr -> SubAttr -> Bool
(SubAttr -> SubAttr -> Bool)
-> (SubAttr -> SubAttr -> Bool) -> Eq SubAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: SubAttr -> SubAttr -> Bool
$c/= :: SubAttr -> SubAttr -> Bool
== :: SubAttr -> SubAttr -> Bool
$c== :: SubAttr -> SubAttr -> Bool
Eq, Int -> SubAttr -> ShowS
[SubAttr] -> ShowS
SubAttr -> String
(Int -> SubAttr -> ShowS)
-> (SubAttr -> String) -> ([SubAttr] -> ShowS) -> Show SubAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SubAttr] -> ShowS
$cshowList :: [SubAttr] -> ShowS
show :: SubAttr -> String
$cshow :: SubAttr -> String
showsPrec :: Int -> SubAttr -> ShowS
$cshowsPrec :: Int -> SubAttr -> ShowS
Show, String -> SubAttr
(String -> SubAttr) -> IsString SubAttr
forall a. (String -> a) -> IsString a
fromString :: String -> SubAttr
$cfromString :: String -> SubAttr
IsString)

-- | attrPath  = [URI ":"] ATTRNAME *1subAtt
data AttrPath = AttrPath (Maybe Schema) AttrName (Maybe SubAttr)
  deriving (AttrPath -> AttrPath -> Bool
(AttrPath -> AttrPath -> Bool)
-> (AttrPath -> AttrPath -> Bool) -> Eq AttrPath
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AttrPath -> AttrPath -> Bool
$c/= :: AttrPath -> AttrPath -> Bool
== :: AttrPath -> AttrPath -> Bool
$c== :: AttrPath -> AttrPath -> Bool
Eq, Int -> AttrPath -> ShowS
[AttrPath] -> ShowS
AttrPath -> String
(Int -> AttrPath -> ShowS)
-> (AttrPath -> String) -> ([AttrPath] -> ShowS) -> Show AttrPath
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AttrPath] -> ShowS
$cshowList :: [AttrPath] -> ShowS
show :: AttrPath -> String
$cshow :: AttrPath -> String
showsPrec :: Int -> AttrPath -> ShowS
$cshowsPrec :: Int -> AttrPath -> ShowS
Show)

-- | Smart constructor that refers to a toplevel field with default schema
topLevelAttrPath :: Text -> AttrPath
topLevelAttrPath :: Text -> AttrPath
topLevelAttrPath Text
x = Maybe Schema -> AttrName -> Maybe SubAttr -> AttrPath
AttrPath Maybe Schema
forall a. Maybe a
Nothing (Text -> AttrName
AttrName Text
x) Maybe SubAttr
forall a. Maybe a
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 :: [Schema] -> Text -> Either Text Filter
parseFilter [Schema]
supportedSchemas =
  ASetter (Either String Filter) (Either Text Filter) String Text
-> (String -> Text) -> Either String Filter -> Either Text Filter
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter (Either String Filter) (Either Text Filter) String Text
forall a b a'. Traversal (Either a b) (Either a' b) a a'
_Left String -> Text
pack
    (Either String Filter -> Either Text Filter)
-> (Text -> Either String Filter) -> Text -> Either Text Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Parser Filter -> ByteString -> Either String Filter
forall a. Parser a -> ByteString -> Either String a
parseOnly (Parser ()
skipSpace Parser () -> Parser Filter -> Parser Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Schema] -> Parser Filter
pFilter [Schema]
supportedSchemas Parser Filter -> Parser () -> Parser Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
skipSpace Parser Filter -> Parser () -> Parser Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Parser ()
forall t. Chunk t => Parser t ()
endOfInput)
    (ByteString -> Either String Filter)
-> (Text -> ByteString) -> Text -> Either String Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
encodeUtf8

-- |
-- @
-- ATTRNAME  = ALPHA *(nameChar)
-- attrPath  = [URI ":"] ATTRNAME *1subAtt
-- @
pAttrPath :: [Schema] -> Parser AttrPath
pAttrPath :: [Schema] -> Parser AttrPath
pAttrPath [Schema]
supportedSchemas = do
  Maybe Schema
schema <- (Schema -> Maybe Schema
forall a. a -> Maybe a
Just (Schema -> Maybe Schema)
-> Parser ByteString Schema -> Parser ByteString (Maybe Schema)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Schema] -> Parser ByteString Schema
pSchema [Schema]
supportedSchemas Parser ByteString Schema
-> Parser ByteString Char -> Parser ByteString Schema
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
':')) Parser ByteString (Maybe Schema)
-> Parser ByteString (Maybe Schema)
-> Parser ByteString (Maybe Schema)
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> Maybe Schema -> Parser ByteString (Maybe Schema)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Schema
forall a. Maybe a
Nothing
  Maybe Schema -> AttrName -> Maybe SubAttr -> AttrPath
AttrPath Maybe Schema
schema (AttrName -> Maybe SubAttr -> AttrPath)
-> Parser ByteString AttrName
-> Parser ByteString (Maybe SubAttr -> AttrPath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString AttrName
pAttrName Parser ByteString (Maybe SubAttr -> AttrPath)
-> Parser ByteString (Maybe SubAttr) -> Parser AttrPath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Parser ByteString SubAttr -> Parser ByteString (Maybe SubAttr)
forall (f :: * -> *) a. Alternative f => f a -> f (Maybe a)
optional Parser ByteString SubAttr
pSubAttr

-- | subAttr   = "." ATTRNAME
pSubAttr :: Parser SubAttr
pSubAttr :: Parser ByteString SubAttr
pSubAttr = Char -> Parser ByteString Char
char Char
'.' Parser ByteString Char
-> Parser ByteString SubAttr -> Parser ByteString SubAttr
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> (AttrName -> SubAttr
SubAttr (AttrName -> SubAttr)
-> Parser ByteString AttrName -> Parser ByteString SubAttr
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString AttrName
pAttrName)

-- | valuePath = attrPath "[" valFilter "]"
pValuePath :: [Schema] -> Parser ValuePath
pValuePath :: [Schema] -> Parser ValuePath
pValuePath [Schema]
supportedSchemas =
  AttrPath -> Filter -> ValuePath
ValuePath (AttrPath -> Filter -> ValuePath)
-> Parser AttrPath -> Parser ByteString (Filter -> ValuePath)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Schema] -> Parser AttrPath
pAttrPath [Schema]
supportedSchemas Parser ByteString (Filter -> ValuePath)
-> Parser Filter -> Parser ValuePath
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Char -> Parser ByteString Char
char Char
'[' Parser ByteString Char -> Parser Filter -> Parser Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> [Schema] -> Parser Filter
pFilter [Schema]
supportedSchemas Parser Filter -> Parser ByteString Char -> Parser Filter
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Char -> Parser ByteString Char
char Char
']')

-- | Value literal parser.
pCompValue :: Parser CompValue
pCompValue :: Parser CompValue
pCompValue =
  [Parser CompValue] -> Parser CompValue
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
    [ CompValue
ValNull CompValue -> Parser ByteString ByteString -> Parser CompValue
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
string ByteString
"null",
      Bool -> CompValue
ValBool Bool
True CompValue -> Parser ByteString ByteString -> Parser CompValue
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ByteString -> Parser ByteString ByteString
stringCI ByteString
"true"),
      Bool -> CompValue
ValBool Bool
False CompValue -> Parser ByteString ByteString -> Parser CompValue
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ (ByteString -> Parser ByteString ByteString
stringCI ByteString
"false"),
      Scientific -> CompValue
ValNumber (Scientific -> CompValue)
-> Parser ByteString Scientific -> Parser CompValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Scientific
Aeson.scientific,
      Text -> CompValue
ValString (Text -> CompValue) -> Parser ByteString Text -> Parser CompValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Parser ByteString Text
Aeson.jstring
    ]

-- | Comparison operator parser.
pCompareOp :: Parser CompareOp
pCompareOp :: Parser CompareOp
pCompareOp =
  [Parser CompareOp] -> Parser CompareOp
forall (f :: * -> *) a. Alternative f => [f a] -> f a
choice
    [ CompareOp
OpEq CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"eq",
      CompareOp
OpNe CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"ne",
      CompareOp
OpCo CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"co",
      CompareOp
OpSw CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"sw",
      CompareOp
OpEw CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"ew",
      CompareOp
OpGt CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"gt",
      CompareOp
OpGe CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"ge",
      CompareOp
OpLt CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"lt",
      CompareOp
OpLe CompareOp -> Parser ByteString ByteString -> Parser CompareOp
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ ByteString -> Parser ByteString ByteString
stringCI ByteString
"le"
    ]

-- | Filter parser.
pFilter :: [Schema] -> Parser Filter
pFilter :: [Schema] -> Parser Filter
pFilter [Schema]
supportedSchemas =
  AttrPath -> CompareOp -> CompValue -> Filter
FilterAttrCompare
    (AttrPath -> CompareOp -> CompValue -> Filter)
-> Parser AttrPath
-> Parser ByteString (CompareOp -> CompValue -> Filter)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Schema] -> Parser AttrPath
pAttrPath [Schema]
supportedSchemas
    Parser ByteString (CompareOp -> CompValue -> Filter)
-> Parser CompareOp -> Parser ByteString (CompValue -> Filter)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
skipSpace1 Parser () -> Parser CompareOp -> Parser CompareOp
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser CompareOp
pCompareOp)
    Parser ByteString (CompValue -> Filter)
-> Parser CompValue -> Parser Filter
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Parser ()
skipSpace1 Parser () -> Parser CompValue -> Parser CompValue
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser CompValue
pCompValue)

-- | Utility parser for skipping one or more spaces.
skipSpace1 :: Parser ()
skipSpace1 :: Parser ()
skipSpace1 = Parser ByteString Char
space Parser ByteString Char -> Parser () -> Parser ()
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Parser ()
skipSpace

----------------------------------------------------------------------------
-- Rendering

-- | Render a filter according to the SCIM spec.
renderFilter :: Filter -> Text
renderFilter :: Filter -> Text
renderFilter Filter
filter_ = case Filter
filter_ of
  FilterAttrCompare AttrPath
attr CompareOp
op CompValue
val ->
    AttrPath -> Text
rAttrPath AttrPath
attr Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CompareOp -> Text
rCompareOp CompareOp
op Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
" " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> CompValue -> Text
rCompValue CompValue
val

rAttrPath :: AttrPath -> Text
rAttrPath :: AttrPath -> Text
rAttrPath (AttrPath Maybe Schema
schema AttrName
attr Maybe SubAttr
subAttr) =
  Text -> (Schema -> Text) -> Maybe Schema -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" ((Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
":") (Text -> Text) -> (Schema -> Text) -> Schema -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Schema -> Text
getSchemaUri) Maybe Schema
schema
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AttrName -> Text
rAttrName AttrName
attr
    Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> (SubAttr -> Text) -> Maybe SubAttr -> Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Text
"" SubAttr -> Text
rSubAttr Maybe SubAttr
subAttr

rSubAttr :: SubAttr -> Text
rSubAttr :: SubAttr -> Text
rSubAttr (SubAttr AttrName
x) = Text
"." Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AttrName -> Text
rAttrName AttrName
x

rValuePath :: ValuePath -> Text
rValuePath :: ValuePath -> Text
rValuePath (ValuePath AttrPath
attrPath Filter
filter') = AttrPath -> Text
rAttrPath AttrPath
attrPath Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"[" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Filter -> Text
renderFilter Filter
filter' Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"]"

-- | Value literal renderer.
rCompValue :: CompValue -> Text
rCompValue :: CompValue -> Text
rCompValue = \case
  CompValue
ValNull -> Text
"null"
  ValBool Bool
True -> Text
"true"
  ValBool Bool
False -> Text
"false"
  ValNumber Scientific
n -> Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Text
forall a. ToJSON a => a -> Text
Aeson.encodeToLazyText (Scientific -> Value
Aeson.Number Scientific
n)
  ValString Text
s -> Text -> Text
toStrict (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Value -> Text
forall a. ToJSON a => a -> Text
Aeson.encodeToLazyText (Text -> Value
Aeson.String Text
s)

-- | Comparison operator renderer.
rCompareOp :: CompareOp -> Text
rCompareOp :: CompareOp -> Text
rCompareOp = \case
  CompareOp
OpEq -> Text
"eq"
  CompareOp
OpNe -> Text
"ne"
  CompareOp
OpCo -> Text
"co"
  CompareOp
OpSw -> Text
"sw"
  CompareOp
OpEw -> Text
"ew"
  CompareOp
OpGt -> Text
"gt"
  CompareOp
OpGe -> Text
"ge"
  CompareOp
OpLt -> Text
"lt"
  CompareOp
OpLe -> Text
"le"

-- | Execute a comparison operator.
compareStr :: CompareOp -> Text -> Text -> Bool
compareStr :: CompareOp -> Text -> Text -> Bool
compareStr = \case
  CompareOp
OpEq -> Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(==) -- equal
  CompareOp
OpNe -> Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
(/=) -- not equal
  CompareOp
OpCo -> (Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
isInfixOf -- A contains B
  CompareOp
OpSw -> (Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
isPrefixOf -- A starts with B
  CompareOp
OpEw -> (Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
isSuffixOf -- A ends with B
  CompareOp
OpGt -> Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
(>) -- greater than
  CompareOp
OpGe -> Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
(>=) -- greater than or equal to
  CompareOp
OpLt -> Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
(<) -- less than
  CompareOp
OpLe -> Text -> Text -> Bool
forall a. Ord a => a -> a -> Bool
(<=) -- less than or equal to

----------------------------------------------------------------------------
-- Instances

-- | We currently only support filtering on core user schema
instance FromHttpApiData Filter where
  parseUrlPiece :: Text -> Either Text Filter
parseUrlPiece = [Schema] -> Text -> Either Text Filter
parseFilter [Schema
User20]

instance ToHttpApiData Filter where
  toUrlPiece :: Filter -> Text
toUrlPiece = Filter -> Text
renderFilter