module Ribosome.Host.Interpreter.Host where

import Conc (Restoration, withAsync_)
import Data.MessagePack (Object (ObjectNil))
import Exon (exon)
import Log (Severity (Error, Warn), dataLog)
import Polysemy.Process (Process)
import System.IO.Error (IOError)

import Ribosome.Host.Data.BootError (BootError (BootError))
import Ribosome.Host.Data.Event (Event (Event), EventName (EventName))
import Ribosome.Host.Data.Report (LogReport (LogReport), Report (Report), severity)
import Ribosome.Host.Data.Request (Request (Request), RequestId, RpcMethod (RpcMethod))
import qualified Ribosome.Host.Data.Response as Response
import Ribosome.Host.Data.Response (Response)
import Ribosome.Host.Data.RpcError (RpcError)
import Ribosome.Host.Data.RpcMessage (RpcMessage)
import qualified Ribosome.Host.Effect.Handlers as Handlers
import Ribosome.Host.Effect.Handlers (Handlers)
import qualified Ribosome.Host.Effect.Host as Host
import Ribosome.Host.Effect.Host (Host)
import Ribosome.Host.Effect.Responses (Responses)
import Ribosome.Host.Effect.Rpc (Rpc)
import Ribosome.Host.Error (resumeBootError)
import Ribosome.Host.Listener (listener)

invalidMethod ::
  Request ->
  Response
invalidMethod :: Request -> Response
invalidMethod (Request (RpcMethod Text
name) [Object]
_) =
  Text -> Response
Response.Error [exon|Invalid method for request: #{name}|]

publishEvent ::
  Member (Events er Event) r =>
  Request ->
  Sem r ()
publishEvent :: forall er (r :: EffectRow).
Member (Events er Event) r =>
Request -> Sem r ()
publishEvent (Request (RpcMethod Text
name) [Object]
args) =
  Event -> Sem r ()
forall e resource (r :: EffectRow).
Member (Events resource e) r =>
e -> Sem r ()
publish (EventName -> [Object] -> Event
Event (Text -> EventName
EventName Text
name) [Object]
args)

handlerIOError ::
  Members [Error Report, Final IO] r =>
  Sem r a ->
  Sem r a
handlerIOError :: forall (r :: EffectRow) a.
Members '[Error Report, Final IO] r =>
Sem r a -> Sem r a
handlerIOError =
  (IOError -> Report) -> Sem r a -> Sem r a
forall exc err (r :: EffectRow) a.
(Exception exc, Member (Error err) r, Member (Final IO) r) =>
(exc -> err) -> Sem r a -> Sem r a
fromExceptionSemVia \ (IOError
e :: IOError) ->
    HasCallStack => Text -> [Text] -> Severity -> Report
Text -> [Text] -> Severity -> Report
Report Text
"Internal error" [Item [Text]
"Handler exception", IOError -> Text
forall b a. (Show a, IsString b) => a -> b
show IOError
e] Severity
Error

handlerReport ::
  Member (DataLog LogReport) r =>
  Bool ->
  RpcMethod ->
  Report ->
  Sem r ()
handlerReport :: forall (r :: EffectRow).
Member (DataLog LogReport) r =>
Bool -> RpcMethod -> Report -> Sem r ()
handlerReport Bool
notification (RpcMethod Text
method) Report
r =
  LogReport -> Sem r ()
forall a (r :: EffectRow). Member (DataLog a) r => a -> Sem r ()
dataLog (Report -> Bool -> Bool -> ReportContext -> LogReport
LogReport Report
r (Bool
notification Bool -> Bool -> Bool
|| Report -> Severity
severity Report
r Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
< Severity
Error) (Report -> Severity
severity Report
r Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
>= Severity
Warn) (Text -> ReportContext
forall a. IsString a => Text -> a
fromText Text
method))

handle ::
  Members [Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Log, Final IO] r =>
  Bool ->
  Request ->
  Sem r (Maybe Response)
handle :: forall (r :: EffectRow).
Members
  '[Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Log,
    Final IO]
  r =>
Bool -> Request -> Sem r (Maybe Response)
handle Bool
notification (Request RpcMethod
method [Object]
args) =
  Sem (Error Report : r) (Maybe Object)
