module Gamgee.Effects.JSONStore
  ( -- * Effect
    JSONStore (..)

    -- * Actions
  , jsonEncode
  , jsonDecode

    -- * Interpretations
  , runJSONStore
  , configStoreToByteStore
  ) where

import qualified Data.Aeson               as Aeson
import qualified Gamgee.Effects.ByteStore as BS
import qualified Gamgee.Effects.Error     as Err
import qualified Gamgee.Token             as Token
import           Polysemy                 (Member, Sem)
import qualified Polysemy                 as P
import qualified Polysemy.Error           as P
import           Relude



----------------------------------------------------------------------------------------------------
-- An abstract JSON store effect that encodes and decodes JSON objects
----------------------------------------------------------------------------------------------------

data JSONStore o m a where
  JsonEncode :: o -> JSONStore o m ()
  JsonDecode :: JSONStore o m o

P.makeSem ''JSONStore


----------------------------------------------------------------------------------------------------
-- Interpret JSONStore backed by a ByteStore
----------------------------------------------------------------------------------------------------

-- | Reinterprets a JSONStore as a ByteStore
runJSONStore :: Member (P.Error Err.EffError) r
             => Sem (JSONStore Token.Tokens : r) a
             -> Sem (BS.ByteStore : r) a
runJSONStore :: Sem (JSONStore Tokens : r) a -> Sem (ByteStore : r) a
runJSONStore = Sem (JSONStore Config : r) a -> Sem (ByteStore : r) a
forall (r :: [(* -> *) -> * -> *]) a.
Member (Error EffError) r =>
Sem (JSONStore Config : r) a -> Sem (ByteStore : r) a
configStoreToByteStore (Sem (JSONStore Config : r) a -> Sem (ByteStore : r) a)
-> (Sem (JSONStore Tokens : r) a -> Sem (JSONStore Config : r) a)
-> Sem (JSONStore Tokens : r) a
-> Sem (ByteStore : r) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Sem (JSONStore Tokens : r) a -> Sem (JSONStore Config : r) a
forall (r :: [(* -> *) -> * -> *]) a.
Member (Error EffError) r =>
Sem (JSONStore Tokens : r) a -> Sem (JSONStore Config : r) a
tokenStoreToConfigStore

tokenStoreToConfigStore :: Member (P.Error Err.EffError) r
                        => Sem (JSONStore Token.Tokens : r) a
                        -> Sem (JSONStore Token.Config : r) a
tokenStoreToConfigStore :: Sem (JSONStore Tokens : r) a -> Sem (JSONStore Config : r) a
tokenStoreToConfigStore =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 JSONStore Tokens (Sem rInitial) x -> Sem (JSONStore Config : r) x)
-> Sem (JSONStore Tokens : r) a -> Sem (JSONStore Config : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  JSONStore Tokens (Sem rInitial) x -> Sem (JSONStore Config : r) x)
 -> Sem (JSONStore Tokens : r) a -> Sem (JSONStore Config : r) a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    JSONStore Tokens (Sem rInitial) x -> Sem (JSONStore Config : r) x)
-> Sem (JSONStore Tokens : r) a
-> Sem (JSONStore Config : r) a
forall a b. (a -> b) -> a -> b
$ \case
    JsonEncode o -> Tokens -> Sem (JSONStore Config : r) Config
forall (r :: [(* -> *) -> * -> *]). Tokens -> Sem r Config
tokensToConfig Tokens
o Sem (JSONStore Config : r) Config
-> (Config -> Sem (JSONStore Config : r) ())
-> Sem (JSONStore Config : r) ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> Sem (JSONStore Config : r) ()
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (JSONStore o) r =>
o -> Sem r ()
jsonEncode
    JSONStore Tokens (Sem rInitial) x
JsonDecode   -> Sem (JSONStore Config : r) Config
forall o (r :: [(* -> *) -> * -> *]).
MemberWithError (JSONStore o) r =>
Sem r o
jsonDecode Sem (JSONStore Config : r) Config
-> (Config -> Sem (JSONStore Config : r) Tokens)
-> Sem (JSONStore Config : r) Tokens
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Config -> Sem (JSONStore Config : r) Tokens
forall (r :: [(* -> *) -> * -> *]).
Member (Error EffError) r =>
Config -> Sem r Tokens
configToTokens

  where
    tokensToConfig :: Token.Tokens -> Sem r Token.Config
    tokensToConfig :: Tokens -> Sem r Config
tokensToConfig Tokens
ts = Config -> Sem r Config
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Sem r Config) -> Config -> Sem r Config
forall a b. (a -> b) -> a -> b
$ Config :: Word32 -> Tokens -> Config
Token.Config { configVersion :: Word32
Token.configVersion = Word32
Token.currentConfigVersion, configTokens :: Tokens
Token.configTokens = Tokens
ts }

    configToTokens :: Member (P.Error Err.EffError) r => Token.Config -> Sem r Token.Tokens
    configToTokens :: Config -> Sem r Tokens
