{-# LANGUAGE NoPatternSynonyms #-}
module LaunchDarkly.Server.Operators
( Op (..)
, getOperation
) where
import Control.Lens ((.~))
import Control.Monad (liftM2)
import Data.Aeson.Types (FromJSON, ToJSON (..), Value (..), parseJSON, withText)
import Data.Char (isDigit)
import Data.Either (fromRight)
import Data.Maybe (fromMaybe, isJust)
import Data.Scientific (Scientific, toRealFloat)
import Data.SemVer (Version, fromText, metadata, toText)
import Data.Text (Text, isInfixOf, isPrefixOf, isSuffixOf, unpack)
import qualified Data.Text as T
import Data.Text.Encoding (encodeUtf8)
import Data.Time.Clock (UTCTime)
import Data.Time.Clock.POSIX (POSIXTime, posixSecondsToUTCTime)
import Data.Time.ISO8601 (parseISO8601)
import GHC.Generics (Generic)
import System.IO.Unsafe (unsafePerformIO)
import Text.Regex.PCRE.ByteString (compBlank, compile, execBlank, execute)
data Op
= OpIn
| OpEndsWith
| OpStartsWith
| OpMatches
| OpContains
| OpLessThan
| OpLessThanOrEqual
| OpGreaterThan
| OpGreaterThanOrEqual
| OpBefore
| OpAfter
| OpSemVerEqual
| OpSemVerLessThan
| OpSemVerGreaterThan
| OpSegmentMatch
| OpUnknown
deriving (Generic, Show, Eq)
instance FromJSON Op where
parseJSON = withText "Op" $ \v -> case v of
"in" -> pure OpIn
"endsWith" -> pure OpEndsWith
"startsWith" -> pure OpStartsWith
"matches" -> pure OpMatches
"contains" -> pure OpContains
"lessThan" -> pure OpLessThan
"lessThanOrEqual" -> pure OpLessThanOrEqual
"greaterThan" -> pure OpGreaterThan
"greaterThanOrEqual" -> pure OpGreaterThanOrEqual
"before" -> pure OpBefore
"after" -> pure OpAfter
"semVerEqual" -> pure OpSemVerEqual
"semVerLessThan" -> pure OpSemVerLessThan
"semVerGreaterThan" -> pure OpSemVerGreaterThan
"segmentMatch" -> pure OpSegmentMatch
_ -> pure OpUnknown
instance ToJSON Op where
toJSON op = String $ case op of
OpIn -> "in"
OpEndsWith -> "endsWith"
OpStartsWith -> "startsWith"
OpMatches -> "matches"
OpContains -> "contains"
OpLessThan -> "lessThan"
OpLessThanOrEqual -> "lessThanOrEqual"
OpGreaterThan -> "greaterThan"
OpGreaterThanOrEqual -> "greaterThanOrEqual"
OpBefore -> "before"
OpAfter -> "after"
OpSemVerEqual -> "semVerEqual"
OpSemVerLessThan -> "semVerLessThan"
OpSemVerGreaterThan -> "semVerGreaterThan"
OpSegmentMatch -> "segmentMatch"
OpUnknown -> "unknown"
checkString :: (Text -> Text -> Bool) -> Value -> Value -> Bool
checkString op (String x) (String y) = op x y
checkString _ _ _ = False
checkNumber :: (Scientific -> Scientific -> Bool) -> Value -> Value -> Bool
checkNumber op (Number x) (Number y) = op x y
checkNumber _ _ _ = False
doubleToPOSIXTime :: Double -> POSIXTime
doubleToPOSIXTime = realToFrac
parseTime :: Value -> Maybe UTCTime
parseTime (Number x) = Just $ posixSecondsToUTCTime $ doubleToPOSIXTime $ (toRealFloat x) / 1000
parseTime (String x) = parseISO8601 $ unpack x
parseTime _ = Nothing
compareTime :: (UTCTime -> UTCTime -> Bool) -> Value -> Value -> Bool
compareTime op x y = fromMaybe False $ liftM2 op (parseTime x) (parseTime y)
padSemVer :: Text -> Text
padSemVer text = T.concat [l, padding, r]
where
(l, r) = T.span (\c -> isDigit c || c == '.') text
dots = T.count "." l
padding = if dots < 2 then T.replicate (2 - dots) ".0" else ""
parseSemVer :: Text -> Either String Version
parseSemVer raw =
fmap (metadata .~ []) (fromText $ padSemVer raw) >>= \x ->
if T.isPrefixOf (toText x) (padSemVer raw) then Right x else Left "mismatch"
where
compareSemVer :: (Version -> Version -> Bool) -> Text -> Text -> Bool
compareSemVer op x y = fromRight False $ liftM2 op (parseSemVer x) (parseSemVer y)
-- | Return True if the pattern matches part of the text.
--
-- A pattern that is not valid does not match. A match error, for example a
-- match limit, also does not match. The pattern compiles without UTF mode.
-- Thus, "." and case-insensitive matches operate on bytes of the UTF-8 text.
--
-- The function uses the IO functions of regex-pcre-builtin. The pure match
-- functions throw an exception when a match error occurs.
matches :: Text -> Text -> Bool
matches text pattern = unsafePerformIO $ do
compiled <- compile compBlank execBlank (encodeUtf8 pattern)
case compiled of
Left _ -> pure False
Right regex -> either (const False) isJust <$> execute regex (encodeUtf8 text)
getOperation :: Op -> (Value -> Value -> Bool)
getOperation op = case op of
OpIn -> (==)
OpEndsWith -> checkString (flip isSuffixOf)
OpStartsWith -> checkString (flip isPrefixOf)
OpContains -> checkString (flip isInfixOf)
OpMatches -> checkString matches
OpLessThan -> checkNumber (<)
OpLessThanOrEqual -> checkNumber (<=)
OpGreaterThan -> checkNumber (>)
OpGreaterThanOrEqual -> checkNumber (>=)
OpBefore -> compareTime (<)
OpAfter -> compareTime (>)
OpSemVerEqual -> checkString $ compareSemVer (==)
OpSemVerLessThan -> checkString $ compareSemVer (<)
OpSemVerGreaterThan -> checkString $ compareSemVer (>)
OpSegmentMatch -> error "cannot get operation for OpSegmentMatch"
OpUnknown -> const $ const False