{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE Rank2Types #-}

{-|

Redis DB snaplet.

-}

module Snap.Snaplet.RedisDB
    (RedisDB(..)
    , runRedisDB
    , redisConnection
    , redisDBInit
    , redisDBInitConf)

where

import Control.Lens
import Control.Monad.State

import Database.Redis hiding (String)
import Data.Configurator as C
import Data.Configurator.Types (Configured(..), Value(..))
import Data.Maybe
import Data.Ratio (numerator, denominator)
import qualified Data.Text as T

import Snap.Snaplet

-- | Snaplet's state data type
newtype RedisDB = RedisDB
                  { RedisDB -> Connection
_connection :: Connection -- ^ DB connection pool.
                  }

makeLenses ''RedisDB

newtype ConfiguredPortID = ConfiguredPortID { ConfiguredPortID -> PortID
unConfiguredPortID :: PortID }

-- | Instance to allow port to be either a path to a unix socket or a
-- port number.
instance Configured ConfiguredPortID where
  convert :: Value -> Maybe ConfiguredPortID
convert (Number Rational
r) | Rational -> Integer
forall a. Ratio a -> a
denominator Rational
r Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
1 = ConfiguredPortID -> Maybe ConfiguredPortID
forall a. a -> Maybe a
Just (ConfiguredPortID -> Maybe ConfiguredPortID)
-> ConfiguredPortID -> Maybe ConfiguredPortID
forall a b. (a -> b) -> a -> b
$ PortID -> ConfiguredPortID
ConfiguredPortID (PortID -> ConfiguredPortID) -> PortID -> ConfiguredPortID
forall a b. (a -> b) -> a -> b
$ PortNumber -> PortID
PortNumber (PortNumber -> PortID) -> PortNumber -> PortID
forall a b. (a -> b) -> a -> b
$ Integer -> PortNumber
forall a. Num a => Integer -> a
fromInteger (Integer -> PortNumber) -> Integer -> PortNumber
forall a b. (a -> b) -> a -> b
$ Rational -> Integer
forall a. Ratio a -> a
numerator Rational
r
  convert (String Text
s) = ConfiguredPortID -> Maybe ConfiguredPortID
forall a. a -> Maybe a
Just (ConfiguredPortID -> Maybe ConfiguredPortID)
-> ConfiguredPortID -> Maybe ConfiguredPortID
forall a b. (a -> b) -> a -> b
$ PortID -> ConfiguredPortID
ConfiguredPortID (PortID -> ConfiguredPortID) -> PortID -> ConfiguredPortID
forall a b. (a -> b) -> a -> b
$ String -> PortID
UnixSocket (String -> PortID) -> String -> PortID
forall a b. (a -> b) -> a -> b
$ Text -> String
T.unpack Text
s
  convert Value
_ = Maybe ConfiguredPortID
forall a. Maybe a
Nothing

-- | A lens to retrieve the connection to Redis from the 'RedisDB'
-- wrapper.
redisConnection :: Lens' RedisDB Connection
redisConnection :: (Connection -> f Connection) -> RedisDB -> f RedisDB
redisConnection = (Connection -> f Connection) -> RedisDB -> f RedisDB
Iso' RedisDB Connection
connection

-- | Perform action using Redis connection from RedisDB snaplet pool
-- (wrapper for 'Database.Redis.runRedis').
--
-- > runRedisDB database $ do
-- >   set "hello" "world"
runRedisDB :: (MonadIO m, MonadState app m) =>
               Lens' app (Snaplet RedisDB) -> Redis a -> m a
runRedisDB :: Lens' app (Snaplet RedisDB) -> Redis a -> m a
runRedisDB Lens' app (Snaplet RedisDB)
snaplet Redis a
action = do
  Connection
c <- (app -> Connection) -> m Connection
forall s (m :: * -> *) a. MonadState s m => (s -> a) -> m a
gets ((app -> Connection) -> m Connection)
-> (app -> Connection) -> m Connection
forall a b. (a -> b) -> a -> b
$ Getting Connection app Connection -> app -> Connection
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view ((Snaplet RedisDB -> Const Connection (Snaplet RedisDB))
-> app -> Const Connection app
Lens' app (Snaplet RedisDB)
snaplet ((Snaplet RedisDB -> Const Connection (Snaplet RedisDB))
 -> app -> Const Connection app)
-> ((Connection -> Const Connection Connection)
    -> Snaplet RedisDB -> Const Connection (Snaplet RedisDB))
-> Getting Connection app Connection
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RedisDB -> Const Connection RedisDB)
-> Snaplet RedisDB -> Const Connection (Snaplet RedisDB)
forall s. Lens' (Snaplet s) s
snapletValue ((RedisDB -> Const Connection RedisDB)
 -> Snaplet RedisDB -> Const Connection (Snaplet RedisDB))
-> ((Connection -> Const Connection Connection)
    -> RedisDB -> Const Connection RedisDB)
-> (Connection -> Const Connection Connection)
-> Snaplet RedisDB
-> Const Connection (Snaplet RedisDB)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Connection -> Const Connection Connection)
-> RedisDB -> Const Connection RedisDB
Iso' RedisDB Connection
connection)
  IO a -> m a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> m a) -> IO a -> m a
