module Redis.Settings
  ( Settings (..),
    ClusterMode (..),
    DefaultExpiry (..),
    QueryTimeout (..),
    MaxKeySize (..),
    decoder,
    decoderWithEnvVarPrefix,
    decoderWithCustomConnectionString,
  )
where

import qualified Data.List.NonEmpty as NonEmpty
import Data.Text.Encoding (encodeUtf8)
import Database.Redis hiding (Ok)
import qualified Environment
import qualified Text
import qualified Text.URI as URI
import Prelude (Either (Left, Right), foldr, fromIntegral, id, pure)

data ClusterMode = Cluster | NotCluster
  deriving (Int -> ClusterMode -> ShowS
[ClusterMode] -> ShowS
ClusterMode -> String
(Int -> ClusterMode -> ShowS)
-> (ClusterMode -> String)
-> ([ClusterMode] -> ShowS)
-> Show ClusterMode
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ClusterMode -> ShowS
showsPrec :: Int -> ClusterMode -> ShowS
$cshow :: ClusterMode -> String
show :: ClusterMode -> String
$cshowList :: [ClusterMode] -> ShowS
showList :: [ClusterMode] -> ShowS
Show)

-- | Settings required to initiate a redis connection.
data Settings = Settings
  { -- | Full redis connection string.
    --
    -- Default env var name is REDIS_CONNECTION_STRING
    -- default is "redis://localhost:6379"
    Settings -> ConnectInfo
connectionInfo :: ConnectInfo,
    -- | Set to 1 for cluster, everything else is not.
    --
    -- Default env var name is REDIS_CLUSTER
    -- Default is 0
    Settings -> ClusterMode
clusterMode :: ClusterMode,
    -- | Set a default amount of seconds after which all keys touched by this
    -- handler will expire. The expire time of a key is reset every time it is
    -- read or written. A value of 0 means no default expiry.
    --
    -- Default env var name is REDIS_DEFAULT_EXPIRY_SECONDS
    -- default is 0
    Settings -> DefaultExpiry
defaultExpiry :: DefaultExpiry,
    -- | 0 means no timeout, every other value is a timeout in milliseconds.
    --
    -- Default env var name is REDIS_QUERY_TIMEOUT_MILLISECONDS
    -- default is 1000
    Settings -> QueryTimeout
queryTimeout :: QueryTimeout,
    Settings -> MaxKeySize
maxKeySize :: MaxKeySize
  }
  deriving (Int -> Settings -> ShowS
[Settings] -> ShowS
Settings -> String
(Int -> Settings -> ShowS)
-> (Settings -> String) -> ([Settings] -> ShowS) -> Show Settings
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Settings -> ShowS
showsPrec :: Int -> Settings -> ShowS
$cshow :: Settings -> String
show :: Settings -> String
$cshowList :: [Settings] -> ShowS
showList :: [Settings] -> ShowS
Show)

data MaxKeySize = NoMaxKeySize | MaxKeySize Int
  deriving (Int -> MaxKeySize -> ShowS
[MaxKeySize] -> ShowS
MaxKeySize -> String
(Int -> MaxKeySize -> ShowS)
-> (MaxKeySize -> String)
-> ([MaxKeySize] -> ShowS)
-> Show MaxKeySize
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> MaxKeySize -> ShowS
showsPrec :: Int -> MaxKeySize -> ShowS
$cshow :: MaxKeySize -> String
show :: MaxKeySize -> String
$cshowList :: [MaxKeySize] -> ShowS
showList :: [MaxKeySize] -> ShowS
Show)

data DefaultExpiry = NoDefaultExpiry | ExpireKeysAfterSeconds Int
  deriving (Int -> DefaultExpiry -> ShowS
[DefaultExpiry] -> ShowS
DefaultExpiry -> String
(Int -> DefaultExpiry -> ShowS)
-> (DefaultExpiry -> String)
-> ([DefaultExpiry] -> ShowS)
-> Show DefaultExpiry
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> DefaultExpiry -> ShowS
showsPrec :: Int -> DefaultExpiry -> ShowS
$cshow :: DefaultExpiry -> String
show :: DefaultExpiry -> String
$cshowList :: [DefaultExpiry] -> ShowS
showList :: [DefaultExpiry] -> ShowS
Show)

