{-# options_haddock prune #-}

-- |Classes for converting functions to RPC handlers that may have special parameters.
module Ribosome.Host.Handler.Codec where

import Data.Aeson (eitherDecodeStrict')
import qualified Data.ByteString as ByteString
import Data.MessagePack (Object)
import qualified Data.Text as Text
import Exon (exon)
import qualified Options.Applicative as Optparse
import Options.Applicative (defaultPrefs, execParserPure, info, renderFailure)

import Ribosome.Host.Class.Msgpack.Decode (MsgpackDecode (fromMsgpack), fromMsgpackText)
import Ribosome.Host.Class.Msgpack.Encode (MsgpackEncode (toMsgpack))
import Ribosome.Host.Data.Args (
  ArgList (ArgList),
  Args (Args),
  JsonArgs (JsonArgs),
  OptionParser (optionParser),
  Options (Options),
  )
import Ribosome.Host.Data.Bang (Bang (NoBang))
import Ribosome.Host.Data.Bar (Bar (Bar))
import Ribosome.Host.Data.Report (Report, basicReport, toReport)
import Ribosome.Host.Data.RpcHandler (Handler, RpcHandlerFun)

decodeArg ::
  Member (Stop Report) r =>
  MsgpackDecode a =>
  Object ->
  Sem r a
decodeArg :: forall (r :: EffectRow) a.
(Member (Stop Report) r, MsgpackDecode a) =>
Object -> Sem r a
decodeArg =
  Either Report a -> Sem r a
forall err (r :: EffectRow) a.
Member (Stop err) r =>
Either err a -> Sem r a
stopEither (Either Report a -> Sem r a)
-> (Object -> Either Report a) -> Object -> Sem r a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DecodeError -> Report) -> Either DecodeError a -> Either Report a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first DecodeError -> Report
forall e. Reportable e => e -> Report
toReport (Either DecodeError a -> Either Report a)
-> (Object -> Either DecodeError a) -> Object -> Either Report a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Object -> Either DecodeError a
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack

extraError ::
  Member (Stop Report) r =>
  [Object] ->
  Sem r a
extraError :: forall (r :: EffectRow) a.
Member (Stop Report) r =>
[Object] -> Sem r a
extraError [Object]
o =
  Report -> Sem r a
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop (String -> Report
forall a. IsString a => String -> a
fromString [exon|Extraneous arguments: #{show o}|])

optArg ::
  Member (Stop Report) r =>
  MsgpackDecode a =>
  a ->
  [Object] ->
  Sem r ([Object], a)
optArg :: forall (r :: EffectRow) a.
(Member (Stop Report) r, MsgpackDecode a) =>
a -> [Object] -> Sem r ([Object], a)
optArg a
dflt = \case
  [] -> ([Object], a) -> Sem r ([Object], a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], a
dflt)
  (Object
o : [Object]
rest) -> do
    a
a <- Object -> Sem r a
forall (r :: EffectRow) a.
(Member (Stop Report) r, MsgpackDecode a) =>
Object -> Sem r a
decodeArg Object
o
    pure ([Object]
rest, a
a)

-- |This class is used by 'HandlerCodec' to decode handler function parameters.
-- Each parameter may consume zero or arbitrarily many of the RPC message's arguments.
--
-- Users may create instances for their types to implement custom decoding, especially for commands, since those don't
-- have structured arguments.
--
-- See also 'Ribosome.CommandHandler'.
class HandlerArg a r where
  -- Take an arbitrary number of arguments from the list and return a value of type @a@ as well as the remaining
    -- arguments.
  handlerArg :: [Object] -> Sem r ([Object], a)

instance {-# overlappable #-} (
    Member (Stop Report) r,
    MsgpackDecode a
  ) => HandlerArg a r where
    handlerArg :: [Object] -> Sem r ([Object], a)
handlerArg = \case
      [] -> Report -> Sem r ([Object], a)
forall e (r :: EffectRow) a. Member (Stop e) r => e -> Sem r a
stop Report
"too few arguments"
      (Object
o : [Object]
rest) -> do
        a
a <- Object -> Sem r a
forall (r :: EffectRow) a.
(Member (Stop Report) r, MsgpackDecode a) =>
Object -> Sem r a
decodeArg Object
o
        pure ([Object]
rest, a
a)

instance (
    HandlerArg a r
  ) => HandlerArg (Maybe a) r where
    handlerArg :: [Object] -> Sem r ([Object], Maybe a)
handlerArg = \case
      [] -> ([Object], Maybe a) -> Sem r ([Object], Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Maybe a
forall a. Maybe a
Nothing)
      [Object]
os -> (a -> Maybe a) -> ([Object], a) -> ([Object], Maybe a)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second a -> Maybe a
forall a. a -> Maybe a
Just (([Object], a) -> ([Object], Maybe a))
-> Sem r ([Object], a) -> Sem r ([Object], Maybe a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Object] -> Sem r ([Object], a)
forall a (r :: EffectRow).
HandlerArg a r =>
[Object] -> Sem r ([Object], a)
handlerArg [Object]
os

instance HandlerArg Bar r where
  handlerArg :: [Object] -> Sem r ([Object], Bar)
handlerArg [Object]
os =
    ([Object], Bar) -> Sem r ([Object], Bar)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Object]
os, Bar
Bar)

