diff --git a/models b/models index 1fd956be7..ee1fae56c 100644 --- a/models +++ b/models @@ -61,10 +61,10 @@ Corrector -- ) UniqueCorrector userId courseId CourseParticipant - userId UserId courseId CourseId + userId UserId registration UTCTime - UniqueCourseParticipant userId courseId + UniqueCourseParticipant courseId userId Sheet courseId CourseId name Text diff --git a/routes b/routes index 10f0aa4d8..941fe5b63 100644 --- a/routes +++ b/routes @@ -16,7 +16,7 @@ !/course/edit CourseEditR GET POST !/course/#TermIdentifier CourseListTermR GET /course/#TermIdentifier/#Text/edit CourseEditExistR GET -/course/#TermIdentifier/#Text/show CourseShowR GET +/course/#TermIdentifier/#Text/show CourseShowR GET POST -- For demonstration /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index b63e51f89..68c7b72c1 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -16,8 +16,8 @@ import Data.Time import qualified Data.Text as T import Yesod.Form.Bootstrap3 -import Colonnade -import Yesod.Colonnade +import Colonnade hiding (fromMaybe) +import Yesod.Colonnade import qualified Data.UUID.Cryptographic as UUID @@ -58,18 +58,52 @@ getCourseListTermR tidini = do getCourseShowR :: TermIdentifier -> Text -> Handler Html getCourseShowR tid csh = do - (courseEnt,(schoolMB,participants)) <- runDB $ do + mbAid <- maybeAuthId + (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh - dependent <- (,) + dependent <- (,,) <$> get (courseSchoolId course) -- join <*> count [CourseParticipantCourseId ==. cid] -- join + <*> (case mbAid of -- Someone please refactor this late-night mess here! + Nothing -> return False + (Just aid) -> do + regL <- getBy (UniqueCourseParticipant cid aid) + return $ isJust regL) return $ (courseEnt,dependent) - let course = entityVal courseEnt + let course = entityVal courseEnt + (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered defaultLayout $ do setTitle $ [shamlet| #{termToText tid} - #{csh}|] $(widgetFile "course") - + +registerButton :: Bool -> Form () +registerButton registered = + renderBootstrap3 bsHorizontalDefault $ + pure () <* bootstrapSubmit regMsg + where + msg = if registered then "Abmelden" else "Anmelden" + regMsg = msg :: BootstrapSubmit Text +postCourseShowR :: TermIdentifier -> Text -> Handler Html +postCourseShowR tid csh = do + aid <- requireAuthId + (cid, registered) <- runDB $ do + (Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh + registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid) + return (cid, registered) + ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered + case regResult of + (FormSuccess _) + | registered -> do + runDB $ deleteBy $ UniqueCourseParticipant cid aid + setMessage "Sie wurden abgemeldet." + | otherwise -> do + actTime <- liftIO $ getCurrentTime + regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime + when (isJust regOk) $ setMessage "Erfolgreich angemeldet!" + -- redirect or not?! I guess not, since we want GET now + getCourseShowR tid csh + getCourseEditR :: Handler Html getCourseEditR = do -- TODO: Defaults für Semester hier ermitteln und übergeben diff --git a/src/Handler/Home.bak b/src/Handler/Home.bak new file mode 100644 index 000000000..11dec1ca5 --- /dev/null +++ b/src/Handler/Home.bak @@ -0,0 +1,67 @@ +{-# LANGUAGE NoImplicitPrelude #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE TypeFamilies #-} +module Handler.Home where + +import Import +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 + } + +-- This is a handler function for the GET request method on the HomeR +-- resource pattern. All of your resource patterns are defined in +-- config/routes +-- +-- The majority of the code you will write in Yesod lives in these handler +-- functions. You can spread them across multiple files if you are so +-- inclined, or create a single monolithic file. +getHomeR :: Handler Html +getHomeR = do + (formWidget, formEnctype) <- generateFormPost sampleForm + let submission = Nothing :: Maybe FileForm + handlerName = "getHomeR" :: Text + defaultLayout $ do + let (commentFormId, commentTextareaId, commentListId) = commentIds + aDomId <- newIdent + setTitle "Welcome To Yesod!" + $(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 + + 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") diff --git a/templates/course.hamlet b/templates/course.hamlet index fd8fc510d..a23e8697e 100644 --- a/templates/course.hamlet +++ b/templates/course.hamlet @@ -24,6 +24,9 @@ #{participants} $maybe capacity <- courseCapacity course \ von #{capacity} +
+ ^{regWidget} +