data QueryTimeout = NoQueryTimeout | TimeoutQueryAfterMilliseconds Int
  deriving (Int -> QueryTimeout -> ShowS
[QueryTimeout] -> ShowS
QueryTimeout -> String
(Int -> QueryTimeout -> ShowS)
-> (QueryTimeout -> String)
-> ([QueryTimeout] -> ShowS)
-> Show QueryTimeout
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> QueryTimeout -> ShowS
showsPrec :: Int -> QueryTimeout -> ShowS
$cshow :: QueryTimeout -> String
show :: QueryTimeout -> String
$cshowList :: [QueryTimeout] -> ShowS
showList :: [QueryTimeout] -> ShowS
Show)

-- | decodes Settings from environmental variables
decoder :: Environment.Decoder Settings
decoder :: Decoder Settings
decoder =
  Text -> Decoder Settings
decoderWithEnvVarPrefix Text
""

-- | decodes Settings from environmental variables with custom connection string
decoderWithCustomConnectionString :: Text -> Environment.Decoder Settings
decoderWithCustomConnectionString :: Text -> Decoder Settings
decoderWithCustomConnectionString Text
connectionStringEnvVar =
  (ConnectInfo
 -> ClusterMode
 -> DefaultExpiry
 -> QueryTimeout
 -> MaxKeySize
 -> Settings)
-> Decoder ConnectInfo
-> Decoder ClusterMode
-> Decoder DefaultExpiry
-> Decoder QueryTimeout
-> Decoder MaxKeySize
-> Decoder Settings
forall (m :: * -> *) a b c d e value.
Applicative m =>
(a -> b -> c -> d -> e -> value)
-> m a -> m b -> m c -> m d -> m e -> m value
map5
    ConnectInfo
-> ClusterMode
-> DefaultExpiry
-> QueryTimeout
-> MaxKeySize
-> Settings
Settings
    (Text -> Decoder ConnectInfo
decoderConnectInfo Text
connectionStringEnvVar)
    (Text -> Decoder ClusterMode
decoderClusterMode Text
"")
    (Text -> Decoder DefaultExpiry
decoderDefaultExpiry Text
"")
    (Text -> Decoder QueryTimeout
decoderQueryTimeout Text
"")
    (Text -> Decoder MaxKeySize
decoderMaxKeySize Text
"")

-- | decodes Settings from environmental variables prefixed with a Text
-- >>> decoderWithEnvVarPrefix "WORKER_"
decoderWithEnvVarPrefix :: Text -> Environment.Decoder Settings
decoderWithEnvVarPrefix :: Text -> Decoder Settings
decoderWithEnvVarPrefix Text
prefix =
  (ConnectInfo
 -> ClusterMode
 -> DefaultExpiry
 -> QueryTimeout
 -> MaxKeySize
 -> Settings)
-> Decoder ConnectInfo
-> Decoder ClusterMode
-> Decoder DefaultExpiry
-> Decoder QueryTimeout
-> Decoder MaxKeySize
-> Decoder Settings
forall (m :: * -> *) a b c d e value.
Applicative m =>
(a -> b -> c -> d -> e -> value)
-> m a -> m b -> m c -> m d -> m e -> m value
map5
    ConnectInfo
-> ClusterMode
-> DefaultExpiry
-> QueryTimeout
-> MaxKeySize
-> Settings
Settings
    (Text -> Decoder ConnectInfo
decoderConnectInfo (Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"REDIS_CONNECTION_STRING"))
    (Text -> Decoder ClusterMode
decoderClusterMode Text
prefix)
    (Text -> Decoder DefaultExpiry
decoderDefaultExpiry Text
prefix)
    (Text -> Decoder QueryTimeout
decoderQueryTimeout Text
prefix)
    (Text -> Decoder MaxKeySize
decoderMaxKeySize Text
prefix)

