Enable simple username+password login - ugly but serviceable

This commit is contained in:
Danielle McLean 2017-10-06 10:38:10 +11:00
parent e141fb4666
commit f934632484
Signed by: 00dani
GPG key ID: 5A5D2D1AFF12EEC5
5 changed files with 20 additions and 31 deletions

View file

@ -1,9 +1,10 @@
User
username Text maxlen=190
password Text maxlen=79
fullName Text maxlen=500
email Text maxlen=190
note Text sqltype=mediumtext
UniqueUsername username
UniqueUser username
UniqueEmail email
deriving Typeable

View file

@ -46,9 +46,11 @@ dependencies:
- time
- case-insensitive
- wai
- conduit-combinators >= 1.1 && < 1.2
- libravatar >=0.4 && <0.5
- split >=0.2 && <0.3
- yesod-auth-hashdb >=1.6.2 && <1.7
- yesod-sitemap >=1.4 && <1.5
# The library contains all of our application code. The executable

View file

@ -12,10 +12,9 @@ import Database.Persist.Sql (ConnectionPool, runSqlPool)
import Text.Hamlet (hamletFile)
import Text.Jasmine (minifym)
-- Used only when in "auth-dummy-login" setting is enabled.
import Yesod.Auth.Dummy
import Yesod.Auth.HashDB (authHashDB)
import qualified Yesod.Auth.Message as AuthMsg
import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed))
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
@ -125,13 +124,7 @@ instance Yesod App where
authRoute _ = Just $ AuthR LoginR
-- Routes not requiring authentication.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized KeybaseR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized SitemapR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
isAuthorized _ _ = return Authorized
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
@ -163,8 +156,7 @@ instance Yesod App where
-- Define breadcrumbs.
instance YesodBreadcrumbs App where
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb (AuthR _) = return ("login", Just HomeR)
breadcrumb _ = return ("home", Nothing)
-- How to run database actions.
@ -183,25 +175,14 @@ instance YesodAuth App where
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest _ = HomeR
-- Override the above two destinations when a Referer: header is present
redirectToReferer _ = True
authenticate creds = runDB $ do
x <- getBy . UniqueUsername $ credsIdent creds
case x of
Just (Entity uid _) -> return $ Authenticated uid
Nothing -> Authenticated <$> insert User
{ userUsername = credsIdent creds
, userFullName = ""
, userEmail = ""
, userNote = ""
}
authenticate = fmap toResult . lookupCreds
where
lookupCreds = runDB . getBy . UniqueUser . credsIdent
toResult = UserError AuthMsg.InvalidLogin `maybe` (Authenticated . entityKey)
-- You can add other plugins like Google Email, email or OAuth here
authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
-- Enable authDummy login if enabled.
where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
authPlugins _ = [authHashDB (Just . UniqueUser)]
authHttpManager = getHttpManager
-- | Access function to determine if a user is logged in.

View file

@ -10,7 +10,7 @@ import Widget.Hcard (hcard)
getHomeR :: Handler Html
getHomeR = do
user <- runDB . getBy404 $ UniqueUsername "dani"
user <- runDB . getBy404 $ UniqueUser "dani"
let name = userFullName . entityVal $ user
maybeTitle <- asks $ appTitle . appSettings
defaultLayout $ do

View file

@ -11,6 +11,7 @@ module Model where
import ClassyPrelude.Yesod
import Database.Persist.Quasi
import Yesod.Auth.HashDB ( HashDBUser(..) )
-- You can define all of your database entities in the entities file.
-- You can find more information on persistent and how to declare entities
@ -18,3 +19,7 @@ import Database.Persist.Quasi
-- http://www.yesodweb.com/book/persistent/
share [mkPersist sqlSettings, mkMigrate "migrateAll"]
$(persistFileWith lowerCaseSettings "config/models")
instance HashDBUser User where
userPasswordHash = Just . userPassword
setPasswordHash pw u = u { userPassword = pw }