{-# LANGUAGE DeriveAnyClass      #-}
{-# LANGUAGE DeriveGeneric       #-}
{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Hyperion.Database.KeyValMap where

import           Control.Lens                     (views)
import           Control.Monad.Catch              (MonadCatch)
import           Control.Monad.IO.Class           (MonadIO)
import           Control.Monad.Reader             (MonadReader)
import           Data.Aeson                       (FromJSON, ToJSON)
import qualified Data.Aeson                       as Aeson
import           Data.Binary                      (Binary)
import qualified Data.ByteString.Lazy             as LBS
import           Data.Data                        (Typeable)
import           Data.Text                        (Text)
import qualified Data.Text.Encoding               as T
import           Data.Time.Clock                  (UTCTime)
import qualified Database.SQLite.Simple           as Sql
import qualified Database.SQLite.Simple.FromField as Sql
import qualified Database.SQLite.Simple.Ok        as Sql
import qualified Database.SQLite.Simple.ToField   as Sql
import           GHC.Generics                     (Generic)
import           Hyperion.Database.HasDB
import           Prelude                          hiding (lookup)

-- * General comments
-- $
-- "Hyperion.Database.KeyValMap" provides various actions with Sqlite
-- DB using 'withConnection' from "Hyperion.Database.HasDB".
--
-- The DB contains entries for 'KeyValMap': given 'kvMapName' and a
-- key, DB can produce value or values for the key.  We think about
-- this as a map, i.e. there is a preferred value for each key for a
-- given 'KeyValMap', even if DB contains the key several times. This
-- is described below.
--
-- The keys and values are represented by JSON encoding of Haskell
-- values. "Data.Aeson" is used to perform encoding/decoding.  Thus,
-- the keys and the values should implement 'ToJSON'/'FromJSON'
-- appropriately.


-- * Convention on DB entries with the same key
-- $
-- The database table for a 'KeyValMap' can contain multiple entries
-- with the same key. In this case, the newest entry is the active
-- one. Older entries are always ignored. Thus, an update can be
-- achieved by inserting a new key val pair.
--
-- The reason for this choice is that newer programs should not modify
-- data associated with old programs. However, a new program may
-- lookup data from old programs. This convention allows one to change
-- the data that a new program sees without violating the above
-- constraint.


-- | Type for 'KeyValMap' holds the types of key and value, but only
-- contains 'kvMapName' the name of the map
newtype KeyValMap a b = KeyValMap { KeyValMap a b -> Text
kvMapName :: Text }
  deriving (KeyValMap a b -> KeyValMap a b -> Bool
(KeyValMap a b -> KeyValMap a b -> Bool)
-> (KeyValMap a b -> KeyValMap a b -> Bool) -> Eq (KeyValMap a b)
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
forall a b. KeyValMap a b -> KeyValMap a b -> Bool
/= :: KeyValMap a b -> KeyValMap a b -> Bool
$c/= :: forall a b. KeyValMap a b -> KeyValMap a b -> Bool
== :: KeyValMap a b -> KeyValMap a b -> Bool
$c== :: forall a b. KeyValMap a b -> KeyValMap a b -> Bool
Eq, Eq (KeyValMap a b)
Eq (KeyValMap a b)
-> (KeyValMap a b -> KeyValMap a b -> Ordering)
-> (KeyValMap a b -> KeyValMap a b -> Bool)
-> (KeyValMap a b -> KeyValMap a b -> Bool)
-> (KeyValMap a b -> KeyValMap a b -> Bool)
-> (KeyValMap a b -> KeyValMap a b -> Bool)
-> (KeyValMap a b -> KeyValMap a b -> KeyValMap a b)
-> (KeyValMap a b -> KeyValMap a b -> KeyValMap a b)
-> Ord (KeyValMap a b)
KeyValMap a b -> KeyValMap a b -> Bool
KeyValMap a b -> KeyValMap a b -> Ordering
KeyValMap a b -> KeyValMap a b -> KeyValMap a b
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a b. Eq (KeyValMap a b)
forall a b. KeyValMap a b -> KeyValMap a b -> Bool
forall a b. KeyValMap a b -> KeyValMap a b -> Ordering
forall a b. KeyValMap a b -> KeyValMap a b -> KeyValMap a b
min :: KeyValMap a b -> KeyValMap a b -> KeyValMap a b
$cmin :: forall a b. KeyValMap a b -> KeyValMap a b -> KeyValMap a b
max :: KeyValMap a b -> KeyValMap a b -> KeyValMap a b
$cmax :: forall a b. KeyValMap a b -> KeyValMap a b -> KeyValMap a b
>= :: KeyValMap a b -> KeyValMap a b -> Bool
$c>= :: forall a b. KeyValMap a b -> KeyValMap a b -> Bool
> :: KeyValMap a b -> KeyValMap a b -> Bool
$c> :: forall a b. KeyValMap a b -> KeyValMap a b -> Bool
<= :: KeyValMap a b -> KeyValMap a b -> Bool
$c<= :: forall a b. KeyValMap a b -> KeyValMap a b -> Bool
< :: KeyValMap a b -> KeyValMap a b -> Bool
$c< :: forall a b. KeyValMap a b -> KeyValMap a b -> Bool
compare :: KeyValMap a b -> KeyValMap a b -> Ordering
$ccompare :: forall a b. KeyValMap a b -> KeyValMap a b -> Ordering
$cp1Ord :: forall a b. Eq (KeyValMap a b)
Ord, Int -> KeyValMap a b -> ShowS
[KeyValMap a b] -> ShowS
KeyValMap a b -> String
(Int -> KeyValMap a b -> ShowS)
-> (KeyValMap a b -> String)
-> ([KeyValMap a b] -> ShowS)
-> Show (KeyValMap a b)
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
forall a b. Int -> KeyValMap a b -> ShowS
forall a b. [KeyValMap a b] -> ShowS
forall a b. KeyValMap a b -> String
showList :: [KeyValMap a b] -> ShowS
$cshowList :: forall a b. [KeyValMap a b] -> ShowS
show :: KeyValMap a b -> String
$cshow :: forall a b. KeyValMap a b -> String
showsPrec :: Int -> KeyValMap a b -> ShowS
$cshowsPrec :: forall a b. Int -> KeyValMap a b -> ShowS
Show, (forall x. KeyValMap a b -> Rep (KeyValMap a b) x)
-> (forall x. Rep (KeyValMap a b) x -> KeyValMap a b)
-> Generic (KeyValMap a b)
forall x. Rep (KeyValMap a b) x -> KeyValMap a b
forall x. KeyValMap a b -> Rep (KeyValMap a b) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a b x. Rep (KeyValMap a b) x -> KeyValMap a b
forall a b x. KeyValMap a b -> Rep (KeyValMap a b) x
$cto :: forall a b x. Rep (KeyValMap a b) x -> KeyValMap a b
$cfrom :: forall a b x. KeyValMap a b -> Rep (KeyValMap a b) x
Generic, Get (KeyValMap a b)
[KeyValMap a b] -> Put
KeyValMap a b -> Put
(KeyValMap a b -> Put)
-> Get (KeyValMap a b)
-> ([KeyValMap a b] -> Put)
-> Binary (KeyValMap a b)
forall t. (t -> Put) -> Get t -> ([t] -> Put) -> Binary t
forall a b. Get (KeyValMap a b)
forall a b. [KeyValMap a b] -> Put
forall a b. KeyValMap a b -> Put
putList :: [KeyValMap a b] -> Put
$cputList :: forall a b. [KeyValMap a b] -> Put
get :: Get (KeyValMap a b)
$cget :: forall a b. Get (KeyValMap a b)
put :: KeyValMap a b -> Put
$cput :: forall a b. KeyValMap a b -> Put
Binary, Value -> Parser [KeyValMap a b]
Value -> Parser (KeyValMap a b)
(Value -> Parser (KeyValMap a b))
-> (Value -> Parser [KeyValMap a b]) -> FromJSON (KeyValMap a b)
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
forall a b. Value -> Parser [KeyValMap a b]
forall a b. Value -> Parser (KeyValMap a b)
parseJSONList :: Value -> Parser [KeyValMap a b]
$cparseJSONList :: forall a b. Value -> Parser [KeyValMap a b]
parseJSON :: Value -> Parser (KeyValMap a b)
$cparseJSON :: forall a b. Value -> Parser (KeyValMap a b)
FromJSON, [KeyValMap a b] -> Encoding
[KeyValMap a b] -> Value
KeyValMap a b -> Encoding
KeyValMap a b -> Value
(KeyValMap a b -> Value)
-> (KeyValMap a b -> Encoding)
-> ([KeyValMap a b] -> Value)
-> ([KeyValMap a b] -> Encoding)
-> ToJSON (KeyValMap a b)
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
forall a b. [KeyValMap a b] -> Encoding
forall a b. [KeyValMap a b] -> Value
forall a b. KeyValMap a b -> Encoding
forall a b. KeyValMap a b -> Value
toEncodingList :: [KeyValMap a b] -> Encoding
$ctoEncodingList :: forall a b. [KeyValMap a b] -> Encoding
toJSONList :: [KeyValMap a b] -> Value
$ctoJSONList :: forall a b. [KeyValMap a b] -> Value
toEncoding :: KeyValMap a b -> Encoding
$ctoEncoding :: forall a b. KeyValMap a b -> Encoding
toJSON :: KeyValMap a b -> Value
$ctoJSON :: forall a b. KeyValMap a b -> Value
ToJSON)

-- | 'KeyValMap' is an instance of 'ToField' in order to use with Sqlite
instance Sql.ToField (KeyValMap a b) where
  toField :: KeyValMap a b -> SQLData
toField = Text -> SQLData
forall a. ToField a => a -> SQLData
Sql.toField (Text -> SQLData)
-> (KeyValMap a b -> Text) -> KeyValMap a b -> SQLData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. KeyValMap a b -> Text
forall a b. KeyValMap a b -> Text
kvMapName

-- | 'setupKeyValTable' creates the table "hyperion_key_val" if it
-- doesn't yet exist.  This table will hold the map-key-val entries.
--
-- The entry format is @program_id, kv_map, key, val, created_at@.
-- These are the program id, map name, key, value, and timestamp,
-- respectively.
--
-- @program_id@ is not used in lookups
setupKeyValTable
  :: (MonadIO m, MonadReader env m, HasDB env, MonadCatch m)
  => m ()
setupKeyValTable :: m ()
setupKeyValTable = (Connection -> IO ()) -> m ()
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m) =>
(Connection -> IO a) -> m a
withConnectionRetry ((Connection -> IO ()) -> m ()) -> (Connection -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  Connection -> Query -> IO ()
Sql.execute_ Connection
conn Query
sql
  where
    sql :: Query
sql =
      Query
"create table if not exists hyperion_key_val \
      \( program_id text not null \
      \, kv_map text not null \
      \, key text not null \
      \, val text not null \
      \, created_at timestamp default current_timestamp not null \
      \)"

newtype JsonField a = JsonField a

-- | Make 'JsonField' an instance of 'FromField'. First turns the field into Text and then tries to decode JSON.
-- Returns 'Sql.Errors' or 'Sql.Ok' with the result.
instance (Typeable a, FromJSON a) => Sql.FromField (JsonField a) where
  fromField :: FieldParser (JsonField a)
fromField Field
f = case FieldParser Text
forall a. FromField a => FieldParser a
Sql.fromField Field
f of
    Sql.Ok Text
txt -> case ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
Aeson.eitherDecode (ByteString -> ByteString
LBS.fromStrict (Text -> ByteString
T.encodeUtf8 Text
txt)) of
      Left String
err     -> (String -> String -> String -> ResultError)
-> Field -> String -> Ok (JsonField a)
forall a err.
(Typeable a, Exception err) =>
(String -> String -> String -> err) -> Field -> String -> Ok a
Sql.returnError String -> String -> String -> ResultError
Sql.ConversionFailed Field
f String
err
      Right a
result -> JsonField a -> Ok (JsonField a)
forall a. a -> Ok a
Sql.Ok (a -> JsonField a
forall a. a -> JsonField a
JsonField a
result)
    Sql.Errors [SomeException]
err -> [SomeException] -> Ok (JsonField a)
forall a. [SomeException] -> Ok a
Sql.Errors [SomeException]
err

-- | Make 'JsonField' an instance of 'ToField'.
instance ToJSON a => Sql.ToField (JsonField a) where
  toField :: JsonField a -> SQLData
toField (JsonField a
a) = Text -> SQLData
Sql.SQLText (Text -> SQLData) -> Text -> SQLData
forall a b. (a -> b) -> a -> b
$ ByteString -> Text
T.decodeUtf8 (ByteString -> Text) -> ByteString -> Text
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString
LBS.toStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encode a
a

-- | Inserts an map-key-val entry into the database.
--
-- If fails, retries using 'withConnectionRetry'
insert
  :: (MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a, ToJSON b)
  => KeyValMap a b
  -> a
  -> b
  -> m ()
insert :: KeyValMap a b -> a -> b -> m ()
insert KeyValMap a b
kvMap a
key b
val = do
  ProgramId
programId <- LensLike' (Const ProgramId) env DatabaseConfig
-> (DatabaseConfig -> ProgramId) -> m ProgramId
forall s (m :: * -> *) r a.
MonadReader s m =>
LensLike' (Const r) s a -> (a -> r) -> m r
views LensLike' (Const ProgramId) env DatabaseConfig
forall env. HasDB env => Lens' env DatabaseConfig
dbConfigLens DatabaseConfig -> ProgramId
dbProgramId
  (Connection -> IO ()) -> m ()
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m) =>
(Connection -> IO a) -> m a
withConnectionRetry ((Connection -> IO ()) -> m ()) -> (Connection -> IO ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> Connection
-> Query
-> (ProgramId, KeyValMap a b, JsonField a, JsonField b)
-> IO ()
forall q. ToRow q => Connection -> Query -> q -> IO ()
Sql.execute Connection
conn Query
sql
    ( ProgramId
programId
    , KeyValMap a b
kvMap
    , a -> JsonField a
forall a. a -> JsonField a
JsonField a
key
    , b -> JsonField b
forall a. a -> JsonField a
JsonField b
val
    )
  where
    sql :: Query
sql =
      Query
"insert into hyperion_key_val(program_id, kv_map, key, val) \
      \values (?, ?, ?, ?)"

-- | Looks up a value in the database given the map name and the
-- key. Takes the most recent matching entry according to the
-- convention.
--
-- If fails, retries using 'withConnectionRetry'
lookup
  :: (MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a, Typeable b, FromJSON b)
  => KeyValMap a b
  -> a
  -> m (Maybe b)
lookup :: KeyValMap a b -> a -> m (Maybe b)
lookup KeyValMap a b
kvMap a
key = (Connection -> IO (Maybe b)) -> m (Maybe b)
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m) =>
(Connection -> IO a) -> m a
withConnectionRetry ((Connection -> IO (Maybe b)) -> m (Maybe b))
-> (Connection -> IO (Maybe b)) -> m (Maybe b)
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  [Only (JsonField b)]
result <- Connection
-> Query -> (KeyValMap a b, JsonField a) -> IO [Only (JsonField b)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
Sql.query Connection
conn Query
sql (KeyValMap a b
kvMap, a -> JsonField a
forall a. a -> JsonField a
JsonField a
key)
  case [Only (JsonField b)]
result of
    []                         -> Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe b
forall a. Maybe a
Nothing
    Sql.Only (JsonField b
a) : [Only (JsonField b)]
_ -> Maybe b -> IO (Maybe b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe b -> IO (Maybe b)) -> Maybe b -> IO (Maybe b)
forall a b. (a -> b) -> a -> b
$ b -> Maybe b
forall a. a -> Maybe a
Just b
a
  where
    sql :: Query
sql =
      Query
"select val from hyperion_key_val \
      \where kv_map = ? and key = ? \
      \order by created_at desc \
      \limit 1"

-- | Returns the list of all kev-value pairs for a given map. Again
-- only keeps the latest versino of the value accroding to the
-- convention.
--
-- If fails, retries using 'withConnectionRetry'
lookupAll
  :: (MonadIO m, MonadReader env m, HasDB env, MonadCatch m, Typeable a, FromJSON a, Typeable b, FromJSON b)
  => KeyValMap a b
  -> m [(a,b)]
lookupAll :: KeyValMap a b -> m [(a, b)]
lookupAll KeyValMap a b
kvMap = (Connection -> IO [(a, b)]) -> m [(a, b)]
forall (m :: * -> *) env a.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m) =>
(Connection -> IO a) -> m a
withConnectionRetry ((Connection -> IO [(a, b)]) -> m [(a, b)])
-> (Connection -> IO [(a, b)]) -> m [(a, b)]
forall a b. (a -> b) -> a -> b
$ \Connection
conn -> do
  [(JsonField a, JsonField b, UTCTime)]
result <- Connection
-> Query
-> Only (KeyValMap a b)
-> IO [(JsonField a, JsonField b, UTCTime)]
forall q r.
(ToRow q, FromRow r) =>
Connection -> Query -> q -> IO [r]
Sql.query Connection
conn Query
sql (KeyValMap a b -> Only (KeyValMap a b)
forall a. a -> Only a
Sql.Only KeyValMap a b
kvMap)
  [(a, b)] -> IO [(a, b)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([(a, b)] -> IO [(a, b)]) -> [(a, b)] -> IO [(a, b)]
forall a b. (a -> b) -> a -> b
$ ((JsonField a, JsonField b, UTCTime) -> (a, b))
-> [(JsonField a, JsonField b, UTCTime)] -> [(a, b)]
forall a b. (a -> b) -> [a] -> [b]
map (\(JsonField a
a, JsonField b
b, UTCTime
_ :: UTCTime) -> (a
a,b
b)) [(JsonField a, JsonField b, UTCTime)]
result
  where
    sql :: Query
sql =
      Query
"select key, val, max(created_at) from hyperion_key_val \
      \where kv_map = ? \
      \group by key \
      \order by created_at"

-- | Same as 'lookup' but with a default value provided
lookupDefault
  :: (MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a, Typeable b, FromJSON b)
  => KeyValMap a b
  -> b
  -> a
  -> m b
lookupDefault :: KeyValMap a b -> b -> a -> m b
lookupDefault KeyValMap a b
kvMap b
def a
key = KeyValMap a b -> a -> m (Maybe b)
forall (m :: * -> *) env a b.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a,
 Typeable b, FromJSON b) =>
KeyValMap a b -> a -> m (Maybe b)
lookup KeyValMap a b
kvMap a
key m (Maybe b) -> (Maybe b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just b
v -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
v
  Maybe b
Nothing -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
def

-- | This implements memoization using the DB.  Given a function, it
-- first tries to look up the function result in the DB and if no
-- result is available, runs the function and inserts the result into
-- the DB
memoizeWithMap
  :: (MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a, ToJSON b, Typeable b, FromJSON b)
  => KeyValMap a b -- ^ The 'KeyValMap' in which to memoize
  -> (a -> m b)
  -> a
  -> m b
memoizeWithMap :: KeyValMap a b -> (a -> m b) -> a -> m b
memoizeWithMap KeyValMap a b
kvMap a -> m b
f a
a = do
  KeyValMap a b -> a -> m (Maybe b)
forall (m :: * -> *) env a b.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a,
 Typeable b, FromJSON b) =>
KeyValMap a b -> a -> m (Maybe b)
lookup KeyValMap a b
kvMap a
a m (Maybe b) -> (Maybe b -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just b
b -> b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b
    Maybe b
Nothing -> do
      b
b <- a -> m b
f a
a
      KeyValMap a b -> a -> b -> m ()
forall (m :: * -> *) env a b.
(MonadIO m, MonadReader env m, HasDB env, MonadCatch m, ToJSON a,
 ToJSON b) =>
KeyValMap a b -> a -> b -> m ()
insert KeyValMap a b
kvMap a
a b
b
      b -> m b
forall (m :: * -> *) a. Monad m => a -> m a
return b
b