{-# LANGUAGE GADTs #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}

module Redis.Script
  ( Script (..),
    script,
    -- Internal API
    luaScriptHash,
    evalShaString,
    scriptLoadString,
    mapKeys,
    -- For testing
    parser,
    Tokens (..),
    ScriptParam (..),
    HasScriptParam (..),
  )
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)
import qualified Language.Haskell.TH as TH
import qualified Language.Haskell.TH.Quote as QQ
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

data Script result = Script
  { -- | The Lua script to be executed with @args placeholders for Redis
    forall result. Script result -> Text
luaScript :: Text,
    -- | The script string as extracted from a `script` quasi quote.
    forall result. Script result -> Text
quasiQuotedString :: Text,
    forall result. Script result -> [Text]
keys :: [Text],
    -- | The parameters that fill the placeholders in this query
    forall result. Script result -> Secret [Text]
arguments :: Log.Secret [Text]
  }
  deriving (Script result -> Script result -> Bool
(Script result -> Script result -> Bool)
-> (Script result -> Script result -> Bool) -> Eq (Script result)
forall result. Script result -> Script result -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall result. Script result -> Script result -> Bool
== :: Script result -> Script result -> Bool
$c/= :: forall result. Script result -> Script result -> Bool
/= :: Script result -> Script result -> Bool
Eq, Int -> Script result -> ShowS
[Script result] -> ShowS
Script result -> List Char
(Int -> Script result -> ShowS)
-> (Script result -> List Char)
-> ([Script result] -> ShowS)
-> Show (Script result)
forall result. Int -> Script result -> ShowS
forall result. [Script result] -> ShowS
forall result. Script result -> List Char
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall result. Int -> Script result -> ShowS
showsPrec :: Int -> Script result -> ShowS
$cshow :: forall result. Script result -> List Char
show :: Script result -> List Char
$cshowList :: forall result. [Script result] -> ShowS
showList :: [Script result] -> ShowS
Show)

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

