From 315accc42edef5d64f0038f4260eb4537a9599c0 Mon Sep 17 00:00:00 2001 From: Dennis Frieberg Date: Thu, 22 Aug 2024 02:02:29 +0200 Subject: [PATCH] before adding stack to develop --- .gitignore | 3 + OwOpointTracker.cabal | 16 +- config/routes.yesodroutes | 8 +- src/Application.hs | 2 - src/Foundation.hs | 197 ++++++++++++------------ src/Handler/Comment.hs | 16 -- src/Handler/Home.hs | 98 ++++++------ src/Handler/Profile.hs | 15 -- templates/default-layout-wrapper.hamlet | 20 --- templates/default-layout.hamlet | 34 ---- templates/homepage.hamlet | 124 +-------------- templates/homepage.julius | 34 ---- templates/homepage.lucius | 9 -- test/Handler/CommentSpec.hs | 47 ------ test/Handler/HomeSpec.hs | 58 +++---- test/Handler/ProfileSpec.hs | 28 ---- test/TestImport.hs | 42 ++--- 17 files changed, 216 insertions(+), 535 deletions(-) delete mode 100644 src/Handler/Comment.hs delete mode 100644 src/Handler/Profile.hs delete mode 100644 templates/homepage.julius delete mode 100644 test/Handler/CommentSpec.hs delete mode 100644 test/Handler/ProfileSpec.hs diff --git a/.gitignore b/.gitignore index 56eed70..9daf56b 100644 --- a/.gitignore +++ b/.gitignore @@ -30,3 +30,6 @@ result-* # ---> Yesod *.sqlite3 +*.sqlite3-shm +*.sqlite3-wal +static/tmp/ diff --git a/OwOpointTracker.cabal b/OwOpointTracker.cabal index 6f12bcb..0ba5298 100644 --- a/OwOpointTracker.cabal +++ b/OwOpointTracker.cabal @@ -18,13 +18,9 @@ data-files: config/models.persistentmodels , static/fonts/glyphicons-halflings-regular.svg , static/fonts/glyphicons-halflings-regular.ttf , static/fonts/glyphicons-halflings-regular.woff - , templates/default-layout-wrapper.hamlet - , templates/default-layout.hamlet - , templates/default-layout.lucius - , templates/homepage.hamlet - , templates/homepage.julius - , templates/homepage.lucius - , templates/profile.hamlet + , templates/*.hamlet +-- , templates/*.julius + , templates/*.lucius flag dev description: Turn on development settings, like auto-reload templates. @@ -40,10 +36,8 @@ library exposed-modules: Application Foundation - Handler.Comment Handler.Common Handler.Home - Handler.Profile Import Import.NoFoundation Model @@ -98,7 +92,7 @@ library ghc-options: -Wall -fwarn-tabs -O0 cpp-options: -DDEVELOPMENT else - ghc-options: -Wall -fwarn-tabs -O2 + ghc-options: -Wall -fwarn-tabs -O1 executable OwOpointTracker main-is: main.hs @@ -157,10 +151,8 @@ test-suite OwOpointTracker-test type: exitcode-stdio-1.0 main-is: Spec.hs other-modules: - Handler.CommentSpec Handler.CommonSpec Handler.HomeSpec - Handler.ProfileSpec TestImport Paths_OwOpointTracker hs-source-dirs: diff --git a/config/routes.yesodroutes b/config/routes.yesodroutes index 37e8bea..342837b 100644 --- a/config/routes.yesodroutes +++ b/config/routes.yesodroutes @@ -2,13 +2,13 @@ -- Syntax for this file here: https://www.yesodweb.com/book/routing-and-handlers /static StaticR Static appStatic -/auth AuthR Auth getAuth +-- /auth AuthR Auth getAuth /favicon.ico FaviconR GET /robots.txt RobotsR GET -/ HomeR GET POST +/ HomeR GET -/comments CommentR POST +-- /comments CommentR POST -/profile ProfileR GET +-- /profile ProfileR GET diff --git a/src/Application.hs b/src/Application.hs index 2a0a7f9..e05dd18 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -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 diff --git a/src/Foundation.hs b/src/Foundation.hs index 488b645..8a58789 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -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. diff --git a/src/Handler/Comment.hs b/src/Handler/Comment.hs deleted file mode 100644 index df8dcb1..0000000 --- a/src/Handler/Comment.hs +++ /dev/null @@ -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 diff --git a/src/Handler/Home.hs b/src/Handler/Home.hs index 3a18677..4af4112 100644 --- a/src/Handler/Home.hs +++ b/src/Handler/Home.hs @@ -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] diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs deleted file mode 100644 index f0b8102..0000000 --- a/src/Handler/Profile.hs +++ /dev/null @@ -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") diff --git a/templates/default-layout-wrapper.hamlet b/templates/default-layout-wrapper.hamlet index 1737670..c58c944 100644 --- a/templates/default-layout-wrapper.hamlet +++ b/templates/default-layout-wrapper.hamlet @@ -16,15 +16,6 @@ $newline never ^{pageHead pc} - \ -