-> Sem r (Either Report (Maybe Object))
forall e (r :: EffectRow) a.
(Typeable e, Member (Final IO) r) =>
Sem (Error e : r) a -> Sem r (Either e a)
errorToIOFinal (Sem (Error Report : r) (Maybe Object)
-> Sem (Error Report : r) (Maybe Object)
forall (r :: EffectRow) a.
Members '[Error Report, Final IO] r =>
Sem r a -> Sem r a
handlerIOError ((Report -> Sem (Error Report : r) (Maybe Object))
-> Sem (Handlers : Error Report : r) (Maybe Object)
-> Sem (Error Report : r) (Maybe Object)
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
(err -> Sem r a) -> Sem (eff : r) a -> Sem r a
resuming Report -> Sem (Error Report : r) (Maybe Object)
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (RpcMethod
-> [Object] -> Sem (Handlers : Error Report : r) (Maybe Object)
forall (r :: EffectRow).
Member Handlers r =>
RpcMethod -> [Object] -> Sem r (Maybe Object)
Handlers.run RpcMethod
method [Object]
args))) Sem r (Either Report (Maybe Object))
-> (Either Report (Maybe Object) -> Sem r (Maybe Response))
-> Sem r (Maybe Response)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Right Maybe Object
Nothing ->
      Maybe Response -> Sem r (Maybe Response)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Response
forall a. Maybe a
Nothing
    Right (Just Object
a) ->
      Maybe Response -> Sem r (Maybe Response)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Maybe Response
forall a. a -> Maybe a
Just (Object -> Response
Response.Success Object
a))
    Left r :: Report
r@(Report Text
e [Text]
_ Severity
severity) -> do
      Bool -> RpcMethod -> Report -> Sem r ()
forall (r :: EffectRow).
Member (DataLog LogReport) r =>
Bool -> RpcMethod -> Report -> Sem r ()
handlerReport Bool
notification RpcMethod
method Report
r
      let
        response :: Response
response =
          if Severity
severity Severity -> Severity -> Bool
forall a. Ord a => a -> a -> Bool
< Severity
Error then Object -> Response
Response.Success Object
ObjectNil else Text -> Response
Response.Error Text
e
      Maybe Response -> Sem r (Maybe Response)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Response -> Maybe Response
forall a. a -> Maybe a
Just Response
response)

interpretHost ::
  Members [Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Events er Event, Log, Final IO] r =>
  InterpreterFor Host r
interpretHost :: forall er (r :: EffectRow).
Members
  '[Handlers !! Report, Rpc !! RpcError, DataLog LogReport,
    Events er Event, Log, Final IO]
  r =>
InterpreterFor Host r
interpretHost =
  (forall (rInitial :: EffectRow) x.
 Host (Sem rInitial) x -> Sem r x)
-> Sem (Host : r) a -> Sem r a
forall (e :: (* -> *) -> * -> *) (r :: EffectRow) a.
FirstOrder e "interpret" =>
(forall (rInitial :: EffectRow) x. e (Sem rInitial) x -> Sem r x)
-> Sem (e : r) a -> Sem r a
interpret \case
    Host.Request Request
req ->
      Response -> Maybe Response -> Response
forall a. a -> Maybe a -> a
fromMaybe (Request -> Response
invalidMethod Request
req) (Maybe Response -> Response)
-> Sem r (Maybe Response) -> Sem r Response
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> Request -> Sem r (Maybe Response)
forall (r :: EffectRow).
Members
  '[Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Log,
    Final IO]
  r =>
Bool -> Request -> Sem r (Maybe Response)
handle Bool
False Request
req
    Host.Notification Request
req -> do
      Maybe Response
res <- Bool -> Request -> Sem r (Maybe Response)
forall (r :: EffectRow).
Members
  '[Handlers !! Report, Rpc !! RpcError, DataLog LogReport, Log,
    Final IO]
  r =>
Bool -> Request -> Sem r (Maybe Response)
handle Bool
True Request
req
      Bool -> Sem r () -> Sem r ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Response -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Response
res) (Request -> Sem r ()
forall er (r :: EffectRow).
Member (Events er Event) r =>
Request -> Sem r ()
publishEvent Request
req)

register ::
  Members [Handlers !! Report, Error BootError] r =>
  Sem r ()
