-- | Micro-framework for building a non-web application
--
-- This is a version of the /ReaderT Design Pattern/.
--
-- <https://www.fpcomplete.com/blog/2017/06/readert-design-pattern>
--
-- == Basic Usage
--
-- Start by defining a type to hold your global application state:
--
-- > data App = App
-- >   { appDryRun :: Bool
-- >   , appLogger :: Logger
-- >   }
--
-- This type can be as complex or simple as you want. It might hold a separate
-- @Config@ attribute or may keep everything as one level of properties. It
-- could even hold an @'IORef'@ if you need mutable application state.
--
-- The only requirements are 'HasLogger':
--
-- > instance HasLogger App where
-- >   loggerL = lens appLogger $ \x y -> x { appLogger = y }
--
-- and a bracketed function for building and using a value:
--
-- > loadApp :: (App -> m a) -> m a
-- > loadApp f = do
-- >   app <- -- ...
-- >   f app
--
-- It's likely you'll want to use @"Freckle.App.Env"@ to load your @App@:
--
-- > import qualified Blammo.Logger.LogSettings.Env as LoggerEnv
-- > import qualified Freckle.App.Env as Env
-- >
-- > loadApp f = do
-- >   app <- Env.parse id $ App
-- >     <$> Env.switch "DRY_RUN" mempty
-- >     <*> LoggerEnv.parser
--
-- Now you have application-specific actions that can do IO, log, and access
-- your state:
--
-- > myAppAction :: (MonadIO m, MonadLogger m, MonadReader App env) => m ()
-- > myAppAction = do
-- >   isDryRun <- asks appDryRun
-- >
-- >   if isDryRun
-- >     then logWarn "Skipping due to dry-run"
-- >     else liftIO $ fireTheMissles
--
-- These actions can be (composed of course, or) invoked by a @main@ that
-- handles the reader context and evaluating the logging action.
--
-- > main :: IO ()
-- > main = do
-- >   runApp loadApp $ do
-- >     myAppAction
-- >     myOtherAppAction
--
-- == 'AppT'
--
-- Functions like @myAppAction@ will be run in the concrete stack 'AppT', but
-- you should prefer using using constraints (e.g. @'MonadReader' app@). See its
-- docs for all the constraints it satisfies.
--
-- == Database
--
-- Adding Database access requires a few more instances on your @App@ type:
--
-- - @'HasSqlPool'@: so we can, you know, talk to a DB
-- - @'HasStatsClient'@: so we can manage connection count metrics
--
-- Most often, this will be easiest if you indeed separate a @Config@ attribute:
--
-- > data Config = Config
-- >   { configDbPoolSize :: Int
-- >   , configLogSettings :: LogSettings
-- >   , configStatsSettings :: StatsSettings
-- >   }
--
-- So you can isolate Env-related concerns
--
-- > loadConfig :: IO Config
-- > loadConfig = Env.parse id $ Config
-- >   <$> Env.var Env.auto "PGPOOLSIZE" (Env.def 1)
-- >   <*> LoggerEnv.parser
-- >   <*> envParseStatsSettings
--
-- from the runtime application state:
--
-- > data App = App
-- >   { appConfig :: Config
-- >   , appLogger :: Logger
-- >   , appSqlPool :: SqlPool
-- >   , appStatsClient :: StatsClient
-- >   }
-- >
-- > instance HasLogger App where
-- >   loggerL = appLogger $ \x y -> x { appLogger = y }
-- >
-- > instance HasSqlPool App where
-- >   getSqlPool = appSqlPool
-- >
-- > instance HasStatsClient App where
-- >   statsClientL = lens appStatsClient $ \x y -> x { appStatsClient = y }
--
-- The @"Freckle.App.Database"@ module provides @'makePostgresPool'@ for
-- building a Pool given this (limited) config data:
--
-- > loadApp :: (App -> IO a) -> IO a
-- > loadApp f = do
-- >   appConfig{..} <- loadConfig
-- >   appLogger <- newLogger configLoggerSettings
-- >   appSqlPool <- runLoggerLoggingT appLogger $ makePostgresPool configDbPoolSize
-- >   withStatsClient configStatsSettings $ \appStatsClient -> do
-- >     f App{..}
--
-- This unlocks @'runDB'@ for your application:
--
-- > myAppAction
-- >   :: ( MonadUnliftIO m
-- >      , MonadReader env m
-- >      , HasSqlPool env
-- >      , HasStatsClient env
-- >      )
-- >   => SqlPersistT m [Entity Something]
-- > myAppAction = runDB $ selectList [] []
--
-- == Testing
--
-- @"Freckle.App.Test"@ exposes an @'AppExample'@ type for examples in a
-- @'SpecWith' App@ spec. The can be run by giving your @loadApp@ function to
-- Hspec's @'aroundAll'@.
--
-- Using MTL-style constraints (i.e. 'MonadReader') means you can use your
-- actions directly in expectations, but you may need some type annotations:
--
-- > spec :: Spec
-- > spec = aroundAll loadApp $ do
-- >   describe "myAppAction" $ do
-- >     it "works" $ do
-- >       result <- myAppAction :: AppExample App Text
-- >       result `shouldBe` "as expected"
--
-- If your @App@ type has the required instances, you can use 'runDB' in your
-- specs too:
--
-- > spec :: Spec
-- > spec = aroundAll loadApp $ do
-- >   describe "myQuery" $ do
-- >     it "works" $ do
-- >       result <- runDB myQuery :: AppExample App Text
-- >       result `shouldBe` "as expected"
--
module Freckle.App
  ( runApp
  , setLineBuffering

  -- * Concrete transformer stack
  , AppT(..)
  , runAppT

  -- * Re-exports
  , module Freckle.App.Database
  , module Freckle.App.OpenTelemetry
  , module Blammo.Logging
  , module Control.Monad.Reader
  ) where

