Authentication backend for Vervis, fork of Hackage package by the same name

[[ 🗃 ^VE2Kr yesod-auth-account ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Commits]

Clone

HTTPS: git clone https://vervis.peers.community/repos/VE2Kr

SSH: git clone USERNAME@vervis.peers.community:VE2Kr

Branches

Tags

master :: tests /

Foundation.hs

1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121

{-# LANGUAGE CPP, QuasiQuotes, TypeFamilies, GeneralizedNewtypeDeriving #-}
{-# LANGUAGE FlexibleContexts, FlexibleInstances, TemplateHaskell, OverloadedStrings #-}
{-# LANGUAGE GADTs, MultiParamTypeClasses, TypeSynonymInstances #-}

module Foundation where

import Data.Text (Text)
import Data.ByteString (ByteString)
import Database.Persist.Sqlite
import Data.IORef
import Database.Persist.EmailAddress
import System.IO.Unsafe (unsafePerformIO)
import Text.Email.Validate
import Yesod
import Yesod.Auth
import Yesod.Auth.Account
import Yesod.Test

share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistUpperCase|
User
    username Text
    UniqueUsername username
    password ByteString
    emailAddress EmailAddress
    verified Bool
    verifyKey Text
    resetPasswordKey Text
    deriving Show
|]

instance PersistUserCredentials User where
    userUsernameF = UserUsername
    userPasswordHashF = UserPassword
    userEmailF = UserEmailAddress
    userEmailVerifiedF = UserVerified
    userEmailVerifyKeyF = UserVerifyKey
    userResetPwdKeyF = UserResetPasswordKey
    uniqueUsername = UniqueUsername

    userCreate name email key pwd = User name pwd email False key ""

data MyApp = MyApp ConnectionPool

blankEmail :: EmailAddress
blankEmail = unsafeEmailAddress "" ""

lastVerifyEmailR :: IORef (Username, EmailAddress, Text) -- ^ (username, email, verify url)
{-# NOINLINE lastVerifyEmailR #-}
lastVerifyEmailR = unsafePerformIO (newIORef ("", blankEmail, ""))

lastNewPwdEmailR :: IORef (Username, EmailAddress, Text) -- ^ (username, email, verify url)
{-# NOINLINE lastNewPwdEmailR #-}
lastNewPwdEmailR = unsafePerformIO (newIORef ("", blankEmail, ""))

lastVerifyEmail :: MonadIO m => m (Username, EmailAddress, Text)
lastVerifyEmail = liftIO $ readIORef lastVerifyEmailR

lastNewPwdEmail :: MonadIO m => m (Username, EmailAddress, Text)
lastNewPwdEmail = liftIO $ readIORef lastNewPwdEmailR

mkYesod "MyApp" [parseRoutes|
/ HomeR GET
/auth AuthR Auth getAuth
|]

instance Yesod MyApp

instance RenderMessage MyApp FormMessage where
    renderMessage _ _ = defaultFormMessage

instance YesodPersist MyApp where
#if MIN_VERSION_yesod(1,4,0)
    type YesodPersistBackend MyApp = SqlBackend
#else
    type YesodPersistBackend MyApp = SqlPersistT
#endif
    runDB action = do
        MyApp pool <- getYesod
        runSqlPool action pool

instance YesodAuth MyApp where
    type AuthId MyApp = Username
    getAuthId = return . Just . credsIdent
    loginDest _ = HomeR
    logoutDest _ = HomeR
    authPlugins _ = [accountPlugin]
    authHttpManager _ = error "No manager needed"
    onLogin = return ()
    maybeAuthId = lookupSession "_ID"

instance AccountSendEmail MyApp where
    sendVerifyEmail name email url =
        liftIO $ writeIORef lastVerifyEmailR (name, email, url)

    sendNewPasswordEmail name email url =
        liftIO $ writeIORef lastNewPwdEmailR (name, email, url)

instance YesodAuthAccount (AccountPersistDB MyApp User) MyApp where
    runAccountDB = runAccountPersistDB

getHomeR :: Handler Html
getHomeR = do
    maid <- maybeAuthId
    case maid of
        Nothing -> defaultLayout $ [whamlet|
<p>Please visit the <a href="@{AuthR LoginR}">Login page</a>
|]
        Just u -> defaultLayout $ [whamlet|
<p>You are logged in as #{u}
<p><a href="@{AuthR LogoutR}">Logout</a>
|]

-- Temporary helpers for testing
get' :: Yesod site => Text -> YesodExample site ()
get' url = Yesod.Test.get url

post' :: Yesod site => Text -> RequestBuilder site () -> YesodExample site ()
post' url builder = request $ do
    setUrl url
    setMethod "POST"
    builder
[See repo JSON]