App.hs

{-# LANGUAGE BlockArguments #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE MultiParamTypeClasses #-}

module RIO.App
  ( App(..)
  , SetupApp
  , appMain
  , nestApp
  ) where

import RIO

import Control.Monad.Trans.Resource (MonadResource(..))
import qualified Control.Monad.Trans.Resource as ResourceT
import RIO.Process (HasProcessContext(..), ProcessContext, mkDefaultProcessContext)

data App env st = App
  { appLogFunc        :: LogFunc
  , appProcessContext :: ProcessContext
  , appResources      :: ResourceT.InternalState
  , appEnv            :: env
  , appState          :: SomeRef st
  }

instance HasLogFunc (App env st) where
  logFuncL =
    lens
      appLogFunc
      \x y -> x{appLogFunc = y}

instance HasProcessContext (App env st) where
  processContextL =
    lens
      appProcessContext
      \x y -> x{appProcessContext = y}

instance MonadResource (RIO (App env st)) where
  liftResourceT action =
    asks appResources >>=
      liftIO . ResourceT.runInternalState action

instance HasStateRef st (App env st) where
  stateRefL =
    lens
      appState
      \x y -> x{appState = y}

{- | Bootstrap environment.

Has logging and hold permanent resources, but no env and state of its own.
Used to setup initial environment and state, that can be derived from allocated resources.
-}
type SetupApp = App () ()

appMain
  :: IO options
  -> (options -> Bool)
  -> (options -> RIO SetupApp (env, st))
  -> RIO (App env st) ()
  -> IO ()
appMain parseOptions verbose setup run = do
  options <- parseOptions

  logFunc <- logOptionsHandle stderr (verbose options)
  appProcessContext <- mkDefaultProcessContext
  stateRef <- newSomeRef ()

  withLogFunc logFunc \appLogFunc ->
    bracket ResourceT.createInternalState ResourceT.closeInternalState \appResources -> do
      let
        setupApp = App
          { appEnv   = ()
          , appState = stateRef
          , ..
          }
      runRIO setupApp $
        nestApp (setup options) run

nestApp
  :: (MonadUnliftIO m, MonadReader (App env st) m)
  => RIO (App env st) (innerEnv, innerSt)
  -> RIO (App innerEnv innerSt) a
  -> m a
nestApp setupNext action =
  bracket ResourceT.createInternalState ResourceT.closeInternalState \nestedResources -> do
    oldApp <- ask
    (innerEnv, innerState) <- runRIO
      oldApp{appResources=nestedResources}
      setupNext
    innerStateRef <- newSomeRef innerState
    let
      nextApp = oldApp
        { appResources = nestedResources
        , appEnv       = innerEnv
        , appState     = innerStateRef
        }
    runRIO nextApp action