module LaunchDarkly.Server.Operators
    ( Op(..)
    , getOperation
    ) where

import Data.Maybe            (fromMaybe, isJust)
import Data.Either           (fromRight)
import Data.Text as          T
import Data.Text             (Text, isPrefixOf, isInfixOf, isSuffixOf, unpack)
import Data.Char             (isDigit)
import Data.Text.Encoding    (encodeUtf8)
import Data.Scientific       (Scientific, toRealFloat)
import Data.Aeson.Types      (Value(..), FromJSON, ToJSON(..), withText, parseJSON)
import Data.Time.ISO8601     (parseISO8601)
import Data.Time.Clock       (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import Data.SemVer           (Version, fromText, toText, metadata)
import Control.Monad         (liftM2)
import Control.Lens          ((.~))
import GHC.Generics          (Generic)
import Text.Regex.PCRE.Light (compileM, match)

data Op =
      OpIn
    | OpEndsWith
    | OpStartsWith
    | OpMatches
    | OpContains
    | OpLessThan
    | OpLessThanOrEqual
    | OpGreaterThan
    | OpGreaterThanOrEqual
    | OpBefore
    | OpAfter
    | OpSemVerEqual
    | OpSemVerLessThan
    | OpSemVerGreaterThan
    | OpSegmentMatch
    | OpUnknown
    deriving ((forall x. Op -> Rep Op x)
-> (forall x. Rep Op x -> Op) -> Generic Op
forall x. Rep Op x -> Op
forall x. Op -> Rep Op x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep Op x -> Op
$cfrom :: forall x. Op -> Rep Op x
Generic, Int -> Op -> ShowS
[Op] -> ShowS
Op -> String
(Int -> Op -> ShowS)
-> (Op -> String) -> ([Op] -> ShowS) -> Show Op
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Op] -> ShowS
$cshowList :: [Op] -> ShowS
show :: Op -> String
$cshow :: Op -> String
showsPrec :: Int -> Op -> ShowS
$cshowsPrec :: Int -> Op -> ShowS
Show, Op -> Op -> Bool
(Op -> Op -> Bool) -> (Op -> Op -> Bool) -> Eq Op
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Op -> Op -> Bool
$c/= :: Op -> Op -> Bool
== :: Op -> Op -> Bool
$c== :: Op -> Op -> Bool
Eq)

instance FromJSON Op where
    parseJSON :: Value -> Parser Op
parseJSON = String -> (Text -> Parser Op) -> Value -> Parser Op
forall a. String -> (Text -> Parser a) -> Value -> Parser a
withText String
"Op" ((Text -> Parser Op) -> Value -> Parser Op)
-> (Text -> Parser Op) -> Value -> Parser Op
forall a b. (a -> b) -> a -> b
$ \Text
v -> case Text
v of
        Text
"in"                 -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpIn
        Text
"endsWith"           -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpEndsWith
        Text
"startsWith"         -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpStartsWith
        Text
"matches"            -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpMatches
        Text
"contains"           -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpContains
        Text
"lessThan"           -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpLessThan
        Text
"lessThanOrEqual"    -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpLessThanOrEqual
        Text
"greaterThan"        -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpGreaterThan
        Text
"greaterThanOrEqual" -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpGreaterThanOrEqual
        Text
"before"             -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpBefore
        Text
"after"              -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpAfter
        Text
"semVerEqual"        -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpSemVerEqual
        Text
"semVerLessThan"     -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpSemVerLessThan
        Text
"semVerGreaterThan"  -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpSemVerGreaterThan
        Text
"segmentMatch"       -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpSegmentMatch
        Text
_                    -> Op -> Parser Op
forall (f :: * -> *) a. Applicative f => a -> f a
pure Op
OpUnknown

instance ToJSON Op where
    toJSON :: Op -> Value
toJSON Op
op = Text -> Value
String (Text -> Value) -> Text -> Value
forall a b. (a -> b) -> a -> b
$ case Op
op of
        Op
OpIn                 -> Text
"in"
        Op
OpEndsWith           -> Text
"endsWith"
        Op
OpStartsWith         -> Text
"startsWith"
        Op
OpMatches            -> Text
"matches"
        Op
OpContains           -> Text
"contains"
        Op
OpLessThan           -> Text
"lessThan"
        Op
OpLessThanOrEqual    -> Text
"lessThanOrEqual"
        Op
OpGreaterThan        -> Text
"greaterThan"
        Op
OpGreaterThanOrEqual -> Text
"greaterThanOrEqual"
        Op