import Freckle.App.Prelude

import Blammo.Logging
import Control.Monad.Catch (MonadCatch, MonadThrow)
import Control.Monad.IO.Unlift (MonadUnliftIO(..))
import Control.Monad.Primitive (PrimMonad(..))
import Control.Monad.Reader
import Control.Monad.Trans.Resource (MonadResource, ResourceT, runResourceT)
import Freckle.App.Database
import Freckle.App.OpenTelemetry
import System.IO (BufferMode(..), hSetBuffering, stderr, stdout)

runApp
  :: HasLogger app
  => (forall b . (app -> IO b) -> IO b)
  -> AppT app IO a
  -> IO a
runApp :: forall app a.
HasLogger app =>
(forall b. (app -> IO b) -> IO b) -> AppT app IO a -> IO a
runApp forall b. (app -> IO b) -> IO b
loadApp AppT app IO a
action = do
  forall (m :: * -> *). MonadIO m => m ()
setLineBuffering
  forall b. (app -> IO b) -> IO b
loadApp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) app a.
(MonadUnliftIO m, HasLogger app) =>
AppT app m a -> app -> m a
runAppT AppT app IO a
action

-- | Ensure output is streamed if in a Docker container
--
-- 'runApp' calls this for you, but it may be useful if you're running the app
-- some other way.
--
setLineBuffering :: MonadIO m => m ()
setLineBuffering :: forall (m :: * -> *). MonadIO m => m ()
setLineBuffering = forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO forall a b. (a -> b) -> a -> b
$ do
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  Handle -> BufferMode -> IO ()
hSetBuffering Handle
stderr BufferMode
LineBuffering

