yesod-auth-hmac-keccak 0.0.0.3 → 0.0.0.4

raw patch · 3 files changed

+98/−49 lines, 3 files

Files

• hssrc/Yesod/Auth/HmacKeccak.hs +88/−47
• hssrc/Yesod/Auth/Types.hs +9/−1
• yesod-auth-hmac-keccak.cabal +1/−1

@@ -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 @@     <a href="@{route}">_{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

@@ -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)

@@ -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