OpBefore             -> Text
"before"
        Op
OpAfter              -> Text
"after"
        Op
OpSemVerEqual        -> Text
"semVerEqual"
        Op
OpSemVerLessThan     -> Text
"semVerLessThan"
        Op
OpSemVerGreaterThan  -> Text
"semVerGreaterThan"
        Op
OpSegmentMatch       -> Text
"segmentMatch"
        Op
OpUnknown            -> Text
"unknown"

checkString :: (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString :: (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString Text -> Text -> Bool
op (String Text
x) (String Text
y) = Text -> Text -> Bool
op Text
x Text
y
checkString Text -> Text -> Bool
_ Value
_ Value
_                    = Bool
False

checkNumber :: (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber :: (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber Scientific -> Scientific -> Bool
op (Number Scientific
x) (Number Scientific
y) = Scientific -> Scientific -> Bool
op Scientific
x Scientific
y
checkNumber Scientific -> Scientific -> Bool
_ Value
_ Value
_                    = Bool
False

doubleToPOSIXTime :: Double -> POSIXTime
doubleToPOSIXTime :: Double -> POSIXTime
doubleToPOSIXTime = Double -> POSIXTime
forall a b. (Real a, Fractional b) => a -> b
realToFrac

parseTime :: Value -> Maybe UTCTime
parseTime :: Value -> Maybe UTCTime
parseTime (Number Scientific
x) = UTCTime -> Maybe UTCTime
forall a. a -> Maybe a
Just (UTCTime -> Maybe UTCTime) -> UTCTime -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ POSIXTime -> UTCTime
posixSecondsToUTCTime (POSIXTime -> UTCTime) -> POSIXTime -> UTCTime
forall a b. (a -> b) -> a -> b
$ Double -> POSIXTime
doubleToPOSIXTime (Double -> POSIXTime) -> Double -> POSIXTime
forall a b. (a -> b) -> a -> b
$ (Scientific -> Double
forall a. RealFloat a => Scientific -> a
toRealFloat Scientific
x) Double -> Double -> Double
forall a. Fractional a => a -> a -> a
/ Double
1000
parseTime (String Text
x) = String -> Maybe UTCTime
parseISO8601 (String -> Maybe UTCTime) -> String -> Maybe UTCTime
forall a b. (a -> b) -> a -> b
$ Text -> String
unpack Text
x
parseTime Value
_          = Maybe UTCTime
forall a. Maybe a
Nothing

compareTime :: (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool
compareTime :: (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool
compareTime UTCTime -> UTCTime -> Bool
op Value
x Value
y = Bool -> Maybe Bool -> Bool
forall a. a -> Maybe a -> a
fromMaybe Bool
False (Maybe Bool -> Bool) -> Maybe Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (UTCTime -> UTCTime -> Bool)
-> Maybe UTCTime -> Maybe UTCTime -> Maybe Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 UTCTime -> UTCTime -> Bool
op (Value -> Maybe UTCTime
parseTime Value
x) (Value -> Maybe UTCTime
parseTime Value
y)

padSemVer :: Text -> Text
padSemVer :: Text -> Text
padSemVer Text
text = [Text] -> Text
T.concat [Text
l, Text
padding, Text
r] where
    (Text
l, Text
r) = (Char -> Bool) -> Text -> (Text, Text)
T.span (\Char
c -> Char -> Bool
isDigit Char
c Bool -> Bool -> Bool
|| Char
c Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
== Char
'.') Text
text
    dots :: Int
dots = Text -> Text -> Int
T.count Text
"." Text
l
    padding :: Text
padding = if Int
dots Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
2 then Int -> Text -> Text
T.replicate (Int
2 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
dots) Text
".0" else Text
""

parseSemVer :: Text -> Either String Version
parseSemVer :: Text -> Either String Version
parseSemVer Text
raw = (Version -> Version)
-> Either String Version -> Either String Version
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Identifier] -> Identity [Identifier])
-> Version -> Identity Version
forall (f :: * -> *).
Functor f =>
([Identifier] -> f [Identifier]) -> Version -> f Version
metadata (([Identifier] -> Identity [Identifier])
 -> Version -> Identity Version)
-> [Identifier] -> Version -> Version
forall s t a b. ASetter s t a b -> b -> s -> t
.~ []) (Text -> Either String Version
fromText (Text -> Either String Version) -> Text -> Either String Version
forall a b. (a -> b) -> a -> b
$ Text -> Text
padSemVer Text
raw) Either String Version
-> (Version -> Either String Version) -> Either String Version
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Version
x ->
    if Text -> Text -> Bool
T.isPrefixOf (Version -> Text
toText Version
x) (Text -> Text
padSemVer Text
raw) then Version -> Either String Version
forall a b. b -> Either a b
Right Version
x else String -> Either String Version
forall a b. a -> Either a b
Left String
"mismatch" where

compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool
compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool
compareSemVer Version -> Version -> Bool
op Text
x Text
y = Bool -> Either String Bool -> Bool
forall b a. b -> Either a b -> b
fromRight Bool
False (Either String Bool -> Bool) -> Either String Bool -> Bool
forall a b. (a -> b) -> a -> b
$ (Version -> Version -> Bool)
-> Either String Version
-> Either String Version
-> Either String Bool
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Version -> Version -> Bool
op (Text -> Either String Version
parseSemVer Text
x) (Text -> Either String Version
parseSemVer Text
y)

matches :: Text -> Text -> Bool
matches :: Text -> Text -> Bool
matches Text
text Text
pattern = case ByteString -> [PCREOption] -> Either String Regex
compileM (Text -> ByteString
encodeUtf8 Text
pattern) [] of
    Left String
_         -> Bool
False
    Right Regex
compiled -> Maybe [ByteString] -> Bool
forall a. Maybe a -> Bool
isJust (Maybe [ByteString] -> Bool) -> Maybe [ByteString] -> Bool
forall a b. (a -> b) -> a -> b
$ Regex -> ByteString -> [PCREExecOption] -> Maybe [ByteString]
match Regex
compiled (Text -> ByteString
encodeUtf8 Text
text) []

getOperation :: Op -> (Value -> Value -> Bool)
getOperation :: Op -> Value -> Value -> Bool
getOperation Op
op = case Op
op of
    Op
OpIn                 -> Value -> Value -> Bool
forall a. Eq a => a -> a -> Bool
(==)
    Op
OpEndsWith           -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString ((Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
isSuffixOf)
    Op
OpStartsWith         -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString ((Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
isPrefixOf)
    Op
OpContains           -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString ((Text -> Text -> Bool) -> Text -> Text -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Text -> Text -> Bool
isInfixOf)
    Op
OpMatches            -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString Text -> Text -> Bool
matches
    Op
OpLessThan           -> (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(<)
    Op
OpLessThanOrEqual    -> (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(<=)
    Op
OpGreaterThan        -> (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(>)
    Op
OpGreaterThanOrEqual -> (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber Scientific -> Scientific -> Bool
forall a. Ord a => a -> a -> Bool
(>=)
    Op
OpBefore             -> (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool
compareTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
(<)
    Op
OpAfter              -> (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool
compareTime UTCTime -> UTCTime -> Bool
forall a. Ord a => a -> a -> Bool
(>)
    Op
OpSemVerEqual        -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString ((Text -> Text -> Bool) -> Value -> Value -> Bool)
-> (Text -> Text -> Bool) -> Value -> Value -> Bool
forall a b. (a -> b) -> a -> b
$ (Version -> Version -> Bool) -> Text -> Text -> Bool
compareSemVer Version -> Version -> Bool
forall a. Eq a => a -> a -> Bool
(==)
    Op
OpSemVerLessThan     -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString ((Text -> Text -> Bool) -> Value -> Value -> Bool)
-> (Text -> Text -> Bool) -> Value -> Value -> Bool
forall a b. (a -> b) -> a -> b
$ (Version -> Version -> Bool) -> Text -> Text -> Bool
compareSemVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
(<)
    Op
OpSemVerGreaterThan  -> (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString ((Text -> Text -> Bool) -> Value -> Value -> Bool)
-> (Text -> Text -> Bool) -> Value -> Value -> Bool
forall a b. (a -> b) -> a -> b
$ (Version -> Version -> Bool) -> Text -> Text -> Bool
compareSemVer Version -> Version -> Bool
forall a. Ord a => a -> a -> Bool
(>)
    Op
OpSegmentMatch       -> String -> Value -> Value -> Bool
forall a. HasCallStack => String -> a
error String
"cannot get operation for OpSegmentMatch"
    Op
OpUnknown            -> (Value -> Bool) -> Value -> Value -> Bool
forall a b. a -> b -> a
const ((Value -> Bool) -> Value -> Value -> Bool)
-> (Value -> Bool) -> Value -> Value -> Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Value -> Bool
forall a b. a -> b -> a
const Bool
False