diff --git a/hssrc/Yesod/Auth/HmacKeccak.hs b/hssrc/Yesod/Auth/HmacKeccak.hs --- a/hssrc/Yesod/Auth/HmacKeccak.hs +++ b/hssrc/Yesod/Auth/HmacKeccak.hs @@ -43,22 +43,76 @@ import Paths_yesod_auth_hmac_keccak as Paths import Yesod.Auth.JsPath +-- | type alias type Username = Text --- js_auth_js :: String --- js_auth_js = --- unsafePerformIO $ readFile =<< getDataFileName "static/js/auth.js" +-- | main class for defining internals +class ( YesodAuth master + , HmacSendMail master + , HmacDB db + , UserCredentials (UserAccount db) + , TokenData (TokenFoo db) + , RenderMessage master FormMessage + ) => YesodHmacKeccak db master | master -> db where + -- | function for accessing the database (runDB eqivalent). + -- can be set to 'runHmacPersistDB' + runHmacDB :: db a -> HandlerT master IO a + -- runHmacDB = runHmacPersistDB + + -- | function to determine a valid username. + -- Default: 'defaultCheckValidUsername' + checkValidUsername :: (MonadHandler m, HandlerSite m ~ master) + => Username -> m (Either Text Username) + checkValidUsername = defaultCheckValidUsername + + -- | Handler for rendering the registration page. + -- Default: 'getNewAccountR'' + getNewAccountR :: HandlerT Auth (HandlerT master IO) Html + getNewAccountR = getNewAccountR' + + -- | Handler for processing registration. + -- Default: 'postNewAccountR'' + postNewAccountR :: HandlerT Auth (HandlerT master IO) Html + postNewAccountR = postNewAccountR' + + -- | Handler for rendering reactivation request page. + -- Default: 'getReactivateR'' + getReactivateR :: HandlerT Auth (HandlerT master IO) Html + getReactivateR = getReactivateR' + + -- | Handler for processing reactivation requests. + -- Default: 'postReactivateR'' + postReactivateR :: HandlerT Auth (HandlerT master IO) Html + postReactivateR = postReactivateR' + + -- | Function for rendering all messages in this plugin. + -- Default: 'defaultAccountMsg' + renderAccountMessage :: master -> [Text] -> AccountMsg -> Text + renderAccountMessage _ _ = defaultAccountMsg + + -- | Route for providing login without javascript. + -- Default: 'Nothing' + rawLoginRoute :: Maybe (Route (HandlerSite (WidgetT master IO))) + rawLoginRoute = Nothing + + -- | Widget for the login page. + -- Default: 'defaultLoginWidget' + loginWidget + :: YesodHmacKeccak db master + => (Route Auth -> Route master) -> WidgetT master IO () + loginWidget = defaultLoginWidget + hmacPlugin :: YesodHmacKeccak db master => AuthPlugin master hmacPlugin = AuthPlugin "authHmacKeccak" dispatch loginWidget where dispatch "POST" ["login"] = postLoginR' >>= sendResponse - dispatch "GET" ["newaccount"] = getNewAccountR' >>= sendResponse - dispatch "POST" ["newaccount"] = postNewAccountR' >>= sendResponse - dispatch "GET" ["resetpasswd"] = getReactivateR' >>= sendResponse - dispatch "POST" ["resetpasswd"] = postReactivateR' >>= sendResponse + dispatch "GET" ["newaccount"] = getNewAccountR >>= sendResponse + dispatch "POST" ["newaccount"] = postNewAccountR >>= sendResponse + dispatch "GET" ["resetpasswd"] = getReactivateR >>= sendResponse + dispatch "POST" ["resetpasswd"] = postReactivateR >>= sendResponse dispatch "GET" ["verify", k] = getVerifyR' (encodeUtf8 k) >>= sendResponse dispatch "POST" ["verify", k] = postVerifyR' (encodeUtf8 k) >>= sendResponse dispatch _ _ = notFound @@ -77,10 +131,11 @@ -- Login procedure. -loginWidget - :: YesodHmacKeccak db master - => (Route Auth -> Route master) -> WidgetT master IO () -loginWidget tm = do +-- | Overridable default login widget +defaultLoginWidget + :: YesodHmacKeccak db master + => (Route Auth -> Route master) -> WidgetT master IO () +defaultLoginWidget tm = do render <- getUrlRenderParams toWidgetHead $ $(jsFile jsPath) render [whamlet| @@ -101,6 +156,19 @@ _{MsgNoJsLogin} |] +-- | Overridable default check for valid usernames +defaultCheckValidUsername + :: ( MonadHandler m + , HandlerSite m ~ master + , YesodHmacKeccak db master + ) + => Username -> m (Either Text Username) +defaultCheckValidUsername u + | T.all C.isAlphaNum u = return $ Right u + | otherwise = do + mr <- getMessageRender + return $ Left $ mr MsgInvalidUsername + postLoginR' :: ( YesodHmacKeccak db master , YesodAuth master @@ -405,6 +473,8 @@ -- classes and foo +-- | Class for providing user credentials to the plugin. A user type is required +-- to have all these fields. class UserCredentials u where userUserName :: u -> Username userUserSalt :: u -> ByteString @@ -412,11 +482,13 @@ userUserEmail :: u -> Text userUserActive :: u -> Bool +-- | Class for providing tokens for user activation. class TokenData t where tokenTokenKind :: t -> Text tokenTokenUsername :: t -> Username tokenTokenToken :: t -> ByteString +-- | Class for defining the accessor functions of the database for users class PersistUserCredentials u where userUsernameF :: EntityField u Username userUserSaltF :: EntityField u ByteString @@ -425,24 +497,29 @@ userUserActiveF :: EntityField u Bool uniqueUsername :: Text -> P.Unique u + -- | create a new user ready for activation from provided data userCreate :: Username -- ^ User name -> Text -- ^ Email -> ByteString -- ^ User salt -> u +-- | Class for defining the accessor functions of the database for tokens class PersistToken t where tokenTokenTokenF :: EntityField t ByteString tokenTokenKindF :: EntityField t Text tokenTokenUsernameF :: EntityField t Username uniqueToken :: ByteString -> P.Unique t + -- | create a new token from provided data tokenCreate :: ByteString -- ^ actual Token -> Username -- ^ User name -> Text -- ^ Token kind -> t +-- | This class lets you define you own database behaviour, but it comes pre- +-- defined with sane defaults. class HmacDB m where type UserAccount m @@ -478,42 +555,6 @@ sendReactivateEmail :: Username -> Text -> Text -> HandlerT master IO () - -class ( YesodAuth master - , HmacSendMail master - , HmacDB db - , UserCredentials (UserAccount db) - , TokenData (TokenFoo db) - , RenderMessage master FormMessage - ) => YesodHmacKeccak db master | master -> db where - - runHmacDB :: db a -> HandlerT master IO a - - checkValidUsername :: (MonadHandler m, HandlerSite m ~ master) - => Username -> m (Either Text Username) - checkValidUsername u - | T.all C.isAlphaNum u = return $ Right u - | otherwise = do - mr <- getMessageRender - return $ Left $ mr MsgInvalidUsername - - getNewAccountR :: HandlerT Auth (HandlerT master IO) Html - getNewAccountR = getNewAccountR' - - postNewAccountR :: HandlerT Auth (HandlerT master IO) Html - postNewAccountR = postNewAccountR' - - getReactivateR :: HandlerT Auth (HandlerT master IO) Html - getReactivateR = getReactivateR' - - postReactivateR :: HandlerT Auth (HandlerT master IO) Html - postReactivateR = postReactivateR' - - renderAccountMessage :: master -> [Text] -> AccountMsg -> Text - renderAccountMessage _ _ = defaultAccountMsg - - rawLoginRoute :: Maybe (Route (HandlerSite (WidgetT master IO))) - rawLoginRoute = Nothing instance YesodHmacKeccak db master => RenderMessage master AccountMsg where renderMessage = renderAccountMessage diff --git a/hssrc/Yesod/Auth/Types.hs b/hssrc/Yesod/Auth/Types.hs --- a/hssrc/Yesod/Auth/Types.hs +++ b/hssrc/Yesod/Auth/Types.hs @@ -1,5 +1,13 @@ -module Yesod.Auth.Types where +{-# LANGUAGE TemplateHaskell #-} +module Yesod.Auth.Types + ( Username(..) + , gimmeFile + ) where import Yesod.Auth.Import +import Text.Julius (jsFile) +import Yesod.Auth.JsPath (jsPath) type Username = Text + +gimmeFile = $(jsFile jsPath) diff --git a/yesod-auth-hmac-keccak.cabal b/yesod-auth-hmac-keccak.cabal --- a/yesod-auth-hmac-keccak.cabal +++ b/yesod-auth-hmac-keccak.cabal @@ -2,7 +2,7 @@ -- further documentation, see http://haskell.org/cabal/users-guide/ name: yesod-auth-hmac-keccak -version: 0.0.0.3 +version: 0.0.0.4 synopsis: An account authentication plugin for yesod with encrypted token transfer. description: This authentication plugin for Yesod uses a challenge-response