configToTokens Config
cfg = if Config -> Word32
Token.configVersion Config
cfg Word32 -> Word32 -> Bool
forall a. Eq a => a -> a -> Bool
== Word32
Token.currentConfigVersion
                         then Tokens -> Sem r Tokens
forall (m :: * -> *) a. Monad m => a -> m a
return (Config -> Tokens
Token.configTokens Config
cfg)
                         else EffError -> Sem r Tokens
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (EffError -> Sem r Tokens) -> EffError -> Sem r Tokens
forall a b. (a -> b) -> a -> b
$ Word32 -> EffError
Err.UnsupportedConfigVersion (Word32 -> EffError) -> Word32 -> EffError
forall a b. (a -> b) -> a -> b
$ Config -> Word32
Token.configVersion Config
cfg

configStoreToByteStore :: Member (P.Error Err.EffError) r
                       => Sem (JSONStore Token.Config : r) a
                       -> Sem (BS.ByteStore : r) a
configStoreToByteStore :: Sem (JSONStore Config : r) a -> Sem (ByteStore : r) a
configStoreToByteStore =
  (forall (rInitial :: [(* -> *) -> * -> *]) x.
 JSONStore Config (Sem rInitial) x -> Sem (ByteStore : r) x)
-> Sem (JSONStore Config : r) a -> Sem (ByteStore : r) a
forall (e1 :: (* -> *) -> * -> *) (e2 :: (* -> *) -> * -> *)
       (r :: [(* -> *) -> * -> *]) a.
FirstOrder e1 "reinterpret" =>
(forall (rInitial :: [(* -> *) -> * -> *]) x.
 e1 (Sem rInitial) x -> Sem (e2 : r) x)
-> Sem (e1 : r) a -> Sem (e2 : r) a
P.reinterpret ((forall (rInitial :: [(* -> *) -> * -> *]) x.
  JSONStore Config (Sem rInitial) x -> Sem (ByteStore : r) x)
 -> Sem (JSONStore Config : r) a -> Sem (ByteStore : r) a)
-> (forall (rInitial :: [(* -> *) -> * -> *]) x.
    JSONStore Config (Sem rInitial) x -> Sem (ByteStore : r) x)
-> Sem (JSONStore Config : r) a
-> Sem (ByteStore : r) a
forall a b. (a -> b) -> a -> b
$ \case
    JsonEncode cfg -> LByteString -> Sem (ByteStore : r) ()
forall (r :: [(* -> *) -> * -> *]).
MemberWithError ByteStore r =>
LByteString -> Sem r ()
BS.writeByteStore (LByteString -> Sem (ByteStore : r) ())
-> LByteString -> Sem (ByteStore : r) ()
forall a b. (a -> b) -> a -> b
$ Config -> LByteString
forall a. ToJSON a => a -> LByteString
Aeson.encode Config
cfg
    JSONStore Config (Sem rInitial) x
JsonDecode     -> do
      Maybe LByteString
bytes <- Sem (ByteStore : r) (Maybe LByteString)
forall (r :: [(* -> *) -> * -> *]).
MemberWithError ByteStore r =>
Sem r (Maybe LByteString)
BS.readByteStore
      let
        cfg :: Either String Config
cfg = Either String Config
-> (LByteString -> Either String Config)
-> Maybe LByteString
-> Either String Config
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Config -> Either String Config
forall a b. b -> Either a b
Right Config
Token.initialConfig) LByteString -> Either String Config
forall a. FromJSON a => LByteString -> Either String a
Aeson.eitherDecode' Maybe LByteString
bytes
      (String -> Sem (ByteStore : r) Config)
-> (Config -> Sem (ByteStore : r) Config)
-> Either String Config
-> Sem (ByteStore : r) Config
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> Sem (ByteStore : r) Config
forall (r :: [(* -> *) -> * -> *]) a.
Member (Error EffError) r =>
String -> Sem r a
handleDecodeError Config -> Sem (ByteStore : r) Config
forall (m :: * -> *) a. Monad m => a -> m a
return Either String Config
cfg

  where
    handleDecodeError :: Member (P.Error Err.EffError) r => String -> Sem r a
    handleDecodeError :: String -> Sem r a
handleDecodeError String
msg = EffError -> Sem r a
forall e (r :: [(* -> *) -> * -> *]) a.
MemberWithError (Error e) r =>
e -> Sem r a
P.throw (EffError -> Sem r a) -> EffError -> Sem r a
forall a b. (a -> b) -> a -> b
$ Text -> EffError
Err.JSONDecodeError (Text -> EffError) -> Text -> EffError
forall a b. (a -> b) -> a -> b
$ String -> Text
forall a. ToText a => a -> Text
toText String
msg