decoderClusterMode :: Text -> Environment.Decoder ClusterMode
decoderClusterMode :: Text -> Decoder ClusterMode
decoderClusterMode Text
prefix =
  Variable -> Parser ClusterMode -> Decoder ClusterMode
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Environment.Variable
      { name :: Text
Environment.name = Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"REDIS_CLUSTER",
        description :: Text
Environment.description = Text
"Set to 1 for cluster, everything else is not",
        defaultValue :: Text
Environment.defaultValue = Text
"0"
      }
    ( Parser Text
-> (Text -> Result Text ClusterMode) -> Parser ClusterMode
forall a b. Parser a -> (a -> Result Text b) -> Parser b
Environment.custom
        Parser Text
Environment.text
        ( \Text
str ->
            if Text -> Text
Text.trim Text
str Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"1"
              then ClusterMode -> Result Text ClusterMode
forall error value. value -> Result error value
Ok ClusterMode
Cluster
              else ClusterMode -> Result Text ClusterMode
forall error value. value -> Result error value
Ok ClusterMode
NotCluster
        )
    )

decoderConnectInfo :: Text -> Environment.Decoder ConnectInfo
decoderConnectInfo :: Text -> Decoder ConnectInfo
decoderConnectInfo Text
envVarName =
  Variable -> Parser ConnectInfo -> Decoder ConnectInfo
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Environment.Variable
      { name :: Text
Environment.name = Text
envVarName,
        description :: Text
Environment.description = Text
"Full redis connection string",
        defaultValue :: Text
Environment.defaultValue = Text
"redis://localhost:6379"
      }
    ( Parser URI
-> (URI -> Result Text ConnectInfo) -> Parser ConnectInfo
forall a b. Parser a -> (a -> Result Text b) -> Parser b
Environment.custom
        Parser URI
Environment.uri
        ( \URI
uri ->
            case (RText 'Scheme -> Text) -> Maybe (RText 'Scheme) -> Maybe Text
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map RText 'Scheme -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText (URI -> Maybe (RText 'Scheme)
URI.uriScheme URI
uri) of
              Just Text
"redis" -> URI -> Result Text ConnectInfo
parseRedisSchemeURI URI
uri
              Just Text
"redis+unix" -> URI -> Result Text ConnectInfo
parseRedisSocketSchemeURI URI
uri
              Just Text
unrecognizedScheme -> Text -> Result Text ConnectInfo
forall error value. error -> Result error value
Err (Text
"Invalid URI scheme for connection string: " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
unrecognizedScheme)
              Maybe Text
Nothing -> Text -> Result Text ConnectInfo
forall error value. error -> Result error value
Err Text
"URI scheme missing from connection string"
        )
    )

parseRedisSchemeURI :: URI.URI -> Result Text ConnectInfo
parseRedisSchemeURI :: URI -> Result Text ConnectInfo
parseRedisSchemeURI URI
uri =
  case String -> Either String ConnectInfo
parseConnectInfo (URI -> String
URI.renderStr URI
uri) of
    Left String
parseError -> Text -> Result Text ConnectInfo
forall error value. error -> Result error value
Err (Text
"Invalid Redis connection string: " Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ String -> Text
Text.fromList String
parseError)
    Right ConnectInfo
info' -> ConnectInfo -> Result Text ConnectInfo
forall error value. value -> Result error value
Ok ConnectInfo
info'

parseRedisSocketSchemeURI :: URI.URI -> Result Text ConnectInfo
parseRedisSocketSchemeURI :: URI -> Result Text ConnectInfo
parseRedisSocketSchemeURI URI
uri =
  let uriPathTextFromURI :: Result Text Text