instance (
    Member (Stop Report) r
  ) => HandlerArg Bang r where
    handlerArg :: [Object] -> Sem r ([Object], Bang)
handlerArg =
      Bang -> [Object] -> Sem r ([Object], Bang)
forall (r :: EffectRow) a.
(Member (Stop Report) r, MsgpackDecode a) =>
a -> [Object] -> Sem r ([Object], a)
optArg Bang
NoBang

instance (
    Member (Stop Report) r
  ) => HandlerArg Args r where
  handlerArg :: [Object] -> Sem r ([Object], Args)
handlerArg [Object]
os =
    case (Object -> Either DecodeError Text)
-> [Object] -> Either DecodeError [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> Either DecodeError Text
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack [Object]
os of
      Right [Text]
a ->
        ([Object], Args) -> Sem r ([Object], Args)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Text -> Args
Args ([Text] -> Text
Text.unwords [Text]
a))
      Left DecodeError
e ->
        Text -> [Text] -> Sem r ([Object], Args)
forall (r :: EffectRow) a.
(Member (Stop Report) r, HasCallStack) =>
Text -> [Text] -> Sem r a
basicReport [exon|Invalid arguments: #{show os}|] [Item [Text]
"Invalid type for Args", [Object] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Object]
os, DecodeError -> Text
forall b a. (Show a, IsString b) => a -> b
show DecodeError
e]

instance (
    Member (Stop Report) r
  ) => HandlerArg ArgList r where
  handlerArg :: [Object] -> Sem r ([Object], ArgList)
handlerArg [Object]
os =
    case (Object -> Either DecodeError Text)
-> [Object] -> Either DecodeError [Text]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> Either DecodeError Text
forall a. MsgpackDecode a => Object -> Either DecodeError a
fromMsgpack [Object]
os of
      Right [Text]
a ->
        ([Object], ArgList) -> Sem r ([Object], ArgList)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], [Text] -> ArgList
ArgList [Text]
a)
      Left DecodeError
e ->
        Text -> [Text] -> Sem r ([Object], ArgList)
forall (r :: EffectRow) a.
(Member (Stop Report) r, HasCallStack) =>
Text -> [Text] -> Sem r a
basicReport [exon|Invalid arguments: #{show os}|] [Item [Text]
"Invalid type for ArgList", [Object] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Object]
os, DecodeError -> Text
forall b a. (Show a, IsString b) => a -> b
show DecodeError
e]

instance (
    Member (Stop Report) r,
    FromJSON a
  ) => HandlerArg (JsonArgs a) r where
  handlerArg :: [Object] -> Sem r ([Object], JsonArgs a)
handlerArg [Object]
os =
    case (String -> Text) -> Either String a -> Either Text a
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first String -> Text
forall a. ToText a => a -> Text
toText (Either String a -> Either Text a)
-> ([ByteString] -> Either String a)
-> [ByteString]
-> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Either String a
forall a. FromJSON a => ByteString -> Either String a
eitherDecodeStrict' (ByteString -> Either String a)
-> ([ByteString] -> ByteString) -> [ByteString] -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [ByteString] -> ByteString
ByteString.concat ([ByteString] -> Either Text a)
-> Either Text [ByteString] -> Either Text a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object -> Either Text ByteString)
-> [Object] -> Either Text [ByteString]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> Either Text ByteString
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpackText [Object]
os of
      Right a
a ->
        ([Object], JsonArgs a) -> Sem r ([Object], JsonArgs a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], a -> JsonArgs a
forall a. a -> JsonArgs a
JsonArgs a
a)
      Left Text
