{-# 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)

-- | Update an existing 'User'. Must already have a valid 'UserId'.
--
-- no security checks are performed to ensure that the caller is
-- authorized to change data for the 'User'.
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 ()