{-# LANGUAGE DataKinds        #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE MonoLocalBinds   #-}
{-# LANGUAGE RankNTypes       #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeOperators    #-}
module Plutus.ChainIndex.Emulator.Server(
    serveChainIndexQueryServer,
    serveChainIndex) where

import Control.Concurrent.STM (TVar)
import Control.Concurrent.STM qualified as STM
import Control.Monad.Except qualified as E
import Control.Monad.Freer (Eff, interpret, run, type (~>))
import Control.Monad.Freer.Error (Error, runError)
import Control.Monad.Freer.Extras.Log (handleLogIgnore)
import Control.Monad.Freer.Extras.Modify (raiseEnd)
import Control.Monad.Freer.State (evalState)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Data.ByteString.Lazy qualified as BSL
import Data.Proxy (Proxy (..))
import Data.Text qualified as Text
import Data.Text.Encoding qualified as Text
import Network.Wai.Handler.Warp qualified as Warp
import Plutus.ChainIndex (ChainIndexError, ChainIndexLog)
import Plutus.ChainIndex.Api (API, FullAPI, swagger)
import Plutus.ChainIndex.Effects (ChainIndexControlEffect, ChainIndexQueryEffect)
import Plutus.ChainIndex.Emulator.Handlers (ChainIndexEmulatorState (..), handleControl, handleQuery)
import Plutus.ChainIndex.Server hiding (serveChainIndexQueryServer)
import Servant.API ((:<|>) (..))
import Servant.Server (Handler, ServerError, err500, errBody, hoistServer, serve)

serveChainIndexQueryServer ::
    Int -- ^ Port
    -> TVar ChainIndexEmulatorState -- ^ Chain index state (TODO: When the disk state is stored in a DB, replace this with DB connection info)
    -> IO ()
serveChainIndexQueryServer :: Int -> TVar ChainIndexEmulatorState -> IO ()
serveChainIndexQueryServer Int
port TVar ChainIndexEmulatorState
diskState = do
    let server :: ServerT API Handler
server = Proxy API
-> (forall x.
    Eff
      '[ChainIndexQueryEffect, ChainIndexControlEffect,
        Error ServerError]
      x
    -> Handler x)
-> ServerT
     API
     (Eff
        '[ChainIndexQueryEffect, ChainIndexControlEffect,
          Error ServerError])
-> ServerT API Handler
forall api (m :: * -> *) (n :: * -> *).
HasServer api '[] =>
Proxy api
-> (forall x. m x -> n x) -> ServerT api m -> ServerT api n
hoistServer (Proxy API
forall k (t :: k). Proxy t
Proxy @API) (TVar ChainIndexEmulatorState
-> forall x.
   Eff
     '[ChainIndexQueryEffect, ChainIndexControlEffect,
       Error ServerError]
     x
   -> Handler x
runChainIndexQuery TVar ChainIndexEmulatorState
diskState) ServerT
  API
  (Eff
     '[ChainIndexQueryEffect, ChainIndexControlEffect,
       Error ServerError])
forall (effs :: [* -> *]).
(Member (Error ServerError) effs,
 Member ChainIndexQueryEffect effs,
 Member ChainIndexControlEffect effs) =>
ServerT API (Eff effs)
serveChainIndex
    Int -> Application -> IO ()
