{-# LANGUAGE DeriveFunctor #-}
module Servant.Util.Combinators.Filtering.Filters.Like
( pattern Esc
, CaseSensitivity (..)
, mkLikePattern
, LikePattern (..)
, FilterLike (..)
, mkLikePatternUnsafe
, filterContains
) where
import Universum
import qualified Data.Map as M
import qualified Data.Text.Lazy as LT
import Fmt (Buildable (..), (+|), (|+))
import Servant (FromHttpApiData (..), ToHttpApiData (..))
import System.Console.Pretty (Color (..), Style (..), color, style)
import Servant.Util.Combinators.Filtering.Base
newtype CaseSensitivity = CaseSensitivity Bool
instance Buildable CaseSensitivity where
build :: CaseSensitivity -> Builder
build (CaseSensitivity Bool
cs)
| Bool
cs = Builder
""
| Bool
otherwise = Builder
"(case-insensitive)"
newtype LikePattern = LikePatternUnsafe
{ LikePattern -> LText
unLikePattern :: LText
}
pattern Esc :: Char
pattern $bEsc :: Char
$mEsc :: forall r. Char -> (Void# -> r) -> (Void# -> r) -> r
Esc = '\\'
escapedChar :: Char -> LText
escapedChar :: Char -> LText
escapedChar Char
c = String -> LText
LT.pack [Char
Esc, Char
c]
mkLikePattern :: LText -> Either Text LikePattern
mkLikePattern :: LText -> Either Text LikePattern
mkLikePattern LText
txt = do
if String -> Bool
valid (LText -> String
forall a. ToString a => a -> String
toString LText
txt)
then Either Text ()
forall (f :: * -> *). Applicative f => f ()
pass
else Text -> Either Text ()
forall a b. a -> Either a b
Left Text
"Single escape character ('\') is not allowed"
LikePattern -> Either Text LikePattern
forall (m :: * -> *) a. Monad m => a -> m a
return (LText -> LikePattern
LikePatternUnsafe LText
txt)
where
valid :: String -> Bool
valid = \case
Char
Esc : Char
Esc : String
r -> String -> Bool
valid String
r
Char
Esc : Char
'.' : String
r -> String -> Bool
valid String
r
Char
Esc : Char
'*' : String
r -> String -> Bool
valid String
r
Char
Esc : String
_ -> Bool
False
Char
_ : String
r -> String -> Bool
valid String
r
[] -> Bool
True
mkLikePatternUnsafe :: LText -> LikePattern
mkLikePatternUnsafe :: LText -> LikePattern
mkLikePatternUnsafe = (Text -> LikePattern)
-> (LikePattern -> LikePattern)
-> Either Text LikePattern
-> LikePattern
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> LikePattern
forall a. HasCallStack => Text -> a
error LikePattern -> LikePattern
forall a. a -> a
id (Either Text LikePattern -> LikePattern)
-> (LText -> Either Text LikePattern) -> LText -> LikePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> Either Text LikePattern
mkLikePattern
instance IsString LikePattern where
fromString :: String -> LikePattern
fromString = (Text -> LikePattern)
-> (LikePattern -> LikePattern)
-> Either Text LikePattern
-> LikePattern
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either Text -> LikePattern
forall a. HasCallStack => Text -> a
error LikePattern -> LikePattern
forall a. a -> a
id (Either Text LikePattern -> LikePattern)
-> (String -> Either Text LikePattern) -> String -> LikePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LText -> Either Text LikePattern
mkLikePattern (LText -> Either Text LikePattern)
-> (String -> LText) -> String -> Either Text LikePattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> LText
forall a. IsString a => String -> a
fromString
instance Buildable LikePattern where
build :: LikePattern -> Builder
build (LikePatternUnsafe LText
p) = Text
like Text -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
" " Builder -> Builder -> Builder
forall b. FromBuilder b => Builder -> Builder -> b
+| LText
p LText -> Builder -> Builder
forall a b. (Buildable a, FromBuilder b) => a -> Builder -> b
|+ Builder
""
where
like :: Text
like = Style -> Text -> Text
forall a. Pretty a => Style -> a -> a
style Style
Faint (Color -> Text -> Text
forall a. Pretty a => Color -> a -> a
color Color
White Text
"like") :: Text
data FilterLike a
= FilterLike CaseSensitivity LikePattern
deriving ((a -> b) -> FilterLike a -> FilterLike b
(forall a b. (a -> b) -> FilterLike a -> FilterLike b)
-> (forall a b. a -> FilterLike b -> FilterLike a)
-> Functor FilterLike
forall a b. a -> FilterLike b -> FilterLike a
forall a b. (a -> b) -> FilterLike a -> FilterLike b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: a -> FilterLike b -> FilterLike a
$c<$ :: forall a b. a -> FilterLike b -> FilterLike a
fmap :: (a -> b) -> FilterLike a -> FilterLike b
$cfmap :: forall a b. (a -> b) -> FilterLike a -> FilterLike b
Functor)
filterContains :: CaseSensitivity -> Text -> FilterLike a
filterContains :: CaseSensitivity -> Text -> FilterLike a
filterContains CaseSensitivity
cs Text
pat =
CaseSensitivity -> LikePattern -> FilterLike a
forall a. CaseSensitivity -> LikePattern -> FilterLike a
FilterLike CaseSensitivity
cs (LText -> LikePattern
LikePatternUnsafe (LText -> LikePattern) -> LText -> LikePattern
forall a b. (a -> b) -> a -> b
$ LText -> LText
asContains (LText -> LText) -> LText -> LText
forall a b. (a -> b) -> a -> b
$ Text -> LText
LT.fromStrict Text
pat)
where
asContains :: LText -> LText
asContains LText
t = LText
t
LText -> (LText -> LText) -> LText
forall a b. a -> (a -> b) -> b
& LText -> LText -> LText -> LText
LT.replace LText
"." (Char -> LText
escapedChar Char
'.')
LText -> (LText -> LText) -> LText
forall a b. a -> (a -> b) -> b
& LText -> LText -> LText -> LText
LT.replace LText
"*" (Char -> LText
escapedChar Char
'*')
LText -> (LText -> LText) -> LText
forall a b. a -> (a -> b) -> b
& LText -> LText -> LText -> LText
LT.replace (Char -> LText
LT.singleton Char
Esc) (Char -> LText
escapedChar Char
Esc)
LText -> (LText -> LText) -> LText
forall a b. a -> (a -> b) -> b
& Char -> LText -> LText
LT.cons Char
'*'
LText -> (LText -> LText) -> LText
forall a b. a -> (a -> b) -> b
& (LText -> Char -> LText) -> Char -> LText -> LText
forall a b c. (a -> b -> c) -> b -> a -> c
flip LText -> Char -> LText
LT.snoc Char
'*'
instance BuildableAutoFilter FilterLike where
buildAutoFilter :: Text -> FilterLike a -> Builder
buildAutoFilter Text
name = \case
FilterLike CaseSensitivity
cs LikePattern
f -> Text -> Builder
forall p. Buildable p => p -> Builder
build Text
name Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> LikePattern -> Builder
forall p. Buildable p => p -> Builder
build LikePattern
f Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> Builder
" " Builder -> Builder -> Builder
forall a. Semigroup a => a -> a -> a
<> CaseSensitivity -> Builder
forall p. Buildable p => p -> Builder
build CaseSensitivity
cs
instance IsAutoFilter FilterLike where
autoFilterEnglishOpsNames :: OpsDescriptions
autoFilterEnglishOpsNames =
[ (Text
"like", Text
"regex match (`.` for any char, `*` for any substring)")
, (Text
"ilike", Text
"case-insensitive regex")
, (Text
"contains", Text
"contains text, requires no escaping")
, (Text
"icontains", Text
"case-insensitive 'contains text'")
]
autoFilterParsers :: Proxy FilterLike -> Map Text (FilteringValueParser (FilterLike a))
autoFilterParsers Proxy FilterLike
_ = [(Text, FilteringValueParser (FilterLike a))]
-> Map Text (FilteringValueParser (FilterLike a))
forall k a. Ord k => [(k, a)] -> Map k a
M.fromList
[ ( Text
"like"
, CaseSensitivity -> LikePattern -> FilterLike a
forall a. CaseSensitivity -> LikePattern -> FilterLike a
FilterLike (Bool -> CaseSensitivity
CaseSensitivity Bool
True) (LikePattern -> FilterLike a)
-> FilteringValueParser LikePattern
-> FilteringValueParser (FilterLike a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilteringValueParser LikePattern
parseLikePattern
)
, ( Text
"ilike"
, CaseSensitivity -> LikePattern -> FilterLike a
forall a. CaseSensitivity -> LikePattern -> FilterLike a
FilterLike (Bool -> CaseSensitivity
CaseSensitivity Bool
False) (LikePattern -> FilterLike a)
-> FilteringValueParser LikePattern
-> FilteringValueParser (FilterLike a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilteringValueParser LikePattern
parseLikePattern
)
, ( Text
"contains"
, CaseSensitivity -> Text -> FilterLike a
forall a. CaseSensitivity -> Text -> FilterLike a
filterContains (Bool -> CaseSensitivity
CaseSensitivity Bool
True) (Text -> FilterLike a)
-> FilteringValueParser Text -> FilteringValueParser (FilterLike a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilteringValueParser Text
forall a. FromHttpApiData a => FilteringValueParser a
parseFilteringValueAsIs
)
, ( Text
"icontains"
, CaseSensitivity -> Text -> FilterLike a
forall a. CaseSensitivity -> Text -> FilterLike a
filterContains (Bool -> CaseSensitivity
CaseSensitivity Bool
False) (Text -> FilterLike a)
-> FilteringValueParser Text -> FilteringValueParser (FilterLike a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FilteringValueParser Text
forall a. FromHttpApiData a => FilteringValueParser a
parseFilteringValueAsIs
)
]
where
parseLikePattern :: FilteringValueParser LikePattern
parseLikePattern = (Text -> Either Text LikePattern)
-> FilteringValueParser LikePattern
forall a. (Text -> Either Text a) -> FilteringValueParser a
FilteringValueParser ((Text -> Either Text LikePattern)
-> FilteringValueParser LikePattern)
-> (Text -> Either Text LikePattern)
-> FilteringValueParser LikePattern
forall a b. (a -> b) -> a -> b
$ \Text
t -> do
LText
pat <- Text -> Either Text LText
forall a. FromHttpApiData a => Text -> Either Text a
parseUrlPiece Text
t
LText -> Either Text LikePattern
mkLikePattern LText
pat
autoFilterEncode :: FilterLike a -> (Text, Text)
autoFilterEncode = \case
FilterLike CaseSensitivity
cs (LikePattern -> LText
unLikePattern -> LText
pat)
| CaseSensitivity Bool
True <- CaseSensitivity
cs
-> (Text
"like", LText -> Text
forall a. ToHttpApiData a => a -> Text
toQueryParam LText
pat)
| Bool
otherwise
-> (Text
"ilike", LText -> Text
forall a. ToHttpApiData a => a -> Text
toQueryParam LText
pat)