{-# 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

-- | Whether search is case-sensitive.
newtype CaseSensitivity = CaseSensitivity Bool

instance Buildable CaseSensitivity where
    build :: CaseSensitivity -> Builder
build (CaseSensitivity Bool
cs)
        | Bool
cs = Builder
""
        | Bool
otherwise = Builder
"(case-insensitive)"

-- | Simple regexp pattern, @.@ and @*@ signed will be considered.
-- Escaping is performed via prefixing with backslash.
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

-- | Support for SQL's LIKE syntax.
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)

-- | Construct a filter that matches when text contains given substring.
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)