implemented yesodauth, now need use it in handler

This commit is contained in:
Stuce 2025-06-23 11:25:55 +01:00
parent 4b9d2e8733
commit ab707af870
2 changed files with 27 additions and 1 deletions

View file

@ -1,11 +1,14 @@
{-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE ViewPatterns #-} {-# LANGUAGE ViewPatterns #-}
{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE RecordWildCards #-}
{-# OPTIONS_GHC -fno-warn-orphans #-} {-# OPTIONS_GHC -fno-warn-orphans #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE InstanceSigs #-}
module Application module Application
( getApplicationDev ( getApplicationDev
, appMain , appMain
@ -43,6 +46,9 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
import Handler.Common import Handler.Common
import Handler.Home import Handler.Home
import Handler.TodoEntry import Handler.TodoEntry
import Yesod.Auth
import Database.Persist.Class.PersistUnique (getByValueUniques)
import Database.Persist.SqlBackend.SqlPoolHooks (getAlterBackend)
-- This line actually creates our YesodDispatch instance. It is the second half -- This line actually creates our YesodDispatch instance. It is the second half
-- of the call to mkYesodData which occurs in Foundation.hs. Please see the -- of the call to mkYesodData which occurs in Foundation.hs. Please see the
@ -187,3 +193,23 @@ handler h = getAppSettings >>= makeFoundation >>= flip unsafeHandler h
-- | Run DB queries -- | Run DB queries
db :: ReaderT SqlBackend Handler a -> IO a db :: ReaderT SqlBackend Handler a -> IO a
db = handler . runDB db = handler . runDB
instance YesodAuthPersist App
instance YesodAuth App where
type AuthId App = Key User
loginDest _ = HomeR
logoutDest _ = HomeR
authPlugins _ = [ ]
authenticate :: (MonadHandler m, HandlerSite m ~ App) => Creds App -> m (AuthenticationResult App)
authenticate _ = liftHandler $ do
mUserName <- lookupHeader "remoteUser"
case mUserName of
Just userNameBS -> do
let userName = decodeUtf8 userNameBS
x <- runDB $ insertBy $ User userName
return $ Authenticated $
case x of
Left (Entity user _) -> user -- existing user
Right user -> user -- newly added user
Nothing -> notAuthenticated

View file

@ -241,7 +241,7 @@ getItems text todolistId = map read (lines text)
-- Nothing -> runDB $ insert $ User "Stuce" -- Nothing -> runDB $ insert $ User "Stuce"
-- Just u -> return $ entityKey u -- Just u -> return $ entityKey u
-- TODO: this is kinda ugly, i need to try to find better solution, maybe do a custom auth instance, but i guess it goes for the moment -- TODO: use yesodAuth and clean this mess
getUserId :: Handler (Key User) getUserId :: Handler (Key User)
getUserId = do getUserId = do
mName <- lookupHeader "Remote-User" mName <- lookupHeader "Remote-User"