{-# LANGUAGE DeriveDataTypeable, RecordWildCards, FlexibleContexts, Rank2Types, OverloadedStrings, MultiParamTypeClasses #-}
module Clckwrks.Authenticate.Plugin where

import Clckwrks.Monad
import Clckwrks.Acid               (GetAcidState(..), GetCoreState(..), GetEnableOpenId(..), acidCore, acidProfileData, coreFromAddress, coreReplyToAddress, coreSendmailPath, getAcidState)
import Clckwrks.Authenticate.Route (routeAuth)
import Clckwrks.Authenticate.URL   (AuthURL(..))
import Clckwrks.ProfileData.Acid   (HasRole(..))
import Clckwrks.ProfileData.Types  (Role(..))
import Clckwrks.Types              (NamedLink(..))
import Clckwrks.URL
import Control.Applicative         ((<$>))
import Control.Lens                ((^.))
import Control.Monad.Reader        (ask)
import Control.Monad.State         (get)
import Control.Monad.Trans         (MonadIO, lift)
import Data.Acid as Acid           (AcidState, query)
import Data.Maybe                  (isJust)
import Data.Monoid                 ((<>))
import qualified Data.Set          as Set
import Data.Text                   (Text)
import Data.Typeable               (Typeable)
import qualified Data.Text         as Text
import qualified Data.Set          as Set
import qualified Data.Text.Lazy as TL
import Data.UserId                  (UserId)
import Happstack.Authenticate.Core  (AuthenticateState, AuthenticateConfig(..), getToken, tokenUser, userId, usernamePolicy)
import Happstack.Authenticate.Route (initAuthentication)
import Happstack.Authenticate.Password.Core (PasswordConfig(..))
import Happstack.Authenticate.Password.Route (initPassword)
import Happstack.Authenticate.OpenId.Route (initOpenId)
import Happstack.Server
import System.FilePath             ((</>))
import Web.Plugins.Core            (Plugin(..), When(Always), addCleanup, addHandler, addPluginState, getConfig, getPluginRouteFn, getPluginState, getPluginsSt, initPlugin)
import Web.Routes

newtype AcidStateAuthenticate = AcidStateAuthenticate { AcidStateAuthenticate -> AcidState AuthenticateState
acidStateAuthenticate :: AcidState AuthenticateState }
    deriving Typeable

authenticateHandler
  :: (AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response)
  -> (AuthURL -> [(Text, Maybe Text)] -> Text)
  -> ClckPlugins
  -> [Text]
  -> ClckT ClckURL (ServerPartT IO) Response
authenticateHandler :: (AuthenticateURL
 -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> (AuthURL -> [(Text, Maybe Text)] -> Text)
-> ClckPlugins
-> [Text]
-> ClckT ClckURL (ServerPartT IO) Response
authenticateHandler AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
routeAuthenticate AuthURL -> [(Text, Maybe Text)] -> Text
showAuthenticateURL ClckPlugins
_plugins [Text]
paths =
    case URLParser AuthURL -> [Text] -> Either String AuthURL
forall a. URLParser a -> [Text] -> Either String a
parseSegments URLParser AuthURL
forall url. PathInfo url => URLParser url
fromPathSegments [Text]
paths of
      (Left String
e)  -> Response -> ClckT ClckURL (ServerPartT IO) Response
forall (m :: * -> *) a. FilterMonad Response m => a -> m a
notFound (Response -> ClckT ClckURL (ServerPartT IO) Response)
-> Response -> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ String -> Response
forall a. ToMessage a => a -> Response
toResponse (String -> String
forall a. Show a => a -> String
show String
e)
      (Right AuthURL
u) -> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall url (m :: * -> *) a.
RouteT url (StateT ClckState m) a -> ClckT url m a
ClckT (RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
 -> ClckT ClckURL (ServerPartT IO) Response)
-> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
-> ClckT ClckURL (ServerPartT IO) Response
forall a b. (a -> b) -> a -> b
$ ((ClckURL -> [(Text, Maybe Text)] -> Text)
 -> AuthURL -> [(Text, Maybe Text)] -> Text)
-> RouteT AuthURL (StateT ClckState (ServerPartT IO)) Response
-> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
forall url' url (m :: * -> *) a.
((url' -> [(Text, Maybe Text)] -> Text)
 -> url -> [(Text, Maybe Text)] -> Text)
-> RouteT url m a -> RouteT url' m a
withRouteT (ClckURL -> [(Text, Maybe Text)] -> Text)
-> AuthURL -> [(Text, Maybe Text)] -> Text
forall url'.
(url' -> [(Text, Maybe Text)] -> Text)
-> AuthURL -> [(Text, Maybe Text)] -> Text
flattenURL (RouteT AuthURL (StateT ClckState (ServerPartT IO)) Response
 -> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response)
-> RouteT AuthURL (StateT ClckState (ServerPartT IO)) Response
-> RouteT ClckURL (StateT ClckState (ServerPartT IO)) Response
forall a b. (a -> b) -> a -> b
$ ClckT AuthURL (ServerPartT IO) Response
-> RouteT AuthURL (StateT ClckState (ServerPartT IO)) Response
forall url (m :: * -> *) a.
ClckT url m a -> RouteT url (StateT ClckState m) a
unClckT (ClckT AuthURL (ServerPartT IO) Response
 -> RouteT AuthURL (StateT ClckState (ServerPartT IO)) Response)
-> ClckT AuthURL (ServerPartT IO) Response
-> RouteT AuthURL (StateT ClckState (ServerPartT IO)) Response
forall a b. (a -> b) -> a -> b
$ (AuthenticateURL
 -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> AuthURL -> ClckT AuthURL (ServerPartT IO) Response
routeAuth AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
routeAuthenticate AuthURL
u -- ClckT $ withRouteT flattenURL $ unClckT $
  where
      flattenURL ::   ((url' -> [(Text, Maybe Text)] -> Text) -> (AuthURL -> [(Text, Maybe Text)] -> Text))
      flattenURL :: (url' -> [(Text, Maybe Text)] -> Text)
-> AuthURL -> [(Text, Maybe Text)] -> Text
flattenURL url' -> [(Text, Maybe Text)] -> Text
_ AuthURL
u [(Text, Maybe Text)]
p = AuthURL -> [(Text, Maybe Text)] -> Text
showAuthenticateURL AuthURL
u [(Text, Maybe Text)]
p

authMenuCallback :: (AuthURL -> [(Text, Maybe Text)] -> Text)
                 -> ClckT ClckURL IO (String, [NamedLink])
authMenuCallback :: (AuthURL -> [(Text, Maybe Text)] -> Text)
-> ClckT ClckURL IO (String, [NamedLink])
authMenuCallback AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn =
       (String, [NamedLink]) -> ClckT ClckURL IO (String, [NamedLink])
forall (m :: * -> *) a. Monad m => a -> m a
return (String
"Authenticate", [Text -> Text -> NamedLink
NamedLink Text
"Login" (AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn AuthURL
Login [])])

addAuthAdminMenu :: ClckT url IO ()
addAuthAdminMenu :: ClckT url IO ()
addAuthAdminMenu =
    do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url IO ClckState -> ClckT url IO ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url IO ClckState
forall s (m :: * -> *). MonadState s m => m s
get
       ~(Just AuthURL -> [(Text, Maybe Text)] -> Text
authShowURL) <- ClckPlugins
-> Text
-> ClckT url IO (Maybe (AuthURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn 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)
       (Text, [(Set Role, Text, Text)]) -> ClckT url IO ()
forall (m :: * -> *) url.
Monad m =>
(Text, [(Set Role, Text, Text)]) -> ClckT url m ()
addAdminMenu (Text
"Authentication", [([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Visitor]      , Text
"Change Password", AuthURL -> [(Text, Maybe Text)] -> Text
authShowURL AuthURL
ChangePassword [])])
       (Text, [(Set Role, Text, Text)]) -> ClckT url IO ()
forall (m :: * -> *) url.
Monad m =>
(Text, [(Set Role, Text, Text)]) -> ClckT url m ()
addAdminMenu (Text
"Authentication", [([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator], Text
"OpenId Realm"   , AuthURL -> [(Text, Maybe Text)] -> Text
authShowURL AuthURL
OpenIdRealm    [])])
       (Text, [(Set Role, Text, Text)]) -> ClckT url IO ()
forall (m :: * -> *) url.
Monad m =>
(Text, [(Set Role, Text, Text)]) -> ClckT url m ()
addAdminMenu (Text
"Authentication", [([Role] -> Set Role
forall a. Ord a => [a] -> Set a
Set.fromList [Role
Administrator], Text
"Authentication Modes", AuthURL -> [(Text, Maybe Text)] -> Text
authShowURL AuthURL
AuthModes [])])

authenticateInit
  :: ClckPlugins
  -> IO (Maybe Text)
authenticateInit :: ClckPlugins -> IO (Maybe Text)
authenticateInit ClckPlugins
plugins =
  do ~(Just AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn) <- ClckPlugins
-> Text -> IO (Maybe (AuthURL -> [(Text, Maybe Text)] -> Text))
forall (m :: * -> *) url theme n hook config st.
(MonadIO m, Typeable url) =>
Plugins theme n hook config st
-> Text -> m (Maybe (url -> [(Text, Maybe Text)] -> Text))
getPluginRouteFn ClckPlugins
plugins (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)
     ClckPlugins -> ClckT ClckURL IO (String, [NamedLink]) -> IO ()
forall (m :: * -> *) theme n hook config.
MonadIO m =>
Plugins theme n hook config ClckPluginsSt
-> ClckT ClckURL IO (String, [NamedLink]) -> m ()
addNavBarCallback ClckPlugins
plugins ((AuthURL -> [(Text, Maybe Text)] -> Text)
-> ClckT ClckURL IO (String, [NamedLink])
authMenuCallback AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn)
     -- addHandler plugins (pluginName clckPlugin) (authenticateHandler clckShowFn)
     ClckwrksConfig
cc <- ClckPlugins -> IO ClckwrksConfig
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m config
getConfig ClckPlugins
plugins
     Acid
acid <- ClckPluginsSt -> Acid
cpsAcid (ClckPluginsSt -> Acid) -> IO ClckPluginsSt -> IO Acid
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckPlugins -> IO ClckPluginsSt
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> m st
getPluginsSt ClckPlugins
plugins
     let basePath :: String
basePath = String -> (String -> String) -> Maybe String -> String
forall b a. b -> (a -> b) -> Maybe a -> b
maybe String
"_state" (\String
top -> String
top String -> String -> String
</> String
"_state") (ClckwrksConfig -> Maybe String
clckTopDir ClckwrksConfig
cc)
         baseUri :: Text
baseUri = case ClckwrksConfig -> Maybe Text
calcTLSBaseURI ClckwrksConfig
cc of
           Maybe Text
Nothing  -> ClckwrksConfig -> Text
calcBaseURI ClckwrksConfig
cc
           (Just Text
b) -> Text
b
     CoreState
cs <- AcidState (EventState GetCoreState)
-> GetCoreState -> IO (EventResult GetCoreState)
forall event.
QueryEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
Acid.query (Acid -> AcidState CoreState
acidCore Acid
acid) GetCoreState
GetCoreState
     let authenticateConfig :: AuthenticateConfig
authenticateConfig = AuthenticateConfig :: (UserId -> IO Bool)
-> (Username -> Maybe CoreError)
-> Bool
-> Maybe SimpleAddress
-> Maybe SimpleAddress
-> Maybe String
-> AuthenticateConfig
AuthenticateConfig {
                                _isAuthAdmin :: UserId -> IO Bool
_isAuthAdmin          = \UserId
uid -> AcidState (EventState HasRole)
-> HasRole -> IO (EventResult HasRole)
forall event.
QueryEvent event =>
AcidState (EventState event) -> event -> IO (EventResult event)
Acid.query (Acid -> AcidState ProfileDataState
acidProfileData Acid
acid) (UserId -> Set Role -> HasRole
HasRole UserId
uid (Role -> Set Role
forall a. a -> Set a
Set.singleton Role
Administrator))
                              , _usernameAcceptable :: Username -> Maybe CoreError
_usernameAcceptable   = Username -> Maybe CoreError
usernamePolicy
                              , _requireEmail :: Bool
_requireEmail         = Bool
True
                              , _systemFromAddress :: Maybe SimpleAddress
_systemFromAddress    = CoreState
cs CoreState
-> Getting (Maybe SimpleAddress) CoreState (Maybe SimpleAddress)
-> Maybe SimpleAddress
forall s a. s -> Getting a s a -> a
^. Getting (Maybe SimpleAddress) CoreState (Maybe SimpleAddress)
Lens' CoreState (Maybe SimpleAddress)
coreFromAddress
                              , _systemReplyToAddress :: Maybe SimpleAddress
_systemReplyToAddress = CoreState
cs CoreState
-> Getting (Maybe SimpleAddress) CoreState (Maybe SimpleAddress)
-> Maybe SimpleAddress
forall s a. s -> Getting a s a -> a
^. Getting (Maybe SimpleAddress) CoreState (Maybe SimpleAddress)
Lens' CoreState (Maybe SimpleAddress)
coreReplyToAddress
                              , _systemSendmailPath :: Maybe String
_systemSendmailPath   = CoreState
cs CoreState
-> Getting (Maybe String) CoreState (Maybe String) -> Maybe String
forall s a. s -> Getting a s a -> a
^. Getting (Maybe String) CoreState (Maybe String)
Lens' CoreState (Maybe String)
coreSendmailPath
                              }
         passwordConfig :: PasswordConfig
passwordConfig = PasswordConfig :: Text -> Text -> (Text -> Maybe Text) -> PasswordConfig
PasswordConfig {
                            _resetLink :: Text
_resetLink = Text
baseUri Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn AuthURL
ResetPassword [] Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text
"/#"
                          , _domain :: Text
_domain = String -> Text
Text.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ ClckwrksConfig -> String
clckHostname ClckwrksConfig
cc
                          , _passwordAcceptable :: Text -> Maybe Text
_passwordAcceptable = Maybe Text -> Text -> Maybe Text
forall a b. a -> b -> a
const Maybe Text
forall a. Maybe a
Nothing
                          }

     (IO ()
authCleanup, AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
routeAuthenticate, AcidState AuthenticateState
authenticateState) <- Maybe String
-> AuthenticateConfig
-> [String
    -> AcidState AuthenticateState
    -> AuthenticateConfig
    -> IO
         (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
          RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> IO
     (IO (),
      AuthenticateURL
      -> RouteT AuthenticateURL (ServerPartT IO) Response,
      AcidState AuthenticateState)
initAuthentication (String -> Maybe String
forall a. a -> Maybe a
Just String
basePath) AuthenticateConfig
authenticateConfig
        ((PasswordConfig
-> String
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initPassword PasswordConfig
passwordConfig) (String
 -> AcidState AuthenticateState
 -> AuthenticateConfig
 -> IO
      (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
       RouteT AuthenticateURL (ServerPartT IO) JStat))
-> [String
    -> AcidState AuthenticateState
    -> AuthenticateConfig
    -> IO
         (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
          RouteT AuthenticateURL (ServerPartT IO) JStat)]
-> [String
    -> AcidState AuthenticateState
    -> AuthenticateConfig
    -> IO
         (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
          RouteT AuthenticateURL (ServerPartT IO) JStat)]
forall a. a -> [a] -> [a]
: if Bool
True then [ String
-> AcidState AuthenticateState
-> AuthenticateConfig
-> IO
     (Bool -> IO (), (AuthenticationMethod, AuthenticationHandler),
      RouteT AuthenticateURL (ServerPartT IO) JStat)
initOpenId ] else [])
     ClckPlugins
-> Text
-> (ClckPlugins
    -> [Text] -> ClckT ClckURL (ServerPartT IO) Response)
-> IO ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st
-> Text -> (Plugins theme n hook config st -> [Text] -> n) -> m ()
addHandler     ClckPlugins
plugins (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) ((AuthenticateURL
 -> RouteT AuthenticateURL (ServerPartT IO) Response)
-> (AuthURL -> [(Text, Maybe Text)] -> Text)
-> ClckPlugins
-> [Text]
-> ClckT ClckURL (ServerPartT IO) Response
authenticateHandler AuthenticateURL -> RouteT AuthenticateURL (ServerPartT IO) Response
routeAuthenticate AuthURL -> [(Text, Maybe Text)] -> Text
authShowFn)
     ClckPlugins -> Text -> AcidStateAuthenticate -> IO ()
forall (m :: * -> *) state theme n hook config st.
(MonadIO m, Typeable state) =>
Plugins theme n hook config st -> Text -> state -> m ()
addPluginState ClckPlugins
plugins (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) (AcidState AuthenticateState -> AcidStateAuthenticate
AcidStateAuthenticate AcidState AuthenticateState
authenticateState)
     ClckPlugins -> When -> IO () -> IO ()
forall (m :: * -> *) theme n hook config st.
MonadIO m =>
Plugins theme n hook config st -> When -> IO () -> m ()
addCleanup ClckPlugins
plugins When
Always IO ()
authCleanup
     Maybe Text -> IO (Maybe Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
forall a. Maybe a
Nothing
{-
addClckAdminMenu :: ClckT url IO ()
addClckAdminMenu =
    do p <- plugins <$> get
       (Just clckShowURL) <- getPluginRouteFn p (pluginName clckPlugin)
       addAdminMenu ( "Profile"
                    , [ (Set.fromList [Administrator, Visitor], "Edit Your Profile"      , clckShowURL (Profile EditProfileData) [])
                      ]
                    )

       addAdminMenu ( "Clckwrks"
                    , [ (Set.singleton Administrator, "Console"      , clckShowURL (Admin Console)      [])
                      , (Set.singleton Administrator, "Edit Settings", clckShowURL (Admin EditSettings) [])
                      , (Set.singleton Administrator, "Edit Nav Bar" , clckShowURL (Admin EditNavBar)   [])
                      ]
                    )
-}
authenticatePlugin :: Plugin AuthURL Theme (ClckT ClckURL (ServerPartT IO) Response) (ClckT ClckURL IO ()) ClckwrksConfig ClckPluginsSt
authenticatePlugin :: Plugin
  AuthURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
authenticatePlugin = Plugin :: forall url theme n hook config st.
Text
-> (Plugins theme n hook config st -> IO (Maybe Text))
-> [Text]
-> (url -> [Text])
-> hook
-> Plugin url theme n hook config st
Plugin
    { pluginName :: Text
pluginName           = Text
"authenticate"
    , pluginInit :: ClckPlugins -> IO (Maybe Text)
pluginInit           = ClckPlugins -> IO (Maybe Text)
authenticateInit
    , pluginDepends :: [Text]
pluginDepends        = []
    , pluginToPathSegments :: AuthURL -> [Text]
pluginToPathSegments = AuthURL -> [Text]
forall url. PathInfo url => url -> [Text]
toPathSegments
    , pluginPostHook :: ClckT ClckURL IO ()
pluginPostHook       = ClckT ClckURL IO ()
forall url. ClckT url IO ()
addAuthAdminMenu
    }

plugin :: ClckPlugins
       -> Text
       -> IO (Maybe Text)
plugin :: ClckPlugins -> Text -> IO (Maybe Text)
plugin ClckPlugins
plugins Text
baseURI =
    ClckPlugins
-> Text
-> Plugin
     AuthURL
     Theme
     (ClckT ClckURL (ServerPartT IO) Response)
     (ClckT ClckURL IO ())
     ClckwrksConfig
     ClckPluginsSt
-> IO (Maybe Text)
forall url theme n hook config st.
Typeable url =>
Plugins theme n hook config st
-> Text -> Plugin url theme n hook config st -> IO (Maybe Text)
initPlugin ClckPlugins
plugins Text
baseURI Plugin
  AuthURL
  Theme
  (ClckT ClckURL (ServerPartT IO) Response)
  (ClckT ClckURL IO ())
  ClckwrksConfig
  ClckPluginsSt
authenticatePlugin

getUserId :: (Happstack m) => ClckT url m (Maybe UserId)
getUserId :: ClckT url m (Maybe UserId)
getUserId =
  do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url m ClckState -> ClckT url m ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
     ~(Just (AcidStateAuthenticate AcidState AuthenticateState
authenticateState)) <- ClckPlugins -> Text -> ClckT url m (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)
     Maybe (Token, JWT VerifiedJWT)
mToken <- AcidState AuthenticateState
-> ClckT url m (Maybe (Token, JWT VerifiedJWT))
forall (m :: * -> *).
Happstack m =>
AcidState AuthenticateState -> m (Maybe (Token, JWT VerifiedJWT))
getToken AcidState AuthenticateState
authenticateState
     case Maybe (Token, JWT VerifiedJWT)
mToken of
       Maybe (Token, JWT VerifiedJWT)
Nothing       -> Maybe UserId -> ClckT url m (Maybe UserId)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe UserId
forall a. Maybe a
Nothing
       (Just (Token
token, JWT VerifiedJWT
_)) -> Maybe UserId -> ClckT url m (Maybe UserId)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe UserId -> ClckT url m (Maybe UserId))
-> Maybe UserId -> ClckT url m (Maybe UserId)
forall a b. (a -> b) -> a -> b
$ UserId -> Maybe UserId
forall a. a -> Maybe a
Just (Token
token Token -> Getting User Token User -> User
forall s a. s -> Getting a s a -> a
^. Getting User Token User
Lens' Token User
tokenUser User -> Getting UserId User UserId -> UserId
forall s a. s -> Getting a s a -> a
^. Getting UserId User UserId
Lens' User UserId
userId)

instance (Functor m, MonadIO m) => GetAcidState (ClckT url m) AuthenticateState where
    getAcidState :: ClckT url m (AcidState AuthenticateState)
getAcidState =
      do ClckPlugins
p <- ClckState -> ClckPlugins
plugins (ClckState -> ClckPlugins)
-> ClckT url m ClckState -> ClckT url m ClckPlugins
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ClckT url m ClckState
forall s (m :: * -> *). MonadState s m => m s
get
         ~(Just (AcidStateAuthenticate AcidState AuthenticateState
authenticateState)) <- ClckPlugins -> Text -> ClckT url m (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)
         AcidState AuthenticateState
-> ClckT url m (AcidState AuthenticateState)
forall (f :: * -> *) a. Applicative f => a -> f a
pure AcidState AuthenticateState
authenticateState