newtype AppT app m a = AppT
  { forall app (m :: * -> *) a.
AppT app m a -> ReaderT app (LoggingT (ResourceT m)) a
unAppT :: ReaderT app (LoggingT (ResourceT m)) a
  }
  deriving newtype
    ( forall a b. a -> AppT app m b -> AppT app m a
forall a b. (a -> b) -> AppT app m a -> AppT app m b
forall app (m :: * -> *) a b.
Functor m =>
a -> AppT app m b -> AppT app m a
forall app (m :: * -> *) a b.
Functor m =>
(a -> b) -> AppT app m a -> AppT app m b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> AppT app m b -> AppT app m a
$c<$ :: forall app (m :: * -> *) a b.
Functor m =>
a -> AppT app m b -> AppT app m a
fmap :: forall a b. (a -> b) -> AppT app m a -> AppT app m b
$cfmap :: forall app (m :: * -> *) a b.
Functor m =>
(a -> b) -> AppT app m a -> AppT app m b
Functor
    , forall a. a -> AppT app m a
forall a b. AppT app m a -> AppT app m b -> AppT app m a
forall a b. AppT app m a -> AppT app m b -> AppT app m b
forall a b. AppT app m (a -> b) -> AppT app m a -> AppT app m b
forall a b c.
(a -> b -> c) -> AppT app m a -> AppT app m b -> AppT app m c
forall {app} {m :: * -> *}. Applicative m => Functor (AppT app m)
forall app (m :: * -> *) a. Applicative m => a -> AppT app m a
forall app (m :: * -> *) a b.
Applicative m =>
AppT app m a -> AppT app m b -> AppT app m a
forall app (m :: * -> *) a b.
Applicative m =>
AppT app m a -> AppT app m b -> AppT app m b
forall app (m :: * -> *) a b.
Applicative m =>
AppT app m (a -> b) -> AppT app m a -> AppT app m b
forall app (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> AppT app m a -> AppT app m b -> AppT app m c
forall (f :: * -> *).
Functor f
-> (forall a. a -> f a)
-> (forall a b. f (a -> b) -> f a -> f b)
-> (forall a b c. (a -> b -> c) -> f a -> f b -> f c)
-> (forall a b. f a -> f b -> f b)
-> (forall a b. f a -> f b -> f a)
-> Applicative f
<* :: forall a b. AppT app m a -> AppT app m b -> AppT app m a
$c<* :: forall app (m :: * -> *) a b.
Applicative m =>
AppT app m a -> AppT app m b -> AppT app m a
*> :: forall a b. AppT app m a -> AppT app m b -> AppT app m b
$c*> :: forall app (m :: * -> *) a b.
Applicative m =>
AppT app m a -> AppT app m b -> AppT app m b
liftA2 :: forall a b c.
(a -> b -> c) -> AppT app m a -> AppT app m b -> AppT app m c
$cliftA2 :: forall app (m :: * -> *) a b c.
Applicative m =>
(a -> b -> c) -> AppT app m a -> AppT app m b -> AppT app m c
<*> :: forall a b. AppT app m (a -> b) -> AppT app m a -> AppT app m b
$c<*> :: forall app (m :: * -> *) a b.
Applicative m =>
AppT app m (a -> b) -> AppT app m a -> AppT app m b
pure :: forall a. a -> AppT app m a
$cpure :: forall app (m :: * -> *) a. Applicative m => a -> AppT app m a
Applicative
    , forall a. a -> AppT app m a
forall a b. AppT app m a -> AppT app m b -> AppT app m b
forall a b. AppT app m a -> (a -> AppT app m b) -> AppT app m b
forall {app} {m :: * -> *}. Monad m => Applicative (AppT app m)
forall app (m :: * -> *) a. Monad m => a -> AppT app m a
forall app (m :: * -> *) a b.
Monad m =>
AppT app m a -> AppT app m b -> AppT app m b
forall app (m :: * -> *) a b.
Monad m =>
AppT app m a -> (a -> AppT app m b) -> AppT app m b
forall (m :: * -> *).
Applicative m
-> (forall a b. m a -> (a -> m b) -> m b)
-> (forall a b. m a -> m b -> m b)
-> (forall a. a -> m a)
-> Monad m
return :: forall a. a -> AppT app m a
$creturn :: forall app (m :: * -> *) a. Monad m => a -> AppT app m a
>> :: forall a b. AppT app m a -> AppT app m b -> AppT app m b
$c>> :: forall app (m :: * -> *) a b.
Monad m =>
AppT app m a -> AppT app m b -> AppT app m b
>>= :: forall a b. AppT app m a -> (a -> AppT app m b) -> AppT app m b
$c>>= :: forall app (m :: * -> *) a b.
Monad m =>
AppT app m a -> (a -> AppT app m b) -> AppT app m b
Monad
    , forall a. IO a -> AppT app m a
forall {app} {m :: * -> *}. MonadIO m => Monad (AppT app m)
forall app (m :: * -> *) a. MonadIO m => IO a -> AppT app m a
forall (m :: * -> *).
Monad m -> (forall a. IO a -> m a) -> MonadIO m
liftIO :: forall a. IO a -> AppT app m a
$cliftIO :: forall app (m :: * -> *) a. MonadIO m => IO a -> AppT app m a
MonadIO
    , forall e a. Exception e => e -> AppT app m a
forall {app} {m :: * -> *}. MonadThrow m => Monad (AppT app m)
forall app (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> AppT app m a
forall (m :: * -> *).
Monad m -> (forall e a. Exception e => e -> m a) -> MonadThrow m
throwM :: forall e a. Exception e => e -> AppT app m a
$cthrowM :: forall app (m :: * -> *) e a.
(MonadThrow m, Exception e) =>
e -> AppT app m a
MonadThrow
    , forall e a.
Exception e =>
AppT app m a -> (e -> AppT app m a) -> AppT app m a
forall {app} {m :: * -> *}. MonadCatch m => MonadThrow (AppT app m)
forall app (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
AppT app m a -> (e -> AppT app m a) -> AppT app m a
forall (m :: * -> *).
MonadThrow m
-> (forall e a. Exception e => m a -> (e -> m a) -> m a)
-> MonadCatch m
catch :: forall e a.
Exception e =>
AppT app m a -> (e -> AppT app m a) -> AppT app m a
$ccatch :: forall app (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
AppT app m a -> (e -> AppT app m a) -> AppT app m a
MonadCatch
    , forall b.
((forall a. AppT app m a -> AppT app m a) -> AppT app m b)
-> AppT app m b
forall a b c.
AppT app m a
-> (a -> ExitCase b -> AppT app m c)
-> (a -> AppT app m b)
-> AppT app m (b, c)
forall {app} {m :: * -> *}. MonadMask m => MonadCatch (AppT app m)
forall app (m :: * -> *) b.
MonadMask m =>
((forall a. AppT app m a -> AppT app m a) -> AppT app m b)
-> AppT app m b
forall app (m :: * -> *) a b c.
MonadMask m =>
AppT app m a
-> (a -> ExitCase b -> AppT app m c)
-> (a -> AppT app m b)
-> AppT app m (b, c)
forall (m :: * -> *).
MonadCatch m
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b. ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
generalBracket :: forall a b c.
AppT app m a
-> (a -> ExitCase b -> AppT app m c)
-> (a -> AppT app m b)
-> AppT app m (b, c)
$cgeneralBracket :: forall app (m :: * -> *) a b c.
MonadMask m =>
AppT app m a
-> (a -> ExitCase b -> AppT app m c)
-> (a -> AppT app m b)
-> AppT app m (b, c)
uninterruptibleMask :: forall b.
((forall a. AppT app m a -> AppT app m a) -> AppT app m b)
-> AppT app m b
$cuninterruptibleMask :: forall app (m :: * -> *) b.
MonadMask m =>
((forall a. AppT app m a -> AppT app m a) -> AppT app m b)
-> AppT app m b
mask :: forall b.
((forall a. AppT app m a -> AppT app m a) -> AppT app m b)
-> AppT app m b
$cmask :: forall app (m :: * -> *) b.
MonadMask m =>
((forall a. AppT app m a -> AppT app m a) -> AppT app m b)
-> AppT app m b
MonadMask
    , forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> AppT app m ()
forall {app} {m :: * -> *}. MonadIO m => Monad (AppT app m)
forall app (m :: * -> *) msg.
(MonadIO m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> AppT app m ()
forall (m :: * -> *).
Monad m
-> (forall msg.
    ToLogStr msg =>
    Loc -> LogSource -> LogLevel -> msg -> m ())
-> MonadLogger m
monadLoggerLog :: forall msg.
ToLogStr msg =>
Loc -> LogSource -> LogLevel -> msg -> AppT app m ()
$cmonadLoggerLog :: forall app (m :: * -> *) msg.
(MonadIO m, ToLogStr msg) =>
Loc -> LogSource -> LogLevel -> msg -> AppT app m ()
MonadLogger
    , AppT app m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall app (m :: * -> *). MonadIO m => MonadLogger (AppT app m)
forall app (m :: * -> *). MonadIO m => MonadIO (AppT app m)
forall app (m :: * -> *).
MonadIO m =>
AppT app m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
forall (m :: * -> *).
MonadLogger m
-> MonadIO m
-> m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
-> MonadLoggerIO m
askLoggerIO :: AppT app m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
$caskLoggerIO :: forall app (m :: * -> *).
MonadIO m =>
AppT app m (Loc -> LogSource -> LogLevel -> LogStr -> IO ())
MonadLoggerIO
    , forall a. ResourceT IO a -> AppT app m a
forall app (m :: * -> *). MonadIO m => MonadIO (AppT app m)
forall app (m :: * -> *) a.
MonadIO m =>
ResourceT IO a -> AppT app m a
forall (m :: * -> *).
MonadIO m -> (forall a. ResourceT IO a -> m a) -> MonadResource m
liftResourceT :: forall a. ResourceT IO a -> AppT app m a
$cliftResourceT :: forall app (m :: * -> *) a.
MonadIO m =>
ResourceT IO a -> AppT app m a
MonadResource
    , MonadReader app
    )

-- Just copies ReaderT's definition. This can be newtype-derived in GHC 8.10+,
-- but we do it by hand while we want to support older.
instance MonadUnliftIO m => MonadUnliftIO (AppT app m) where
  withRunInIO :: forall b.
((forall a. AppT app m a -> IO a) -> IO b) -> AppT app m b
withRunInIO (forall a. AppT app m a -> IO a) -> IO b
inner = forall app (m :: * -> *) a.
ReaderT app (LoggingT (ResourceT m)) a -> AppT app m a
AppT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) b.
MonadUnliftIO m =>
((forall a. m a -> IO a) -> IO b) -> m b
withRunInIO forall a b. (a -> b) -> a -> b
$ \forall a. ReaderT app (LoggingT (ResourceT m)) a -> IO a
run -> (forall a. AppT app m a -> IO a) -> IO b
inner forall a b. (a -> b) -> a -> b
$ forall a. ReaderT app (LoggingT (ResourceT m)) a -> IO a
run forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall app (m :: * -> *) a.
AppT app m a -> ReaderT app (LoggingT (ResourceT m)) a
unAppT
  {-# INLINE withRunInIO #-}

instance PrimMonad m => PrimMonad (AppT app m) where
  type PrimState (AppT app m) = PrimState m

  -- This should really just be `lift . primitive`, but:
  --
  -- - We'd need `MonadTrans (AppT app)`, which meh
  -- - We'd need an orphan `Primitive LoggingT`, which no thanks
  --
  primitive :: forall a.
(State# (PrimState (AppT app m))
 -> (# State# (PrimState (AppT app m)), a #))
-> AppT app m a
primitive = forall app (m :: * -> *) a.
ReaderT app (LoggingT (ResourceT m)) a -> AppT app m a
AppT forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
PrimMonad m =>
(State# (PrimState m) -> (# State# (PrimState m), a #)) -> m a
primitive
  {-# INLINE primitive #-}

instance Applicative m => MonadTracer (AppT app m) where
  getVaultData :: AppT app m (Maybe XRayVaultData)
getVaultData = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a. Maybe a
Nothing

runAppT :: (MonadUnliftIO m, HasLogger app) => AppT app m a -> app -> m a
runAppT :: forall (m :: * -> *) app a.
(MonadUnliftIO m, HasLogger app) =>
AppT app m a -> app -> m a
runAppT AppT app m a
action app
app =
  forall (m :: * -> *) a. MonadUnliftIO m => ResourceT m a -> m a
runResourceT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) env a.
(MonadUnliftIO m, HasLogger env) =>
env -> LoggingT m a -> m a
runLoggerLoggingT app
app forall a b. (a -> b) -> a -> b
$ forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT (forall app (m :: * -> *) a.
AppT app m a -> ReaderT app (LoggingT (ResourceT m)) a
unAppT AppT app m a
action) app
app