{-# LANGUAGE RecordWildCards, OverloadedStrings #-}
module Clckwrks.Authenticate.API
       ( Username(..)
       , getEmail
       , getUser
       , getUsername
       , insecureUpdateUser
       ) where

import Clckwrks.Monad               (Clck, plugins)
import Control.Monad                (join)
import Control.Monad.State          (get)
import Control.Monad.Trans          (liftIO)
import Clckwrks.Authenticate.Plugin (AcidStateAuthenticate(..), authenticatePlugin)
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  (GetUserByUserId(..), Email(..), UpdateUser(..), User(..), Username(..))
import Web.Plugins.Core             (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin)

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 (AcidStateAuthenticate AcidState AuthenticateState
authenticateState)) <- ClckPlugins
-> Text -> ClckT url (ServerPartT IO) (Maybe AcidStateAuthenticate)
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 AcidState (EventState GetUserByUserId)
AcidState AuthenticateState
authenticateState (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 (AcidStateAuthenticate AcidState AuthenticateState
authenticateState)) <- ClckPlugins
-> Text -> ClckT url (ServerPartT IO) (Maybe AcidStateAuthenticate)
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 AcidState (EventState UpdateUser)
AcidState AuthenticateState
authenticateState (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