-- | Functions to implement 'Api' __servers__.
module Control.Eff.Concurrent.Api.Server
  (
  -- * Api Server
    serve
  , spawnServer
  -- * Api Callbacks
  , ApiHandler(..)
  , unhandledCallError
  , unhandledCastError
  , defaultTermination
  -- * Callback Composition
  , Servable(..)
  , ServerCallback(..)
  , requestHandlerSelector
  , terminationHandler
  )
where

import           Control.Eff
import           Control.Eff.Concurrent.Api
import           Control.Eff.Concurrent.Api.Internal
import           Control.Eff.Concurrent.Process
import           Control.Lens
import           Data.Proxy
import           Data.Typeable                  ( Typeable
                                                , typeRep
                                                )
import           Data.Dynamic
import           Control.Applicative
import           Data.Kind
import           GHC.Stack


-- | A record of callbacks, handling requests sent to a /server/ 'Process', all
-- belonging to a specific 'Api' family instance.
-- The values of this type can be 'serve'ed or combined via 'Servable' or
-- 'ServerCallback's.
data ApiHandler api eff where
  ApiHandler ::
     { -- | A cast will not return a result directly. This is used for async
       -- methods.
       _handleCast
         :: HasCallStack
         => Api api 'Asynchronous -> Eff eff ()
      -- | A call is a blocking operation, the caller is blocked until this
      -- handler calls the reply continuation.
     , _handleCall
         :: forall reply . HasCallStack
         => Api api ('Synchronous reply) -> (reply -> Eff eff ()) -> Eff eff ()
     -- | 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 eff ()
     } -> ApiHandler api eff


-- | Building block for composition of 'ApiHandler'.
-- A wrapper for 'ApiHandler'. Use this to combine 'ApiHandler', allowing a
-- process to implement several 'Api' instances. The termination will be evenly
-- propagated.
-- Create this via e.g. 'Servable' instances
-- To serve multiple apis use '<>' to combine server callbacks, e.g.
--
-- @@@
-- let f = apiHandlerServerCallback px $ ApiHandler ...
--     g = apiHandlerServerCallback px $ ApiHandler ...
--     h = f <> g
-- in serve px h
-- @@@
--
data ServerCallback eff =
  ServerCallback { _requestHandlerSelector :: MessageSelector (Eff eff ())
                 , _terminationHandler :: Maybe String -> Eff eff ()
                 }

makeLenses ''ServerCallback

instance Semigroup (ServerCallback eff) where
  l <> r = l & requestHandlerSelector .~
                  MessageSelector (\x ->
                    runMessageSelector (view requestHandlerSelector l) x <|>
                    runMessageSelector (view requestHandlerSelector r) x)
             & terminationHandler .~
                  (\errorMessage ->
                      do (l^.terminationHandler) errorMessage
                         (r^.terminationHandler) errorMessage)

instance Monoid (ServerCallback eff) where
  mappend = (<>)
  mempty = ServerCallback
              { _requestHandlerSelector = MessageSelector (const Nothing)
              , _terminationHandler = const (return ())
              }

-- | Helper type class to allow composition of 'ApiHandler'.
class Servable a where
  -- | The effect of the callbacks
  type ServerEff a :: [Type -> Type]
  -- | The is used to let the spawn function return multiple 'Server' 'ProcessId's
  -- in a type safe way, e.g. for a tuple instance of this class
  -- @(Server a, Server b)@
  type ServerPids a
  -- | The is used to let the spawn function return multiple 'Server' 'ProcessId's
  -- in a type safe way.
  toServerPids :: proxy a -> ProcessId -> ServerPids a
  -- | Convert the value to a 'ServerCallback'
  toServerCallback :: (SetMember Process (Process effScheduler) (ServerEff a))
    => SchedulerProxy effScheduler -> a -> ServerCallback (ServerEff a)

instance Servable (ServerCallback eff)  where
  type ServerEff (ServerCallback eff) = eff
  type ServerPids (ServerCallback eff) = ProcessId
  toServerCallback  = const id
  toServerPids = const id

instance Typeable a => Servable (ApiHandler a eff)  where
  type ServerEff (ApiHandler a eff) = eff
  type ServerPids (ApiHandler a eff) = Server a
  toServerCallback  = apiHandlerServerCallback
  toServerPids _ = asServer

instance (ServerEff a ~ ServerEff b, Servable a, Servable b) => Servable (a, b) where
  type ServerPids (a, b) = (ServerPids a, ServerPids b)
  type ServerEff (a, b) = ServerEff a
  toServerCallback px (a, b) = toServerCallback px a <> toServerCallback px b
  toServerPids _ pid =
    ( toServerPids (Proxy :: Proxy a) pid
    , toServerPids (Proxy :: Proxy b) pid
    )

-- | Receive and process incoming requests until the process exits.
serve
  :: forall a effScheduler
   . ( Servable a
     , SetMember Process (Process effScheduler) (ServerEff a)
     , HasCallStack
     )
  => SchedulerProxy effScheduler
  -> a
  -> Eff (ServerEff a) ()
serve px a =
  let serverCb = toServerCallback px a
  in  receiveLoopSuchThat px (serverCb ^. requestHandlerSelector) $ \case
        Left  reason   -> (serverCb ^. terminationHandler) reason
        Right handleIt -> handleIt

-- | Spawn a new process, that will receive and process incoming requests
-- until the process exits. Also handle all internal effects.
spawnServer
  :: forall a effScheduler eff
   . ( Servable a
     , SetMember Process (Process effScheduler) (ServerEff a)
     , SetMember Process (Process effScheduler) eff
     , HasCallStack
     )
  => SchedulerProxy effScheduler
  -> a
  -> (  Eff (ServerEff a) ()
     -> Eff (Process effScheduler ': effScheduler) ()
     )
  -> Eff eff (ServerPids a)
spawnServer px a handleEff = do
  pid <- spawn (handleEff (serve px a))
  return (toServerPids (Proxy @a) pid)

-- | Wrap an 'ApiHandler' into a composable 'ServerCallback' value.
apiHandlerServerCallback
  :: forall eff effScheduler api
   . ( HasCallStack
     , Typeable api
     , SetMember Process (Process effScheduler) eff
     )
  => SchedulerProxy effScheduler
  -> ApiHandler api eff
  -> ServerCallback eff
apiHandlerServerCallback px handlers = mempty
  { _requestHandlerSelector = selectHandlerMethod px handlers
  , _terminationHandler     = _handleTerminate handlers
  }

-- | Try to parse an incoming message to an API request, and apply either
-- the 'handleCall' method or the 'handleCast' method to it.
selectHandlerMethod
  :: forall eff effScheduler api
   . ( HasCallStack
     , Typeable api
     , SetMember Process (Process effScheduler) eff
     )
  => SchedulerProxy effScheduler
  -> ApiHandler api eff
  -> MessageSelector (Eff eff ())
selectHandlerMethod px handlers =
  MessageSelector (fmap (applyHandlerMethod px handlers) . fromDynamic)

-- | Apply either the '_handleCall', '_handleCast' or the '_handleTerminate'
-- callback to an incoming request.
applyHandlerMethod
  :: forall eff effScheduler api
   . ( Typeable api
     , SetMember Process (Process effScheduler) eff
     , HasCallStack
     )
  => SchedulerProxy effScheduler
  -> ApiHandler api eff
  -> Request api
  -> Eff eff ()
applyHandlerMethod _px handlers (Terminate e) = _handleTerminate handlers e
applyHandlerMethod _ handlers (Cast request) = _handleCast handlers request
applyHandlerMethod px handlers (Call fromPid request) = _handleCall handlers
                                                                    request
                                                                    sendReply
 where
  sendReply :: Typeable reply => reply -> Eff eff ()
  sendReply reply =
    sendMessage px fromPid (toDyn $! (Response (Proxy @api) $! 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 _ = withFrozenCallStack $ 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 = withFrozenCallStack $ 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 =
  withFrozenCallStack $ maybe (exitNormally px) (exitWithError px)