Initial module implementation

yesod-auth/Yesod/Auth/Hardcoded.hs

@@ -0,0 +1,75 @@
+{-# LANGUAGE FlexibleContexts      #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE OverloadedStrings     #-}
+{-# LANGUAGE QuasiQuotes           #-}
+{-# LANGUAGE RankNTypes            #-}
+{-# LANGUAGE TemplateHaskell       #-}
+{-# LANGUAGE TypeFamilies          #-}
+module Yesod.Auth.Hardcoded
+  ( YesodAuthHardcoded(..)
+  , authHardcoded
+  , loginR )
+  where
+
+import           Yesod.Auth          (Auth, AuthPlugin (..), AuthRoute,
+                                      Creds (..), Route (..), YesodAuth,
+                                      loginErrorMessageI, setCredsRedirect)
+import qualified Yesod.Auth.Message  as Msg
+import           Yesod.Core
+import           Yesod.Form          (ireq, runInputPost, textField)
+
+import           Control.Applicative ((<$>), (<*>))
+import           Data.Text           (Text)
+
+
+loginR :: AuthRoute
+loginR = PluginR "hardcoded" ["login"]
+
+class (YesodAuth site) => YesodAuthHardcoded site where
+
+  -- | Check whether given user name exists among hardcoded names.
+  doesUserNameExist :: Text -> HandlerT site IO Bool
+
+  -- | Validate given user name with given password.
+  validatePassword :: Text -> Text -> HandlerT site IO Bool
+
+
+authHardcoded :: YesodAuthHardcoded m => AuthPlugin m
+authHardcoded =
+  AuthPlugin "hardcoded" dispatch loginWidget
+  where
+    dispatch "POST" ["login"] = postLoginR >>= sendResponse
+    dispatch _ _ = notFound
+    loginWidget toMaster =
+      [whamlet|
+        $newline never
+        <form method="post" action="@{toMaster loginR}">
+          <table>
+            <tr>
+              <th>_{Msg.UserName}
+              <td>
+                 <input type="text" name="username" required>
+            <tr>
+              <th>_{Msg.Password}
+              <td>
+                 <input type="password" name="password" required>
+            <tr>
+              <td colspan="2">
+                 <button type="submit" .btn .btn-success>_{Msg.LoginTitle}
+        |]
+
+
+postLoginR :: (YesodAuthHardcoded master)
+           => HandlerT Auth (HandlerT master IO) TypedContent
+postLoginR =
+  do (username, password) <- lift (runInputPost
+       ((,) <$> ireq textField "username"
+            <*> ireq textField "password"))
+     isValid <- lift (validatePassword username password)
+     if isValid
+        then lift (setCredsRedirect (Creds "hardcoded" username []))
+        else do isExists <- lift (doesUserNameExist username)
+                loginErrorMessageI LoginR
+                                   (if isExists
+                                       then Msg.InvalidUsernamePass
+                                       else Msg.IdentifierNotFound username)

yesod-auth/yesod-auth.cabal

@@ -75,6 +75,7 @@ library
                      Yesod.Auth.Message
                      Yesod.Auth.GoogleEmail
                      Yesod.Auth.GoogleEmail2
+                     Yesod.Auth.Hardcoded
     other-modules:   Yesod.Auth.Routes
                      Yesod.PasswordStore
     ghc-options:     -Wall