From 25878b6ce5a9df4540a00fe1a14f738e42d58640 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 20 May 2024 18:45:19 -0300 Subject: [PATCH 01/39] Write the shell of script execution The core will be in Redis.Script --- nri-redis/nri-redis.cabal | 4 ++ nri-redis/package.yaml | 1 + nri-redis/src/Redis.hs | 12 +++++- nri-redis/src/Redis/Handler.hs | 5 +++ nri-redis/src/Redis/Internal.hs | 6 +++ nri-redis/src/Redis/Script.hs | 73 +++++++++++++++++++++++++++++++++ 6 files changed, 99 insertions(+), 2 deletions(-) create mode 100644 nri-redis/src/Redis/Script.hs diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index 37060b7b..bd356d5b 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -40,6 +40,7 @@ library Redis.Codec Redis.Handler Redis.Internal + Redis.Script Redis.Settings Paths_nri_redis hs-source-dirs: @@ -76,6 +77,7 @@ library , pcre-light >=0.4.1.0 && <0.4.2 , resourcet >=1.2.0 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 + , template-haskell >=2.19 && <3.0 , text >=1.2.3.1 && <2.1 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 @@ -96,6 +98,7 @@ test-suite tests Redis.Hash Redis.Internal Redis.List + Redis.Script Redis.Set Redis.Settings Redis.SortedSet @@ -135,6 +138,7 @@ test-suite tests , pcre-light >=0.4.1.0 && <0.4.2 , resourcet >=1.2.0 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 + , template-haskell >=2.19 && <3.0 , text >=1.2.3.1 && <2.1 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index 84d83ab3..a920ec90 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -30,6 +30,7 @@ dependencies: - resourcet >= 1.2.0 && < 1.3 - safe-exceptions >= 0.1.7.0 && < 1.3 - text >= 1.2.3.1 && < 2.1 + - template-haskell >= 2.19 && < 3.0 - unordered-containers >=0.2.0.0 && <0.3 - uuid >=1.3.0 && < 1.4 library: diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index 080401e7..44db8d14 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -37,6 +37,7 @@ module Redis set, setex, setnx, + eval, -- * Running Redis queries Internal.query, @@ -52,6 +53,8 @@ module Redis where import qualified Data.Aeson as Aeson +import qualified Redis.Script as Script +import qualified Database.Redis import qualified Data.ByteString as ByteString import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty @@ -135,7 +138,11 @@ data Api key a = Api -- performed. SETNX is short for "SET if Not eXists". -- -- https://redis.io/commands/setnx - setnx :: key -> a -> Internal.Query Bool + setnx :: key -> a -> Internal.Query Bool, + -- | Invoke the execution of a server-side Lua script. + -- + -- https://redis.io/commands/eval + eval :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a } -- | Creates a json API mapping a 'key' to a json-encodable-decodable type @@ -181,5 +188,6 @@ makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey = ping = Internal.Ping |> map (\_ -> ()), set = \key value -> Internal.Set (toKey key) (codecEncoder value), setex = \key seconds value -> Internal.Setex (toKey key) seconds (codecEncoder value), - setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value) + setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value), + eval = \script -> Internal.Eval script } diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index 585617be..a92ff539 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -12,6 +12,7 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Acquire import qualified Data.ByteString import qualified Data.List.NonEmpty as NonEmpty +import qualified Redis.Script as Script import qualified Data.Text.Encoding import qualified Database.Redis import qualified Dict @@ -165,6 +166,10 @@ doRawQuery query = Database.Redis.del (NonEmpty.toList (map toB keys)) |> PreparedQuery |> map (Ok << Prelude.fromIntegral) + Internal.Eval script -> + Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.paramNames script)) (map toB(Script.paramValues script)) + |> PreparedQuery + |> map Ok Internal.Exists key -> Database.Redis.exists (toB key) |> PreparedQuery diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index e06c7dc6..68191a69 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -38,6 +38,7 @@ import qualified Log.RedisCommands as RedisCommands import NriPrelude hiding (map, map2, map3) import qualified Platform import qualified Redis.Settings as Settings +import qualified Redis.Script as Script import qualified Set import qualified Text import qualified Tuple @@ -79,6 +80,7 @@ cmds :: Query b -> [Text] cmds query'' = case query'' of Del keys -> [unwords ("DEL" : NonEmpty.toList keys)] + Eval script -> [Script.evalString script] Exists key -> [unwords ["EXISTS", key]] Expire key val -> [unwords ["EXPIRE", key, Text.fromInt val]] Get key -> [unwords ["GET", key]] @@ -136,6 +138,7 @@ unwords = Text.join " " -- | A Redis query data Query a where Del :: NonEmpty Text -> Query Int + Eval :: Database.Redis.RedisResult a => Script.Script a -> Query a Exists :: Text -> Query Bool Expire :: Text -> Int -> Query () Get :: Text -> Query (Maybe ByteString) @@ -271,6 +274,7 @@ namespaceQuery prefix query' = mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a) mapKeys fn query' = case query' of + Eval script -> Task.map Eval (Script.mapKeys fn script) Exists key -> Task.map Exists (fn key) Ping -> Task.succeed Ping Get key -> Task.map Get (fn key) @@ -314,6 +318,7 @@ mapKeys fn query' = mapReturnedKeys :: (Text -> Text) -> Query a -> Query a mapReturnedKeys fn query' = case query' of + Eval _ -> query' Exists key -> Exists key Ping -> Ping Get key -> Get key @@ -371,6 +376,7 @@ keysTouchedByQuery query' = case query' of Apply f x -> Set.union (keysTouchedByQuery f) (keysTouchedByQuery x) Del keys -> Set.fromList (NonEmpty.toList keys) + Eval script -> Script.keysTouchedByScript script Exists key -> Set.singleton key -- We use this function to collect keys we need to expire. If the user is -- explicitly setting an expiry we don't want to overwrite that. diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs new file mode 100644 index 00000000..487995e7 --- /dev/null +++ b/nri-redis/src/Redis/Script.hs @@ -0,0 +1,73 @@ +{-# LANGUAGE TemplateHaskell #-} + +module Redis.Script (Script(..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues) where + +import qualified Language.Haskell.TH as TH +import qualified Language.Haskell.TH.Quote as QQ +import Data.ByteString (ByteString) +import qualified Set +import Data.Text.Encoding (encodeUtf8) +import qualified Prelude +import qualified Database.Redis + +data Script result = Script + { -- | The Lua script to be executed + luaScript :: Text, + -- | The parameters that fill the placeholders in this query + params :: Log.Secret [Param], + -- | The script string as extracted from a `script` quasi quote. + quasiQuotedString :: Text + } deriving (Eq, Show) + +data Param = Param + { kind :: ParamKind, + name :: Text, + value :: Text + } + deriving (Eq, Show) + +data ParamKind = RedisKey | ArbitraryValue + deriving (Eq, Show) + +script :: QQ.QuasiQuoter +script = + QQ.QuasiQuoter + { QQ.quoteExp = qqScript, + QQ.quoteType = Prelude.error "script not supported in types", + QQ.quotePat = Prelude.error "script not supported in patterns", + QQ.quoteDec = Prelude.error "script not supported in declarations" + } + +qqScript :: Prelude.String -> TH.ExpQ +qqScript scriptWithVars = do + -- let bs = encodeUtf8 (Text.fromList scriptWithVars) + let str = Text.fromList scriptWithVars + [|Script str [] str|] + +-- | EVAL script numkeys [key [key ...]] [arg [arg ...]] +evalString :: Script a -> Text +evalString = Debug.todo "evalString" + +-- | Map the keys in the script to the keys in the Redis API +mapKeys :: (Text -> Task err Text) -> Script a -> Task err (Script a) +mapKeys _fn _script = Debug.todo "mapKeys" + +-- | Get the keys touched by the script +keysTouchedByScript :: Script a -> Set.Set Text +keysTouchedByScript = Debug.todo "keysTouchedByScript" + +-- | Get the parameter names in the script +paramNames :: Script a -> List Text +paramNames script' = + script' + |> params + |> Log.unSecret + |> List.map (\param -> name param) + +-- | Get the parameter values in the script +paramValues :: Script a -> List Text +paramValues script' = + script' + |> params + |> Log.unSecret + |> List.map (\param -> value param) From 386357e515498a09928e24681fa2f1cf60705a62 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 20 May 2024 20:22:46 -0300 Subject: [PATCH 02/39] format --- nri-redis/src/Redis.hs | 4 ++-- nri-redis/src/Redis/Handler.hs | 4 ++-- nri-redis/src/Redis/Internal.hs | 2 +- 3 files changed, 5 insertions(+), 5 deletions(-) diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index 44db8d14..dd263bcb 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -53,16 +53,16 @@ module Redis where import qualified Data.Aeson as Aeson -import qualified Redis.Script as Script -import qualified Database.Redis import qualified Data.ByteString as ByteString import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty +import qualified Database.Redis import qualified Dict import qualified NonEmptyDict import qualified Redis.Codec as Codec import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal +import qualified Redis.Script as Script import qualified Redis.Settings as Settings import qualified Prelude diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index a92ff539..339989b0 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -12,13 +12,13 @@ import Control.Monad.IO.Class (liftIO) import qualified Data.Acquire import qualified Data.ByteString import qualified Data.List.NonEmpty as NonEmpty -import qualified Redis.Script as Script import qualified Data.Text.Encoding import qualified Database.Redis import qualified Dict import qualified GHC.Stack as Stack import qualified Platform import qualified Redis.Internal as Internal +import qualified Redis.Script as Script import qualified Redis.Settings as Settings import qualified Set import qualified Text @@ -167,7 +167,7 @@ doRawQuery query = |> PreparedQuery |> map (Ok << Prelude.fromIntegral) Internal.Eval script -> - Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.paramNames script)) (map toB(Script.paramValues script)) + Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.paramNames script)) (map toB (Script.paramValues script)) |> PreparedQuery |> map Ok Internal.Exists key -> diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 68191a69..5191bd9b 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -37,8 +37,8 @@ import qualified List import qualified Log.RedisCommands as RedisCommands import NriPrelude hiding (map, map2, map3) import qualified Platform -import qualified Redis.Settings as Settings import qualified Redis.Script as Script +import qualified Redis.Settings as Settings import qualified Set import qualified Text import qualified Tuple From cdadce7e6a9511d5f72b74eaee90127b9b487411 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 20 May 2024 21:28:15 -0300 Subject: [PATCH 03/39] Attempt at an attoparsec parser, which I gave up on Turns out error messages are important --- nri-redis/nri-redis.cabal | 2 ++ nri-redis/package.yaml | 1 + nri-redis/src/Redis/Script.hs | 52 +++++++++++++++++++++++------ nri-redis/test/Helpers.hs | 3 +- nri-redis/test/Spec.hs | 4 ++- nri-redis/test/Spec/Redis/Script.hs | 49 +++++++++++++++++++++++++++ 6 files changed, 97 insertions(+), 14 deletions(-) create mode 100644 nri-redis/test/Spec/Redis/Script.hs diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index bd356d5b..a154f497 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -65,6 +65,7 @@ library build-depends: aeson >=1.4.6.0 && <2.2 , async >=2.2.2 && <2.3 + , attoparsec >=0.13.0.0 && <0.15 , base >=4.12.0.0 && <4.18 , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 @@ -126,6 +127,7 @@ test-suite tests build-depends: aeson >=1.4.6.0 && <2.2 , async >=2.2.2 && <2.3 + , attoparsec >=0.13.0.0 && <0.15 , base >=4.12.0.0 && <4.18 , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index a920ec90..cf3ed2ab 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -16,6 +16,7 @@ extra-doc-files: dependencies: - aeson >= 1.4.6.0 && < 2.2 - async >=2.2.2 && <2.3 + - attoparsec >= 0.13.0.0 && < 0.15 - base >= 4.12.0.0 && < 4.18 - bytestring >= 0.10.8.2 && < 0.12 - conduit >= 1.3.0 && < 1.4 diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 487995e7..c4362fdb 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -1,14 +1,13 @@ -{-# LANGUAGE TemplateHaskell #-} - -module Redis.Script (Script(..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues) where +module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, ScriptExpression (..)) where +import Data.Attoparsec.Text (Parser, char,choice, inClass, many1', skipSpace, takeWhile1, (), endOfInput) +import qualified Data.Attoparsec.Text as Attoparsec import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as QQ -import Data.ByteString (ByteString) +-- import Control.Applicative ((<|>)) import qualified Set -import Data.Text.Encoding (encodeUtf8) +import Prelude (pure) import qualified Prelude -import qualified Database.Redis data Script result = Script { -- | The Lua script to be executed @@ -17,7 +16,8 @@ data Script result = Script params :: Log.Secret [Param], -- | The script string as extracted from a `script` quasi quote. quasiQuotedString :: Text - } deriving (Eq, Show) + } + deriving (Eq, Show) data Param = Param { kind :: ParamKind, @@ -40,9 +40,39 @@ script = qqScript :: Prelude.String -> TH.ExpQ qqScript scriptWithVars = do - -- let bs = encodeUtf8 (Text.fromList scriptWithVars) let str = Text.fromList scriptWithVars - [|Script str [] str|] + let _expr = Attoparsec.parseOnly parser str + -- let parsedScript = case expr str of + -- Left err -> Prelude.error <| "Failed to parse script: " ++ err + -- Right parsed -> + -- [|parsedScript|] + Debug.todo "qqScript" + +data ScriptExpression + = ScriptText Text + | ScriptVariable Text + deriving (Show, Eq) + +parser :: Parser (List ScriptExpression) +parser = do + result <- many1' (choice [parseText, parseVariable]) "Expected at least one" + endOfInput + pure <| result + +parseText :: Parser ScriptExpression +parseText = do + text <- takeWhile1 ('$' /=) "Expected text" + pure <| ScriptText text + +parseVariable :: Parser ScriptExpression +parseVariable = do + _ <- char '$' "Expected '$'" + _ <- char '{' "Expected '{'" + skipSpace "Expected space after '{'" + name <- (takeWhile1 (not << inClass "${}")) + "No '$', '{' or '}' allowed in interpolated expression. Note: I'm a simple parser and I don't support records inside ${}." + _ <- char '}' "Expected '}' after: ${" ++ Text.toList name + pure <| ScriptVariable <| Text.trim name -- | EVAL script numkeys [key [key ...]] [arg [arg ...]] evalString :: Script a -> Text @@ -62,7 +92,7 @@ paramNames script' = script' |> params |> Log.unSecret - |> List.map (\param -> name param) + |> List.map name -- | Get the parameter values in the script paramValues :: Script a -> List Text @@ -70,4 +100,4 @@ paramValues script' = script' |> params |> Log.unSecret - |> List.map (\param -> value param) + |> List.map value diff --git a/nri-redis/test/Helpers.hs b/nri-redis/test/Helpers.hs index 406a1716..9522e36c 100644 --- a/nri-redis/test/Helpers.hs +++ b/nri-redis/test/Helpers.hs @@ -30,11 +30,10 @@ getHandlers = do -- > foo -- > bar -- > baz --- +-- -- In GHC 8.10.x (and possibly GHC 9.0.x?) `srcLocEndLine` and `srcLocEndCol` -- would correspond to the `z` at the end of `baz`. Unfortunately, in GHC 9.2.x -- it corresponds to the second `o` at the end of `foo`. - goldenResultsDir :: Text #if __GLASGOW_HASKELL__ >= 902 goldenResultsDir = "test/golden-results-9.2" diff --git a/nri-redis/test/Spec.hs b/nri-redis/test/Spec.hs index c4728238..bccfe6e0 100644 --- a/nri-redis/test/Spec.hs +++ b/nri-redis/test/Spec.hs @@ -1,6 +1,7 @@ import qualified Conduit import Helpers import qualified Spec.Redis +import qualified Spec.Redis.Script import qualified Spec.Settings import qualified Test import qualified Prelude @@ -12,5 +13,6 @@ main = <| Test.describe "nri-redis" [ Spec.Redis.tests testHandlers, - Spec.Settings.tests + Spec.Settings.tests, + Spec.Redis.Script.tests ] diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs new file mode 100644 index 00000000..35f509fe --- /dev/null +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -0,0 +1,49 @@ +module Spec.Redis.Script (tests) where + +import qualified Data.Attoparsec.Text as Attoparsec +import Data.Either (Either (..)) +import qualified Expect +import Redis.Script +import qualified Test + +tests :: Test.Test +tests = + Test.describe + "Redis.Script" + [ Test.describe "parser" parserTests + ] + +parserTests :: List Test.Test +parserTests = + [ Test.test "1 word" <| \_ -> + (Attoparsec.parseOnly parser "Jabuticaba") + |> Expect.equal (Right [ScriptText "Jabuticaba"]), + Test.test "3 words" <| \_ -> + (Attoparsec.parseOnly parser "Picolé de Jabuticaba") + |> Expect.equal (Right [ScriptText "Picolé de Jabuticaba"]), + Test.test "1 value" <| \_ -> + (Attoparsec.parseOnly parser "${value}") + |> Expect.equal (Right [ScriptVariable "value"]), + Test.test "function application" <| \_ -> + (Attoparsec.parseOnly parser "${func arg1 arg2}") + |> Expect.equal (Right [ScriptVariable "func arg1 arg2"]), + Test.test "text and variables" <| \_ -> + (Attoparsec.parseOnly parser "some text ${value} some more text ${ anotherValue }") + |> Expect.equal + ( Right + [ ScriptText "some text ", + ScriptVariable "value", + ScriptText " some more text ", + ScriptVariable "anotherValue" + ] + ), + Test.only <| Test.test "ERROR: nested ${}" <| \_ -> do + (Attoparsec.parseOnly parser "asdasd ${ ${ value } }") + |> Expect.equal (Left "Expected at least one > No '$', '{' or '}' allowed in interpolated expression. Note: I'm a simple parser and I don't support records inside ${}.: Failed reading: takeWhile1"), + Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do + (Attoparsec.parseOnly parser "${ v$alue }") + |> Expect.equal (Left "Expected at least one > Expected '}' after: ${v > '}': Failed reading: satisfy"), + Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do + (Attoparsec.parseOnly parser "${ v{alue }") + |> Expect.equal (Left "Expected at least one > Expected '}' after: ${v > '}': Failed reading: satisfy") + ] From 542438abf1624592e6573358cab63879f1f64483 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 20 May 2024 22:46:04 -0300 Subject: [PATCH 04/39] Ditch attoparsec for megaparsec: great error msgs --- nri-redis/nri-redis.cabal | 5 +- nri-redis/package.yaml | 2 +- nri-redis/src/Redis/Script.hs | 40 ++++++------- nri-redis/test/Spec/Redis/Script.hs | 88 ++++++++++++++++++++++++----- 4 files changed, 98 insertions(+), 37 deletions(-) diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index a154f497..94143c87 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -65,12 +65,12 @@ library build-depends: aeson >=1.4.6.0 && <2.2 , async >=2.2.2 && <2.3 - , attoparsec >=0.13.0.0 && <0.15 , base >=4.12.0.0 && <4.18 , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 , containers >=0.6.0.1 && <0.7 , hedis >=0.14.0 && <0.16 + , megaparsec >=9.2.2 && <9.3 , modern-uri >=0.3.1.0 && <0.4 , nri-env-parser >=0.1.0.0 && <0.2 , nri-observability >=0.1.0 && <0.2 @@ -90,6 +90,7 @@ test-suite tests other-modules: Helpers Spec.Redis + Spec.Redis.Script Spec.Settings NonEmptyDict Redis @@ -127,12 +128,12 @@ test-suite tests build-depends: aeson >=1.4.6.0 && <2.2 , async >=2.2.2 && <2.3 - , attoparsec >=0.13.0.0 && <0.15 , base >=4.12.0.0 && <4.18 , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 , containers >=0.6.0.1 && <0.7 , hedis >=0.14.0 && <0.16 + , megaparsec >=9.2.2 && <9.3 , modern-uri >=0.3.1.0 && <0.4 , nri-env-parser >=0.1.0.0 && <0.2 , nri-observability >=0.1.0 && <0.2 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index cf3ed2ab..d2016831 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -16,13 +16,13 @@ extra-doc-files: dependencies: - aeson >= 1.4.6.0 && < 2.2 - async >=2.2.2 && <2.3 - - attoparsec >= 0.13.0.0 && < 0.15 - base >= 4.12.0.0 && < 4.18 - bytestring >= 0.10.8.2 && < 0.12 - conduit >= 1.3.0 && < 1.4 - containers >= 0.6.0.1 && < 0.7 # hedis 14 introduces redis-cluster support - hedis >= 0.14.0 && < 0.16 + - megaparsec >= 9.2.2 && < 9.3 - modern-uri >= 0.3.1.0 && < 0.4 - nri-env-parser >= 0.1.0.0 && < 0.2 - nri-observability >= 0.1.0 && < 0.2 diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index c4362fdb..eb52906f 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -1,12 +1,13 @@ -module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, ScriptExpression (..)) where +module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, Tokens (..)) where -import Data.Attoparsec.Text (Parser, char,choice, inClass, many1', skipSpace, takeWhile1, (), endOfInput) -import qualified Data.Attoparsec.Text as Attoparsec +import Data.Void (Void) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as QQ --- import Control.Applicative ((<|>)) import qualified Set -import Prelude (pure) +import Text.Megaparsec ((<|>)) +import qualified Text.Megaparsec as P +import qualified Text.Megaparsec.Char as PC +import Prelude (notElem, pure, (<*)) import qualified Prelude data Script result = Script @@ -41,37 +42,36 @@ script = qqScript :: Prelude.String -> TH.ExpQ qqScript scriptWithVars = do let str = Text.fromList scriptWithVars - let _expr = Attoparsec.parseOnly parser str + let _expr = P.parse parser "" str -- let parsedScript = case expr str of -- Left err -> Prelude.error <| "Failed to parse script: " ++ err -- Right parsed -> -- [|parsedScript|] Debug.todo "qqScript" -data ScriptExpression +data Tokens = ScriptText Text | ScriptVariable Text deriving (Show, Eq) -parser :: Parser (List ScriptExpression) +type Parser = P.Parsec Void Text + +parser :: Parser (List Tokens) parser = do - result <- many1' (choice [parseText, parseVariable]) "Expected at least one" - endOfInput - pure <| result + (P.some (parseText <|> parseVariable)) + <* P.eof -parseText :: Parser ScriptExpression +parseText :: Parser Tokens parseText = do - text <- takeWhile1 ('$' /=) "Expected text" + text <- P.takeWhile1P (Just "some plain text") (/= '$') pure <| ScriptText text -parseVariable :: Parser ScriptExpression +parseVariable :: Parser Tokens parseVariable = do - _ <- char '$' "Expected '$'" - _ <- char '{' "Expected '{'" - skipSpace "Expected space after '{'" - name <- (takeWhile1 (not << inClass "${}")) - "No '$', '{' or '}' allowed in interpolated expression. Note: I'm a simple parser and I don't support records inside ${}." - _ <- char '}' "Expected '}' after: ${" ++ Text.toList name + _ <- PC.string "${" + _ <- PC.space + name <- P.takeWhile1P (Just "anything but '$', '{' or '}' (no records, sorry)") (\t -> t `notElem` ['$', '{', '}']) + _ <- PC.char '}' pure <| ScriptVariable <| Text.trim name -- | EVAL script numkeys [key [key ...]] [arg [arg ...]] diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 35f509fe..1f1bef14 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -1,10 +1,10 @@ module Spec.Redis.Script (tests) where -import qualified Data.Attoparsec.Text as Attoparsec import Data.Either (Either (..)) import qualified Expect import Redis.Script import qualified Test +import qualified Text.Megaparsec as P tests :: Test.Test tests = @@ -16,19 +16,19 @@ tests = parserTests :: List Test.Test parserTests = [ Test.test "1 word" <| \_ -> - (Attoparsec.parseOnly parser "Jabuticaba") + P.runParser parser "" "Jabuticaba" |> Expect.equal (Right [ScriptText "Jabuticaba"]), Test.test "3 words" <| \_ -> - (Attoparsec.parseOnly parser "Picolé de Jabuticaba") + P.runParser parser "" "Picolé de Jabuticaba" |> Expect.equal (Right [ScriptText "Picolé de Jabuticaba"]), Test.test "1 value" <| \_ -> - (Attoparsec.parseOnly parser "${value}") + P.runParser parser "" "${value}" |> Expect.equal (Right [ScriptVariable "value"]), Test.test "function application" <| \_ -> - (Attoparsec.parseOnly parser "${func arg1 arg2}") + P.runParser parser "" "${func arg1 arg2}" |> Expect.equal (Right [ScriptVariable "func arg1 arg2"]), Test.test "text and variables" <| \_ -> - (Attoparsec.parseOnly parser "some text ${value} some more text ${ anotherValue }") + P.runParser parser "" "some text ${value} some more text ${ anotherValue }" |> Expect.equal ( Right [ ScriptText "some text ", @@ -37,13 +37,73 @@ parserTests = ScriptVariable "anotherValue" ] ), - Test.only <| Test.test "ERROR: nested ${}" <| \_ -> do - (Attoparsec.parseOnly parser "asdasd ${ ${ value } }") - |> Expect.equal (Left "Expected at least one > No '$', '{' or '}' allowed in interpolated expression. Note: I'm a simple parser and I don't support records inside ${}.: Failed reading: takeWhile1"), - Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do - (Attoparsec.parseOnly parser "${ v$alue }") - |> Expect.equal (Left "Expected at least one > Expected '}' after: ${v > '}': Failed reading: satisfy"), + Test.test "ERROR: empty" <| \_ -> do + P.runParser parser "" "" + |> mapLeft P.errorBundlePretty + |> Expect.equal + ( Left + "1:1:\n\ + \ |\n\ + \1 | \n\ + \ | ^\n\ + \unexpected end of input\n\ + \expecting \"${\" or some plain text\n\ + \" + ), + Test.test "ERROR: empty variable" <| \_ -> do + P.runParser parser "" "${}" + |> mapLeft P.errorBundlePretty + |> Expect.equal + ( Left + "1:3:\n\ + \ |\n\ + \1 | ${}\n\ + \ | ^\n\ + \unexpected '}'\n\ + \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\ + \" + ), + Test.test "ERROR: nested ${}" <| \_ -> do + P.runParser parser "" "asdasd ${ ${ value } }" + |> mapLeft P.errorBundlePretty + |> Expect.equal + ( Left + "1:11:\n\ + \ |\n\ + \1 | asdasd ${ ${ value } }\n\ + \ | ^\n\ + \unexpected '$'\n\ + \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\ + \" + ), Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do - (Attoparsec.parseOnly parser "${ v{alue }") - |> Expect.equal (Left "Expected at least one > Expected '}' after: ${v > '}': Failed reading: satisfy") + P.runParser parser "" "${ v$alue }" + |> mapLeft P.errorBundlePretty + |> Expect.equal + ( Left + "1:5:\n\ + \ |\n\ + \1 | ${ v$alue }\n\ + \ | ^\n\ + \unexpected '$'\n\ + \expecting '}' or anything but '$', '{' or '}' (no records, sorry)\n\ + \" + ), + Test.test "ERROR: misplaced { inside ${}" <| \_ -> do + P.runParser parser "" "${ v{alue }" + |> mapLeft P.errorBundlePretty + |> Expect.equal + ( Left + "1:5:\n\ + \ |\n\ + \1 | ${ v{alue }\n\ + \ | ^\n\ + \unexpected '{'\n\ + \expecting '}' or anything but '$', '{' or '}' (no records, sorry)\n\ + \" + ) ] + +mapLeft :: (a -> c) -> Either a b -> Either c b +mapLeft f (Left a) = Left (f a) +mapLeft _ (Right b) = Right b From 436e7b45fab80865a080cde014863ba2ce660871 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 16:53:39 -0300 Subject: [PATCH 05/39] Create TemplateHaskell API for writing Lua Scripts --- nri-redis/nri-redis.cabal | 2 + nri-redis/package.yaml | 1 + nri-redis/src/Redis/Script.hs | 117 ++++++++++++++++++++++++---- nri-redis/test/Spec/Redis/Script.hs | 22 +++++- 4 files changed, 128 insertions(+), 14 deletions(-) diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index 94143c87..9e3a081c 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -69,6 +69,7 @@ library , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 , containers >=0.6.0.1 && <0.7 + , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16 , megaparsec >=9.2.2 && <9.3 , modern-uri >=0.3.1.0 && <0.4 @@ -132,6 +133,7 @@ test-suite tests , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 , containers >=0.6.0.1 && <0.7 + , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16 , megaparsec >=9.2.2 && <9.3 , modern-uri >=0.3.1.0 && <0.4 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index d2016831..3690c81a 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -20,6 +20,7 @@ dependencies: - bytestring >= 0.10.8.2 && < 0.12 - conduit >= 1.3.0 && < 1.4 - containers >= 0.6.0.1 && < 0.7 + - haskell-src-meta >= 0.8.12 && < 0.9 # hedis 14 introduces redis-cluster support - hedis >= 0.14.0 && < 0.16 - megaparsec >= 9.2.2 && < 9.3 diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index eb52906f..ea84cadb 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -1,6 +1,14 @@ -module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, Tokens (..)) where +{-# LANGUAGE GADTs #-} +{-# LANGUAGE IncoherentInstances #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE UndecidableInstances #-} +module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, Tokens (..), ScriptParam (..), printScript) where + +import Data.Either (Either (..)) import Data.Void (Void) +import qualified GHC.TypeLits +import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as QQ import qualified Set @@ -11,16 +19,44 @@ import Prelude (notElem, pure, (<*)) import qualified Prelude data Script result = Script - { -- | The Lua script to be executed + { -- | The Lua script to be executed with @args placeholders for Redis luaScript :: Text, - -- | The parameters that fill the placeholders in this query - params :: Log.Secret [Param], -- | The script string as extracted from a `script` quasi quote. - quasiQuotedString :: Text + quasiQuotedString :: Text, + -- | The parameters that fill the placeholders in this query + params :: Log.Secret [EvaluatedParam] } deriving (Eq, Show) -data Param = Param +-- | A type for enforcing parameters used in [script|${ ... }|] are either tagged as Key or Literal. +-- +-- We need keys to be tagged, otherwise we can't implement `mapKeys` and enforce namespacing +-- in Redis APIs. +-- +-- We make this extra generic to allow us to provide nice error messages using TypeError in a +-- type class below. +data ScriptParam + = forall a. (Show a) => Key a + | forall a. (Show a) => Literal a + +class HasScriptParam a where + getScriptParam :: a -> ScriptParam + +instance HasScriptParam ScriptParam where + getScriptParam = Prelude.id + +-- | This instance is used to provide a helpful error message when a user tries to use a type +-- other than a ScriptParam in a [script|${ ... }|] quasi quote. +-- +-- It is what forces us to have IncoherentInstances and UndecidedInstances enabled. +instance + {-# OVERLAPPABLE #-} + GHC.TypeLits.TypeError (GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.") => + HasScriptParam x + where + getScriptParam = Prelude.error "This won't ever hit bc this generates a compile-time error." + +data EvaluatedParam = EvaluatedParam { kind :: ParamKind, name :: Text, value :: Text @@ -39,15 +75,54 @@ script = QQ.quoteDec = Prelude.error "script not supported in declarations" } -qqScript :: Prelude.String -> TH.ExpQ +qqScript :: Prelude.String -> TH.Q TH.Exp qqScript scriptWithVars = do let str = Text.fromList scriptWithVars - let _expr = P.parse parser "" str - -- let parsedScript = case expr str of - -- Left err -> Prelude.error <| "Failed to parse script: " ++ err - -- Right parsed -> - -- [|parsedScript|] - Debug.todo "qqScript" + let parseResult = P.parse parser "" str + case parseResult of + Left err -> Prelude.error <| "Failed to parse script: " ++ P.errorBundlePretty err + Right tokens -> do + let luaScript' = tokensToScript tokens + let paramsExp = + tokens + |> List.filterMap + ( \t -> + case t of + ScriptVariable name -> Just name + _ -> Nothing + ) + -- Parse haskell syntax between ${} and convert to a TH Exp + |> List.indexedMap (\idx exp -> varToExp exp |> scriptParamExpression (Prelude.fromIntegral idx)) + |> TH.ListE + |> TH.AppE (TH.VarE 'Log.mkSecret) + scriptConstructor <- [|Script luaScript' str|] + pure <| scriptConstructor `TH.AppE` paramsExp + +scriptParamExpression :: Prelude.Integer -> TH.Exp -> TH.Exp +scriptParamExpression idx exp = + (TH.VarE 'evaluateScriptParam) `TH.AppE` TH.LitE (TH.IntegerL idx) `TH.AppE` exp + +evaluateScriptParam :: HasScriptParam a => Int -> a -> EvaluatedParam +evaluateScriptParam idx scriptParam = + case getScriptParam scriptParam of + Key a -> + EvaluatedParam + { kind = RedisKey, + name = "arg" ++ Text.fromInt idx, + value = Debug.toString a + } + Literal a -> + EvaluatedParam + { kind = ArbitraryValue, + name = "arg" ++ Text.fromInt idx, + value = Debug.toString a + } + +varToExp :: Text -> TH.Exp +varToExp var = + case parseExp (Text.toList var) of + Left err -> Prelude.error <| "Failed to parse variable: " ++ err + Right exp -> exp data Tokens = ScriptText Text @@ -74,6 +149,17 @@ parseVariable = do _ <- PC.char '}' pure <| ScriptVariable <| Text.trim name +tokensToScript :: List Tokens -> Text +tokensToScript tokens = + tokens + |> List.indexedMap + ( \idx t -> + case t of + ScriptText text -> text + ScriptVariable _ -> "@arg" ++ Text.fromInt idx + ) + |> Text.join "" + -- | EVAL script numkeys [key [key ...]] [arg [arg ...]] evalString :: Script a -> Text evalString = Debug.todo "evalString" @@ -101,3 +187,8 @@ paramValues script' = |> params |> Log.unSecret |> List.map value + +printScript :: Script a -> Text +printScript Script {luaScript, quasiQuotedString, params} = + let printableParams = Log.unSecret params + in "Script { luaScript = \"" ++ luaScript ++ "\", quasiQuotedString = \"" ++ quasiQuotedString ++ "\", params = " ++ Debug.toString printableParams ++ " }" diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 1f1bef14..9e02114a 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} + module Spec.Redis.Script (tests) where import Data.Either (Either (..)) @@ -10,7 +12,8 @@ tests :: Test.Test tests = Test.describe "Redis.Script" - [ Test.describe "parser" parserTests + [ Test.describe "parser" parserTests, + Test.describe "th tests" thTests ] parserTests :: List Test.Test @@ -104,6 +107,23 @@ parserTests = ) ] +thTests :: List Test.Test +thTests = + [ Test.test "just text" <| \_ -> + [script|some text|] + |> printScript + |> Expect.equal "Script { luaScript = \"some text\", quasiQuotedString = \"some text\", params = [] }", + Test.test "one key argument" <| \_ -> + [script|${Key "hi"}|] + |> printScript + |> Expect.equal "Script { luaScript = \"@arg0\", quasiQuotedString = \"${Key \"hi\"}\", params = [ EvaluatedParam\n { kind = RedisKey , name = \"arg0\" , value = \"\\\"hi\\\"\" }\n] }" + -- We can't test for compile-time errors, but manually test our helpful error message, uncomment + -- the lines below: + -- Test.test "compilation error" <| \_ -> + -- [script|${123}|] + -- |> Expect.equal "Doesn't matter, this won't compile" + ] + mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f (Left a) = Left (f a) mapLeft _ (Right b) = Right b From 05f10d441c69032d5061408a9078aa0f761b1121 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 16:53:47 -0300 Subject: [PATCH 06/39] format --- nri-redis/src/Redis/Script.hs | 2 +- nri-redis/test/Spec/Redis/Script.hs | 24 ++++++++++++------------ 2 files changed, 13 insertions(+), 13 deletions(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index ea84cadb..9c6ea8e1 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -191,4 +191,4 @@ paramValues script' = printScript :: Script a -> Text printScript Script {luaScript, quasiQuotedString, params} = let printableParams = Log.unSecret params - in "Script { luaScript = \"" ++ luaScript ++ "\", quasiQuotedString = \"" ++ quasiQuotedString ++ "\", params = " ++ Debug.toString printableParams ++ " }" + in "Script { luaScript = \"" ++ luaScript ++ "\", quasiQuotedString = \"" ++ quasiQuotedString ++ "\", params = " ++ Debug.toString printableParams ++ " }" diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 9e02114a..8008f444 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -58,13 +58,13 @@ parserTests = |> mapLeft P.errorBundlePretty |> Expect.equal ( Left - "1:3:\n\ - \ |\n\ - \1 | ${}\n\ - \ | ^\n\ - \unexpected '}'\n\ - \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\ - \" + "1:3:\n\ + \ |\n\ + \1 | ${}\n\ + \ | ^\n\ + \unexpected '}'\n\ + \expecting anything but '$', '{' or '}' (no records, sorry) or white space\n\ + \" ), Test.test "ERROR: nested ${}" <| \_ -> do P.runParser parser "" "asdasd ${ ${ value } }" @@ -117,11 +117,11 @@ thTests = [script|${Key "hi"}|] |> printScript |> Expect.equal "Script { luaScript = \"@arg0\", quasiQuotedString = \"${Key \"hi\"}\", params = [ EvaluatedParam\n { kind = RedisKey , name = \"arg0\" , value = \"\\\"hi\\\"\" }\n] }" - -- We can't test for compile-time errors, but manually test our helpful error message, uncomment - -- the lines below: - -- Test.test "compilation error" <| \_ -> - -- [script|${123}|] - -- |> Expect.equal "Doesn't matter, this won't compile" + -- We can't test for compile-time errors, but manually test our helpful error message, uncomment + -- the lines below: + -- Test.test "compilation error" <| \_ -> + -- [script|${123}|] + -- |> Expect.equal "Doesn't matter, this won't compile" ] mapLeft :: (a -> c) -> Either a b -> Either c b From 367691b535dfffca54d30e201bb1b04e63c6c7ea Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 17:30:24 -0300 Subject: [PATCH 07/39] Write a failing test for eval --- nri-redis/src/Redis.hs | 5 ++++- nri-redis/test/Spec/Redis.hs | 11 ++++++++++- 2 files changed, 14 insertions(+), 2 deletions(-) diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index dd263bcb..bae175b8 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -38,6 +38,8 @@ module Redis setex, setnx, eval, + script, + ScriptParam (..), -- * Running Redis queries Internal.query, @@ -62,6 +64,7 @@ import qualified NonEmptyDict import qualified Redis.Codec as Codec import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal +import Redis.Script (ScriptParam (..), script) import qualified Redis.Script as Script import qualified Redis.Settings as Settings import qualified Prelude @@ -189,5 +192,5 @@ makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey = set = \key value -> Internal.Set (toKey key) (codecEncoder value), setex = \key seconds value -> Internal.Setex (toKey key) seconds (codecEncoder value), setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value), - eval = \script -> Internal.Eval script + eval = \script' -> Internal.Eval script' } diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 394c671d..925657f3 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -1,3 +1,5 @@ +{-# LANGUAGE QuasiQuotes #-} + module Spec.Redis (tests) where import qualified Control.Concurrent.MVar as MVar @@ -369,7 +371,11 @@ queryTests redisHandler = |> Expect.equal (List.length expectedKeys) keySet |> Set.toList - |> Expect.equal expectedKeys + |> Expect.equal expectedKeys, + Test.test "eval runs and returns something" <| \() -> do + let script = [Redis.script|return 1|] + result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds + Expect.equal result 1 ] where testNS = addNamespace "testNamespace" redisHandler @@ -396,6 +402,9 @@ sortedSetApi = Redis.SortedSet.textApi identity jsonApi' :: Redis.Api Text [Int] jsonApi' = Redis.jsonApi identity +intJsonApi :: Redis.Api Text Prelude.Integer +intJsonApi = Redis.jsonApi identity + -- | Timestamps recorded in spans would make each test result different from the -- last. This helper sets all timestamps to zero to prevent this. -- From 95dc076721db49013dc2b164f5ae9f840ce7272c Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 17:30:48 -0300 Subject: [PATCH 08/39] Update srcLoc lines for tests --- .../observability-spec-reporting-redis-counter-query | 8 ++++---- ...observability-spec-reporting-redis-counter-transaction | 8 ++++---- .../observability-spec-reporting-redis-hash-query | 8 ++++---- .../observability-spec-reporting-redis-hash-transaction | 8 ++++---- .../observability-spec-reporting-redis-list-query | 8 ++++---- .../observability-spec-reporting-redis-list-transaction | 8 ++++---- .../observability-spec-reporting-redis-query | 8 ++++---- .../observability-spec-reporting-redis-transaction | 8 ++++---- 8 files changed, 32 insertions(+), 32 deletions(-) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-query b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-query index 603091d3..04341825 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-query +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 103 + , srcLocStartLine = 105 , srcLocStartCol = 9 - , srcLocEndLine = 103 + , srcLocEndLine = 105 , srcLocEndCol = 28 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-transaction b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-transaction index c23d218d..e07ff4cb 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-transaction +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-counter-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 110 + , srcLocStartLine = 112 , srcLocStartCol = 9 - , srcLocEndLine = 110 + , srcLocEndLine = 112 , srcLocEndCol = 34 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-query b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-query index 8f3276fe..ac4a6b9d 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-query +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 75 + , srcLocStartLine = 77 , srcLocStartCol = 9 - , srcLocEndLine = 75 + , srcLocEndLine = 77 , srcLocEndCol = 25 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-transaction b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-transaction index ea1b4dae..0adbbfc1 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-transaction +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-hash-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 82 + , srcLocStartLine = 84 , srcLocStartCol = 9 - , srcLocEndLine = 82 + , srcLocEndLine = 84 , srcLocEndCol = 31 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-query b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-query index fad2b828..45249434 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-query +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 89 + , srcLocStartLine = 91 , srcLocStartCol = 9 - , srcLocEndLine = 89 + , srcLocEndLine = 91 , srcLocEndCol = 25 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-transaction b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-transaction index af1747c1..32e95609 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-transaction +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-list-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 96 + , srcLocStartLine = 98 , srcLocStartCol = 9 - , srcLocEndLine = 96 + , srcLocEndLine = 98 , srcLocEndCol = 31 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-query b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-query index 6c6bad25..90079f79 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-query +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 61 + , srcLocStartLine = 63 , srcLocStartCol = 9 - , srcLocEndLine = 61 + , srcLocEndLine = 63 , srcLocEndCol = 20 } ) diff --git a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-transaction b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-transaction index 4c668af9..a501c913 100644 --- a/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-transaction +++ b/nri-redis/test/golden-results-9.2/observability-spec-reporting-redis-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 29 + , srcLocEndLine = 31 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 68 + , srcLocStartLine = 70 , srcLocStartCol = 9 - , srcLocEndLine = 68 + , srcLocEndLine = 70 , srcLocEndCol = 26 } ) From cc6a51ed15fd3951c36728021b09ad13f27d1a7a Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 17:31:02 -0300 Subject: [PATCH 09/39] Implement mapKeys --- nri-redis/src/Redis/Script.hs | 14 +++++++++++++- 1 file changed, 13 insertions(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 9c6ea8e1..98381629 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -5,6 +5,7 @@ module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, Tokens (..), ScriptParam (..), printScript) where +import qualified Control.Monad import Data.Either (Either (..)) import Data.Void (Void) import qualified GHC.TypeLits @@ -166,7 +167,18 @@ evalString = Debug.todo "evalString" -- | Map the keys in the script to the keys in the Redis API mapKeys :: (Text -> Task err Text) -> Script a -> Task err (Script a) -mapKeys _fn _script = Debug.todo "mapKeys" +mapKeys fn script' = do + newParams <- + script' + |> params + |> Log.unSecret + |> Control.Monad.mapM + ( \param -> + case kind param of + RedisKey -> fn (value param) |> Task.map (\newValue -> param {value = newValue}) + ArbitraryValue -> pure param + ) + pure <| script' {params = Log.mkSecret newParams} -- | Get the keys touched by the script keysTouchedByScript :: Script a -> Set.Set Text From bf28b5a4670a151f8ddd4b6d6d5749b506ecace5 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 17:31:54 -0300 Subject: [PATCH 10/39] Implement keysTouchedByScript --- nri-redis/src/Redis/Script.hs | 12 +++++++++++- 1 file changed, 11 insertions(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 98381629..5c6279ad 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -182,7 +182,17 @@ mapKeys fn script' = do -- | Get the keys touched by the script keysTouchedByScript :: Script a -> Set.Set Text -keysTouchedByScript = Debug.todo "keysTouchedByScript" +keysTouchedByScript script' = + script' + |> params + |> Log.unSecret + |> List.filterMap + ( \param -> + case kind param of + RedisKey -> Just (value param) + ArbitraryValue -> Nothing + ) + |> Set.fromList -- | Get the parameter names in the script paramNames :: Script a -> List Text From 346d7583e77542c1ca197897fd23099fe7ca9a91 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 17:37:51 -0300 Subject: [PATCH 11/39] Implement evalString (test is green now) --- nri-redis/src/Redis/Script.hs | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 5c6279ad..82bcdf4b 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -163,7 +163,11 @@ tokensToScript tokens = -- | EVAL script numkeys [key [key ...]] [arg [arg ...]] evalString :: Script a -> Text -evalString = Debug.todo "evalString" +evalString script' = + let paramCount = script' |> params |> Log.unSecret |> List.length |> Text.fromInt + paramKeys = paramNames script' |> Text.join " " + paramArgs = paramValues script' |> List.map (\_ -> "***") |> Text.join " " + in "EVAL " ++ luaScript script' ++ " " ++ paramCount ++ " " ++ paramKeys ++ " " ++ paramArgs -- | Map the keys in the script to the keys in the Redis API mapKeys :: (Text -> Task err Text) -> Script a -> Task err (Script a) From 4e3fb2a360d1a0a65d6a22b8013db86e7360ae51 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 22 May 2024 18:00:06 -0300 Subject: [PATCH 12/39] Add failing test for script with arguments This is failing bc I misunderstood `eval` in Redis Eval is: EVAL script numkeys key key key arg arg arg Keys here is not the NAME of the argument, as I thought, but rather an input parameter in full There's no named arguments in Redis. I assumed that by reading examples from the C# API Client in the Rate Limiting implementation docs. Args and Keys are referenced like KEYS[1] KEYS[2] KEYS [3] and ARGV[1] ARGV[2] ARGV[3] Let's fix that in the next few commits --- nri-redis/test/Spec/Redis.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 925657f3..5d6c5786 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -375,6 +375,13 @@ queryTests redisHandler = Test.test "eval runs and returns something" <| \() -> do let script = [Redis.script|return 1|] result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds + Expect.equal result 1, + Test.test "eval with arguments runs and returns something" <| \() -> do + let script = [Redis.script| + local a = ${Redis.Key "hi"} + local b = ${Redis.Literal "hello"} + return 1|] + result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds Expect.equal result 1 ] where From f322af458b92a121713058142f39ea370afce8ad Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Thu, 23 May 2024 17:15:17 -0300 Subject: [PATCH 13/39] Fix API and hence fix script w/ arguments test Splits up keys and arguments, uses KEYS[1] and ARGV[1] inside luaScript --- nri-redis/src/Redis/Handler.hs | 2 +- nri-redis/src/Redis/Script.hs | 189 ++++++++++++++-------------- nri-redis/test/Spec/Redis.hs | 3 +- nri-redis/test/Spec/Redis/Script.hs | 4 +- 4 files changed, 103 insertions(+), 95 deletions(-) diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index 339989b0..2dc7e01b 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -167,7 +167,7 @@ doRawQuery query = |> PreparedQuery |> map (Ok << Prelude.fromIntegral) Internal.Eval script -> - Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.paramNames script)) (map toB (Script.paramValues script)) + Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.keys script)) (map toB (Log.unSecret (Script.arguments script))) |> PreparedQuery |> map Ok Internal.Exists key -> diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 82bcdf4b..75686b4e 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -3,10 +3,11 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, paramNames, paramValues, parser, Tokens (..), ScriptParam (..), printScript) where +module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, parser, Tokens (..), ScriptParam (..), printScript) where import qualified Control.Monad import Data.Either (Either (..)) +import qualified Data.Text import Data.Void (Void) import qualified GHC.TypeLits import Language.Haskell.Meta.Parse (parseExp) @@ -24,8 +25,9 @@ data Script result = Script luaScript :: Text, -- | The script string as extracted from a `script` quasi quote. quasiQuotedString :: Text, + keys :: [Text], -- | The parameters that fill the placeholders in this query - params :: Log.Secret [EvaluatedParam] + arguments :: Log.Secret [Text] } deriving (Eq, Show) @@ -59,7 +61,6 @@ instance data EvaluatedParam = EvaluatedParam { kind :: ParamKind, - name :: Text, value :: Text } deriving (Eq, Show) @@ -78,46 +79,88 @@ script = qqScript :: Prelude.String -> TH.Q TH.Exp qqScript scriptWithVars = do - let str = Text.fromList scriptWithVars - let parseResult = P.parse parser "" str + let quotedScript = Text.fromList scriptWithVars + let parseResult = P.parse parser "" quotedScript case parseResult of Left err -> Prelude.error <| "Failed to parse script: " ++ P.errorBundlePretty err Right tokens -> do - let luaScript' = tokensToScript tokens - let paramsExp = - tokens - |> List.filterMap - ( \t -> - case t of - ScriptVariable name -> Just name - _ -> Nothing - ) - -- Parse haskell syntax between ${} and convert to a TH Exp - |> List.indexedMap (\idx exp -> varToExp exp |> scriptParamExpression (Prelude.fromIntegral idx)) - |> TH.ListE - |> TH.AppE (TH.VarE 'Log.mkSecret) - scriptConstructor <- [|Script luaScript' str|] - pure <| scriptConstructor `TH.AppE` paramsExp - -scriptParamExpression :: Prelude.Integer -> TH.Exp -> TH.Exp -scriptParamExpression idx exp = - (TH.VarE 'evaluateScriptParam) `TH.AppE` TH.LitE (TH.IntegerL idx) `TH.AppE` exp - -evaluateScriptParam :: HasScriptParam a => Int -> a -> EvaluatedParam -evaluateScriptParam idx scriptParam = + paramsExp <- + tokens + |> Control.Monad.mapM toEvaluatedToken + |> map TH.ListE + quotedScriptExp <- [|quotedScript|] + pure <| (TH.VarE 'scriptFromEvaluatedTokens) `TH.AppE` quotedScriptExp `TH.AppE` paramsExp + +data ScriptBuilder = ScriptBuilder + { buffer :: Text, + keyIdx :: Int, + keyList :: List Text, + argIdx :: Int, + argList :: List Text + } + +scriptFromEvaluatedTokens :: Text -> [EvaluatedToken] -> Script a +scriptFromEvaluatedTokens quasiQuotedString' evaluatedTokens = + let keyTpl n = "KEYS[" ++ Text.fromInt n ++ "]" + argTpl n = "ARGV[" ++ Text.fromInt n ++ "]" + script' = + List.foldl + ( \token scriptBuilder@(ScriptBuilder {buffer, keyIdx, keyList, argIdx, argList}) -> + case token of + EvaluatedText text -> scriptBuilder {buffer = buffer ++ text} + EvaluatedVariable var -> + case kind var of + RedisKey -> + scriptBuilder + { buffer = buffer ++ keyTpl (keyIdx + 1), + keyIdx = keyIdx + 1, + keyList = value var : keyList + } + ArbitraryValue -> + scriptBuilder + { buffer = buffer ++ argTpl (argIdx + 1), + argIdx = argIdx + 1, + argList = value var : argList + } + ) + (ScriptBuilder "" 0 [] 0 []) + evaluatedTokens + in Script + { luaScript = buffer script', + quasiQuotedString = quasiQuotedString', + keys = keyList script', + arguments = Log.mkSecret (argList script') + } + +toEvaluatedToken :: Tokens -> TH.Q TH.Exp +toEvaluatedToken token = + case token of + ScriptText text -> [|EvaluatedText text|] + ScriptVariable var -> pure <| (TH.VarE 'evaluateScriptParam) `TH.AppE` (varToExp var) + +evaluateScriptParam :: HasScriptParam a => a -> EvaluatedToken +evaluateScriptParam scriptParam = case getScriptParam scriptParam of Key a -> - EvaluatedParam - { kind = RedisKey, - name = "arg" ++ Text.fromInt idx, - value = Debug.toString a - } + EvaluatedVariable + <| EvaluatedParam + { kind = RedisKey, + value = unquoteString (Debug.toString a) + } Literal a -> - EvaluatedParam - { kind = ArbitraryValue, - name = "arg" ++ Text.fromInt idx, - value = Debug.toString a - } + EvaluatedVariable + <| EvaluatedParam + { kind = ArbitraryValue, + value = unquoteString (Debug.toString a) + } + +-- | Remove leading and trailing quotes from a string +unquoteString :: Text -> Text +unquoteString str = + str + |> Data.Text.stripPrefix "\"" + |> Maybe.andThen (Data.Text.stripSuffix "\"") + |> Maybe.withDefault str varToExp :: Text -> TH.Exp varToExp var = @@ -125,6 +168,7 @@ varToExp var = Left err -> Prelude.error <| "Failed to parse variable: " ++ err Right exp -> exp +-- | Tokens after parsing quasi-quoted text data Tokens = ScriptText Text | ScriptVariable Text @@ -150,71 +194,34 @@ parseVariable = do _ <- PC.char '}' pure <| ScriptVariable <| Text.trim name -tokensToScript :: List Tokens -> Text -tokensToScript tokens = - tokens - |> List.indexedMap - ( \idx t -> - case t of - ScriptText text -> text - ScriptVariable _ -> "@arg" ++ Text.fromInt idx - ) - |> Text.join "" +data EvaluatedToken + = EvaluatedText Text + | EvaluatedVariable EvaluatedParam + deriving (Show, Eq) -- | EVAL script numkeys [key [key ...]] [arg [arg ...]] evalString :: Script a -> Text -evalString script' = - let paramCount = script' |> params |> Log.unSecret |> List.length |> Text.fromInt - paramKeys = paramNames script' |> Text.join " " - paramArgs = paramValues script' |> List.map (\_ -> "***") |> Text.join " " - in "EVAL " ++ luaScript script' ++ " " ++ paramCount ++ " " ++ paramKeys ++ " " ++ paramArgs +evalString Script {luaScript, keys, arguments} = + let keyCount = keys |> List.length |> Text.fromInt + keys' = keys |> Text.join " " + args' = arguments |> Log.unSecret |> List.map (\_ -> "***") |> Text.join " " + in "EVAL {{" ++ luaScript ++ "}} " ++ keyCount ++ " " ++ keys' ++ " " ++ args' -- | Map the keys in the script to the keys in the Redis API mapKeys :: (Text -> Task err Text) -> Script a -> Task err (Script a) mapKeys fn script' = do - newParams <- - script' - |> params - |> Log.unSecret - |> Control.Monad.mapM - ( \param -> - case kind param of - RedisKey -> fn (value param) |> Task.map (\newValue -> param {value = newValue}) - ArbitraryValue -> pure param - ) - pure <| script' {params = Log.mkSecret newParams} + keys script' + |> List.map fn + |> Task.sequence + |> Task.map (\keys' -> script' {keys = keys'}) -- | Get the keys touched by the script keysTouchedByScript :: Script a -> Set.Set Text keysTouchedByScript script' = - script' - |> params - |> Log.unSecret - |> List.filterMap - ( \param -> - case kind param of - RedisKey -> Just (value param) - ArbitraryValue -> Nothing - ) + keys script' |> Set.fromList --- | Get the parameter names in the script -paramNames :: Script a -> List Text -paramNames script' = - script' - |> params - |> Log.unSecret - |> List.map name - --- | Get the parameter values in the script -paramValues :: Script a -> List Text -paramValues script' = - script' - |> params - |> Log.unSecret - |> List.map value - printScript :: Script a -> Text -printScript Script {luaScript, quasiQuotedString, params} = - let printableParams = Log.unSecret params - in "Script { luaScript = \"" ++ luaScript ++ "\", quasiQuotedString = \"" ++ quasiQuotedString ++ "\", params = " ++ Debug.toString printableParams ++ " }" +printScript Script {luaScript, quasiQuotedString, keys, arguments} = + let listStr l = List.map (\s -> "\"" ++ s ++ "\"") l |> Text.join ", " + in "Script { luaScript = \"" ++ luaScript ++ "\", quasiQuotedString = \"" ++ quasiQuotedString ++ "\", keys = [" ++ listStr keys ++ "], arguments = [" ++ listStr (Log.unSecret arguments) ++ "] }" diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 5d6c5786..51f474d0 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -377,7 +377,8 @@ queryTests redisHandler = result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds Expect.equal result 1, Test.test "eval with arguments runs and returns something" <| \() -> do - let script = [Redis.script| + let script = + [Redis.script| local a = ${Redis.Key "hi"} local b = ${Redis.Literal "hello"} return 1|] diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 8008f444..34155fba 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -112,11 +112,11 @@ thTests = [ Test.test "just text" <| \_ -> [script|some text|] |> printScript - |> Expect.equal "Script { luaScript = \"some text\", quasiQuotedString = \"some text\", params = [] }", + |> Expect.equal "Script { luaScript = \"some text\", quasiQuotedString = \"some text\", keys = [], arguments = [] }", Test.test "one key argument" <| \_ -> [script|${Key "hi"}|] |> printScript - |> Expect.equal "Script { luaScript = \"@arg0\", quasiQuotedString = \"${Key \"hi\"}\", params = [ EvaluatedParam\n { kind = RedisKey , name = \"arg0\" , value = \"\\\"hi\\\"\" }\n] }" + |> Expect.equal "Script { luaScript = \"KEYS[1]\", quasiQuotedString = \"${Key \"hi\"}\", keys = [\"hi\"], arguments = [] }" -- We can't test for compile-time errors, but manually test our helpful error message, uncomment -- the lines below: -- Test.test "compilation error" <| \_ -> From aec828c2675f1d0a7d2558e4289816f9863c1fb0 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Sat, 25 May 2024 15:55:16 -0300 Subject: [PATCH 14/39] Add returning argument as Text This required a RedisResult instance for Text --- nri-redis/src/Redis/Internal.hs | 9 +++++++++ nri-redis/test/Spec/Redis.hs | 24 +++++++++++++++++++++++- 2 files changed, 32 insertions(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 5191bd9b..9a4cfc56 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -1,6 +1,8 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE RankNTypes #-} +-- For the RedisResult Text instance +{-# OPTIONS_GHC -fno-warn-orphans #-} module Redis.Internal ( Error (..), @@ -30,6 +32,7 @@ import qualified Data.Aeson as Aeson import Data.ByteString (ByteString) import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty +import qualified Data.Text.Encoding import qualified Database.Redis import qualified Dict import qualified GHC.Stack as Stack @@ -466,3 +469,9 @@ foldWithScan handler keyMatchPattern approxCountPerBatch processKeyBatch initAcc then Task.succeed nextAccumulator else go nextAccumulator nextCursor in go initAccumulator Database.Redis.cursor0 + +-- This is an orphaned instance +instance Database.Redis.RedisResult Text where + decode r = do + decodedBs <- Database.Redis.decode r + Prelude.pure <| Data.Text.Encoding.decodeUtf8 decodedBs diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 51f474d0..392336fa 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -383,7 +383,29 @@ queryTests redisHandler = local b = ${Redis.Literal "hello"} return 1|] result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds - Expect.equal result 1 + Expect.equal result 1, + Test.test "eval with arguments returns argument" <| \() -> do + let script = + [Redis.script| + local a = ${Redis.Key 2} + local b = ${Redis.Literal 3} + return b|] + result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds + Expect.equal result 3, + Test.test "eval with arguments namespaces key" <| \() -> do + let script = [Redis.script|return ${Redis.Key "hi"}|] + result <- Redis.eval api script |> Redis.query testNS |> Expect.succeeds + Expect.true + ( List.member + result + -- All tests here run twice: + -- - once with the auto-extend-expire handler + -- - once with the normal handler + -- each run generates a different namespace + [ "tests-auto-extend-expire:testNamespace:hi", + "tests:testNamespace:hi" + ] + ) ] where testNS = addNamespace "testNamespace" redisHandler From 7f8483190e266efd30feb90cd80fd2ff468496a6 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Sat, 25 May 2024 16:01:45 -0300 Subject: [PATCH 15/39] Warn about returning keys in scripts --- nri-redis/src/Redis/Script.hs | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 75686b4e..711d1bfa 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -68,6 +68,13 @@ data EvaluatedParam = EvaluatedParam data ParamKind = RedisKey | ArbitraryValue deriving (Eq, Show) +-- | Quasi-quoter for creating a Redis Lua script with placeholders for Redis keys and arguments. +-- +-- > [script|SET ${Key "a-redis-key"} ${Literal 123}|] +-- +-- **IMPORTANT**: It is NOT SAFE to return Redis keys using this. Our Redis APIs inject +-- "namespaces" (prefixes) on keys, and any keys returned by Lua will have their namespaces +-- applied. If you try to reuse those keys in follow-up queries, namespaces will be doubly-applied. script :: QQ.QuasiQuoter script = QQ.QuasiQuoter From 81d57c68494d495d7e2f79289ac1396b41d6cb62 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Sat, 25 May 2024 16:22:09 -0300 Subject: [PATCH 16/39] Reorganize code in Script --- nri-redis/src/Redis/Script.hs | 131 +++++++++++++++++++++------------- 1 file changed, 82 insertions(+), 49 deletions(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 711d1bfa..86fa2029 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -3,7 +3,20 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} -module Redis.Script (Script (..), script, evalString, mapKeys, keysTouchedByScript, parser, Tokens (..), ScriptParam (..), printScript) where +module Redis.Script + ( Script (..), + script, + -- Internal API + evalString, + mapKeys, + keysTouchedByScript, + -- For testing + parser, + Tokens (..), + ScriptParam (..), + printScript, + ) +where import qualified Control.Monad import Data.Either (Either (..)) @@ -59,15 +72,6 @@ instance where getScriptParam = Prelude.error "This won't ever hit bc this generates a compile-time error." -data EvaluatedParam = EvaluatedParam - { kind :: ParamKind, - value :: Text - } - deriving (Eq, Show) - -data ParamKind = RedisKey | ArbitraryValue - deriving (Eq, Show) - -- | Quasi-quoter for creating a Redis Lua script with placeholders for Redis keys and arguments. -- -- > [script|SET ${Key "a-redis-key"} ${Literal 123}|] @@ -98,6 +102,64 @@ qqScript scriptWithVars = do quotedScriptExp <- [|quotedScript|] pure <| (TH.VarE 'scriptFromEvaluatedTokens) `TH.AppE` quotedScriptExp `TH.AppE` paramsExp +---------------------------- +-- Script template compile-time evaluation +---------------------------- + +data EvaluatedToken + = EvaluatedText Text + | EvaluatedVariable EvaluatedParam + deriving (Show, Eq) + +data EvaluatedParam = EvaluatedParam + { kind :: ParamKind, + value :: Text + } + deriving (Eq, Show) + +data ParamKind = RedisKey | ArbitraryValue + deriving (Eq, Show) + +toEvaluatedToken :: Tokens -> TH.Q TH.Exp +toEvaluatedToken token = + case token of + ScriptText text -> [|EvaluatedText text|] + ScriptVariable var -> pure <| (TH.VarE 'evaluateScriptParam) `TH.AppE` (varToExp var) + +evaluateScriptParam :: HasScriptParam a => a -> EvaluatedToken +evaluateScriptParam scriptParam = + case getScriptParam scriptParam of + Key a -> + EvaluatedVariable + <| EvaluatedParam + { kind = RedisKey, + value = unquoteString (Debug.toString a) + } + Literal a -> + EvaluatedVariable + <| EvaluatedParam + { kind = ArbitraryValue, + value = unquoteString (Debug.toString a) + } + +-- | Remove leading and trailing quotes from a string +unquoteString :: Text -> Text +unquoteString str = + str + |> Data.Text.stripPrefix "\"" + |> Maybe.andThen (Data.Text.stripSuffix "\"") + |> Maybe.withDefault str + +varToExp :: Text -> TH.Exp +varToExp var = + case parseExp (Text.toList var) of + Left err -> Prelude.error <| "Failed to parse variable: " ++ err + Right exp -> exp + +----------------------------- +-- Script record construction +----------------------------- + data ScriptBuilder = ScriptBuilder { buffer :: Text, keyIdx :: Int, @@ -139,41 +201,9 @@ scriptFromEvaluatedTokens quasiQuotedString' evaluatedTokens = arguments = Log.mkSecret (argList script') } -toEvaluatedToken :: Tokens -> TH.Q TH.Exp -toEvaluatedToken token = - case token of - ScriptText text -> [|EvaluatedText text|] - ScriptVariable var -> pure <| (TH.VarE 'evaluateScriptParam) `TH.AppE` (varToExp var) - -evaluateScriptParam :: HasScriptParam a => a -> EvaluatedToken -evaluateScriptParam scriptParam = - case getScriptParam scriptParam of - Key a -> - EvaluatedVariable - <| EvaluatedParam - { kind = RedisKey, - value = unquoteString (Debug.toString a) - } - Literal a -> - EvaluatedVariable - <| EvaluatedParam - { kind = ArbitraryValue, - value = unquoteString (Debug.toString a) - } - --- | Remove leading and trailing quotes from a string -unquoteString :: Text -> Text -unquoteString str = - str - |> Data.Text.stripPrefix "\"" - |> Maybe.andThen (Data.Text.stripSuffix "\"") - |> Maybe.withDefault str - -varToExp :: Text -> TH.Exp -varToExp var = - case parseExp (Text.toList var) of - Left err -> Prelude.error <| "Failed to parse variable: " ++ err - Right exp -> exp +----------------------------- +-- Quasi-quoted text parser +----------------------------- -- | Tokens after parsing quasi-quoted text data Tokens @@ -201,10 +231,9 @@ parseVariable = do _ <- PC.char '}' pure <| ScriptVariable <| Text.trim name -data EvaluatedToken - = EvaluatedText Text - | EvaluatedVariable EvaluatedParam - deriving (Show, Eq) +--------------------------------------------- +-- Helper functions for internal library use +--------------------------------------------- -- | EVAL script numkeys [key [key ...]] [arg [arg ...]] evalString :: Script a -> Text @@ -228,6 +257,10 @@ keysTouchedByScript script' = keys script' |> Set.fromList +--------------------------------------------- +-- Helper functions for testing +--------------------------------------------- + printScript :: Script a -> Text printScript Script {luaScript, quasiQuotedString, keys, arguments} = let listStr l = List.map (\s -> "\"" ++ s ++ "\"") l |> Text.join ", " From d03e83455475b87bb5988787f6279e51fa6c42af Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Sat, 25 May 2024 17:43:10 -0300 Subject: [PATCH 17/39] Failed attempt at implementing a caching eval API Redis provides a faster API for running scripts, where you: - SCRIPT LOAD "the script" - EVALSHA "script sha1" n_keys [keys] [args] I can't implement this because we'd need to restrict `doRawQuery`. `doRawQuery` is generic for both instances of `RedisCtx` in Hedis: - Transactions: `RedisCtx RedisTx Queued` - Regular queries: `RedisCtx Redis (Either Reply)` I'll need a different approach for this. --- nri-redis/nri-redis.cabal | 2 ++ nri-redis/package.yaml | 1 + nri-redis/src/Redis.hs | 21 +++++++++++++++++++-- nri-redis/src/Redis/Handler.hs | 18 ++++++++++++++++++ nri-redis/src/Redis/Internal.hs | 5 +++++ nri-redis/src/Redis/Script.hs | 10 ++++++++++ 6 files changed, 55 insertions(+), 2 deletions(-) diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index 9e3a081c..b1fc1d1e 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -69,6 +69,7 @@ library , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 , containers >=0.6.0.1 && <0.7 + , cryptohash-sha1 >=0.11.101.0 && <0.12 , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16 , megaparsec >=9.2.2 && <9.3 @@ -133,6 +134,7 @@ test-suite tests , bytestring >=0.10.8.2 && <0.12 , conduit >=1.3.0 && <1.4 , containers >=0.6.0.1 && <0.7 + , cryptohash-sha1 >=0.11.101.0 && <0.12 , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16 , megaparsec >=9.2.2 && <9.3 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index 3690c81a..c799cc57 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -20,6 +20,7 @@ dependencies: - bytestring >= 0.10.8.2 && < 0.12 - conduit >= 1.3.0 && < 1.4 - containers >= 0.6.0.1 && < 0.7 + - cryptohash-sha1 >= 0.11.101.0 && < 0.12 - haskell-src-meta >= 0.8.12 && < 0.9 # hedis 14 introduces redis-cluster support - hedis >= 0.14.0 && < 0.16 diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index bae175b8..12365667 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -38,6 +38,7 @@ module Redis setex, setnx, eval, + evalCached, script, ScriptParam (..), @@ -144,8 +145,23 @@ data Api key a = Api setnx :: key -> a -> Internal.Query Bool, -- | Invoke the execution of a server-side Lua script. -- + -- Calling this is not ideal. It's better to use `evalCached`, which will: + -- - Assume the Lua script has been cached and run EVALSHA + -- - Recover from a cache miss error and `SCRIPT LOAD` the Lua script into Redis + -- - Retry the original EVALSHA command + -- -- https://redis.io/commands/eval - eval :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a + eval :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a, + -- | Invoke the execution of a server-side Lua script. + -- + -- This function will: + -- - Assume the Lua script has been cached and run EVALSHA + -- - Recover from a cache miss error and `SCRIPT LOAD` the Lua script into Redis + -- - Retry the original EVALSHA command + -- + -- https://redis.io/commands/evalsha + -- https://redis.io/commands/script-load/ + evalCached :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a } -- | Creates a json API mapping a 'key' to a json-encodable-decodable type @@ -192,5 +208,6 @@ makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey = set = \key value -> Internal.Set (toKey key) (codecEncoder value), setex = \key seconds value -> Internal.Setex (toKey key) seconds (codecEncoder value), setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value), - eval = \script' -> Internal.Eval script' + eval = \script' -> Internal.Eval script', + evalCached = \script' -> Internal.EvalCached script' } diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index 2dc7e01b..b6ecb19f 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -170,6 +170,24 @@ doRawQuery query = Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.keys script)) (map toB (Log.unSecret (Script.arguments script))) |> PreparedQuery |> map Ok + Internal.EvalCached script -> + let evalsha = + Database.Redis.evalsha + (Script.luaScriptHash script) + (map toB (Script.keys script)) + (map toB (Log.unSecret (Script.arguments script))) + loadScript = Database.Redis.scriptLoad (toB (Script.luaScript script)) + evalWithAutorecover = do + result <- evalsha + case result of + Left (Database.Redis.Error err) -> + case err of + "NOSCRIPT No matching script. Please use EVAL." -> loadScript >>= evalsha + _ -> pure result + Right _ -> pure result + in evalWithAutorecover + |> PreparedQuery + |> map Ok Internal.Exists key -> Database.Redis.exists (toB key) |> PreparedQuery diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 9a4cfc56..0278cf5a 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -84,6 +84,7 @@ cmds query'' = case query'' of Del keys -> [unwords ("DEL" : NonEmpty.toList keys)] Eval script -> [Script.evalString script] + EvalCached script -> [Script.evalString script] Exists key -> [unwords ["EXISTS", key]] Expire key val -> [unwords ["EXPIRE", key, Text.fromInt val]] Get key -> [unwords ["GET", key]] @@ -142,6 +143,7 @@ unwords = Text.join " " data Query a where Del :: NonEmpty Text -> Query Int Eval :: Database.Redis.RedisResult a => Script.Script a -> Query a + EvalCached :: Database.Redis.RedisResult a => Script.Script a -> Query a Exists :: Text -> Query Bool Expire :: Text -> Int -> Query () Get :: Text -> Query (Maybe ByteString) @@ -278,6 +280,7 @@ mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a) mapKeys fn query' = case query' of Eval script -> Task.map Eval (Script.mapKeys fn script) + EvalCached script -> Task.map EvalCached (Script.mapKeys fn script) Exists key -> Task.map Exists (fn key) Ping -> Task.succeed Ping Get key -> Task.map Get (fn key) @@ -322,6 +325,7 @@ mapReturnedKeys :: (Text -> Text) -> Query a -> Query a mapReturnedKeys fn query' = case query' of Eval _ -> query' + EvalCached _ -> query' Exists key -> Exists key Ping -> Ping Get key -> Get key @@ -380,6 +384,7 @@ keysTouchedByQuery query' = Apply f x -> Set.union (keysTouchedByQuery f) (keysTouchedByQuery x) Del keys -> Set.fromList (NonEmpty.toList keys) Eval script -> Script.keysTouchedByScript script + EvalCached script -> Script.keysTouchedByScript script Exists key -> Set.singleton key -- We use this function to collect keys we need to expire. If the user is -- explicitly setting an expiry we don't want to overwrite that. diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 86fa2029..79a9c653 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -7,6 +7,7 @@ module Redis.Script ( Script (..), script, -- Internal API + luaScriptHash, evalString, mapKeys, keysTouchedByScript, @@ -19,8 +20,11 @@ module Redis.Script where import qualified Control.Monad +import qualified Crypto.Hash.SHA1 +import qualified Data.ByteString import Data.Either (Either (..)) import qualified Data.Text +import qualified Data.Text.Encoding import Data.Void (Void) import qualified GHC.TypeLits import Language.Haskell.Meta.Parse (parseExp) @@ -257,6 +261,12 @@ keysTouchedByScript script' = keys script' |> Set.fromList +luaScriptHash :: Script a -> Data.ByteString.ByteString +luaScriptHash Script {luaScript} = + luaScript + |> Data.Text.Encoding.encodeUtf8 + |> Crypto.Hash.SHA1.hash + --------------------------------------------- -- Helper functions for testing --------------------------------------------- From 4af9c58309f27d00d037a5be4bcf2c5800edcb80 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 10:59:34 -0300 Subject: [PATCH 18/39] Remove failed attempt at evalCached --- nri-redis/src/Redis.hs | 21 ++------------------- nri-redis/src/Redis/Handler.hs | 18 ------------------ nri-redis/src/Redis/Internal.hs | 5 ----- 3 files changed, 2 insertions(+), 42 deletions(-) diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index 12365667..bae175b8 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -38,7 +38,6 @@ module Redis setex, setnx, eval, - evalCached, script, ScriptParam (..), @@ -145,23 +144,8 @@ data Api key a = Api setnx :: key -> a -> Internal.Query Bool, -- | Invoke the execution of a server-side Lua script. -- - -- Calling this is not ideal. It's better to use `evalCached`, which will: - -- - Assume the Lua script has been cached and run EVALSHA - -- - Recover from a cache miss error and `SCRIPT LOAD` the Lua script into Redis - -- - Retry the original EVALSHA command - -- -- https://redis.io/commands/eval - eval :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a, - -- | Invoke the execution of a server-side Lua script. - -- - -- This function will: - -- - Assume the Lua script has been cached and run EVALSHA - -- - Recover from a cache miss error and `SCRIPT LOAD` the Lua script into Redis - -- - Retry the original EVALSHA command - -- - -- https://redis.io/commands/evalsha - -- https://redis.io/commands/script-load/ - evalCached :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a + eval :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a } -- | Creates a json API mapping a 'key' to a json-encodable-decodable type @@ -208,6 +192,5 @@ makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey = set = \key value -> Internal.Set (toKey key) (codecEncoder value), setex = \key seconds value -> Internal.Setex (toKey key) seconds (codecEncoder value), setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value), - eval = \script' -> Internal.Eval script', - evalCached = \script' -> Internal.EvalCached script' + eval = \script' -> Internal.Eval script' } diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index b6ecb19f..2dc7e01b 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -170,24 +170,6 @@ doRawQuery query = Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.keys script)) (map toB (Log.unSecret (Script.arguments script))) |> PreparedQuery |> map Ok - Internal.EvalCached script -> - let evalsha = - Database.Redis.evalsha - (Script.luaScriptHash script) - (map toB (Script.keys script)) - (map toB (Log.unSecret (Script.arguments script))) - loadScript = Database.Redis.scriptLoad (toB (Script.luaScript script)) - evalWithAutorecover = do - result <- evalsha - case result of - Left (Database.Redis.Error err) -> - case err of - "NOSCRIPT No matching script. Please use EVAL." -> loadScript >>= evalsha - _ -> pure result - Right _ -> pure result - in evalWithAutorecover - |> PreparedQuery - |> map Ok Internal.Exists key -> Database.Redis.exists (toB key) |> PreparedQuery diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 0278cf5a..9a4cfc56 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -84,7 +84,6 @@ cmds query'' = case query'' of Del keys -> [unwords ("DEL" : NonEmpty.toList keys)] Eval script -> [Script.evalString script] - EvalCached script -> [Script.evalString script] Exists key -> [unwords ["EXISTS", key]] Expire key val -> [unwords ["EXPIRE", key, Text.fromInt val]] Get key -> [unwords ["GET", key]] @@ -143,7 +142,6 @@ unwords = Text.join " " data Query a where Del :: NonEmpty Text -> Query Int Eval :: Database.Redis.RedisResult a => Script.Script a -> Query a - EvalCached :: Database.Redis.RedisResult a => Script.Script a -> Query a Exists :: Text -> Query Bool Expire :: Text -> Int -> Query () Get :: Text -> Query (Maybe ByteString) @@ -280,7 +278,6 @@ mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a) mapKeys fn query' = case query' of Eval script -> Task.map Eval (Script.mapKeys fn script) - EvalCached script -> Task.map EvalCached (Script.mapKeys fn script) Exists key -> Task.map Exists (fn key) Ping -> Task.succeed Ping Get key -> Task.map Get (fn key) @@ -325,7 +322,6 @@ mapReturnedKeys :: (Text -> Text) -> Query a -> Query a mapReturnedKeys fn query' = case query' of Eval _ -> query' - EvalCached _ -> query' Exists key -> Exists key Ping -> Ping Get key -> Get key @@ -384,7 +380,6 @@ keysTouchedByQuery query' = Apply f x -> Set.union (keysTouchedByQuery f) (keysTouchedByQuery x) Del keys -> Set.fromList (NonEmpty.toList keys) Eval script -> Script.keysTouchedByScript script - EvalCached script -> Script.keysTouchedByScript script Exists key -> Set.singleton key -- We use this function to collect keys we need to expire. If the user is -- explicitly setting an expiry we don't want to overwrite that. From 9423b07436bbbc39db70b156059222586920c583 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 12:31:36 -0300 Subject: [PATCH 19/39] Move eval to a handler function Allows us to do the `evalsha -> script load -> evalsha` flow --- nri-redis/src/Redis.hs | 2 +- nri-redis/src/Redis/Handler.hs | 85 +++++++++++++++++++++++++++++---- nri-redis/src/Redis/Internal.hs | 7 +++ nri-redis/src/Redis/Script.hs | 28 ++++++++++- nri-redis/test/Spec/Redis.hs | 11 ++--- 5 files changed, 114 insertions(+), 19 deletions(-) diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index bae175b8..98a8d9c0 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -37,13 +37,13 @@ module Redis set, setex, setnx, - eval, script, ScriptParam (..), -- * Running Redis queries Internal.query, Internal.transaction, + Internal.eval, Internal.Query, Internal.Error (..), Internal.map, diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index 2dc7e01b..58a7af17 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -77,6 +77,9 @@ timeoutAfterMilliseconds milliseconds handler' = >> Task.timeout milliseconds Internal.TimeoutError, Internal.doTransaction = Stack.withFrozenCallStack (Internal.doTransaction handler') + >> Task.timeout milliseconds Internal.TimeoutError, + Internal.doEval = + Stack.withFrozenCallStack (Internal.doEval handler') >> Task.timeout milliseconds Internal.TimeoutError } @@ -95,7 +98,10 @@ defaultExpiryKeysAfterSeconds secs handler' = |> Stack.withFrozenCallStack (Internal.doQuery handler'), Internal.doTransaction = \query' -> wrapWithExpire query' - |> Stack.withFrozenCallStack (Internal.doTransaction handler') + |> Stack.withFrozenCallStack (Internal.doTransaction handler'), + Internal.doEval = \script' -> + -- We can't guarantee auto-expire for EVAL, so we just run it as-is + Stack.withFrozenCallStack (Internal.doEval handler' script') } acquireHandler :: Text -> Settings.Settings -> IO (Internal.Handler' x, Connection) @@ -132,6 +138,8 @@ acquireHandler namespace settings = do Database.Redis.TxError err -> Right (Err (Internal.RedisError (Text.fromList err))) ) |> Stack.withFrozenCallStack (platformRedis (Internal.cmds query) connection anything), + Internal.doEval = \script' -> + Stack.withFrozenCallStack (platformRedisScript script' connection anything), Internal.namespace = namespace, Internal.maxKeySize = Settings.maxKeySize settings }, @@ -369,15 +377,7 @@ platformRedis cmds connection anything action = Ok a -> a Err err -> Err err ) - |> Exception.handle (\(_ :: Database.Redis.ConnectionLostException) -> pure <| Err Internal.ConnectionLost) - |> Exception.handleAny - ( \err -> - Exception.displayException err - |> Text.fromList - |> Internal.LibraryError - |> Err - |> pure - ) + |> handleExceptions |> Platform.doAnything anything |> Stack.withFrozenCallStack Internal.traceQuery cmds (connectionHost connection) (connectionPort connection) @@ -388,5 +388,70 @@ toResult reply = Left err -> Err (Internal.RedisError ("Redis library got back a value with a type it didn't expect: " ++ Text.fromList (Prelude.show err))) Right r -> Ok r +handleExceptions :: IO (Result Internal.Error value) -> IO (Result Internal.Error value) +handleExceptions = + Exception.handle (\(_ :: Database.Redis.ConnectionLostException) -> pure <| Err Internal.ConnectionLost) + >> Exception.handleAny + ( \err -> + Exception.displayException err + |> Text.fromList + |> Internal.LibraryError + |> Err + |> pure + ) + +-- | Run a script in Redis trying to leverage the script cache +platformRedisScript :: + (Stack.HasCallStack, Database.Redis.RedisResult a) => + Script.Script a -> + Connection -> + Platform.DoAnythingHandler -> + Task Internal.Error a +platformRedisScript script connection anything = do + -- Try EVALSHA + evalsha script connection anything + |> Task.onError + ( \err -> + case err of + Internal.RedisError "NOSCRIPT No matching script. Please use EVAL." -> do + -- If it fails with NOSCRIPT, load the script and try again + loadScript script connection anything + evalsha script connection anything + _ -> Task.fail err + ) + +evalsha :: + (Stack.HasCallStack, Database.Redis.RedisResult a) => + Script.Script a -> + Connection -> + Platform.DoAnythingHandler -> + Task Internal.Error a +evalsha script connection anything = + Database.Redis.evalsha + (toB (Script.luaScriptHash script)) + (map toB (Script.keys script)) + (map toB (Log.unSecret (Script.arguments script))) + |> Database.Redis.runRedis (connectionHedis connection) + |> map toResult + |> handleExceptions + |> Platform.doAnything anything + |> Stack.withFrozenCallStack Internal.traceQuery [Script.evalShaString script] (connectionHost connection) (connectionPort connection) + +loadScript :: + Stack.HasCallStack => + Script.Script a -> + Connection -> + Platform.DoAnythingHandler -> + Task Internal.Error () +loadScript script connection anything = do + Database.Redis.scriptLoad (toB (Script.luaScript script)) + |> Database.Redis.runRedis (connectionHedis connection) + |> map toResult + |> handleExceptions + -- The result is the hash, which we already have. No sense in decoding it. + |> map (map (\_ -> ())) + |> Platform.doAnything anything + |> Stack.withFrozenCallStack Internal.traceQuery [Script.scriptLoadString script] (connectionHost connection) (connectionPort connection) + toB :: Text -> Data.ByteString.ByteString toB = Data.Text.Encoding.encodeUtf8 diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 9a4cfc56..0300edc6 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -20,6 +20,7 @@ module Redis.Internal sequence, query, transaction, + eval, foldWithScan, -- internal tools traceQuery, @@ -231,6 +232,7 @@ data HasAutoExtendExpire = NoAutoExtendExpire | AutoExtendExpire data Handler' (x :: HasAutoExtendExpire) = Handler' { doQuery :: Stack.HasCallStack => forall a. Query a -> Task Error a, doTransaction :: Stack.HasCallStack => forall a. Query a -> Task Error a, + doEval :: Stack.HasCallStack => forall a. Database.Redis.RedisResult a => Script.Script a -> Task Error a, namespace :: Text, maxKeySize :: Settings.MaxKeySize } @@ -269,6 +271,11 @@ transaction handler query' = |> Task.andThen (ensureMaxKeySize handler) |> Task.andThen (Stack.withFrozenCallStack (doTransaction handler)) +eval :: (Stack.HasCallStack, Database.Redis.RedisResult a) => Handler' x -> Script.Script a -> Task Error a +eval handler script = + Script.mapKeys (\key -> Task.succeed (namespace handler ++ ":" ++ key)) script + |> Task.andThen (Stack.withFrozenCallStack (doEval handler)) + namespaceQuery :: Text -> Query a -> Task err (Query a) namespaceQuery prefix query' = mapKeys (\key -> Task.succeed (prefix ++ key)) query' diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 79a9c653..29fb9136 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -9,6 +9,8 @@ module Redis.Script -- Internal API luaScriptHash, evalString, + evalShaString, + scriptLoadString, mapKeys, keysTouchedByScript, -- For testing @@ -34,6 +36,7 @@ import qualified Set import Text.Megaparsec ((<|>)) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as PC +import qualified Text.Printf import Prelude (notElem, pure, (<*)) import qualified Prelude @@ -247,6 +250,20 @@ evalString Script {luaScript, keys, arguments} = args' = arguments |> Log.unSecret |> List.map (\_ -> "***") |> Text.join " " in "EVAL {{" ++ luaScript ++ "}} " ++ keyCount ++ " " ++ keys' ++ " " ++ args' +-- | EVALSHA hash numkeys [key [key ...]] [arg [arg ...]] +evalShaString :: Script a -> Text +evalShaString script'@(Script {keys, arguments}) = + let keyCount = keys |> List.length |> Text.fromInt + keys' = keys |> Text.join " " + args' = arguments |> Log.unSecret |> List.map (\_ -> "***") |> Text.join " " + hash = luaScriptHash script' + in "EVALSHA " ++ hash ++ " " ++ keyCount ++ " " ++ keys' ++ " " ++ args' + +-- | SCRIPT LOAD "return KEYS[1]" +scriptLoadString :: Script a -> Text +scriptLoadString Script {luaScript} = + "SCRIPT LOAD \"" ++ luaScript ++ "\"" + -- | Map the keys in the script to the keys in the Redis API mapKeys :: (Text -> Task err Text) -> Script a -> Task err (Script a) mapKeys fn script' = do @@ -261,11 +278,20 @@ keysTouchedByScript script' = keys script' |> Set.fromList -luaScriptHash :: Script a -> Data.ByteString.ByteString +luaScriptHash :: Script a -> Text luaScriptHash Script {luaScript} = luaScript |> Data.Text.Encoding.encodeUtf8 |> Crypto.Hash.SHA1.hash + |> toHex + +toHex :: Data.ByteString.ByteString -> Text +toHex bytes = + bytes + |> Data.ByteString.unpack + |> List.map (Text.Printf.printf "%02x") + |> List.concat + |> Text.fromList --------------------------------------------- -- Helper functions for testing diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 392336fa..f0bc5cf5 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -374,7 +374,7 @@ queryTests redisHandler = |> Expect.equal expectedKeys, Test.test "eval runs and returns something" <| \() -> do let script = [Redis.script|return 1|] - result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds + result <- Redis.eval testNS script |> Expect.succeeds Expect.equal result 1, Test.test "eval with arguments runs and returns something" <| \() -> do let script = @@ -382,7 +382,7 @@ queryTests redisHandler = local a = ${Redis.Key "hi"} local b = ${Redis.Literal "hello"} return 1|] - result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds + result <- Redis.eval testNS script |> Expect.succeeds Expect.equal result 1, Test.test "eval with arguments returns argument" <| \() -> do let script = @@ -390,11 +390,11 @@ queryTests redisHandler = local a = ${Redis.Key 2} local b = ${Redis.Literal 3} return b|] - result <- Redis.eval intJsonApi script |> Redis.query testNS |> Expect.succeeds + result <- Redis.eval testNS script |> Expect.succeeds Expect.equal result 3, Test.test "eval with arguments namespaces key" <| \() -> do let script = [Redis.script|return ${Redis.Key "hi"}|] - result <- Redis.eval api script |> Redis.query testNS |> Expect.succeeds + (result :: Text) <- Redis.eval testNS script |> Expect.succeeds Expect.true ( List.member result @@ -432,9 +432,6 @@ sortedSetApi = Redis.SortedSet.textApi identity jsonApi' :: Redis.Api Text [Int] jsonApi' = Redis.jsonApi identity -intJsonApi :: Redis.Api Text Prelude.Integer -intJsonApi = Redis.jsonApi identity - -- | Timestamps recorded in spans would make each test result different from the -- last. This helper sets all timestamps to zero to prevent this. -- From d0e0be728277baaa096f59c0201462e587c894bb Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 13:33:02 -0300 Subject: [PATCH 20/39] Add orphaned instances for Int and () --- nri-redis/src/Redis/Internal.hs | 16 +++++++++++++++- nri-redis/test/Spec/Redis.hs | 7 +++++++ 2 files changed, 22 insertions(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 0300edc6..351124bc 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -477,8 +477,22 @@ foldWithScan handler keyMatchPattern approxCountPerBatch processKeyBatch initAcc else go nextAccumulator nextCursor in go initAccumulator Database.Redis.cursor0 --- This is an orphaned instance +-------------------------------------- +-- Orphaned instances for RedisResult +-------------------------------------- instance Database.Redis.RedisResult Text where decode r = do decodedBs <- Database.Redis.decode r Prelude.pure <| Data.Text.Encoding.decodeUtf8 decodedBs + +instance Database.Redis.RedisResult Int where + decode r = do + (decodedInteger :: Prelude.Integer) <- Database.Redis.decode r + Prelude.pure <| Prelude.fromIntegral decodedInteger + +instance Database.Redis.RedisResult () where + decode r = do + (reply :: Database.Redis.Reply) <- Database.Redis.decode r + case reply of + Database.Redis.Bulk Nothing -> Prelude.pure () + other -> Prelude.Left other diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index f0bc5cf5..2035c1d4 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -376,6 +376,13 @@ queryTests redisHandler = let script = [Redis.script|return 1|] result <- Redis.eval testNS script |> Expect.succeeds Expect.equal result 1, + Test.test "eval returns Int" <| \() -> do + let script = [Redis.script|return 1|] + (result :: Int) <- Redis.eval testNS script |> Expect.succeeds + Expect.equal result 1, + Test.test "eval returns ()" <| \() -> do + let script = [Redis.script|redis.call("ECHO", "hi")|] + Redis.eval testNS script |> Expect.succeeds, Test.test "eval with arguments runs and returns something" <| \() -> do let script = [Redis.script| From 87511efc786c1dde8c82d12cea5d2edaa36a27b5 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 15:12:34 -0300 Subject: [PATCH 21/39] Test that lists work --- nri-redis/test/Spec/Redis.hs | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 2035c1d4..06e665d1 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -383,6 +383,10 @@ queryTests redisHandler = Test.test "eval returns ()" <| \() -> do let script = [Redis.script|redis.call("ECHO", "hi")|] Redis.eval testNS script |> Expect.succeeds, + Test.test "eval returns List Int" <| \() -> do + let script = [Redis.script|return {1,2}|] + (result :: List Int) <- Redis.eval testNS script |> Expect.succeeds + Expect.equal result [1,2], Test.test "eval with arguments runs and returns something" <| \() -> do let script = [Redis.script| From d6f52e5283c8206fca88be38e3be6655a53c8b81 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 16:33:15 -0300 Subject: [PATCH 22/39] Fix for GHC 8.10 --- nri-redis/nri-redis.cabal | 4 ++-- nri-redis/package.yaml | 2 +- nri-redis/src/Redis/Script.hs | 2 +- 3 files changed, 4 insertions(+), 4 deletions(-) diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index b1fc1d1e..f2d0488f 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -80,7 +80,7 @@ library , pcre-light >=0.4.1.0 && <0.4.2 , resourcet >=1.2.0 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 - , template-haskell >=2.19 && <3.0 + , template-haskell >=2.16 && <3.0 , text >=1.2.3.1 && <2.1 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 @@ -145,7 +145,7 @@ test-suite tests , pcre-light >=0.4.1.0 && <0.4.2 , resourcet >=1.2.0 && <1.3 , safe-exceptions >=0.1.7.0 && <1.3 - , template-haskell >=2.19 && <3.0 + , template-haskell >=2.16 && <3.0 , text >=1.2.3.1 && <2.1 , unordered-containers >=0.2.0.0 && <0.3 , uuid >=1.3.0 && <1.4 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index c799cc57..4626cf9f 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -33,7 +33,7 @@ dependencies: - resourcet >= 1.2.0 && < 1.3 - safe-exceptions >= 0.1.7.0 && < 1.3 - text >= 1.2.3.1 && < 2.1 - - template-haskell >= 2.19 && < 3.0 + - template-haskell >= 2.16 && < 3.0 - unordered-containers >=0.2.0.0 && <0.3 - uuid >=1.3.0 && < 1.4 library: diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 29fb9136..0970b656 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -74,7 +74,7 @@ instance HasScriptParam ScriptParam where -- It is what forces us to have IncoherentInstances and UndecidedInstances enabled. instance {-# OVERLAPPABLE #-} - GHC.TypeLits.TypeError (GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.") => + GHC.TypeLits.TypeError ('GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.") => HasScriptParam x where getScriptParam = Prelude.error "This won't ever hit bc this generates a compile-time error." From a7bbce4c99478d511f6d65bf3184fa588a382618 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 16:33:31 -0300 Subject: [PATCH 23/39] Update golden files for ghc 8.10 --- .../observability-spec-reporting-redis-counter-query | 8 ++++---- ...observability-spec-reporting-redis-counter-transaction | 8 ++++---- .../observability-spec-reporting-redis-hash-query | 8 ++++---- .../observability-spec-reporting-redis-hash-transaction | 8 ++++---- .../observability-spec-reporting-redis-list-query | 8 ++++---- .../observability-spec-reporting-redis-list-transaction | 8 ++++---- .../observability-spec-reporting-redis-query | 8 ++++---- .../observability-spec-reporting-redis-transaction | 8 ++++---- 8 files changed, 32 insertions(+), 32 deletions(-) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-query b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-query index dad85b78..a44457e7 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-query +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 103 + , srcLocStartLine = 105 , srcLocStartCol = 9 - , srcLocEndLine = 103 + , srcLocEndLine = 105 , srcLocEndCol = 68 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-transaction b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-transaction index 21c2a3f3..5b14ef76 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-transaction +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-counter-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 110 + , srcLocStartLine = 112 , srcLocStartCol = 9 - , srcLocEndLine = 110 + , srcLocEndLine = 112 , srcLocEndCol = 74 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-query b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-query index 12e996ff..dbc01a55 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-query +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 75 + , srcLocStartLine = 77 , srcLocStartCol = 9 - , srcLocEndLine = 75 + , srcLocEndLine = 77 , srcLocEndCol = 59 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-transaction b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-transaction index 1940b213..18d639d6 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-transaction +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-hash-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 82 + , srcLocStartLine = 84 , srcLocStartCol = 9 - , srcLocEndLine = 82 + , srcLocEndLine = 84 , srcLocEndCol = 65 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-query b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-query index f5b9c766..8923bfe1 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-query +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 89 + , srcLocStartLine = 91 , srcLocStartCol = 9 - , srcLocEndLine = 89 + , srcLocEndLine = 91 , srcLocEndCol = 59 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-transaction b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-transaction index 1d1ed703..ad1e253d 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-transaction +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-list-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 96 + , srcLocStartLine = 98 , srcLocStartCol = 9 - , srcLocEndLine = 96 + , srcLocEndLine = 98 , srcLocEndCol = 65 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-query b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-query index 755a0de0..1fcd70c0 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-query +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-query @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 61 + , srcLocStartLine = 63 , srcLocStartCol = 9 - , srcLocEndLine = 61 + , srcLocEndLine = 63 , srcLocEndCol = 45 } ) diff --git a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-transaction b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-transaction index 2c7749ea..345a0841 100644 --- a/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-transaction +++ b/nri-redis/test/golden-results-8.10/observability-spec-reporting-redis-transaction @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 29 + , srcLocStartLine = 31 , srcLocStartCol = 7 - , srcLocEndLine = 33 + , srcLocEndLine = 35 , srcLocEndCol = 40 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "Spec.Redis" , srcLocFile = "test/Spec/Redis.hs" - , srcLocStartLine = 68 + , srcLocStartLine = 70 , srcLocStartCol = 9 - , srcLocEndLine = 68 + , srcLocEndLine = 70 , srcLocEndCol = 51 } ) From 7a21149aadd4179054e18b74465e901d5a784199 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 16:34:35 -0300 Subject: [PATCH 24/39] Fix for NoRedInk monorepo --- nri-redis/nri-redis.cabal | 4 ++-- nri-redis/package.yaml | 2 +- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/nri-redis/nri-redis.cabal b/nri-redis/nri-redis.cabal index f2d0488f..ecc553eb 100644 --- a/nri-redis/nri-redis.cabal +++ b/nri-redis/nri-redis.cabal @@ -72,7 +72,7 @@ library , cryptohash-sha1 >=0.11.101.0 && <0.12 , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16 - , megaparsec >=9.2.2 && <9.3 + , megaparsec >=9.2.2 && <9.4 , modern-uri >=0.3.1.0 && <0.4 , nri-env-parser >=0.1.0.0 && <0.2 , nri-observability >=0.1.0 && <0.2 @@ -137,7 +137,7 @@ test-suite tests , cryptohash-sha1 >=0.11.101.0 && <0.12 , haskell-src-meta >=0.8.12 && <0.9 , hedis >=0.14.0 && <0.16 - , megaparsec >=9.2.2 && <9.3 + , megaparsec >=9.2.2 && <9.4 , modern-uri >=0.3.1.0 && <0.4 , nri-env-parser >=0.1.0.0 && <0.2 , nri-observability >=0.1.0 && <0.2 diff --git a/nri-redis/package.yaml b/nri-redis/package.yaml index 4626cf9f..cf34c9ec 100644 --- a/nri-redis/package.yaml +++ b/nri-redis/package.yaml @@ -24,7 +24,7 @@ dependencies: - haskell-src-meta >= 0.8.12 && < 0.9 # hedis 14 introduces redis-cluster support - hedis >= 0.14.0 && < 0.16 - - megaparsec >= 9.2.2 && < 9.3 + - megaparsec >= 9.2.2 && < 9.4 - modern-uri >= 0.3.1.0 && < 0.4 - nri-env-parser >= 0.1.0.0 && < 0.2 - nri-observability >= 0.1.0 && < 0.2 From 3e41dcd64548b8e43a998714baedb8007b09abde Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 17:32:45 -0300 Subject: [PATCH 25/39] Remove Eval Cmd The Handler eval is better. The only thing it doesn't support is auto-expire, but I'm skeptical it's a good idea to use that with Lua scripts arbitrarily. --- nri-redis/src/Redis.hs | 11 ++--------- nri-redis/src/Redis/Handler.hs | 4 ---- nri-redis/src/Redis/Internal.hs | 5 ----- nri-redis/src/Redis/Script.hs | 17 ----------------- 4 files changed, 2 insertions(+), 35 deletions(-) diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index 98a8d9c0..fb555dd7 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -58,14 +58,12 @@ import qualified Data.Aeson as Aeson import qualified Data.ByteString as ByteString import Data.List.NonEmpty (NonEmpty) import qualified Data.List.NonEmpty as NonEmpty -import qualified Database.Redis import qualified Dict import qualified NonEmptyDict import qualified Redis.Codec as Codec import qualified Redis.Handler as Handler import qualified Redis.Internal as Internal import Redis.Script (ScriptParam (..), script) -import qualified Redis.Script as Script import qualified Redis.Settings as Settings import qualified Prelude @@ -141,11 +139,7 @@ data Api key a = Api -- performed. SETNX is short for "SET if Not eXists". -- -- https://redis.io/commands/setnx - setnx :: key -> a -> Internal.Query Bool, - -- | Invoke the execution of a server-side Lua script. - -- - -- https://redis.io/commands/eval - eval :: Database.Redis.RedisResult a => Script.Script a -> Internal.Query a + setnx :: key -> a -> Internal.Query Bool } -- | Creates a json API mapping a 'key' to a json-encodable-decodable type @@ -191,6 +185,5 @@ makeApi Codec.Codec {Codec.codecEncoder, Codec.codecDecoder} toKey = ping = Internal.Ping |> map (\_ -> ()), set = \key value -> Internal.Set (toKey key) (codecEncoder value), setex = \key seconds value -> Internal.Setex (toKey key) seconds (codecEncoder value), - setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value), - eval = \script' -> Internal.Eval script' + setnx = \key value -> Internal.Setnx (toKey key) (codecEncoder value) } diff --git a/nri-redis/src/Redis/Handler.hs b/nri-redis/src/Redis/Handler.hs index 58a7af17..dc2aac2b 100644 --- a/nri-redis/src/Redis/Handler.hs +++ b/nri-redis/src/Redis/Handler.hs @@ -174,10 +174,6 @@ doRawQuery query = Database.Redis.del (NonEmpty.toList (map toB keys)) |> PreparedQuery |> map (Ok << Prelude.fromIntegral) - Internal.Eval script -> - Database.Redis.eval (toB (Script.luaScript script)) (map toB (Script.keys script)) (map toB (Log.unSecret (Script.arguments script))) - |> PreparedQuery - |> map Ok Internal.Exists key -> Database.Redis.exists (toB key) |> PreparedQuery diff --git a/nri-redis/src/Redis/Internal.hs b/nri-redis/src/Redis/Internal.hs index 351124bc..490d8866 100644 --- a/nri-redis/src/Redis/Internal.hs +++ b/nri-redis/src/Redis/Internal.hs @@ -84,7 +84,6 @@ cmds :: Query b -> [Text] cmds query'' = case query'' of Del keys -> [unwords ("DEL" : NonEmpty.toList keys)] - Eval script -> [Script.evalString script] Exists key -> [unwords ["EXISTS", key]] Expire key val -> [unwords ["EXPIRE", key, Text.fromInt val]] Get key -> [unwords ["GET", key]] @@ -142,7 +141,6 @@ unwords = Text.join " " -- | A Redis query data Query a where Del :: NonEmpty Text -> Query Int - Eval :: Database.Redis.RedisResult a => Script.Script a -> Query a Exists :: Text -> Query Bool Expire :: Text -> Int -> Query () Get :: Text -> Query (Maybe ByteString) @@ -284,7 +282,6 @@ namespaceQuery prefix query' = mapKeys :: (Text -> Task err Text) -> Query a -> Task err (Query a) mapKeys fn query' = case query' of - Eval script -> Task.map Eval (Script.mapKeys fn script) Exists key -> Task.map Exists (fn key) Ping -> Task.succeed Ping Get key -> Task.map Get (fn key) @@ -328,7 +325,6 @@ mapKeys fn query' = mapReturnedKeys :: (Text -> Text) -> Query a -> Query a mapReturnedKeys fn query' = case query' of - Eval _ -> query' Exists key -> Exists key Ping -> Ping Get key -> Get key @@ -386,7 +382,6 @@ keysTouchedByQuery query' = case query' of Apply f x -> Set.union (keysTouchedByQuery f) (keysTouchedByQuery x) Del keys -> Set.fromList (NonEmpty.toList keys) - Eval script -> Script.keysTouchedByScript script Exists key -> Set.singleton key -- We use this function to collect keys we need to expire. If the user is -- explicitly setting an expiry we don't want to overwrite that. diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 0970b656..89a16761 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -8,11 +8,9 @@ module Redis.Script script, -- Internal API luaScriptHash, - evalString, evalShaString, scriptLoadString, mapKeys, - keysTouchedByScript, -- For testing parser, Tokens (..), @@ -32,7 +30,6 @@ import qualified GHC.TypeLits import Language.Haskell.Meta.Parse (parseExp) import qualified Language.Haskell.TH as TH import qualified Language.Haskell.TH.Quote as QQ -import qualified Set import Text.Megaparsec ((<|>)) import qualified Text.Megaparsec as P import qualified Text.Megaparsec.Char as PC @@ -242,14 +239,6 @@ parseVariable = do -- Helper functions for internal library use --------------------------------------------- --- | EVAL script numkeys [key [key ...]] [arg [arg ...]] -evalString :: Script a -> Text -evalString Script {luaScript, keys, arguments} = - let keyCount = keys |> List.length |> Text.fromInt - keys' = keys |> Text.join " " - args' = arguments |> Log.unSecret |> List.map (\_ -> "***") |> Text.join " " - in "EVAL {{" ++ luaScript ++ "}} " ++ keyCount ++ " " ++ keys' ++ " " ++ args' - -- | EVALSHA hash numkeys [key [key ...]] [arg [arg ...]] evalShaString :: Script a -> Text evalShaString script'@(Script {keys, arguments}) = @@ -272,12 +261,6 @@ mapKeys fn script' = do |> Task.sequence |> Task.map (\keys' -> script' {keys = keys'}) --- | Get the keys touched by the script -keysTouchedByScript :: Script a -> Set.Set Text -keysTouchedByScript script' = - keys script' - |> Set.fromList - luaScriptHash :: Script a -> Text luaScriptHash Script {luaScript} = luaScript From c304e6d3edde270932db11ab56123a9dfdfdccf2 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 17:34:48 -0300 Subject: [PATCH 26/39] ormolu --- nri-redis/test/Spec/Redis.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 06e665d1..2ebecc15 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -386,7 +386,7 @@ queryTests redisHandler = Test.test "eval returns List Int" <| \() -> do let script = [Redis.script|return {1,2}|] (result :: List Int) <- Redis.eval testNS script |> Expect.succeeds - Expect.equal result [1,2], + Expect.equal result [1, 2], Test.test "eval with arguments runs and returns something" <| \() -> do let script = [Redis.script| From b67de8678ada74c372720af0e8da2d1c4136e449 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 27 May 2024 17:34:57 -0300 Subject: [PATCH 27/39] Reorg for hackage docs --- nri-redis/src/Redis.hs | 8 +++++--- 1 file changed, 5 insertions(+), 3 deletions(-) diff --git a/nri-redis/src/Redis.hs b/nri-redis/src/Redis.hs index fb555dd7..8be6379b 100644 --- a/nri-redis/src/Redis.hs +++ b/nri-redis/src/Redis.hs @@ -37,13 +37,10 @@ module Redis set, setex, setnx, - script, - ScriptParam (..), -- * Running Redis queries Internal.query, Internal.transaction, - Internal.eval, Internal.Query, Internal.Error (..), Internal.map, @@ -51,6 +48,11 @@ module Redis Internal.map3, Internal.sequence, Internal.foldWithScan, + + -- * Lua Scripting + script, + ScriptParam (..), + Internal.eval, ) where From d827a72487c6b880813a258d1f8d48c245d7750d Mon Sep 17 00:00:00 2001 From: Micah Hahn Date: Tue, 28 May 2024 12:02:28 -0500 Subject: [PATCH 28/39] Let's avoid the `IncoherentInstances` extension as its dangerous and deprecated --- nri-redis/src/Redis/Script.hs | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 89a16761..392b1bff 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -1,5 +1,4 @@ {-# LANGUAGE GADTs #-} -{-# LANGUAGE IncoherentInstances #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE UndecidableInstances #-} @@ -62,15 +61,15 @@ data ScriptParam class HasScriptParam a where getScriptParam :: a -> ScriptParam -instance HasScriptParam ScriptParam where +-- | This instance is marked as INCOHERENT so that it will be chosen if possible in the overlapping case +instance {-# INCOHERENT #-} HasScriptParam ScriptParam where getScriptParam = Prelude.id -- | This instance is used to provide a helpful error message when a user tries to use a type -- other than a ScriptParam in a [script|${ ... }|] quasi quote. -- --- It is what forces us to have IncoherentInstances and UndecidedInstances enabled. +-- It is what forces us to hav UndecidableInstances enabled. instance - {-# OVERLAPPABLE #-} GHC.TypeLits.TypeError ('GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.") => HasScriptParam x where From aace6cc02382dfbc6082a0c17fa735691b70dbf6 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 16:28:36 -0300 Subject: [PATCH 29/39] Add th-test-utils to the haskell pkgset (+format) I ended up not needing this, but I noticed it was missing and failing tests for nri-postgresql locally --- nix/mk-shell.nix | 10 ++++++---- 1 file changed, 6 insertions(+), 4 deletions(-) diff --git a/nix/mk-shell.nix b/nix/mk-shell.nix index e351fb05..4fd8bbec 100644 --- a/nix/mk-shell.nix +++ b/nix/mk-shell.nix @@ -6,11 +6,12 @@ let with pkgs.haskell.lib; overrideCabal hpkg (drv: { enableSeparateBinOutput = false; }); # It is still necessary to run `hpack --force` into packages home dirs - haskell-language-server = pkgs.haskellPackages.haskell-language-server.override { - hls-ormolu-plugin = pkgs.haskellPackages.hls-ormolu-plugin.override { - ormolu = (workaround140774 pkgs.haskellPackages.ormolu); + haskell-language-server = + pkgs.haskellPackages.haskell-language-server.override { + hls-ormolu-plugin = pkgs.haskellPackages.hls-ormolu-plugin.override { + ormolu = (workaround140774 pkgs.haskellPackages.ormolu); + }; }; - }; in pkgs.mkShell { buildInputs = [ @@ -60,6 +61,7 @@ in pkgs.mkShell { text text-zipper time + th-test-utils unordered-containers uuid vector From f73eecc0ca98dd56ca92cc05cffac0486d88d670 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 17:57:02 -0300 Subject: [PATCH 30/39] Add type-check test for script w/o Key or Literal --- nri-redis/src/Redis/Script.hs | 1 + nri-redis/test/Spec/Redis/Script.hs | 16 ++++++++++------ 2 files changed, 11 insertions(+), 6 deletions(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 392b1bff..1ab3e5a7 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -14,6 +14,7 @@ module Redis.Script parser, Tokens (..), ScriptParam (..), + HasScriptParam (..), printScript, ) where diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 34155fba..a985c476 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -1,4 +1,5 @@ {-# LANGUAGE QuasiQuotes #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} module Spec.Redis.Script (tests) where @@ -116,14 +117,17 @@ thTests = Test.test "one key argument" <| \_ -> [script|${Key "hi"}|] |> printScript - |> Expect.equal "Script { luaScript = \"KEYS[1]\", quasiQuotedString = \"${Key \"hi\"}\", keys = [\"hi\"], arguments = [] }" - -- We can't test for compile-time errors, but manually test our helpful error message, uncomment - -- the lines below: - -- Test.test "compilation error" <| \_ -> - -- [script|${123}|] - -- |> Expect.equal "Doesn't matter, this won't compile" + |> Expect.equal "Script { luaScript = \"KEYS[1]\", quasiQuotedString = \"${Key \"hi\"}\", keys = [\"hi\"], arguments = [] }", + Test.test "fails on type-checking when not given Key or Literal" <| \_ -> + [script|${False}|] + |> arguments + |> Log.unSecret + |> Expect.equal ["this would have been a type-checking error"] ] +instance {-# INCOHERENT #-} HasScriptParam Bool where + getScriptParam _ = Literal "this would have been a type-checking error" + mapLeft :: (a -> c) -> Either a b -> Either c b mapLeft f (Left a) = Left (f a) mapLeft _ (Right b) = Right b From 4704faa6b9ad40da5a99c3539296b1b0c5d0e505 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 17:58:31 -0300 Subject: [PATCH 31/39] Explain what this does --- nri-redis/test/Spec/Redis/Script.hs | 2 ++ 1 file changed, 2 insertions(+) diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index a985c476..4de1bd2d 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -125,6 +125,8 @@ thTests = |> Expect.equal ["this would have been a type-checking error"] ] +-- This instance is picked when none of the instances in src/Redis/Script.hs work.. +-- proving in real code we would have a type-checking error. instance {-# INCOHERENT #-} HasScriptParam Bool where getScriptParam _ = Literal "this would have been a type-checking error" From 354367553ba5c55d3c0bf7b58b2960b54bc790ae Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 18:01:14 -0300 Subject: [PATCH 32/39] Use Bifunctor.first --- nri-redis/test/Spec/Redis/Script.hs | 15 ++++++--------- 1 file changed, 6 insertions(+), 9 deletions(-) diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 4de1bd2d..1c638cf2 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -3,6 +3,7 @@ module Spec.Redis.Script (tests) where +import qualified Data.Bifunctor import Data.Either (Either (..)) import qualified Expect import Redis.Script @@ -43,7 +44,7 @@ parserTests = ), Test.test "ERROR: empty" <| \_ -> do P.runParser parser "" "" - |> mapLeft P.errorBundlePretty + |> Data.Bifunctor.first P.errorBundlePretty |> Expect.equal ( Left "1:1:\n\ @@ -56,7 +57,7 @@ parserTests = ), Test.test "ERROR: empty variable" <| \_ -> do P.runParser parser "" "${}" - |> mapLeft P.errorBundlePretty + |> Data.Bifunctor.first P.errorBundlePretty |> Expect.equal ( Left "1:3:\n\ @@ -69,7 +70,7 @@ parserTests = ), Test.test "ERROR: nested ${}" <| \_ -> do P.runParser parser "" "asdasd ${ ${ value } }" - |> mapLeft P.errorBundlePretty + |> Data.Bifunctor.first P.errorBundlePretty |> Expect.equal ( Left "1:11:\n\ @@ -82,7 +83,7 @@ parserTests = ), Test.test "ERROR: misplaced ${ inside ${}" <| \_ -> do P.runParser parser "" "${ v$alue }" - |> mapLeft P.errorBundlePretty + |> Data.Bifunctor.first P.errorBundlePretty |> Expect.equal ( Left "1:5:\n\ @@ -95,7 +96,7 @@ parserTests = ), Test.test "ERROR: misplaced { inside ${}" <| \_ -> do P.runParser parser "" "${ v{alue }" - |> mapLeft P.errorBundlePretty + |> Data.Bifunctor.first P.errorBundlePretty |> Expect.equal ( Left "1:5:\n\ @@ -129,7 +130,3 @@ thTests = -- proving in real code we would have a type-checking error. instance {-# INCOHERENT #-} HasScriptParam Bool where getScriptParam _ = Literal "this would have been a type-checking error" - -mapLeft :: (a -> c) -> Either a b -> Either c b -mapLeft f (Left a) = Left (f a) -mapLeft _ (Right b) = Right b From 6b3a646fba65632799bfecaa0f8d85338744f7c7 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 18:22:11 -0300 Subject: [PATCH 33/39] Fix golden-results for nri-postgresql --- .../observability-spec-postgres-reporting | 10 +++++----- 1 file changed, 5 insertions(+), 5 deletions(-) diff --git a/nri-postgresql/test/golden-results/observability-spec-postgres-reporting b/nri-postgresql/test/golden-results/observability-spec-postgres-reporting index 8832a53f..a672bcd7 100644 --- a/nri-postgresql/test/golden-results/observability-spec-postgres-reporting +++ b/nri-postgresql/test/golden-results/observability-spec-postgres-reporting @@ -11,8 +11,8 @@ TracingSpan , srcLocFile = "test/ObservabilitySpec.hs" , srcLocStartLine = 53 , srcLocStartCol = 7 - , srcLocEndLine = 57 - , srcLocEndCol = 40 + , srcLocEndLine = 53 + , srcLocEndCol = 33 } ) , details = Nothing @@ -34,8 +34,8 @@ TracingSpan , srcLocFile = "test/ObservabilitySpec.hs" , srcLocStartLine = 35 , srcLocStartCol = 11 - , srcLocEndLine = 42 - , srcLocEndCol = 14 + , srcLocEndLine = 35 + , srcLocEndCol = 27 } ) , details = @@ -60,7 +60,7 @@ TracingSpan , srcLocStartLine = 225 , srcLocStartCol = 9 , srcLocEndLine = 225 - , srcLocEndCol = 69 + , srcLocEndCol = 24 } ) , details = Just "{}" From 77857a850c855473e4778da1011f0ba4de79609f Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 18:33:51 -0300 Subject: [PATCH 34/39] Fix discrepancy in LoC between ghc 9 and ghc 8 --- nri-postgresql/test/ObservabilitySpec.hs | 9 ++- ...bservability-spec-postgres-reporting-ghc-8 | 76 +++++++++++++++++++ ...servability-spec-postgres-reporting-ghc-9} | 8 +- 3 files changed, 88 insertions(+), 5 deletions(-) create mode 100644 nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-8 rename nri-postgresql/test/golden-results/{observability-spec-postgres-reporting => observability-spec-postgres-reporting-ghc-9} (94%) diff --git a/nri-postgresql/test/ObservabilitySpec.hs b/nri-postgresql/test/ObservabilitySpec.hs index e2ff3037..9b2d2c77 100644 --- a/nri-postgresql/test/ObservabilitySpec.hs +++ b/nri-postgresql/test/ObservabilitySpec.hs @@ -1,3 +1,4 @@ +{-# LANGUAGE CPP #-} {-# LANGUAGE QuasiQuotes #-} module ObservabilitySpec @@ -42,7 +43,13 @@ tests postgres = ) |> spanForTask Debug.toString span - |> Expect.equalToContentsOf "test/golden-results/observability-spec-postgres-reporting" + |> Expect.equalToContentsOf +#if __GLASGOW_HASKELL__ >= 902 + "test/golden-results/observability-spec-postgres-reporting-ghc-9" +#else + "test/golden-results/observability-spec-postgres-reporting-ghc-8" +#endif + ] spanForTask :: Show e => Task e () -> Expect.Expectation' Platform.TracingSpan diff --git a/nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-8 b/nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-8 new file mode 100644 index 00000000..f61c545a --- /dev/null +++ b/nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-8 @@ -0,0 +1,76 @@ +TracingSpan + { name = "test-root" + , started = MonotonicTime { inMicroseconds = 0 } + , finished = MonotonicTime { inMicroseconds = 0 } + , frame = + Just + ( "rootTracingSpanIO" + , SrcLoc + { srcLocPackage = "main" + , srcLocModule = "ObservabilitySpec" + , srcLocFile = "test/ObservabilitySpec.hs" + , srcLocStartLine = 60 + , srcLocStartCol = 7 + , srcLocEndLine = 64 + , srcLocEndCol = 40 + } + ) + , details = Nothing + , summary = Nothing + , succeeded = Succeeded + , containsFailures = False + , allocated = 0 + , children = + [ TracingSpan + { name = "Postgresql Query" + , started = MonotonicTime { inMicroseconds = 0 } + , finished = MonotonicTime { inMicroseconds = 0 } + , frame = + Just + ( "doQuery" + , SrcLoc + { srcLocPackage = "main" + , srcLocModule = "ObservabilitySpec" + , srcLocFile = "test/ObservabilitySpec.hs" + , srcLocStartLine = 36 + , srcLocStartCol = 11 + , srcLocEndLine = 43 + , srcLocEndCol = 14 + } + ) + , details = + Just + "{\"query\":\"Secret *****\",\"query template\":\"!SELECT 1::bigint\",\"sql operation\":\"UNKNOWN\",\"queried relation\":\"!SELECT 1::bigint\",\"database type\":\"PostgreSQL\",\"host\":\"/mock/db/path.sock\",\"database\":\"mock-db-name\",\"rows returned\":1}" + , summary = Just "UNKNOWN !SELECT 1::bigint" + , succeeded = Succeeded + , containsFailures = False + , allocated = 0 + , children = + [ TracingSpan + { name = "acquiring Postgres connection from pool" + , started = MonotonicTime { inMicroseconds = 0 } + , finished = MonotonicTime { inMicroseconds = 0 } + , frame = + Just + ( "withContext" + , SrcLoc + { srcLocPackage = "main" + , srcLocModule = "Postgres" + , srcLocFile = "src/Postgres.hs" + , srcLocStartLine = 225 + , srcLocStartCol = 9 + , srcLocEndLine = 225 + , srcLocEndCol = 69 + } + ) + , details = Just "{}" + , summary = Just "acquiring Postgres connection from pool" + , succeeded = Succeeded + , containsFailures = False + , allocated = 0 + , children = [] + } + ] + } + ] + } \ No newline at end of file diff --git a/nri-postgresql/test/golden-results/observability-spec-postgres-reporting b/nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-9 similarity index 94% rename from nri-postgresql/test/golden-results/observability-spec-postgres-reporting rename to nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-9 index a672bcd7..94767efe 100644 --- a/nri-postgresql/test/golden-results/observability-spec-postgres-reporting +++ b/nri-postgresql/test/golden-results/observability-spec-postgres-reporting-ghc-9 @@ -9,9 +9,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "ObservabilitySpec" , srcLocFile = "test/ObservabilitySpec.hs" - , srcLocStartLine = 53 + , srcLocStartLine = 60 , srcLocStartCol = 7 - , srcLocEndLine = 53 + , srcLocEndLine = 60 , srcLocEndCol = 33 } ) @@ -32,9 +32,9 @@ TracingSpan { srcLocPackage = "main" , srcLocModule = "ObservabilitySpec" , srcLocFile = "test/ObservabilitySpec.hs" - , srcLocStartLine = 35 + , srcLocStartLine = 36 , srcLocStartCol = 11 - , srcLocEndLine = 35 + , srcLocEndLine = 36 , srcLocEndCol = 27 } ) From 6faeab6fa4b48ebfe05d8399dd86bf24b055777f Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Wed, 29 May 2024 18:44:25 -0300 Subject: [PATCH 35/39] Unblock local run of ObservabilitySpec.hs In CI I think the postgres user gets created somehow. Locally it doesn't --- nri-postgresql/setup-postgres.sh | 4 ++++ 1 file changed, 4 insertions(+) diff --git a/nri-postgresql/setup-postgres.sh b/nri-postgresql/setup-postgres.sh index ae7130b3..eb3b1231 100755 --- a/nri-postgresql/setup-postgres.sh +++ b/nri-postgresql/setup-postgres.sh @@ -23,3 +23,7 @@ psql -c "CREATE TABLE test_table2 (enum_array_col test_enum[] NOT NULL)" || true ## Setup for test/Test.hs psql -c "CREATE TABLE constraints_table (user_id int PRIMARY KEY)" || true + +## Setup for test/ObservabilitySpec.hs +createuser -s postgres +psql -c "GRANT ALL PRIVILEGES ON DATABASE testdb TO postgres;" || true From b6781e69e55d9f652dee131866a1b3872acb1b01 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 3 Jun 2024 17:48:24 -0300 Subject: [PATCH 36/39] Ensure literal argument ordering (failing test) --- nri-redis/test/Spec/Redis.hs | 6 ++++-- 1 file changed, 4 insertions(+), 2 deletions(-) diff --git a/nri-redis/test/Spec/Redis.hs b/nri-redis/test/Spec/Redis.hs index 2ebecc15..84642966 100644 --- a/nri-redis/test/Spec/Redis.hs +++ b/nri-redis/test/Spec/Redis.hs @@ -400,9 +400,11 @@ queryTests redisHandler = [Redis.script| local a = ${Redis.Key 2} local b = ${Redis.Literal 3} - return b|] + local c = ${Redis.Literal 4} + local d = ${Redis.Literal 5} + return {b, c, d}|] result <- Redis.eval testNS script |> Expect.succeeds - Expect.equal result 3, + Expect.equal result [3, 4, 5], Test.test "eval with arguments namespaces key" <| \() -> do let script = [Redis.script|return ${Redis.Key "hi"}|] (result :: Text) <- Redis.eval testNS script |> Expect.succeeds From 50c67862704ca8c88714424b82aebe20dc66b8e2 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 3 Jun 2024 17:48:32 -0300 Subject: [PATCH 37/39] Fix literal argument ordering --- nri-redis/src/Redis/Script.hs | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 1ab3e5a7..d53b644b 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -202,7 +202,7 @@ scriptFromEvaluatedTokens quasiQuotedString' evaluatedTokens = { luaScript = buffer script', quasiQuotedString = quasiQuotedString', keys = keyList script', - arguments = Log.mkSecret (argList script') + arguments = Log.mkSecret (List.reverse (argList script')) } ----------------------------- From 17a5d3dd0b0c40329517559618901b7fff49898a Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 3 Jun 2024 17:54:25 -0300 Subject: [PATCH 38/39] Ditch printScript --- nri-redis/src/Redis/Script.hs | 10 ---------- nri-redis/test/Spec/Redis/Script.hs | 20 ++++++++++++++++---- 2 files changed, 16 insertions(+), 14 deletions(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index d53b644b..60b54cc5 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -15,7 +15,6 @@ module Redis.Script Tokens (..), ScriptParam (..), HasScriptParam (..), - printScript, ) where @@ -275,12 +274,3 @@ toHex bytes = |> List.map (Text.Printf.printf "%02x") |> List.concat |> Text.fromList - ---------------------------------------------- --- Helper functions for testing ---------------------------------------------- - -printScript :: Script a -> Text -printScript Script {luaScript, quasiQuotedString, keys, arguments} = - let listStr l = List.map (\s -> "\"" ++ s ++ "\"") l |> Text.join ", " - in "Script { luaScript = \"" ++ luaScript ++ "\", quasiQuotedString = \"" ++ quasiQuotedString ++ "\", keys = [" ++ listStr keys ++ "], arguments = [" ++ listStr (Log.unSecret arguments) ++ "] }" diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 1c638cf2..622ea102 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -113,12 +113,24 @@ thTests :: List Test.Test thTests = [ Test.test "just text" <| \_ -> [script|some text|] - |> printScript - |> Expect.equal "Script { luaScript = \"some text\", quasiQuotedString = \"some text\", keys = [], arguments = [] }", + |> Expect.equal + ( Script + { luaScript = "some text", + quasiQuotedString = "some text", + keys = [], + arguments = Log.mkSecret [] + } + ), Test.test "one key argument" <| \_ -> [script|${Key "hi"}|] - |> printScript - |> Expect.equal "Script { luaScript = \"KEYS[1]\", quasiQuotedString = \"${Key \"hi\"}\", keys = [\"hi\"], arguments = [] }", + |> Expect.equal + ( Script + { luaScript = "KEYS[1]", + quasiQuotedString = "${Key \"hi\"}", + keys = ["hi"], + arguments = Log.mkSecret [] + } + ), Test.test "fails on type-checking when not given Key or Literal" <| \_ -> [script|${False}|] |> arguments From a55a1437a53020de6c8618e246c2b44ff07e5252 Mon Sep 17 00:00:00 2001 From: Juliano Solanho Date: Mon, 3 Jun 2024 18:03:57 -0300 Subject: [PATCH 39/39] Expand script test suite and fix keys out of order --- nri-redis/src/Redis/Script.hs | 2 +- nri-redis/test/Spec/Redis/Script.hs | 30 +++++++++++++++++++++++++++++ 2 files changed, 31 insertions(+), 1 deletion(-) diff --git a/nri-redis/src/Redis/Script.hs b/nri-redis/src/Redis/Script.hs index 60b54cc5..88a1d16a 100644 --- a/nri-redis/src/Redis/Script.hs +++ b/nri-redis/src/Redis/Script.hs @@ -200,7 +200,7 @@ scriptFromEvaluatedTokens quasiQuotedString' evaluatedTokens = in Script { luaScript = buffer script', quasiQuotedString = quasiQuotedString', - keys = keyList script', + keys = List.reverse (keyList script'), arguments = Log.mkSecret (List.reverse (argList script')) } diff --git a/nri-redis/test/Spec/Redis/Script.hs b/nri-redis/test/Spec/Redis/Script.hs index 622ea102..b03c34f6 100644 --- a/nri-redis/test/Spec/Redis/Script.hs +++ b/nri-redis/test/Spec/Redis/Script.hs @@ -131,6 +131,36 @@ thTests = arguments = Log.mkSecret [] } ), + Test.test "one literal argument" <| \_ -> + [script|${Literal "hi"}|] + |> Expect.equal + ( Script + { luaScript = "ARGV[1]", + quasiQuotedString = "${Literal \"hi\"}", + keys = [], + arguments = Log.mkSecret ["hi"] + } + ), + Test.test "one key one literal argument" <| \_ -> + [script|${Key "a key"} ${Literal "a literal"}|] + |> Expect.equal + ( Script + { luaScript = "KEYS[1] ARGV[1]", + quasiQuotedString = "${Key \"a key\"} ${Literal \"a literal\"}", + keys = ["a key"], + arguments = Log.mkSecret ["a literal"] + } + ), + Test.test "multiple keys and literals" <| \_ -> + [script|${Key "key1"} ${Key "key2"} ${Key "key3"} ${Literal "literal1"} ${Literal "literal2"} ${Literal "literal3"}|] + |> Expect.equal + ( Script + { luaScript = "KEYS[1] KEYS[2] KEYS[3] ARGV[1] ARGV[2] ARGV[3]", + quasiQuotedString = "${Key \"key1\"} ${Key \"key2\"} ${Key \"key3\"} ${Literal \"literal1\"} ${Literal \"literal2\"} ${Literal \"literal3\"}", + keys = ["key1", "key2", "key3"], + arguments = Log.mkSecret ["literal1", "literal2", "literal3"] + } + ), Test.test "fails on type-checking when not given Key or Literal" <| \_ -> [script|${False}|] |> arguments