forall a b. (a -> b) -> a -> b
$ Connection -> Redis a -> IO a
forall a. Connection -> Redis a -> IO a
runRedis Connection
c Redis a
action


-- | Make RedisDB snaplet and initialize database connection from
-- snaplet config file. Options are read from the "redis" section of
-- the application config (e.g. ./devel.cfg) or from the main section
-- of the Redis snaplet config (e.g. ./snaplets/redis/devel.cfg).
--
-- Every field is optional and defaults to defaultConnectInfo values.
--
-- > redis {
-- >     host = "192.168.0.42"
-- >     port = 31415
-- >     auth = "i am so secret"
-- >     max_connections = 1
-- >     max_idle_time = 0.5
-- > }
--
-- Alternately, you can configure it to connect via a socket, for example:
--
-- > redis {
-- >     port = "/var/run/redis/redis.sock"
-- > }
--
-- This corresponds to setting:
--
-- > connectPort = UnixSocket "/var/run/redis/redis.sock"
--
-- in `ConnectInfo`. In this case, the host setting, if anything, is
-- ignored.
--
--
-- > appInit :: SnapletInit MyApp MyApp
-- > appInit = makeSnaplet "app" "App with Redis child snaplet" Nothing $
-- >           do
-- >             d <- nestSnaplet "redis" database redisDBInitConf
-- >             return $ MyApp d
redisDBInitConf :: SnapletInit b RedisDB
redisDBInitConf :: SnapletInit b RedisDB
redisDBInitConf = Text
-> Text
-> Maybe (IO String)
-> Initializer b RedisDB RedisDB
-> SnapletInit b RedisDB
forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"redis" Text
"Redis snaplet." Maybe (IO String)
forall a. Maybe a
Nothing (Initializer b RedisDB RedisDB -> SnapletInit b RedisDB)
-> Initializer b RedisDB RedisDB -> SnapletInit b RedisDB
forall a b. (a -> b) -> a -> b
$ do
    Config
config <- Initializer b RedisDB Config
forall (m :: * -> * -> * -> *) b v.
(Monad (m b v), MonadSnaplet m) =>
m b v Config
getSnapletUserConfig

    ConnectInfo
connInfo <- IO ConnectInfo -> Initializer b RedisDB ConnectInfo
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ConnectInfo -> Initializer b RedisDB ConnectInfo)
-> IO ConnectInfo -> Initializer b RedisDB ConnectInfo
forall a b. (a -> b) -> a -> b
$ do
        Maybe String
cHost <- Config -> Text -> IO (Maybe String)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"host"
        Maybe ConfiguredPortID
cPort <- Config -> Text -> IO (Maybe ConfiguredPortID)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"port"
        Maybe ByteString
cAuth <- Config -> Text -> IO (Maybe ByteString)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"auth"
        Maybe Int
cCons <- Config -> Text -> IO (Maybe Int)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"max_connections"
        Maybe Rational
cIdle <- Config -> Text -> IO (Maybe Rational)
forall a. Configured a => Config -> Text -> IO (Maybe a)
C.lookup Config
config Text
"max_idle_time"

        let def :: ConnectInfo
