nerf/OwOpointTracker
1
0
Fork 0
Code Issues Pull requests Projects Releases Packages Wiki Activity Actions

before adding stack to develop

Browse source
This commit is contained in:
Dennis Frieberg 2024-08-22 02:02:29 +02:00
parent f574c9cebf
commit 315accc42e
Signed by: nerf
GPG key ID: 42DED0E2D8F04FB6
17 changed files with 216 additions and 535 deletions
Download patch file Download diff file Expand all files Collapse all files

2
src/Application.hs
View file

@ -42,8 +42,6 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
-- Don't forget to add new modules to your cabal file!
import Handler.Common
import Handler.Home
import Handler.Comment
import Handler.Profile
-- 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

197
src/Foundation.hs
View file

@ -18,9 +18,9 @@ import Text.Jasmine (minifym)
import Control.Monad.Logger (LogSource)
-- Used only when in "auth-dummy-login" setting is enabled.
import Yesod.Auth.Dummy
-- import Yesod.Auth.Dummy
import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed))
-- import Yesod.Auth.OpenId (authOpenId, IdentifierType (Claimed))
import Yesod.Default.Util (addStaticContentExternal)
import Yesod.Core.Types (Logger)
import qualified Yesod.Core.Unsafe as Unsafe
@ -103,41 +103,42 @@ instance Yesod App where
master <- getYesod
mmsg <- getMessage
muser <- maybeAuthPair
-- muser <- maybeAuthPair
mcurrentRoute <- getCurrentRoute
-- Get the breadcrumbs, as defined in the YesodBreadcrumbs instance.
(title, parents) <- breadcrumbs
-- (title, parents) <- breadcrumbs
let title = "Geländespiel Punktetracker"
-- Define the menu items of the header.
let menuItems =
[ NavbarLeft $ MenuItem
{ menuItemLabel = "Home"
, menuItemRoute = HomeR
, menuItemAccessCallback = True
}
, NavbarLeft $ MenuItem
{ menuItemLabel = "Profile"
, menuItemRoute = ProfileR
, menuItemAccessCallback = isJust muser
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Login"
, menuItemRoute = AuthR LoginR
, menuItemAccessCallback = isNothing muser
}
, NavbarRight $ MenuItem
{ menuItemLabel = "Logout"
, menuItemRoute = AuthR LogoutR
, menuItemAccessCallback = isJust muser
}
]
let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-- let menuItems =
-- [ NavbarLeft $ MenuItem
-- { menuItemLabel = "Home"
-- , menuItemRoute = HomeR
-- , menuItemAccessCallback = True
-- }
-- , NavbarLeft $ MenuItem
-- { menuItemLabel = "Profile"
-- , menuItemRoute = ProfileR
-- , menuItemAccessCallback = isJust muser
-- }
-- , NavbarRight $ MenuItem
-- { menuItemLabel = "Login"
-- , menuItemRoute = AuthR LoginR
-- , menuItemAccessCallback = isNothing muser
-- }
-- , NavbarRight $ MenuItem
-- { menuItemLabel = "Logout"
-- , menuItemRoute = AuthR LogoutR
-- , menuItemAccessCallback = isJust muser
-- }
-- ]
--
-- let navbarLeftMenuItems = [x | NavbarLeft x <- menuItems]
-- let navbarRightMenuItems = [x | NavbarRight x <- menuItems]
--
-- let navbarLeftFilteredMenuItems = [x | x <- navbarLeftMenuItems, menuItemAccessCallback x]
-- let navbarRightFilteredMenuItems = [x | x <- navbarRightMenuItems, menuItemAccessCallback x]
-- We break up the default layout into two components:
-- default-layout is the contents of the body tag, and
@ -152,26 +153,26 @@ instance Yesod App where
withUrlRenderer $(hamletFile "templates/default-layout-wrapper.hamlet")
-- The page to be redirected to when authentication is required.
authRoute
:: App
-> Maybe (Route App)
authRoute _ = Just $ AuthR LoginR
-- authRoute
-- :: App
-- -> Maybe (Route App)
-- authRoute _ = Just $ AuthR LoginR
isAuthorized
:: Route App -- ^ The route the user is visiting.
-> Bool -- ^ Whether or not this is a "write" request.
-> Handler AuthResult
-- Routes not requiring authentication.
isAuthorized (AuthR _) _ = return Authorized
isAuthorized CommentR _ = return Authorized
isAuthorized HomeR _ = return Authorized
isAuthorized FaviconR _ = return Authorized
isAuthorized RobotsR _ = return Authorized
isAuthorized (StaticR _) _ = return Authorized
-- the profile route requires that the user is authenticated, so we
-- delegate to that function
isAuthorized ProfileR _ = isAuthenticated
-- isAuthorized
-- :: Route App -- ^ The route the user is visiting.
-- -> Bool -- ^ Whether or not this is a "write" request.
-- -> Handler AuthResult
-- -- Routes not requiring authentication.
-- isAuthorized (AuthR _) _ = return Authorized
-- isAuthorized CommentR _ = return Authorized
-- isAuthorized HomeR _ = return Authorized
-- isAuthorized FaviconR _ = return Authorized
-- isAuthorized RobotsR _ = return Authorized
-- isAuthorized (StaticR _) _ = return Authorized
--
-- -- the profile route requires that the user is authenticated, so we
-- -- delegate to that function
-- isAuthorized ProfileR _ = isAuthenticated
-- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows
@ -210,17 +211,17 @@ instance Yesod App where
makeLogger = return . appLogger
-- Define breadcrumbs.
instance YesodBreadcrumbs App where
-- Takes the route that the user is currently on, and returns a tuple
-- of the 'Text' that you want the label to display, and a previous
-- breadcrumb route.
breadcrumb
:: Route App -- ^ The route the user is visiting currently.
-> Handler (Text, Maybe (Route App))
breadcrumb HomeR = return ("Home", Nothing)
breadcrumb (AuthR _) = return ("Login", Just HomeR)
breadcrumb ProfileR = return ("Profile", Just HomeR)
breadcrumb _ = return ("home", Nothing)
--instance YesodBreadcrumbs App where
-- -- Takes the route that the user is currently on, and returns a tuple
-- -- of the 'Text' that you want the label to display, and a previous
-- -- breadcrumb route.
-- breadcrumb
-- :: Route App -- ^ The route the user is visiting currently.
-- -> Handler (Text, Maybe (Route App))
-- breadcrumb HomeR = return ("Home", Nothing)
-- breadcrumb (AuthR _) = return ("Login", Just HomeR)
-- breadcrumb ProfileR = return ("Profile", Just HomeR)
-- breadcrumb _ = return ("home", Nothing)
-- How to run database actions.
instance YesodPersist App where
@ -234,45 +235,45 @@ instance YesodPersistRunner App where
getDBRunner :: Handler (DBRunner App, Handler ())
getDBRunner = defaultGetDBRunner appConnPool
instance YesodAuth App where
type AuthId App = UserId
-- Where to send a user after successful login
loginDest :: App -> Route App
loginDest _ = HomeR
-- Where to send a user after logout
logoutDest :: App -> Route App
logoutDest _ = HomeR
-- Override the above two destinations when a Referer: header is present
redirectToReferer :: App -> Bool
redirectToReferer _ = True
authenticate :: (MonadHandler m, HandlerSite m ~ App)
=> Creds App -> m (AuthenticationResult App)
authenticate creds = liftHandler $ runDB $ do
x <- getBy $ UniqueUser $ credsIdent creds
case x of
Just (Entity uid _) -> return $ Authenticated uid
Nothing -> Authenticated <$> insert User
{ userIdent = credsIdent creds
, userPassword = Nothing
}
-- You can add other plugins like Google Email, email or OAuth here
authPlugins :: App -> [AuthPlugin App]
authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
-- Enable authDummy login if enabled.
where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
--instance YesodAuth App where
-- type AuthId App = UserId
--
-- -- Where to send a user after successful login
-- loginDest :: App -> Route App
-- loginDest _ = HomeR
-- -- Where to send a user after logout
-- logoutDest :: App -> Route App
-- logoutDest _ = HomeR
-- -- Override the above two destinations when a Referer: header is present
-- redirectToReferer :: App -> Bool
-- redirectToReferer _ = True
--
-- authenticate :: (MonadHandler m, HandlerSite m ~ App)
-- => Creds App -> m (AuthenticationResult App)
-- authenticate creds = liftHandler $ runDB $ do
-- x <- getBy $ UniqueUser $ credsIdent creds
-- case x of
-- Just (Entity uid _) -> return $ Authenticated uid
-- Nothing -> Authenticated <$> insert User
-- { userIdent = credsIdent creds
-- , userPassword = Nothing
-- }
--
-- -- You can add other plugins like Google Email, email or OAuth here
-- authPlugins :: App -> [AuthPlugin App]
-- authPlugins app = [authOpenId Claimed []] ++ extraAuthPlugins
-- -- Enable authDummy login if enabled.
-- where extraAuthPlugins = [authDummy | appAuthDummyLogin $ appSettings app]
-- | Access function to determine if a user is logged in.
isAuthenticated :: Handler AuthResult
isAuthenticated = do
muid <- maybeAuthId
return $ case muid of
Nothing -> Unauthorized "You must login to access this page"
Just _ -> Authorized
--isAuthenticated :: Handler AuthResult
--isAuthenticated = do
-- muid <- maybeAuthId
-- return $ case muid of
-- Nothing -> Unauthorized "You must login to access this page"
-- Just _ -> Authorized
instance YesodAuthPersist App
--instance YesodAuthPersist App
-- This instance is required to use forms. You can modify renderMessage to
-- achieve customized and internationalized form validation messages.

