{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Clckwrks.Authenticate.API
( Username(..)
, getEmail
, getUser
, getUsername
, insecureUpdateUser
, setCreateUserCallback
) where
import Clckwrks.Authenticate.Plugin (authenticatePlugin)
import Clckwrks.Authenticate.Monad (AuthenticatePluginState(..))
import Clckwrks.Monad (Clck, ClckPlugins, plugins)
import Control.Concurrent.STM (atomically)
import Control.Concurrent.STM.TVar (modifyTVar')
import Control.Monad (join)
import Control.Monad.State (get)
import Control.Monad.Trans (liftIO)
import Data.Acid as Acid (AcidState, query, update)
import Data.Maybe (maybe)
import Data.Monoid (mempty)
import Data.Text (Text)
import Data.UserId (UserId)
import Happstack.Authenticate.Core (AuthenticateConfig(_createUserCallback), GetUserByUserId(..), Email(..), UpdateUser(..), User(..), Username(..))
import Web.Plugins.Core (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin, modifyPluginState')
getUser :: UserId -> Clck url (Maybe User)
getUser :: UserId -> Clck url (Maybe User)
getUser UserId
uid =
do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url (ServerPartT IO) ClckState
-> ClckT url (ServerPartT IO) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url (ServerPartT IO) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
~(Just AuthenticatePluginState
aps) <- ClckPlugins
-> Text
-> ClckT url (ServerPartT IO) (Maybe AuthenticatePluginState)
forall (m :: * -> *) state theme n hook config st.
(MonadIO m, Typeable state) =>
Plugins theme n hook config st -> Text -> m (Maybe state)
getPluginState ClckPlugins
p (Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
authenticatePlugin)
IO (Maybe User) -> Clck url (Maybe User)
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Maybe User) -> Clck url (Maybe User))
-> IO (Maybe User) -> Clck url (Maybe User)
forall a b. (a -> b) -> a -> b
$ AcidState (EventState GetUserByUserId)
-> GetUserByUserId -> IO (EventResult GetUserByUserId)
forall event.
QueryEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
Acid.query (AuthenticatePluginState -> AcidState AuthenticateState
acidStateAuthenticate AuthenticatePluginState
aps) (UserId -> GetUserByUserId
GetUserByUserId UserId
uid)
insecureUpdateUser :: User -> Clck url ()
insecureUpdateUser :: User -> Clck url ()
insecureUpdateUser User
user =
do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url (ServerPartT IO) ClckState
-> ClckT url (ServerPartT IO) ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url (ServerPartT IO) ClckState
forall s (m :: * -> *). MonadState s m => m s
get
~(Just AuthenticatePluginState
aps) <- ClckPlugins
-> Text
-> ClckT url (ServerPartT IO) (Maybe AuthenticatePluginState)
forall (m :: * -> *) state theme n hook config st.
(MonadIO m, Typeable state) =>
Plugins theme n hook config st -> Text -> m (Maybe state)
getPluginState ClckPlugins
p (Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
authenticatePlugin)
IO () -> Clck url ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> Clck url ()) -> IO () -> Clck url ()
forall a b. (a -> b) -> a -> b
$ AcidState (EventState UpdateUser)
-> UpdateUser -> IO (EventResult UpdateUser)
forall event.
UpdateEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
Acid.update (AuthenticatePluginState -> AcidState AuthenticateState
acidStateAuthenticate AuthenticatePluginState
aps) (User -> UpdateUser
UpdateUser User
user)
getUsername :: UserId -> Clck url (Maybe Username)
getUsername :: UserId -> Clck url (Maybe Username)
getUsername UserId
uid =
do Maybe User
mUser <- UserId -> Clck url (Maybe User)
forall url. UserId -> Clck url (Maybe User)
getUser UserId
uid
Maybe Username -> Clck url (Maybe Username)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Username -> Clck url (Maybe Username))
-> Maybe Username -> Clck url (Maybe Username)
forall a b. (a -> b) -> a -> b
$ User -> Username
_username (User -> Username) -> Maybe User -> Maybe Username
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe User
mUser
getEmail :: UserId -> Clck url (Maybe Email)
getEmail :: UserId -> Clck url (Maybe Email)
getEmail UserId
uid =
do Maybe User
mUser <- UserId -> Clck url (Maybe User)
forall url. UserId -> Clck url (Maybe User)
getUser UserId
uid
Maybe Email -> Clck url (Maybe Email)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Email -> Clck url (Maybe Email))
-> Maybe Email -> Clck url (Maybe Email)
forall a b. (a -> b) -> a -> b
$ Maybe (Maybe Email) -> Maybe Email
forall (m :: * -> *) a. Monad m => m (m a) -> m a
join (Maybe (Maybe Email) -> Maybe Email)
-> Maybe (Maybe Email) -> Maybe Email
forall a b. (a -> b) -> a -> b
$ User -> Maybe Email
_email (User -> Maybe Email) -> Maybe User -> Maybe (Maybe Email)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe User
mUser
setCreateUserCallback :: ClckPlugins -> Maybe (User -> IO ()) -> IO ()
setCreateUserCallback :: ClckPlugins -> Maybe (User -> IO ()) -> IO ()
setCreateUserCallback ClckPlugins
p Maybe (User -> IO ())
mcb =
do ~(Just AuthenticatePluginState
aps) <- ClckPlugins -> Text -> IO (Maybe AuthenticatePluginState)
forall (m :: * -> *) state theme n hook config st.
(MonadIO m, Typeable state) =>
Plugins theme n hook config st -> Text -> m (Maybe state)
getPluginState ClckPlugins
p (Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
-> Text
forall url theme n hook config st.
Plugin url theme n hook config st -> Text
pluginName Plugin
AuthURL
Theme
(ClckT ClckURL (ServerPartT IO) Response)
(ClckT ClckURL IO ())
ClckwrksConfig
ClckPluginsSt
authenticatePlugin)
IO () -> IO ()
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ STM () -> IO ()
forall a. STM a -> IO a
atomically (STM () -> IO ()) -> STM () -> IO ()
forall a b. (a -> b) -> a -> b
$ TVar AuthenticateConfig
-> (AuthenticateConfig -> AuthenticateConfig) -> STM ()
forall a. TVar a -> (a -> a) -> STM ()
modifyTVar' (AuthenticatePluginState -> TVar AuthenticateConfig
apsAuthenticateConfigTV AuthenticatePluginState
aps) ((AuthenticateConfig -> AuthenticateConfig) -> STM ())
-> (AuthenticateConfig -> AuthenticateConfig) -> STM ()
forall a b. (a -> b) -> a -> b
$ (\AuthenticateConfig
ac -> AuthenticateConfig
ac { _createUserCallback :: Maybe (User -> IO ())
_createUserCallback = Maybe (User -> IO ())
mcb })
() -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()