def = ConnectInfo
defaultConnectInfo
        ConnectInfo -> IO ConnectInfo
forall (m :: * -> *) a. Monad m => a -> m a
return (ConnectInfo -> IO ConnectInfo) -> ConnectInfo -> IO ConnectInfo
forall a b. (a -> b) -> a -> b
$ ConnectInfo
def { connectHost :: String
connectHost = String -> Maybe String -> String
forall a. a -> Maybe a -> a
fromMaybe (ConnectInfo -> String
connectHost ConnectInfo
def) Maybe String
cHost
                     , connectPort :: PortID
connectPort = PortID
-> (ConfiguredPortID -> PortID) -> Maybe ConfiguredPortID -> PortID
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectInfo -> PortID
connectPort ConnectInfo
def)
                                     ConfiguredPortID -> PortID
unConfiguredPortID Maybe ConfiguredPortID
cPort
                     , connectAuth :: Maybe ByteString
connectAuth = Maybe ByteString
cAuth
                     , connectMaxConnections :: Int
connectMaxConnections =
                       Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe (ConnectInfo -> Int
connectMaxConnections ConnectInfo
def) Maybe Int
cCons
                     , connectMaxIdleTime :: NominalDiffTime
connectMaxIdleTime =
                       NominalDiffTime
-> (Rational -> NominalDiffTime)
-> Maybe Rational
-> NominalDiffTime
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (ConnectInfo -> NominalDiffTime
connectMaxIdleTime ConnectInfo
def) Rational -> NominalDiffTime
forall a. Fractional a => Rational -> a
fromRational Maybe Rational
cIdle
                     }

    Connection
conn <- IO Connection -> Initializer b RedisDB Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> Initializer b RedisDB Connection)
-> IO Connection -> Initializer b RedisDB Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> IO Connection
connect ConnectInfo
connInfo
    RedisDB -> Initializer b RedisDB RedisDB
forall (m :: * -> *) a. Monad m => a -> m a
return (RedisDB -> Initializer b RedisDB RedisDB)
-> RedisDB -> Initializer b RedisDB RedisDB
forall a b. (a -> b) -> a -> b
$ Connection -> RedisDB
RedisDB Connection
conn

------------------------------------------------------------------------------
-- | Make RedisDB snaplet and initialize database connection.
--
-- > appInit :: SnapletInit MyApp MyApp
-- > appInit = makeSnaplet "app" "App with Redis child snaplet" Nothing $
-- >           do
-- >             d <- nestSnaplet "" database $
-- >                                 redisDBInit defaultConnectInfo
-- >             return $ MyApp d
redisDBInit :: ConnectInfo -- ^ Information for connnecting to a Redis server.
            -> SnapletInit b RedisDB
redisDBInit :: ConnectInfo -> SnapletInit b RedisDB
redisDBInit ConnectInfo
connInfo =
    Text
-> Text
-> Maybe (IO String)
-> Initializer b RedisDB RedisDB
-> SnapletInit b RedisDB
forall b v.
Text
-> Text
-> Maybe (IO String)
-> Initializer b v v
-> SnapletInit b v
makeSnaplet Text
"snaplet-redis" Text
"Redis snaplet." Maybe (IO String)
forall a. Maybe a
Nothing (Initializer b RedisDB RedisDB -> SnapletInit b RedisDB)
-> Initializer b RedisDB RedisDB -> SnapletInit b RedisDB
forall a b. (a -> b) -> a -> b
$ do
      Connection
conn <- IO Connection -> Initializer b RedisDB Connection
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Connection -> Initializer b RedisDB Connection)
-> IO Connection -> Initializer b RedisDB Connection
forall a b. (a -> b) -> a -> b
$ ConnectInfo -> IO Connection
connect ConnectInfo
connInfo
      RedisDB -> Initializer b RedisDB RedisDB
forall (m :: * -> *) a. Monad m => a -> m a
return (RedisDB -> Initializer b RedisDB RedisDB)
-> RedisDB -> Initializer b RedisDB RedisDB
forall a b. (a -> b) -> a -> b
$ Connection -> RedisDB
RedisDB Connection
conn