{-# LANGUAGE GeneralizedNewtypeDeriving #-}

-- This file is part of the Wire Server implementation.
--
-- Copyright (C) 2022 Wire Swiss GmbH <opensource@wire.com>
--
-- This program is free software: you can redistribute it and/or modify it under
-- the terms of the GNU Affero General Public License as published by the Free
-- Software Foundation, either version 3 of the License, or (at your option) any
-- later version.
--
-- This program is distributed in the hope that it will be useful, but WITHOUT
-- ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or FITNESS
-- FOR A PARTICULAR PURPOSE. See the GNU Affero General Public License for more
-- details.
--
-- You should have received a copy of the GNU Affero General Public License along
-- with this program. If not, see <https://www.gnu.org/licenses/>.

module Galley.Monad where

import Bilge.IO hiding (options)
import Bilge.RPC
import Cassandra
import Control.Lens
import Control.Monad.Catch
import Galley.Env
import Imports hiding (log)
import Polysemy
import Polysemy.Input
import Prometheus
import System.Logger
import System.Logger.Class qualified as LC

newtype App a = App {forall a. App a -> ReaderT Env IO a
unApp :: ReaderT Env IO a}
  deriving
    ( (forall a b. (a -> b) -> App a -> App b)
-> (forall a b. a -> App b -> App a) -> Functor App
forall a b. a -> App b -> App a
forall a b. (a -> b) -> App a -> App b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> App a -> App b
fmap :: forall a b. (a -> b) -> App a -> App b
$c<$ :: forall a b. a -> App b -> App a
<$ :: forall a b. a -> App b -> App a
Functor,
      Functor App
Functor App =>
(forall a. a -> App a)
-> (forall a b. App (a -> b) -> App a -> App b)
-> (forall a b c. (a -> b -> c) -> App a -> App b -> App c)
-> (forall a b. App a -> App b -> App b)
-> (forall a b. App a -> App b -> App a)
-> Applicative App
forall a. a -> App a
forall a b. App a -> App b -> App a
forall a b. App a -> App b -> App b
forall a b. App (a -> b) -> App a -> App b
forall a b c. (a -> b -> c) -> App a -> App b -> App 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
$cpure :: forall a. a -> App a
pure :: forall a. a -> App a
$c<*> :: forall a b. App (a -> b) -> App a -> App b
<*> :: forall a b. App (a -> b) -> App a -> App b
$cliftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
liftA2 :: forall a b c. (a -> b -> c) -> App a -> App b -> App c
$c*> :: forall a b. App a -> App b -> App b
*> :: forall a b. App a -> App b -> App b
$c<* :: forall a b. App a -> App b -> App a
<* :: forall a b. App a -> App b -> App a
Applicative,
      Applicative App
Applicative App =>
(forall a b. App a -> (a -> App b) -> App b)
-> (forall a b. App a -> App b -> App b)
-> (forall a. a -> App a)
-> Monad App
forall a. a -> App a
forall a b. App a -> App b -> App b
forall a b. App a -> (a -> App b) -> App 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
$c>>= :: forall a b. App a -> (a -> App b) -> App b
>>= :: forall a b. App a -> (a -> App b) -> App b
$c>> :: forall a b. App a -> App b -> App b
>> :: forall a b. App a -> App b -> App b
$creturn :: forall a. a -> App a
return :: forall a. a -> App a
Monad,
      MonadThrow App
MonadThrow App =>
(forall e a.
 (HasCallStack, Exception e) =>
 App a -> (e -> App a) -> App a)
-> MonadCatch App
forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
forall (m :: * -> *).
MonadThrow m =>
(forall e a.
 (HasCallStack, Exception e) =>
 m a -> (e -> m a) -> m a)
-> MonadCatch m
$ccatch :: forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
catch :: forall e a.
(HasCallStack, Exception e) =>
App a -> (e -> App a) -> App a
MonadCatch,
      Monad App
Monad App => (forall a. IO a -> App a) -> MonadIO App
forall a. IO a -> App a
forall (m :: * -> *).
Monad m =>
(forall a. IO a -> m a) -> MonadIO m
$cliftIO :: forall a. IO a -> App a
liftIO :: forall a. IO a -> App a
MonadIO,
      MonadCatch App
MonadCatch App =>
(forall b.
 HasCallStack =>
 ((forall a. App a -> App a) -> App b) -> App b)
-> (forall b.
    HasCallStack =>
    ((forall a. App a -> App a) -> App b) -> App b)
-> (forall a b c.
    HasCallStack =>
    App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c))
-> MonadMask App
forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
forall (m :: * -> *).
MonadCatch m =>
(forall b. HasCallStack => ((forall a. m a -> m a) -> m b) -> m b)
-> (forall b.
    HasCallStack =>
    ((forall a. m a -> m a) -> m b) -> m b)
-> (forall a b c.
    HasCallStack =>
    m a -> (a -> ExitCase b -> m c) -> (a -> m b) -> m (b, c))
-> MonadMask m
$cmask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
mask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
$cuninterruptibleMask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
uninterruptibleMask :: forall b.
HasCallStack =>
((forall a. App a -> App a) -> App b) -> App b
$cgeneralBracket :: forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
generalBracket :: forall a b c.
HasCallStack =>
App a -> (a -> ExitCase b -> App c) -> (a -> App b) -> App (b, c)
MonadMask,
      MonadReader Env,
      Monad App
Monad App =>
(forall e a. (HasCallStack, Exception e) => e -> App a)
-> MonadThrow App
forall e a. (HasCallStack, Exception e) => e -> App a
forall (m :: * -> *).
Monad m =>
(forall e a. (HasCallStack, Exception e) => e -> m a)
-> MonadThrow m
$cthrowM :: forall e a. (HasCallStack, Exception e) => e -> App a
throwM :: forall e a. (HasCallStack, Exception e) => e -> App a
MonadThrow,
      MonadIO App
MonadIO App =>
(forall b. ((forall a. App a -> IO a) -> IO b) -> App b)
-> MonadUnliftIO App
forall b. ((forall a. App a -> IO a) -> IO b) -> App b
forall (m :: * -> *).
MonadIO m =>
(forall b. ((forall a. m a -> IO a) -> IO b) -> m b)
-> MonadUnliftIO m
$cwithRunInIO :: forall b. ((forall a. App a -> IO a) -> IO b) -> App b
withRunInIO :: forall b. ((forall a. App a -> IO a) -> IO b) -> App b
MonadUnliftIO,
      Monad App
Monad App => (IO () -> App ()) -> MonadMonitor App
IO () -> App ()
forall (m :: * -> *). Monad m => (IO () -> m ()) -> MonadMonitor m
$cdoIO :: IO () -> App ()
doIO :: IO () -> App ()
MonadMonitor
    )

