module Reflex.Auth.Trans(
AuthEnv
, AuthT(..)
, newAuthEnv
, runAuthT
, runAuth
, module Reflex.Auth.Class
) where
import Control.Monad.Fix
import Control.Monad.Reader
import Control.Monad.State.Strict
import Language.Javascript.JSaddle.Types
import GHC.Generics
import Reflex
import Reflex.Auth.Class
import Reflex.ExternalRef
import Reflex.Network
type AuthEnv t info = ExternalRef t (Maybe info)
newAuthEnv :: (Reflex t, TriggerEvent t m, MonadIO m) => m (AuthEnv t info)
newAuthEnv = newExternalRef Nothing
newtype AuthT info t m a = AuthT { unAuthT :: ReaderT (AuthEnv t info) m a }
deriving (Functor, Applicative, Monad, Generic, MonadFix)
deriving instance PostBuild t m => PostBuild t (AuthT info t m)
deriving instance NotReady t m => NotReady t (AuthT info t m)
deriving instance PerformEvent t m => PerformEvent t (AuthT info t m)
deriving instance TriggerEvent t m => TriggerEvent t (AuthT info t m)
deriving instance MonadHold t m => MonadHold t (AuthT info t m)
deriving instance MonadSample t m => MonadSample t (AuthT info t m)
deriving instance MonadIO m => MonadIO (AuthT info t m)
#ifndef ghcjs_HOST_OS
deriving instance MonadJSM m => MonadJSM (AuthT info t m)
#endif
deriving instance (Group q, Additive q, Query q, Eq q, MonadQuery t q m, Monad m) => MonadQuery t q (AuthT info t m)
deriving instance (Monoid w, DynamicWriter t w m) => DynamicWriter t w (AuthT info t m)
deriving instance (Monoid w, BehaviorWriter t w m) => BehaviorWriter t w (AuthT info t m)
deriving instance (Semigroup w, EventWriter t w m) => EventWriter t w (AuthT info t m)
deriving instance (Requester t m) => Requester t (AuthT info t m)
instance MonadTrans (AuthT info t) where
lift = AuthT . lift
{-# INLINABLE lift #-}
instance MonadReader e m => MonadReader e (AuthT info t m) where
ask = lift ask
{-# INLINABLE ask #-}
local f (AuthT ma) = AuthT $ do
r <- ask
lift $ local f $ runReaderT ma r
{-# INLINABLE local #-}
instance MonadState s m => MonadState s (AuthT info t m) where
get = lift get
{-# INLINABLE get #-}
put = lift . put
{-# INLINABLE put #-}
instance Adjustable t m => Adjustable t (AuthT info t m) where
runWithReplace a0 a' = do
r <- AuthT ask
lift $ runWithReplace (runAuthT a0 r) $ fmap (`runAuthT` r) a'
{-# INLINABLE runWithReplace #-}
traverseIntMapWithKeyWithAdjust f dm0 dm' = do
r <- AuthT ask
lift $ traverseIntMapWithKeyWithAdjust (\k v -> runAuthT (f k v) r) dm0 dm'
{-# INLINABLE traverseIntMapWithKeyWithAdjust #-}
traverseDMapWithKeyWithAdjust f dm0 dm' = do
r <- AuthT ask
lift $ traverseDMapWithKeyWithAdjust (\k v -> runAuthT (f k v) r) dm0 dm'
{-# INLINABLE traverseDMapWithKeyWithAdjust #-}
traverseDMapWithKeyWithAdjustWithMove f dm0 dm' = do
r <- AuthT ask
lift $ traverseDMapWithKeyWithAdjustWithMove (\k v -> runAuthT (f k v) r) dm0 dm'
{-# INLINABLE traverseDMapWithKeyWithAdjustWithMove #-}
runAuthT :: AuthT info t m a -> AuthEnv t info -> m a
runAuthT (AuthT ma) e = runReaderT ma e
{-# INLINEABLE runAuthT #-}
runAuth :: (Reflex t, TriggerEvent t m, MonadIO m) => AuthT info t m a -> m a
runAuth ma = do
re <- newAuthEnv
runAuthT ma re
{-# INLINABLE runAuth #-}
instance (Eq info, Reflex t, MonadIO m, MonadHold t m, MonadFix m, Adjustable t m) => HasAuth t (AuthT info t m) where
type AuthInfo t (AuthT info t m) = info
getAuthInfoRef = AuthT ask
{-# INLINE getAuthInfoRef #-}
liftAuth unauth authed = do
ref <- AuthT ask
ai0 <- readExternalRef ref
aimd <- holdUniqDyn =<< externalRefDynamic ref
aid <- fmap fromJust <$> improvingMaybe aimd
let
mauthed = runReaderT authed aid
m = maybe unauth (const mauthed)
networkHold (m ai0) $ m <$> updated aimd
where
fromJust Nothing = error "liftAuth: impossible, forced Nothing in authed dynamic"
fromJust (Just a) = a