uriPathTextFromURI =
        case URI -> Maybe (Bool, NonEmpty (RText 'PathPiece))
URI.uriPath URI
uri of
          Maybe (Bool, NonEmpty (RText 'PathPiece))
Nothing -> Text -> Result Text Text
forall error value. error -> Result error value
Err Text
"URI path missing from connection string"
          Just (Bool
_, NonEmpty (RText 'PathPiece)
uriPathSegments) ->
            NonEmpty (RText 'PathPiece)
uriPathSegments
              NonEmpty (RText 'PathPiece)
-> (NonEmpty (RText 'PathPiece) -> NonEmpty Text) -> NonEmpty Text
forall a b. a -> (a -> b) -> b
|> (RText 'PathPiece -> Text)
-> NonEmpty (RText 'PathPiece) -> NonEmpty Text
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map RText 'PathPiece -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText
              NonEmpty Text -> (NonEmpty Text -> NonEmpty Text) -> NonEmpty Text
forall a b. a -> (a -> b) -> b
|> Text -> NonEmpty Text -> NonEmpty Text
forall a. a -> NonEmpty a -> NonEmpty a
NonEmpty.intersperse Text
"/"
              NonEmpty Text -> (NonEmpty Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> (Text -> Text -> Text) -> Text -> NonEmpty Text -> Text
forall a b. (a -> b -> b) -> b -> NonEmpty a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
(++) Text
""
              Text -> (Text -> Text) -> Text
forall a b. a -> (a -> b) -> b
|> (if URI -> Bool
URI.isPathAbsolute URI
uri then (Text
"/" Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++) else Text -> Text
forall a. a -> a
id)
              Text -> (Text -> Result Text Text) -> Result Text Text
forall a b. a -> (a -> b) -> b
|> Text -> Result Text Text
forall error value. value -> Result error value
Ok

      dbNumFromParams :: [QueryParam] -> Result error value
dbNumFromParams [QueryParam]
queryParams =
        case [QueryParam]
queryParams of
          [] -> value -> Result error value
forall error value. value -> Result error value
Ok value
0
          URI.QueryParam RText 'QueryKey
key RText 'QueryValue
value : [QueryParam]
rest ->
            if RText 'QueryKey -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'QueryKey
key Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
"db"
              then case Text -> Maybe Int64
Text.toInt (RText 'QueryValue -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'QueryValue
value) of
                Maybe Int64
Nothing -> error -> Result error value
forall error value. error -> Result error value
Err error
"Expected an integer for db in connection string"
                Just Int64
dbNum -> value -> Result error value
forall error value. value -> Result error value
Ok (Int64 -> value
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int64
dbNum)
              else [QueryParam] -> Result error value
dbNumFromParams [QueryParam]
rest
          QueryParam
_ : [QueryParam]
rest -> [QueryParam] -> Result error value
dbNumFromParams [QueryParam]
rest

      maybePasswordFromURI :: Maybe ByteString
maybePasswordFromURI =
        case URI -> Either Bool Authority
URI.uriAuthority URI
uri of
          Right (URI.Authority (Just (URI.UserInfo RText 'Username
_ (Just RText 'Password
passwordRText))) RText 'Host
_ Maybe Word
_) ->
            ByteString -> Maybe ByteString
forall a. a -> Maybe a
Just (Text -> ByteString
encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
<| RText 'Password -> Text
forall (l :: RTextLabel). RText l -> Text
URI.unRText RText 'Password
passwordRText)
          Either Bool Authority
_ -> Maybe ByteString
forall a. Maybe a
Nothing
   in do
        Text
uriPathText <- Result Text Text
uriPathTextFromURI
        Integer
dbNum <- [QueryParam] -> Result Text Integer
forall {value} {error}.
(Num value, IsString error) =>
[QueryParam] -> Result error value
dbNumFromParams (URI -> [QueryParam]
URI.uriQuery URI
uri)
        ConnectInfo -> Result Text ConnectInfo
forall a. a -> Result Text a
forall (f :: * -> *) a. Applicative f => a -> f a
pure
          (ConnectInfo -> Result Text ConnectInfo)
-> ConnectInfo -> Result Text ConnectInfo
forall a b. (a -> b) -> a -> b
<| ConnectInfo
defaultConnectInfo
            { connectPort = UnixSocket (Text.toList uriPathText),
              connectDatabase = dbNum,
              connectAuth = maybePasswordFromURI
            }

decoderDefaultExpiry :: Text -> Environment.Decoder DefaultExpiry
decoderDefaultExpiry :: Text -> Decoder DefaultExpiry
decoderDefaultExpiry Text
prefix =
  Variable -> Parser Int64 -> Decoder Int64
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Environment.Variable
      { name :: Text
Environment.name = Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"REDIS_DEFAULT_EXPIRY_SECONDS",
        description :: Text
Environment.description = Text
"Set a default amount of seconds after which all keys touched by this handler will expire. The expire time of a key is reset every time it is read or written. A value of 0 means no default expiry.",
        defaultValue :: Text
Environment.defaultValue = Text
"0"
      }
    Parser Int64
forall a. Integral a => Parser a
Environment.int
    Decoder Int64
-> (Decoder Int64 -> Decoder DefaultExpiry)
-> Decoder DefaultExpiry
forall a b. a -> (a -> b) -> b
|> (Int64 -> DefaultExpiry) -> Decoder Int64 -> Decoder DefaultExpiry
forall (m :: * -> *) a value.
Functor m =>
(a -> value) -> m a -> m value
map
      ( \Int64
secs ->
          if Int64
secs Int64 -> Int64 -> Bool
forall a. Eq a => a -> a -> Bool
== Int64
0
            then DefaultExpiry
NoDefaultExpiry
            else Int64 -> DefaultExpiry
ExpireKeysAfterSeconds Int64
secs
      )

decoderQueryTimeout :: Text -> Environment.Decoder QueryTimeout
decoderQueryTimeout :: Text -> Decoder QueryTimeout
decoderQueryTimeout Text
prefix =
  Variable -> Parser QueryTimeout -> Decoder QueryTimeout
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Environment.Variable
      { name :: Text
Environment.name = Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"REDIS_QUERY_TIMEOUT_MILLISECONDS",
        description :: Text
Environment.description = Text
"0 means no timeout, every other value is a timeout in milliseconds.",
        defaultValue :: Text
Environment.defaultValue = Text
"1000"
      }
    ( Parser Int64
-> (Int64 -> Result Text QueryTimeout) -> Parser QueryTimeout
forall a b. Parser a -> (a -> Result Text b) -> Parser b
Environment.custom
        Parser Int64
forall a. Integral a => Parser a
Environment.int
        ( \Int64
milliseconds ->
            if Int64
milliseconds Int64 -> Int64 -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
<= Int64
0
              then QueryTimeout -> Result Text QueryTimeout
forall error value. value -> Result error value
Ok QueryTimeout
NoQueryTimeout
              else QueryTimeout -> Result Text QueryTimeout
forall error value. value -> Result error value
Ok (Int64 -> QueryTimeout
TimeoutQueryAfterMilliseconds Int64
milliseconds)
        )
    )

decoderMaxKeySize :: Text -> Environment.Decoder MaxKeySize
decoderMaxKeySize :: Text -> Decoder MaxKeySize
decoderMaxKeySize Text
prefix =
  Variable -> Parser MaxKeySize -> Decoder MaxKeySize
forall a. Variable -> Parser a -> Decoder a
Environment.variable
    Environment.Variable
      { name :: Text
Environment.name = Text
prefix Text -> Text -> Text
forall appendable.
Semigroup appendable =>
appendable -> appendable -> appendable
++ Text
"REDIS_MAX_KEY_SIZE",
        description :: Text
Environment.description = Text
"0 means no max key size, every other value is a max key size.",
        defaultValue :: Text
Environment.defaultValue = Text
"0"
      }
    ( Parser Int64
-> (Int64 -> Result Text MaxKeySize) -> Parser MaxKeySize
forall a b. Parser a -> (a -> Result Text b) -> Parser b
Environment.custom
        Parser Int64
forall a. Integral a => Parser a
Environment.int
        ( \Int64
maxKeySize ->
            if Int64
maxKeySize Int64 -> Int64 -> Bool
forall comparable.
Ord comparable =>
comparable -> comparable -> Bool
<= Int64
0
              then MaxKeySize -> Result Text MaxKeySize
forall error value. value -> Result error value
Ok MaxKeySize
NoMaxKeySize
              else MaxKeySize -> Result Text MaxKeySize
forall error value. value -> Result error value
Ok (Int64 -> MaxKeySize
MaxKeySize Int64
maxKeySize)
        )
    )