-- | This instance is marked as INCOHERENT so that it will be chosen if possible in the overlapping case
instance {-# INCOHERENT #-} HasScriptParam ScriptParam where
  getScriptParam :: ScriptParam -> ScriptParam
getScriptParam = ScriptParam -> ScriptParam
forall a. a -> a
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 hav UndecidableInstances enabled.
instance
  GHC.TypeLits.TypeError ('GHC.TypeLits.Text "[script| ${..} ] interpolation only supports Key or Literal inputs.") =>
  HasScriptParam x
  where
  getScriptParam :: x -> ScriptParam
getScriptParam = List Char -> x -> ScriptParam
forall a. HasCallStack => List Char -> a
Prelude.error List Char
"This won't ever hit bc this generates a compile-time error."

-- | 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 :: QuasiQuoter
script =
  QQ.QuasiQuoter
    { quoteExp :: List Char -> Q Exp
QQ.quoteExp = List Char -> Q Exp
qqScript,
      quoteType :: List Char -> Q Type
QQ.quoteType = List Char -> List Char -> Q Type
forall a. HasCallStack => List Char -> a
Prelude.error List Char
"script not supported in types",
      quotePat :: List Char -> Q Pat
QQ.quotePat = List Char -> List Char -> Q Pat
forall a. HasCallStack => List Char -> a
Prelude.error List Char
"script not supported in patterns",
      quoteDec :: List Char -> Q [Dec]
QQ.quoteDec = List Char -> List Char -> Q [Dec]
forall a. HasCallStack => List Char -> a
Prelude.error List Char
"script not supported in declarations"
    }

qqScript :: Prelude.String -> TH.Q TH.Exp
qqScript :: List Char -> Q Exp
qqScript List Char
scriptWithVars = do
  let quotedScript :: Text
quotedScript = List Char -> Text
Text.fromList List Char
scriptWithVars
  let parseResult :: Either (ParseErrorBundle Text Void) (List Tokens)
parseResult = Parsec Void Text (List Tokens)
-> List Char
-> Text
-> Either (ParseErrorBundle Text Void) (List Tokens)
forall e s a.
Parsec e s a -> List Char -> s -> Either (ParseErrorBundle s e) a
P.parse Parsec Void Text (List Tokens)
parser List Char
"" Text
quotedScript
  case Either (ParseErrorBundle Text Void) (List Tokens)
parseResult of
    Left ParseErrorBundle Text Void
err -> List Char -> Q Exp
forall a. HasCallStack => List Char -> a
Prelude.error (List Char -> Q Exp) -> List Char -> Q Exp
forall a b. (a -> b) -> a -> b
<| List Char
"Failed to parse script: " List Char -> ShowS
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ ParseErrorBundle Text Void -> List Char
forall s e.
(VisualStream s, TraversableStream s, ShowErrorComponent e) =>
ParseErrorBundle s e -> List Char
P.errorBundlePretty ParseErrorBundle Text Void
err
    Right List Tokens
tokens -> do
      Exp
paramsExp <-
        List Tokens
tokens
          List Tokens -> (List Tokens -> Q [Exp]) -> Q [Exp]
forall a b. a -> (a -> b) -> b
|> (Tokens -> Q Exp) -> List Tokens -> Q [Exp]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
Control.Monad.mapM Tokens -> Q Exp
toEvaluatedToken
          Q [Exp] -> (Q [Exp] -> Q Exp) -> Q Exp
forall a b. a -> (a -> b) -> b
|> ([Exp] -> Exp) -> Q [Exp] -> Q Exp
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map [Exp] -> Exp
TH.ListE
      Exp
quotedScriptExp <- [|quotedScript|]
      Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
<| (Name -> Exp
TH.VarE 'scriptFromEvaluatedTokens) Exp -> Exp -> Exp
`TH.AppE` Exp
quotedScriptExp Exp -> Exp -> Exp
`TH.AppE` Exp
paramsExp

----------------------------
-- Script template compile-time evaluation
----------------------------

data EvaluatedToken
  = EvaluatedText Text
  | EvaluatedVariable EvaluatedParam
  deriving (Int -> EvaluatedToken -> ShowS
[EvaluatedToken] -> ShowS
EvaluatedToken -> List Char
(Int -> EvaluatedToken -> ShowS)
-> (EvaluatedToken -> List Char)
-> ([EvaluatedToken] -> ShowS)
-> Show EvaluatedToken
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvaluatedToken -> ShowS
showsPrec :: Int -> EvaluatedToken -> ShowS
$cshow :: EvaluatedToken -> List Char
show :: EvaluatedToken -> List Char
$cshowList :: [EvaluatedToken] -> ShowS
showList :: [EvaluatedToken] -> ShowS
Show, EvaluatedToken -> EvaluatedToken -> Bool
(EvaluatedToken -> EvaluatedToken -> Bool)
-> (EvaluatedToken -> EvaluatedToken -> Bool) -> Eq EvaluatedToken
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EvaluatedToken -> EvaluatedToken -> Bool
== :: EvaluatedToken -> EvaluatedToken -> Bool
$c/= :: EvaluatedToken -> EvaluatedToken -> Bool
/= :: EvaluatedToken -> EvaluatedToken -> Bool
Eq)

data EvaluatedParam = EvaluatedParam
  { EvaluatedParam -> ParamKind
kind :: ParamKind,
    EvaluatedParam -> Text
value :: Text
  }
  deriving (EvaluatedParam -> EvaluatedParam -> Bool
(EvaluatedParam -> EvaluatedParam -> Bool)
-> (EvaluatedParam -> EvaluatedParam -> Bool) -> Eq EvaluatedParam
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: EvaluatedParam -> EvaluatedParam -> Bool
== :: EvaluatedParam -> EvaluatedParam -> Bool
$c/= :: EvaluatedParam -> EvaluatedParam -> Bool
/= :: EvaluatedParam -> EvaluatedParam -> Bool
Eq, Int -> EvaluatedParam -> ShowS
[EvaluatedParam] -> ShowS
EvaluatedParam -> List Char
(Int -> EvaluatedParam -> ShowS)
-> (EvaluatedParam -> List Char)
-> ([EvaluatedParam] -> ShowS)
-> Show EvaluatedParam
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> EvaluatedParam -> ShowS
showsPrec :: Int -> EvaluatedParam -> ShowS
$cshow :: EvaluatedParam -> List Char
show :: EvaluatedParam -> List Char
$cshowList :: [EvaluatedParam] -> ShowS
showList :: [EvaluatedParam] -> ShowS
Show)

data ParamKind = RedisKey | ArbitraryValue
  deriving (ParamKind -> ParamKind -> Bool
(ParamKind -> ParamKind -> Bool)
-> (ParamKind -> ParamKind -> Bool) -> Eq ParamKind
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ParamKind -> ParamKind -> Bool
== :: ParamKind -> ParamKind -> Bool
$c/= :: ParamKind -> ParamKind -> Bool
/= :: ParamKind -> ParamKind -> Bool
Eq, Int -> ParamKind -> ShowS
[ParamKind] -> ShowS
ParamKind -> List Char
(Int -> ParamKind -> ShowS)
-> (ParamKind -> List Char)
-> ([ParamKind] -> ShowS)
-> Show ParamKind
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ParamKind -> ShowS
showsPrec :: Int -> ParamKind -> ShowS
$cshow :: ParamKind -> List Char
show :: ParamKind -> List Char
$cshowList :: [ParamKind] -> ShowS
showList :: [ParamKind] -> ShowS
Show)

toEvaluatedToken :: Tokens -> TH.Q TH.Exp
toEvaluatedToken :: Tokens -> Q Exp
toEvaluatedToken Tokens
token =
  case Tokens
token of
    ScriptText Text
text -> [|EvaluatedText text|]
    ScriptVariable Text
var -> Exp -> Q Exp
forall a. a -> Q a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Exp -> Q Exp) -> Exp -> Q Exp
forall a b. (a -> b) -> a -> b
<| (Name -> Exp
TH.VarE 'evaluateScriptParam) Exp -> Exp -> Exp
`TH.AppE` (Text -> Exp
varToExp Text
var)

evaluateScriptParam :: HasScriptParam a => a -> EvaluatedToken
evaluateScriptParam :: forall a. HasScriptParam a => a -> EvaluatedToken
evaluateScriptParam a
scriptParam =
  case a -> ScriptParam
forall a. HasScriptParam a => a -> ScriptParam
getScriptParam a
scriptParam of
    Key a
a ->
      EvaluatedParam -> EvaluatedToken
EvaluatedVariable
        (EvaluatedParam -> EvaluatedToken)
-> EvaluatedParam -> EvaluatedToken
forall a b. (a -> b) -> a -> b
<| EvaluatedParam
          { kind :: ParamKind
kind = ParamKind
RedisKey,
            value :: Text
value = Text -> Text
unquoteString (a -> Text
forall a. Show a => a -> Text
Debug.toString a
a)
          }
    Literal a
a ->
      EvaluatedParam -> EvaluatedToken
EvaluatedVariable
        (EvaluatedParam -> EvaluatedToken)
-> EvaluatedParam -> EvaluatedToken
forall a b. (a -> b) -> a -> b
<| EvaluatedParam
          { kind :: ParamKind
kind = ParamKind
ArbitraryValue,
            value :: Text
value = Text -> Text
unquoteString (a -> Text
forall a. Show a => a -> Text
Debug.toString a
a)
          }

-- | Remove leading and trailing quotes from a string
unquoteString :: Text -> Text
unquoteString :: Text -> Text
unquoteString Text
str =
  Text
str
    Text -> (Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> Text -> Text -> Maybe Text
Data.Text.stripPrefix Text
"\""
    Maybe Text -> (Maybe Text -> Maybe Text) -> Maybe Text
forall a b. a -> (a -> b) -> b
|> (Text -> Maybe Text) -> Maybe Text -> Maybe Text
forall a b. (a -> Maybe b) -> Maybe a -> Maybe b
Maybe.andThen (Text -> Text -> Maybe Text
Data.Text.stripSuffix Text
"\"")
    Maybe Text -> (Maybe Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
Maybe.withDefault Text
str

varToExp :: Text -> TH.Exp
varToExp :: Text -> Exp
varToExp Text
var =
  case List Char -> Either (List Char) Exp
parseExp (Text -> List Char
Text.toList Text
var) of
    Left List Char
err -> List Char -> Exp
forall a. HasCallStack => List Char -> a
Prelude.error (List Char -> Exp) -> List Char -> Exp
forall a b. (a -> b) -> a -> b
<| List Char
"Failed to parse variable: " List Char -> ShowS
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ List Char
err
    Right Exp
exp -> Exp
exp

-----------------------------
-- Script record construction
-----------------------------

data ScriptBuilder = ScriptBuilder
  { ScriptBuilder -> Text
buffer :: Text,
    ScriptBuilder -> Int
keyIdx :: Int,
    ScriptBuilder -> [Text]
keyList :: List Text,
    ScriptBuilder -> Int
argIdx :: Int,
    ScriptBuilder -> [Text]
argList :: List Text
  }

scriptFromEvaluatedTokens :: Text -> [EvaluatedToken] -> Script a
scriptFromEvaluatedTokens :: forall a. Text -> [EvaluatedToken] -> Script a
scriptFromEvaluatedTokens Text
quasiQuotedString' [EvaluatedToken]
evaluatedTokens =
  let keyTpl :: Int -> Text
keyTpl Int
n = Text
"KEYS[" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
n Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"]"
      argTpl :: Int -> Text
argTpl Int
n = Text
"ARGV[" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Int -> Text
Text.fromInt Int
n Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"]"
      script' :: ScriptBuilder
script' =
        (EvaluatedToken -> ScriptBuilder -> ScriptBuilder)
-> ScriptBuilder -> [EvaluatedToken] -> ScriptBuilder
forall a b. (a -> b -> b) -> b -> List a -> b
List.foldl
          ( \EvaluatedToken
token scriptBuilder :: ScriptBuilder
scriptBuilder@(ScriptBuilder {Text
buffer :: ScriptBuilder -> Text
buffer :: Text
buffer, Int
keyIdx :: ScriptBuilder -> Int
keyIdx :: Int
keyIdx, [Text]
keyList :: ScriptBuilder -> [Text]
keyList :: [Text]
keyList, Int
argIdx :: ScriptBuilder -> Int
argIdx :: Int
argIdx, [Text]
argList :: ScriptBuilder -> [Text]
argList :: [Text]
argList}) ->
              case EvaluatedToken
token of
                EvaluatedText Text
text -> ScriptBuilder
scriptBuilder {buffer = buffer ++ text}
                EvaluatedVariable EvaluatedParam
var ->
                  case EvaluatedParam -> ParamKind
kind EvaluatedParam
var of
                    ParamKind
RedisKey ->
                      ScriptBuilder
scriptBuilder
                        { buffer = buffer ++ keyTpl (keyIdx + 1),
                          keyIdx = keyIdx + 1,
                          keyList = value var : keyList
                        }
                    ParamKind
ArbitraryValue ->
                      ScriptBuilder
scriptBuilder
                        { buffer = buffer ++ argTpl (argIdx + 1),
                          argIdx = argIdx + 1,
                          argList = value var : argList
                        }
          )
          (Text -> Int -> [Text] -> Int -> [Text] -> ScriptBuilder
ScriptBuilder Text
"" Int
0 [] Int
0 [])
          [EvaluatedToken]
evaluatedTokens
   in Script
        { luaScript :: Text
luaScript = ScriptBuilder -> Text
buffer ScriptBuilder
script',
          quasiQuotedString :: Text
quasiQuotedString = Text
quasiQuotedString',
          keys :: [Text]
keys = [Text] -> [Text]
forall a. List a -> List a
List.reverse (ScriptBuilder -> [Text]
keyList ScriptBuilder
script'),
          arguments :: Secret [Text]
arguments = [Text] -> Secret [Text]
forall a. a -> Secret a
Log.mkSecret ([Text] -> [Text]
forall a. List a -> List a
List.reverse (ScriptBuilder -> [Text]
argList ScriptBuilder
script'))
        }

-----------------------------
-- Quasi-quoted text parser
-----------------------------

-- | Tokens after parsing quasi-quoted text
data Tokens
  = ScriptText Text
  | ScriptVariable Text
  deriving (Int -> Tokens -> ShowS
List Tokens -> ShowS
Tokens -> List Char
(Int -> Tokens -> ShowS)
-> (Tokens -> List Char) -> (List Tokens -> ShowS) -> Show Tokens
forall a.
(Int -> a -> ShowS) -> (a -> List Char) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Tokens -> ShowS
showsPrec :: Int -> Tokens -> ShowS
$cshow :: Tokens -> List Char
show :: Tokens -> List Char
$cshowList :: List Tokens -> ShowS
showList :: List Tokens -> ShowS
Show, Tokens -> Tokens -> Bool
(Tokens -> Tokens -> Bool)
-> (Tokens -> Tokens -> Bool) -> Eq Tokens
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Tokens -> Tokens -> Bool
== :: Tokens -> Tokens -> Bool
$c/= :: Tokens -> Tokens -> Bool
/= :: Tokens -> Tokens -> Bool
Eq)

type Parser = P.Parsec Void Text

parser :: Parser (List Tokens)
parser :: Parsec Void Text (List Tokens)
parser = do
  (ParsecT Void Text Identity Tokens -> Parsec Void Text (List Tokens)
forall (m :: * -> *) a. MonadPlus m => m a -> m [a]
P.some (ParsecT Void Text Identity Tokens
parseText ParsecT Void Text Identity Tokens
-> ParsecT Void Text Identity Tokens
-> ParsecT Void Text Identity Tokens
forall a.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Alternative f => f a -> f a -> f a
<|> ParsecT Void Text Identity Tokens
parseVariable))
    Parsec Void Text (List Tokens)
-> ParsecT Void Text Identity () -> Parsec Void Text (List Tokens)
forall a b.
ParsecT Void Text Identity a
-> ParsecT Void Text Identity b -> ParsecT Void Text Identity a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* ParsecT Void Text Identity ()
forall e s (m :: * -> *). MonadParsec e s m => m ()
P.eof

parseText :: Parser Tokens
parseText :: ParsecT Void Text Identity Tokens
parseText = do
  Text
text <- Maybe (List Char)
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe (List Char) -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (List Char -> Maybe (List Char)
forall a. a -> Maybe a
Just List Char
"some plain text") (Token Text -> Token Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
Token Text
'$')
  Tokens -> ParsecT Void Text Identity Tokens
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tokens -> ParsecT Void Text Identity Tokens)
-> Tokens -> ParsecT Void Text Identity Tokens
forall a b. (a -> b) -> a -> b
<| Text -> Tokens
ScriptText Text
text

parseVariable :: Parser Tokens
parseVariable :: ParsecT Void Text Identity Tokens
parseVariable = do
  Tokens Text
_ <- Tokens Text -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Tokens s -> m (Tokens s)
PC.string Tokens Text
"${"
  ()
_ <- ParsecT Void Text Identity ()
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
m ()
PC.space
  Text
name <- Maybe (List Char)
-> (Token Text -> Bool) -> ParsecT Void Text Identity (Tokens Text)
forall e s (m :: * -> *).
MonadParsec e s m =>
Maybe (List Char) -> (Token s -> Bool) -> m (Tokens s)
P.takeWhile1P (List Char -> Maybe (List Char)
forall a. a -> Maybe a
Just List Char
"anything but '$', '{' or '}' (no records, sorry)") (\Token Text
t -> Char
Token Text
t Char -> List Char -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Char
'$', Char
'{', Char
'}'])
  Char
_ <- Token Text -> ParsecT Void Text Identity (Token Text)
forall e s (m :: * -> *).
(MonadParsec e s m, Token s ~ Char) =>
Token s -> m (Token s)
PC.char Char
Token Text
'}'
  Tokens -> ParsecT Void Text Identity Tokens
forall a. a -> ParsecT Void Text Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tokens -> ParsecT Void Text Identity Tokens)
-> Tokens -> ParsecT Void Text Identity Tokens
forall a b. (a -> b) -> a -> b
<| Text -> Tokens
ScriptVariable (Text -> Tokens) -> Text -> Tokens
forall a b. (a -> b) -> a -> b
<| Text -> Text
Text.trim Text
name

---------------------------------------------
-- Helper functions for internal library use
---------------------------------------------

-- | EVALSHA hash numkeys [key [key ...]] [arg [arg ...]]
evalShaString :: Script a -> Text
evalShaString :: forall result. Script result -> Text
evalShaString script' :: Script a
script'@(Script {[Text]
keys :: forall result. Script result -> [Text]
keys :: [Text]
keys, Secret [Text]
arguments :: forall result. Script result -> Secret [Text]
arguments :: Secret [Text]
arguments}) =
  let keyCount :: Text
keyCount = [Text]
keys [Text] -> ([Text] -> Int) -> Int
forall a b. a -> (a -> b) -> b
|> [Text] -> Int
forall a. List a -> Int
List.length Int -> (Int -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Int -> Text
Text.fromInt
      keys' :: Text
keys' = [Text]
keys [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
Text.join Text
" "
      args' :: Text
args' = Secret [Text]
arguments Secret [Text] -> (Secret [Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> Secret [Text] -> [Text]
forall a. Secret a -> a
Log.unSecret [Text] -> ([Text] -> [Text]) -> [Text]
forall a b. a -> (a -> b) -> b
|> (Text -> Text) -> [Text] -> [Text]
forall a b. (a -> b) -> List a -> List b
List.map (\Text
_ -> Text
"***") [Text] -> ([Text] -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> Text -> [Text] -> Text
Text.join Text
" "
      hash :: Text
hash = Script a -> Text
forall result. Script result -> Text
luaScriptHash Script a
script'
   in Text
"EVALSHA " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
hash Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
" " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
keyCount Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
" " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
keys' Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
" " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
args'

-- | SCRIPT LOAD "return KEYS[1]"
scriptLoadString :: Script a -> Text
scriptLoadString :: forall result. Script result -> Text
scriptLoadString Script {Text
luaScript :: forall result. Script result -> Text
luaScript :: Text
luaScript} =
  Text
"SCRIPT LOAD \"" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
luaScript Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"\""

-- | 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 :: forall err a.
(Text -> Task err Text) -> Script a -> Task err (Script a)
mapKeys Text -> Task err Text
fn Script a
script' = do
  Script a -> [Text]
forall result. Script result -> [Text]
keys Script a
script'
    [Text] -> ([Text] -> List (Task err Text)) -> List (Task err Text)
forall a b. a -> (a -> b) -> b
|> (Text -> Task err Text) -> [Text] -> List (Task err Text)
forall a b. (a -> b) -> List a -> List b
List.map Text -> Task err Text
fn
    List (Task err Text)
-> (List (Task err Text) -> Task err [Text]) -> Task err [Text]
forall a b. a -> (a -> b) -> b
|> List (Task err Text) -> Task err [Text]
forall x a. List (Task x a) -> Task x (List a)
Task.sequence
    Task err [Text]
-> (Task err [Text] -> Task err (Script a)) -> Task err (Script a)
forall a b. a -> (a -> b) -> b
|> ([Text] -> Script a) -> Task err [Text] -> Task err (Script a)
forall a b x. (a -> b) -> Task x a -> Task x b
Task.map (\[Text]
keys' -> Script a
script' {keys = keys'})

luaScriptHash :: Script a -> Text
luaScriptHash :: forall result. Script result -> Text
luaScriptHash Script {Text
luaScript :: forall result. Script result -> Text
luaScript :: Text
luaScript} =
  Text
luaScript
    Text -> (Text -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> Text -> ByteString
Data.Text.Encoding.encodeUtf8
    ByteString -> (ByteString -> ByteString) -> ByteString
forall a b. a -> (a -> b) -> b
|> ByteString -> ByteString
Crypto.Hash.SHA1.hash
    ByteString -> (ByteString -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> ByteString -> Text
toHex

toHex :: Data.ByteString.ByteString -> Text
toHex :: ByteString -> Text
toHex ByteString
bytes =
  ByteString
bytes
    ByteString -> (ByteString -> [Word8]) -> [Word8]
forall a b. a -> (a -> b) -> b
|> ByteString -> [Word8]
Data.ByteString.unpack
    [Word8] -> ([Word8] -> List (List Char)) -> List (List Char)
forall a b. a -> (a -> b) -> b
|> (Word8 -> List Char) -> [Word8] -> List (List Char)
forall a b. (a -> b) -> List a -> List b
List.map (List Char -> Word8 -> List Char
forall r. PrintfType r => List Char -> r
Text.Printf.printf List Char
"%02x")
    List (List Char) -> (List (List Char) -> List Char) -> List Char
forall a b. a -> (a -> b) -> b
|> List (List Char) -> List Char
forall a. List (List a) -> List a
List.concat
    List Char -> (List Char -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> List Char -> Text
Text.fromList