16
src/Handler/Comment.hs
View file

@ -1,16 +0,0 @@
module Handler.Comment where
import Import
postCommentR :: Handler Value
postCommentR = do
-- requireCheckJsonBody will parse the request body into the appropriate type, or return a 400 status code if the request JSON is invalid.
-- (The ToJSON and FromJSON instances are derived in the config/models file).
comment <- (requireCheckJsonBody :: Handler Comment)
-- The YesodAuth instance in Foundation.hs defines the UserId to be the type used for authentication.
maybeCurrentUserId <- maybeAuthId
let comment' = comment { commentUserId = maybeCurrentUserId }
insertedComment <- runDB $ insertEntity comment'
returnJson insertedComment

98
src/Handler/Home.hs
View file

@ -6,14 +6,14 @@
module Handler.Home where
import Import
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Text.Julius (RawJS (..))
--import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
--import Text.Julius (RawJS (..))
-- Define our data that will be used for creating the form.
data FileForm = FileForm
{ fileInfo :: FileInfo
, fileDescription :: Text
}
--data FileForm = FileForm
-- { fileInfo :: FileInfo
-- , fileDescription :: Text
-- }
-- This is a handler function for the GET request method on the HomeR
-- resource pattern. All of your resource patterns are defined in
@ -24,50 +24,52 @@ data FileForm = FileForm
-- inclined, or create a single monolithic file.
getHomeR :: Handler Html
getHomeR = do
(formWidget, formEnctype) <- generateFormPost sampleForm
let submission = Nothing :: Maybe FileForm
handlerName = "getHomeR" :: Text
allComments <- runDB $ getAllComments
-- (formWidget, formEnctype) <- generateFormPost sampleForm
-- let submission = Nothing :: Maybe FileForm
-- handlerName = "getHomeR" :: Text
-- allComments <- runDB $ getAllComments
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
-- let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
setTitle "OwO Geländespielpunkte"
let tutorPoints = 5 :: Int
let erstiePoints = 3 :: Int
$(widgetFile "homepage")
postHomeR :: Handler Html
postHomeR = do
((result, formWidget), formEnctype) <- runFormPost sampleForm
let handlerName = "postHomeR" :: Text
submission = case result of
FormSuccess res -> Just res
_ -> Nothing
allComments <- runDB $ getAllComments
defaultLayout $ do
let (commentFormId, commentTextareaId, commentListId) = commentIds
aDomId <- newIdent
setTitle "Welcome To Yesod!"
$(widgetFile "homepage")
sampleForm :: Form FileForm
sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
<$> fileAFormReq "Choose a file"
<*> areq textField textSettings Nothing
-- Add attributes like the placeholder and CSS classes.
where textSettings = FieldSettings
{ fsLabel = "What's on the file?"
, fsTooltip = Nothing
, fsId = Nothing
, fsName = Nothing
, fsAttrs =
[ ("class", "form-control")
, ("placeholder", "File description")
]
}
commentIds :: (Text, Text, Text)
commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
getAllComments :: DB [Entity Comment]
getAllComments = selectList [] [Asc CommentId]
--postHomeR :: Handler Html
--postHomeR = do
-- ((result, formWidget), formEnctype) <- runFormPost sampleForm
-- let handlerName = "postHomeR" :: Text
-- submission = case result of
-- FormSuccess res -> Just res
-- _ -> Nothing
-- allComments <- runDB $ getAllComments
--
-- defaultLayout $ do
-- let (commentFormId, commentTextareaId, commentListId) = commentIds
-- aDomId <- newIdent
-- setTitle "Welcome To Yesod!"
-- $(widgetFile "homepage")
--
--sampleForm :: Form FileForm
--sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
-- <$> fileAFormReq "Choose a file"
-- <*> areq textField textSettings Nothing
-- -- Add attributes like the placeholder and CSS classes.
-- where textSettings = FieldSettings
-- { fsLabel = "What's on the file?"
-- , fsTooltip = Nothing
-- , fsId = Nothing
-- , fsName = Nothing
-- , fsAttrs =
-- [ ("class", "form-control")
-- , ("placeholder", "File description")
-- ]
-- }
--
--commentIds :: (Text, Text, Text)
--commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")
--
--getAllComments :: DB [Entity Comment]
--getAllComments = selectList [] [Asc CommentId]

15
src/Handler/Profile.hs
View file

@ -1,15 +0,0 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Profile where
import Import
getProfileR :: Handler Html
getProfileR = do
(_, user) <- requireAuthPair
defaultLayout $ do
setTitle . toHtml $ userIdent user <> "'s User page"
$(widgetFile "profile")