Warp.run Int
port (Proxy FullAPI -> Server FullAPI -> Application
forall api.
HasServer api '[] =>
Proxy api -> Server api -> Application
serve (Proxy FullAPI
forall k (t :: k). Proxy t
Proxy @FullAPI) (Handler NoContent
:<|> (((DatumHash -> Handler Datum)
       :<|> ((ValidatorHash -> Handler (Versioned Validator))
             :<|> ((MintingPolicyHash -> Handler (Versioned MintingPolicy))
                   :<|> ((StakeValidatorHash -> Handler (Versioned StakeValidator))
                         :<|> (RedeemerHash -> Handler Redeemer)))))
      :<|> ((TxOutRef -> Handler DecoratedTxOut)
            :<|> ((TxOutRef -> Handler DecoratedTxOut)
                  :<|> ((TxId -> Handler ChainIndexTx)
                        :<|> ((TxOutRef -> Handler IsUtxoResponse)
                              :<|> ((UtxoAtAddressRequest -> Handler UtxosResponse)
                                    :<|> ((QueryAtAddressRequest
                                           -> Handler (QueryResponse [(TxOutRef, DecoratedTxOut)]))
                                          :<|> ((QueryAtAddressRequest
                                                 -> Handler (QueryResponse [Datum]))
                                                :<|> ((UtxoWithCurrencyRequest
                                                       -> Handler UtxosResponse)
                                                      :<|> (([TxId] -> Handler [ChainIndexTx])
                                                            :<|> ((TxoAtAddressRequest
                                                                   -> Handler TxosResponse)
                                                                  :<|> (Handler Tip
                                                                        :<|> (Handler NoContent
                                                                              :<|> Handler
                                                                                     Diagnostics)))))))))))))
ServerT API Handler
server (Handler NoContent
 :<|> (((DatumHash -> Handler Datum)
        :<|> ((ValidatorHash -> Handler (Versioned Validator))
              :<|> ((MintingPolicyHash -> Handler (Versioned MintingPolicy))
                    :<|> ((StakeValidatorHash -> Handler (Versioned StakeValidator))
                          :<|> (RedeemerHash -> Handler Redeemer)))))
       :<|> ((TxOutRef -> Handler DecoratedTxOut)
             :<|> ((TxOutRef -> Handler DecoratedTxOut)
                   :<|> ((TxId -> Handler ChainIndexTx)
                         :<|> ((TxOutRef -> Handler IsUtxoResponse)
                               :<|> ((UtxoAtAddressRequest -> Handler UtxosResponse)
                                     :<|> ((QueryAtAddressRequest
                                            -> Handler (QueryResponse [(TxOutRef, DecoratedTxOut)]))
                                           :<|> ((QueryAtAddressRequest
                                                  -> Handler (QueryResponse [Datum]))
                                                 :<|> ((UtxoWithCurrencyRequest
                                                        -> Handler UtxosResponse)
                                                       :<|> (([TxId] -> Handler [ChainIndexTx])
                                                             :<|> ((TxoAtAddressRequest
                                                                    -> Handler TxosResponse)
                                                                   :<|> (Handler Tip
                                                                         :<|> (Handler NoContent
                                                                               :<|> Handler
                                                                                      Diagnostics))))))))))))))
-> (Handler Value
    :<|> (Handler
            (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
          :<|> (Handler
                  (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                :<|> Tagged Handler Application)))
-> (Handler NoContent
    :<|> (((DatumHash -> Handler Datum)
           :<|> ((ValidatorHash -> Handler (Versioned Validator))
                 :<|> ((MintingPolicyHash -> Handler (Versioned MintingPolicy))
                       :<|> ((StakeValidatorHash -> Handler (Versioned StakeValidator))
                             :<|> (RedeemerHash -> Handler Redeemer)))))
          :<|> ((TxOutRef -> Handler DecoratedTxOut)
                :<|> ((TxOutRef -> Handler DecoratedTxOut)
                      :<|> ((TxId -> Handler ChainIndexTx)
                            :<|> ((TxOutRef -> Handler IsUtxoResponse)
                                  :<|> ((UtxoAtAddressRequest -> Handler UtxosResponse)
                                        :<|> ((QueryAtAddressRequest
                                               -> Handler
                                                    (QueryResponse [(TxOutRef, DecoratedTxOut)]))
                                              :<|> ((QueryAtAddressRequest
                                                     -> Handler (QueryResponse [Datum]))
                                                    :<|> ((UtxoWithCurrencyRequest
                                                           -> Handler UtxosResponse)
                                                          :<|> (([TxId] -> Handler [ChainIndexTx])
                                                                :<|> ((TxoAtAddressRequest
                                                                       -> Handler TxosResponse)
                                                                      :<|> (Handler Tip
                                                                            :<|> (Handler NoContent
                                                                                  :<|> Handler
                                                                                         Diagnostics))))))))))))))
   :<|> (Handler Value
         :<|> (Handler
                 (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
               :<|> (Handler
                       (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
                     :<|> Tagged Handler Application)))
forall a b. a -> b -> a :<|> b
:<|> Handler Value
:<|> (Handler
        (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
      :<|> (Handler
              (SwaggerUiHtml "swagger-ui" ("swagger.json" :> Get '[JSON] Value))
            :<|> Tagged Handler Application))
forall (dir :: Symbol) api.
(Server api ~ Handler Value) =>
Server (SwaggerSchemaUI' dir api)
swagger))

runChainIndexQuery ::
    TVar ChainIndexEmulatorState
    -> Eff '[ChainIndexQueryEffect, ChainIndexControlEffect, Error ServerError] ~> Handler
runChainIndexQuery :: TVar ChainIndexEmulatorState
-> forall x.
   Eff
     '[ChainIndexQueryEffect, ChainIndexControlEffect,
       Error ServerError]
     x
   -> Handler x
runChainIndexQuery TVar ChainIndexEmulatorState
emState_ Eff
  '[ChainIndexQueryEffect, ChainIndexControlEffect,
    Error ServerError]
  x
action = do
    ChainIndexEmulatorState
emState <- IO ChainIndexEmulatorState -> Handler ChainIndexEmulatorState
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (TVar ChainIndexEmulatorState -> IO ChainIndexEmulatorState
forall a. TVar a -> IO a
STM.readTVarIO TVar ChainIndexEmulatorState
emState_)
    let result :: Either ChainIndexError (Either ServerError x)
result = Eff '[] (Either ChainIndexError (Either ServerError x))
-> Either ChainIndexError (Either ServerError x)
forall a. Eff '[] a -> a
run
                    (Eff '[] (Either ChainIndexError (Either ServerError x))
 -> Either ChainIndexError (Either ServerError x))
-> Eff '[] (Either ChainIndexError (Either ServerError x))
-> Either ChainIndexError (Either ServerError x)
forall a b. (a -> b) -> a -> b
$ ChainIndexEmulatorState
-> Eff
     '[State ChainIndexEmulatorState]
     (Either ChainIndexError (Either ServerError x))
-> Eff '[] (Either ChainIndexError (Either ServerError x))
forall s (effs :: [* -> *]) a.
s -> Eff (State s : effs) a -> Eff effs a
evalState ChainIndexEmulatorState
emState
                    (Eff
   '[State ChainIndexEmulatorState]
   (Either ChainIndexError (Either ServerError x))
 -> Eff '[] (Either ChainIndexError (Either ServerError x)))
-> Eff
     '[State ChainIndexEmulatorState]
     (Either ChainIndexError (Either ServerError x))
-> Eff '[] (Either ChainIndexError (Either ServerError x))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]) a.
Eff (Error ChainIndexError : effs) a
-> Eff effs (Either ChainIndexError a)
forall e (effs :: [* -> *]) a.
Eff (Error e : effs) a -> Eff effs (Either e a)
runError @ChainIndexError
                    (Eff
   '[Error ChainIndexError, State ChainIndexEmulatorState]
   (Either ServerError x)
 -> Eff
      '[State ChainIndexEmulatorState]
      (Either ChainIndexError (Either ServerError x)))
-> Eff
     '[Error ChainIndexError, State ChainIndexEmulatorState]
     (Either ServerError x)
-> Eff
     '[State ChainIndexEmulatorState]
     (Either ChainIndexError (Either ServerError x))
forall a b. (a -> b) -> a -> b
$ forall (effs :: [* -> *]).
Eff (LogMsg ChainIndexLog : effs) ~> Eff effs
forall a (effs :: [* -> *]). Eff (LogMsg a : effs) ~> Eff effs
handleLogIgnore @ChainIndexLog
                    (Eff
   '[LogMsg ChainIndexLog, Error ChainIndexError,
     State ChainIndexEmulatorState]
   (Either ServerError x)
 -> Eff
      '[Error ChainIndexError, State ChainIndexEmulatorState]
      (Either ServerError x))
-> Eff
     '[LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     (Either ServerError x)
-> Eff
     '[Error ChainIndexError, State ChainIndexEmulatorState]
     (Either ServerError x)
forall a b. (a -> b) -> a -> b
$ Eff
  '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
    State ChainIndexEmulatorState]
  x
-> Eff
     '[LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     (Either ServerError x)
forall e (effs :: [* -> *]) a.
Eff (Error e : effs) a -> Eff effs (Either e a)
runError
                    (Eff
   '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
     State ChainIndexEmulatorState]
   x
 -> Eff
      '[LogMsg ChainIndexLog, Error ChainIndexError,
        State ChainIndexEmulatorState]
      (Either ServerError x))
-> Eff
     '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     x
-> Eff
     '[LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     (Either ServerError x)
forall a b. (a -> b) -> a -> b
$ (ChainIndexControlEffect
 ~> Eff
      '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
        State ChainIndexEmulatorState])
-> Eff
     '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
       Error ChainIndexError, State ChainIndexEmulatorState]
   ~> Eff
        '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
          State ChainIndexEmulatorState]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret forall (effs :: [* -> *]).
