{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE DeriveFunctor #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE GADTs #-}

-- | Type safe /server/ API processes

module Control.Eff.Concurrent.Api.Server
  ( ApiHandler (..)
  , serve
  , unhandledCallError
  , unhandledCastError
  , defaultTermination
  , serveBoth
  , serve3
  , tryApiHandler
  , UnhandledRequest()
  , catchUnhandled
  , ensureAllHandled
  , castMessage
  , exitUnhandled
  )
where

import           Control.Eff
import           Control.Eff.InternalExtra
import qualified Control.Eff.Exception as Exc
import           Control.Eff.Concurrent.Api
import           Control.Eff.Concurrent.Api.Internal
import           Control.Eff.Concurrent.Process
import           Data.Proxy
import           Data.Typeable (Typeable, typeRep)
import           Data.Dynamic
import           GHC.Stack

-- | Receive messages until the process exits and invoke the callback on each
-- message.
serve
  :: forall r q p
   . (Typeable p, SetMember Process (Process q) r, HasCallStack)
  => SchedulerProxy q
  -> ApiHandler p r
  -> Eff r ()
serve px handlers =
  receiveLoop px
   $ \ mReq ->
       case mReq of
        Left Nothing ->
          applyApiHandler px handlers (Terminate Nothing)
        Left (Just reason) ->
          applyApiHandler px handlers (Terminate (Just reason))
        Right dyn ->
          ensureAllHandled px
            (do msg <- castMessage dyn
                raise (applyApiHandler px handlers msg))

-- | A record of callbacks requests to a /server/, serving a specific 'Api' family instance.
data ApiHandler p r where
  ApiHandler ::
     { -- | A cast will not return a result directly. This is used for async
       -- methods.
       _handleCast
         :: HasCallStack
         => Api p 'Asynchronous -> Eff r ()
      -- | A call is a blocking operation, the caller is blocked until this
      -- handler calls the reply continuation.
     , _handleCall
         :: forall x . HasCallStack
         => Api p ('Synchronous x) -> (x -> Eff r Bool) -> Eff r ()
     -- | This callback is called with @Nothing@ if the process exits
     -- peacefully, or @Just "error message..."@ if the process exits with an
     -- error. This function is responsible to exit the process if necessary.
     -- The default behavior is defined in 'defaultTermination'.
     , _handleTerminate
         :: HasCallStack
         => Maybe String -> Eff r ()
     } -> ApiHandler p r

-- | Apply either the '_handleCall', '_handleCast' or the '_handleTerminate'
-- callback to an incoming 'Request'.
applyApiHandler :: forall r q p
                . ( Typeable p
                  , SetMember Process (Process q) r
                  , HasCallStack)
              => SchedulerProxy q
              -> ApiHandler p r
              -> Request p
              -> Eff r ()
applyApiHandler _px handlers (Terminate e) =
  _handleTerminate handlers e
applyApiHandler _ handlers (Cast request        ) =
  _handleCast handlers request
applyApiHandler px handlers (Call fromPid request) =
  _handleCall handlers request sendReply
      where
       sendReply :: Typeable x => x -> Eff r Bool
       sendReply reply =
         sendMessage px fromPid (toDyn (Response (Proxy @p) reply))

-- * ApiHandler default callbacks

-- | A default handler to use in '_handleCall' in 'ApiHandler'. It will call
-- 'raiseError' with a nice error message.
unhandledCallError
  :: forall p x r q .
    ( Show (Api p ( 'Synchronous x))
    , Typeable p
    , HasCallStack
    , SetMember Process (Process q) r
    )
  => SchedulerProxy q
  -> Api p ( 'Synchronous x)
  -> (x -> Eff r Bool)
  -> Eff r ()
unhandledCallError px api _ = raiseError px
  ("Unhandled call: ("
    ++ show api
    ++ " :: "
    ++ show (typeRep (Proxy @p)) ++ ")")

-- | A default handler to use in '_handleCast' in 'ApiHandler'. It will call
-- 'raiseError' with a nice error message.
unhandledCastError
  :: forall p r q .
    ( Show (Api p 'Asynchronous)
    , Typeable p
    , HasCallStack
    , SetMember Process (Process q) r
    )
  => SchedulerProxy q
  -> Api p 'Asynchronous
  -> Eff r ()
unhandledCastError px api = raiseError px
  ("Unhandled cast: ("
    ++ show api
    ++ " :: "
    ++ show (typeRep (Proxy @p)) ++ ")")

-- | Exit the process either normally of the error message is @Nothing@
-- or with 'exitWithError' otherwise.
defaultTermination :: forall q r .
                     ( HasCallStack, SetMember Process (Process q) r )
                   => SchedulerProxy q
                   -> Maybe String
                   -> Eff r ()
defaultTermination px e =
   maybe (exitNormally px) (exitWithError px) e

-- * Multiple ApiHandler combined

-- | 'serve' two 'ApiHandler's at once. The first handler is used for
-- termination handling.
serveBoth :: forall r q p1 p2
          . ( Typeable p1, Typeable p2
            , SetMember Process (Process q) r
            , HasCallStack)
       => SchedulerProxy q
       -> ApiHandler p1 r -> ApiHandler p2 r
       -> Eff r ()
serveBoth px h1 h2 =
  receiveLoop px
   $ \ mReq ->
       case mReq of
        Left Nothing ->
          applyApiHandler px h1 (Terminate Nothing)
        Left (Just reason) ->
          applyApiHandler px h1 (Terminate (Just reason))
        Right dyn ->
          ensureAllHandled px
            (tryApiHandler px h1 dyn
              `catchUnhandled`
              tryApiHandler px h2)

-- | 'serve' three 'ApiHandler's at once. The first handler is used for
-- termination handling.
serve3 :: forall r q p1 p2 p3
          . ( Typeable p1, Typeable p2, Typeable p3
            , SetMember Process (Process q) r
            , HasCallStack)
       => SchedulerProxy q
       -> ApiHandler p1 r -> ApiHandler p2 r -> ApiHandler p3 r
       -> Eff r ()
serve3 px h1 h2 h3 =
  receiveLoop px
   $ \ mReq ->
       case mReq of
        Left Nothing ->
          applyApiHandler px h1 (Terminate Nothing)
        Left (Just reason) ->
          applyApiHandler px h1 (Terminate (Just reason))
        Right dyn ->
          ensureAllHandled px
            (tryApiHandler px h1 dyn
              `catchUnhandled`
              tryApiHandler px h2
              `catchUnhandled`
              tryApiHandler px h3)

-- | The basic building block of the combination of 'ApiHandler's is this
-- function, which can not only be passed to 'receiveLoop', but also throws an
-- 'UnhandledRequest' exception if 'castMessage' failed, such that multiple
-- invokation of this function for different 'ApiHandler's can be tried, by using 'catchUnhandled'.
--
-- > tryApiHandler px handlers1 message
-- >   `catchUnhandled`
-- > tryApiHandler px handlers2
-- >   `catchUnhandled`
-- > tryApiHandler px handlers3
--
tryApiHandler  :: forall r q p
                . ( Typeable p
                  , SetMember Process (Process q) r
                  , HasCallStack)
              => SchedulerProxy q
              -> ApiHandler p r
              -> Dynamic
              -> Eff (Exc.Exc UnhandledRequest ': r) ()
tryApiHandler px handlers message =
  do request <- castMessage message
     raise (applyApiHandler px handlers request)

-- | An exception that is used by the mechanism that chains together multiple
-- different 'ApiHandler' allowing a single process to implement multiple
-- 'Api's. This exception is thrown by 'castMessage'. This
-- exception can be caught with 'catchUnhandled', this way, several
-- distinct 'ApiHandler' can be tried until one /fits/ or until the
-- 'exitUnhandled' is invoked.
newtype UnhandledRequest = UnhandledRequest { fromUnhandledRequest :: Dynamic }

-- | If 'castMessage' failes to cast the message to a 'Request' for a
-- certain 'ApiHandler' it throws an 'UnhandledRequest' exception. That
-- exception is caught by this function and the raw message is given to the
-- handler function. This is the basis for chaining 'ApiHandler's.
catchUnhandled
  :: forall r a .
    ( Member (Exc.Exc UnhandledRequest) r
    , HasCallStack)
  => Eff r a
  -> (Dynamic -> Eff r a)
  -> Eff r a
catchUnhandled effect handler =
  effect `Exc.catchError` (handler . fromUnhandledRequest)

-- | Catch 'UnhandledRequest's and terminate the process with an error, if necessary.
ensureAllHandled
  :: forall r q .
    (HasCallStack, SetMember Process (Process q) r)
  => SchedulerProxy q
  -> Eff (Exc.Exc UnhandledRequest ': r) ()
  -> Eff r ()
ensureAllHandled px effect =
  do result <- Exc.runError effect
     either (exitUnhandled px . fromUnhandledRequest) return result

-- | Cast a 'Dynamic' value, and if that fails, throw an 'UnhandledRequest'
-- error.
castMessage :: forall r a .
              ( HasCallStack
              , Typeable a
              , Member (Exc.Exc UnhandledRequest) r)
            => Dynamic -> Eff r a
castMessage message =
  maybe
  (Exc.throwError (UnhandledRequest message))
  return
  (fromDynamic message)

-- | If an incoming message could not be casted to a 'Request' corresponding to
-- an 'ApiHandler' (e.g. with 'castMessage') one should use this function to
-- exit the process with a corresponding error.
exitUnhandled
  :: forall r q . (SetMember Process (Process q) r, HasCallStack)
  => SchedulerProxy q
  -> Dynamic
  -> Eff r ()
exitUnhandled px message =
  do let reason = "unhandled message: " ++ show message
     exitWithError px reason