register :: forall (r :: EffectRow).
Members '[Handlers !! Report, Error BootError] r =>
Sem r ()
register =
  Sem (Handlers : r) ()
forall (r :: EffectRow). Member Handlers r => Sem r ()
Handlers.register Sem (Handlers : r) () -> (Report -> Sem r ()) -> Sem r ()
forall err (eff :: (* -> *) -> * -> *) (r :: EffectRow) a.
Member (Resumable err eff) r =>
Sem (eff : r) a -> (err -> Sem r a) -> Sem r a
!! \ Report
e -> BootError -> Sem r ()
forall e (r :: EffectRow) a. Member (Error e) r => e -> Sem r a
throw (Text -> BootError
BootError [exon|Registering handlers: #{show e}|])

type HostDeps er =
  [
    Handlers !! Report,
    Process RpcMessage (Either Text RpcMessage),
    Rpc !! RpcError,
    DataLog LogReport,
    Events er Event,
    Responses RequestId Response !! RpcError,
    Log,
    Error BootError,
    Resource,
    Mask Restoration,
    Race,
    Async,
    Embed IO,
    Final IO
  ]

withHost ::
  Members (HostDeps er) r =>
  InterpreterFor Host r
withHost :: forall er (r :: EffectRow).
Members (HostDeps er) r =>
InterpreterFor Host r
withHost Sem (Host : r) a
sem =
  Sem (Host : r) a -> Sem r a
forall er (r :: EffectRow).
Members
  '[Handlers !! Report, Rpc !! RpcError, DataLog LogReport,
    Events er Event, Log, Final IO]
  r =>
InterpreterFor Host r
interpretHost do
    Sem (Host : r) () -> Sem (Host : r) a -> Sem (Host : r) a
forall (r :: EffectRow) b a.
Members '[Resource, Race, Async] r =>
Sem r b -> Sem r a -> Sem r a
withAsync_ Sem (Host : r) ()
forall (r :: EffectRow).
(Members '[Host, Process RpcMessage (Either Text RpcMessage)] r,
 Members
   '[Responses RequestId Response !! RpcError, Log, Resource,
     Mask Restoration, Race, Async, Embed IO]
   r) =>
Sem r ()
listener do
      Sem (Host : r) ()
forall (r :: EffectRow).
Members '[Handlers !! Report, Error BootError] r =>
Sem r ()
register
      Sem (Host : r) a
sem

testHost ::
  Members (HostDeps er) r =>
  InterpretersFor [Rpc, Host] r
testHost :: forall er (r :: EffectRow).
Members (HostDeps er) r =>
InterpretersFor '[Rpc, Host] r
testHost =
  Sem (Host : r) a -> Sem r a
forall er (r :: EffectRow).
Members (HostDeps er) r =>
InterpreterFor Host r
withHost (Sem (Host : r) a -> Sem r a)
-> (Sem (Rpc : Host : r) a -> Sem (Host : r) a)
-> Sem (Rpc : Host : r) a
-> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  forall (eff :: (* -> *) -> * -> *) err (r :: EffectRow).
(Show err, Members '[eff !! err, Error BootError] r) =>
InterpreterFor eff r
resumeBootError @Rpc

runHost ::
  Members (HostDeps er) r =>
  Sem r ()
runHost :: forall er (r :: EffectRow). Members (HostDeps er) r => Sem r ()
runHost =
  Sem (Host : r) () -> Sem r ()
forall er (r :: EffectRow).
Members
  '[Handlers !! Report, Rpc !! RpcError, DataLog LogReport,
    Events er Event, Log, Final IO]
  r =>
InterpreterFor Host r
interpretHost do
    Sem (Host : r) () -> Sem (Host : r) () -> Sem (Host : r) ()
forall (r :: EffectRow) b a.
Members '[Resource, Race, Async] r =>
Sem r b -> Sem r a -> Sem r a
withAsync_ Sem (Host : r) ()
forall (r :: EffectRow).
Members '[Handlers !! Report, Error BootError] r =>
Sem r ()
register do
      Sem (Host : r) ()
forall (r :: EffectRow).
(Members '[Host, Process RpcMessage (Either Text RpcMessage)] r,
 Members
   '[Responses RequestId Response !! RpcError, Log, Resource,
     Mask Restoration, Race, Async, Embed IO]
   r) =>
Sem r ()
listener