runApp :: Env -> App a -> IO a
runApp :: forall a. Env -> App a -> IO a
runApp Env
env = (ReaderT Env IO a -> Env -> IO a)
-> Env -> ReaderT Env IO a -> IO a
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReaderT Env IO a -> Env -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT Env
env (ReaderT Env IO a -> IO a)
-> (App a -> ReaderT Env IO a) -> App a -> IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. App a -> ReaderT Env IO a
forall a. App a -> ReaderT Env IO a
unApp

instance HasRequestId App where
  getRequestId :: App RequestId
getRequestId = ReaderT Env IO RequestId -> App RequestId
forall a. ReaderT Env IO a -> App a
App (ReaderT Env IO RequestId -> App RequestId)
-> ReaderT Env IO RequestId -> App RequestId
forall a b. (a -> b) -> a -> b
$ Getting RequestId Env RequestId -> ReaderT Env IO RequestId
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting RequestId Env RequestId
Lens' Env RequestId
reqId

instance MonadHttp App where
  handleRequestWithCont :: forall a. Request -> (Response BodyReader -> IO a) -> App a
handleRequestWithCont Request
req Response BodyReader -> IO a
h = do
    Manager
m <- Getting Manager Env Manager -> App Manager
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Manager Env Manager
Lens' Env Manager
manager
    IO a -> App a
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> App a) -> IO a -> App a
forall a b. (a -> b) -> a -> b
$ Request -> Manager -> (Response BodyReader -> IO a) -> IO a
forall a.
Request -> Manager -> (Response BodyReader -> IO a) -> IO a
withResponse Request
req Manager
m Response BodyReader -> IO a
h

instance MonadClient App where
  liftClient :: forall a. Client a -> App a
liftClient Client a
m = do
    ClientState
cs <- Getting ClientState Env ClientState -> App ClientState
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ClientState Env ClientState
Lens' Env ClientState
cstate
    IO a -> App a
forall a. IO a -> App a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO a -> App a) -> IO a -> App a
forall a b. (a -> b) -> a -> b
$ ClientState -> Client a -> IO a
forall (m :: * -> *) a. MonadIO m => ClientState -> Client a -> m a
runClient ClientState
cs Client a
m
  localState :: forall a. (ClientState -> ClientState) -> App a -> App a
localState ClientState -> ClientState
f = ASetter Env Env ClientState ClientState
-> (ClientState -> ClientState) -> App a -> App a
forall s (m :: * -> *) a b r.
MonadReader s m =>
ASetter s s a b -> (a -> b) -> m r -> m r
locally ASetter Env Env ClientState ClientState
Lens' Env ClientState
cstate ClientState -> ClientState
f

instance LC.MonadLogger App where
  log :: Level -> (Msg -> Msg) -> App ()
log Level
lvl Msg -> Msg
m = do
    Env
env <- App Env
forall r (m :: * -> *). MonadReader r m => m r
ask
    Logger -> Level -> (Msg -> Msg) -> App ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
log (Env
env Env -> Getting Logger Env Logger -> Logger
forall s a. s -> Getting a s a -> a
^. Getting Logger Env Logger
Lens' Env Logger
applog) Level
lvl (RequestId -> Msg -> Msg
reqIdMsg (Env
env Env -> Getting RequestId Env RequestId -> RequestId
forall s a. s -> Getting a s a -> a
^. Getting RequestId Env RequestId
Lens' Env RequestId
reqId) (Msg -> Msg) -> (Msg -> Msg) -> Msg -> Msg
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Msg -> Msg
m)

embedApp ::
  ( Member (Embed IO) r,
    Member (Input Env) r
  ) =>
  App a ->
  Sem r a
embedApp :: forall (r :: EffectRow) a.
(Member (Embed IO) r, Member (Input Env) r) =>
App a -> Sem r a
embedApp App a
action = do
  Env
env <- Sem r Env
forall i (r :: EffectRow). Member (Input i) r => Sem r i
input
  IO a -> Sem r a
forall (m :: * -> *) (r :: EffectRow) a.
Member (Embed m) r =>
m a -> Sem r a
embed (IO a -> Sem r a) -> IO a -> Sem r a
forall a b. (a -> b) -> a -> b
$ Env -> App a -> IO a
forall a. Env -> App a -> IO a
runApp Env
env App a
action