From f9346324844647c7d8f7a2654c2b8e9763017928 Mon Sep 17 00:00:00 2001
From: Danielle McLean <dani@00dani.me>
Date: Fri, 6 Oct 2017 10:38:10 +1100
Subject: [PATCH] Enable simple username+password login - ugly but serviceable

---
 config/models       |  3 ++-
 package.yaml        |  2 ++
 src/Foundation.hs   | 39 ++++++++++-----------------------------
 src/Handler/Home.hs |  2 +-
 src/Model.hs        |  5 +++++
 5 files changed, 20 insertions(+), 31 deletions(-)

diff --git a/config/models b/config/models
index ff73c40..ee4023d 100644
--- a/config/models
+++ b/config/models
@@ -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
 
diff --git a/package.yaml b/package.yaml
index 9450c46..f582310 100644
--- a/package.yaml
+++ b/package.yaml
@@ -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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index e441d28..534040e 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -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,9 +156,8 @@ instance Yesod App where
 
 -- Define breadcrumbs.
 instance YesodBreadcrumbs App where
-  breadcrumb HomeR = return ("Home", Nothing)
-  breadcrumb (AuthR _) = return ("Login", Just HomeR)
-  breadcrumb  _ = return ("home", Nothing)
+  breadcrumb (AuthR _) = return ("login", Just HomeR)
+  breadcrumb _ = return ("home", Nothing)
 
 -- How to run database actions.
 instance YesodPersist App where
@@ -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.
diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs
index 74fe394..eae3746 100644
--- a/src/Handler/Home.hs
+++ b/src/Handler/Home.hs
@@ -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
diff --git a/src/Model.hs b/src/Model.hs
index 4420c16..5a9da96 100644
--- a/src/Model.hs
+++ b/src/Model.hs
@@ -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 }