(Member (State ChainIndexEmulatorState) effs,
 Member (Error ChainIndexError) effs,
 Member (LogMsg ChainIndexLog) effs) =>
ChainIndexControlEffect ~> Eff effs
ChainIndexControlEffect
~> Eff
     '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
handleControl
                    (Eff
   '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
     Error ChainIndexError, State ChainIndexEmulatorState]
   x
 -> Eff
      '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
        State ChainIndexEmulatorState]
      x)
-> Eff
     '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
       Error ChainIndexError, State ChainIndexEmulatorState]
     x
-> Eff
     '[Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     x
forall a b. (a -> b) -> a -> b
$ (ChainIndexQueryEffect
 ~> Eff
      '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
        Error ChainIndexError, State ChainIndexEmulatorState])
-> Eff
     '[ChainIndexQueryEffect, ChainIndexControlEffect,
       Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
   ~> Eff
        '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
          Error ChainIndexError, State ChainIndexEmulatorState]
forall (eff :: * -> *) (effs :: [* -> *]).
(eff ~> Eff effs) -> Eff (eff : effs) ~> Eff effs
interpret forall (effs :: [* -> *]).
(Member (State ChainIndexEmulatorState) effs,
 Member (Error ChainIndexError) effs,
 Member (LogMsg ChainIndexLog) effs) =>