e ->
        Text -> [Text] -> Sem r ([Object], JsonArgs a)
forall (r :: EffectRow) a.
(Member (Stop Report) r, HasCallStack) =>
Text -> [Text] -> Sem r a
basicReport [exon|Invalid arguments: #{show os}|] [Item [Text]
"Invalid type for JsonArgs", [Object] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Object]
os, Text
Item [Text]
e]

instance (
    Member (Stop Report) r,
    OptionParser a
  ) => HandlerArg (Options a) r where
  handlerArg :: [Object] -> Sem r ([Object], Options a)
handlerArg [Object]
os =
    case ParserResult a -> Either Text a
forall {b}. ParserResult b -> Either Text b
result (ParserResult a -> Either Text a)
-> ([String] -> ParserResult a) -> [String] -> Either Text a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
forall a. ParserPrefs -> ParserInfo a -> [String] -> ParserResult a
execParserPure ParserPrefs
defaultPrefs (Parser a -> InfoMod a -> ParserInfo a
forall a. Parser a -> InfoMod a -> ParserInfo a
info (forall a. OptionParser a => Parser a
optionParser @a) InfoMod a
forall a. Monoid a => a
mempty) ([String] -> Either Text a)
-> Either Text [String] -> Either Text a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Object -> Either Text String) -> [Object] -> Either Text [String]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Object -> Either Text String
forall a. MsgpackDecode a => Object -> Either Text a
fromMsgpackText [Object]
os of
      Right a
a ->
        ([Object], Options a) -> Sem r ([Object], Options a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], a -> Options a
forall a. a -> Options a
Options a
a)
      Left Text
e ->
        Text -> [Text] -> Sem r ([Object], Options a)
forall (r :: EffectRow) a.
(Member (Stop Report) r, HasCallStack) =>
Text -> [Text] -> Sem r a
basicReport [exon|Invalid arguments: #{show os}|] [Item [Text]
"Invalid type for Options", [Object] -> Text
forall b a. (Show a, IsString b) => a -> b
show [Object]
os, Text
Item [Text]
e]
    where
      result :: ParserResult b -> Either Text b
result = \case
        Optparse.Success b
a -> b -> Either Text b
forall a b. b -> Either a b
Right b
a
        Optparse.Failure ParserFailure ParserHelp
e -> Text -> Either Text b
forall a b. a -> Either a b
Left (String -> Text
forall a. ToText a => a -> Text
toText ((String, ExitCode) -> String
forall a b. (a, b) -> a
fst (ParserFailure ParserHelp -> String -> (String, ExitCode)
renderFailure ParserFailure ParserHelp
e String
"Ribosome")))
        Optparse.CompletionInvoked CompletionResult
_ -> Text -> Either Text b
forall a b. a -> Either a b
Left Text
"Internal optparse error"

-- |The class of functions that can be converted to canonical RPC handlers of type 'RpcHandlerFun'.
class HandlerCodec h r | h -> r where
  -- |Convert a type containing a 'Sem' to a canonicalized 'RpcHandlerFun' by transforming each function parameter with
  -- 'HandlerArg'.
  handlerCodec :: h -> RpcHandlerFun r

instance (
    MsgpackEncode a
  ) => HandlerCodec (Handler r a) r where
    handlerCodec :: Handler r a -> RpcHandlerFun r
handlerCodec Handler r a
h = \case
      [] -> a -> Object
forall a. MsgpackEncode a => a -> Object
toMsgpack (a -> Object) -> Handler r a -> Sem (Stop Report : r) Object
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Handler r a
h
      [Object]
o -> RpcHandlerFun r
forall (r :: EffectRow) a.
Member (Stop Report) r =>
[Object] -> Sem r a
extraError [Object]
o

instance (
    HandlerArg a (Stop Report : r),
    HandlerCodec b r
  ) => HandlerCodec (a -> b) r where
  handlerCodec :: (a -> b) -> RpcHandlerFun r
handlerCodec a -> b
h [Object]
o = do
    ([Object]
rest, a
a) <- [Object] -> Sem (Stop Report : r) ([Object], a)
forall a (r :: EffectRow).
HandlerArg a r =>
[Object] -> Sem r ([Object], a)
handlerArg [Object]
o
    b -> RpcHandlerFun r
forall h (r :: EffectRow). HandlerCodec h r => h -> RpcHandlerFun r
handlerCodec (a -> b
h a
a) [Object]
rest