{-# 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 #-}

-- | Functions to implement 'Api' __servers__.

module Control.Eff.Concurrent.Api.Server
  (
  -- * Api Server
    serve
  , ApiHandler(..)
  -- * ApiHandler default callbacks
  , unhandledCallError
  , unhandledCastError
  , defaultTermination
  -- * Multi Api Server
  , serveBoth
  , serve3
  , tryApiHandler
  , UnhandledRequest()
  , catchUnhandled
  , ensureAllHandled
  , requestFromDynamic
  , 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 and process incoming requests until the process exits, using an 'ApiHandler'.
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 <- requestFromDynamic dyn
      raise (applyApiHandler px handlers msg)
    )

-- | A record of callbacks, handling requests sent to a /server/ 'Process', all
-- belonging to 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 ()) -> 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'. Note, it is unlikely that this function must be used.
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 ()
  sendReply reply =
    sendMessage px fromPid (toDyn $! (Response (Proxy @p) $! reply))

-- | 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 ())
  -> 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


-- | '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 'requestFromDynamic' 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 <- requestFromDynamic 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 'requestFromDynamic'. 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 'requestFromDynamic' 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.
requestFromDynamic
  :: forall r a
   . (HasCallStack, Typeable a, Member (Exc.Exc UnhandledRequest) r)
  => Dynamic
  -> Eff r a
requestFromDynamic 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 'requestFromDynamic') 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