ChainIndexQueryEffect ~> Eff effs
ChainIndexQueryEffect
~> Eff
     '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
       Error ChainIndexError, State ChainIndexEmulatorState]
handleQuery
                    (Eff
   '[ChainIndexQueryEffect, ChainIndexControlEffect,
     Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
     State ChainIndexEmulatorState]
   x
 -> Eff
      '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
        Error ChainIndexError, State ChainIndexEmulatorState]
      x)
-> Eff
     '[ChainIndexQueryEffect, ChainIndexControlEffect,
       Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     x
-> Eff
     '[ChainIndexControlEffect, Error ServerError, LogMsg ChainIndexLog,
       Error ChainIndexError, State ChainIndexEmulatorState]
     x
forall a b. (a -> b) -> a -> b
$ Eff
  '[ChainIndexQueryEffect, ChainIndexControlEffect,
    Error ServerError]
  x
-> Eff
     '[ChainIndexQueryEffect, ChainIndexControlEffect,
       Error ServerError, LogMsg ChainIndexLog, Error ChainIndexError,
       State ChainIndexEmulatorState]
     x
forall (effs :: [* -> *]) (as :: [* -> *]).
CanWeakenEnd as effs =>
Eff as ~> Eff effs
raiseEnd Eff
  '[ChainIndexQueryEffect, ChainIndexControlEffect,
    Error ServerError]
  x
action
    case Either ChainIndexError (Either ServerError x)
result of
        Right (Right x
a) -> x -> Handler x
forall (f :: * -> *) a. Applicative f => a -> f a
pure x
a
        Right (Left ServerError
e) -> ServerError -> Handler x
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError ServerError
e
        Left ChainIndexError
e' ->
            let err :: ServerError
err = ServerError
err500 { errBody :: ByteString
errBody = ByteString -> ByteString
BSL.fromStrict (ByteString -> ByteString) -> ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ Text -> ByteString
Text.encodeUtf8 (Text -> ByteString) -> Text -> ByteString
forall a b. (a -> b) -> a -> b
$ String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ChainIndexError -> String
forall a. Show a => a -> String
show ChainIndexError
e' } in
            ServerError -> Handler x
forall e (m :: * -> *) a. MonadError e m => e -> m a
E.throwError ServerError
err