From b980bab1b18d6783b21ac145de7923e59d80592c Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 9 Oct 2017 22:17:49 +0200 Subject: [PATCH] Course Form works; display not yet. --- models | 18 +-- routes | 11 +- src/Application.hs | 2 +- src/Common.hs | 13 +- src/Foundation.hs | 15 ++- src/Handler/Assist.hs | 99 --------------- src/Handler/Course.hs | 220 ++++++++++++++++++++++++++++++++++ src/Handler/Term.hs | 50 ++++---- src/Handler/Utils/DateTime.hs | 1 + src/Handler/Utils/Form.hs | 55 ++++++++- src/Handler/Utils/Term.hs | 1 + templates/generic_form.hamlet | 2 +- 12 files changed, 338 insertions(+), 149 deletions(-) delete mode 100644 src/Handler/Assist.hs create mode 100644 src/Handler/Course.hs diff --git a/models b/models index d08da58a6..6a73f6296 100644 --- a/models +++ b/models @@ -29,17 +29,19 @@ DegreeCourse json UniqueDegreeCourse degreeId courseId Course name Text - shorthand Text description Html Maybe - linkexternal Text Maybe - schoolId SchoolId - termId TermId -- TermId ist jetzt Text als Typ + linkExternal Text Maybe + shorthand Text + termId TermIdentifier + schoolId SchoolId capacity Int Maybe created UTCTime changed UTCTime - registerFrom UTCTime - registerTo UTCTime - UniqueTermShorthand shorthand termId + createdBy UserId + changedBy UserId + registerFrom UTCTime Maybe + registerTo UTCTime Maybe + CourseTermShort termId shorthand Lecturer userId UserId courseId CourseId @@ -113,7 +115,7 @@ TutorialUser tutorialId TutorialId UniqueTutorialUser userId tutorialId Booking - termId TermId + termId TermIdentifier begin UTCTime end UTCTime weekly Bool diff --git a/routes b/routes index a9f0a8b76..143f36075 100644 --- a/routes +++ b/routes @@ -8,8 +8,11 @@ /profile ProfileR GET -/term ShowTermsR GET -/term/edit EditTermR GET POST -/term/#TermIdentifier/edit EditTermExistR GET +/term TermShowR GET +/term/edit TermEditR GET POST +/term/#TermIdentifier/edit TermEditExistR GET + +/course CourseShowR GET +/course/edit CourseEditR GET POST +/course/#TermIdentifier/#Text/edit CourseEditExistR GET -/assist/newcourse NewCourseR GET POST diff --git a/src/Application.hs b/src/Application.hs index c119fd8e6..6a16acf4e 100644 --- a/src/Application.hs +++ b/src/Application.hs @@ -43,7 +43,7 @@ import Handler.Common import Handler.Home import Handler.Profile import Handler.Term -import Handler.Assist +import Handler.Course -- 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/Common.hs b/src/Common.hs index 2dd8a5525..290bb16ad 100644 --- a/src/Common.hs +++ b/src/Common.hs @@ -35,7 +35,18 @@ permuteFun perm = lamE pat rhs where pat = map varP $ fn:xs rhs = foldl appE (varE fn) $ map varE ps -- rhs = appE (varE fn) (varE $ xs!!1) - ln = length perm + ln = length perm xs = [ mkName $ "x" ++ show j | j <- [1..ln] ] ps = [ xs !! (j-1) | j <- perm ] fn = mkName "fn" + +altFun :: [Int] -> ExpQ -- generic permutation/repetition of function arguments, i.e. $(permuteFun [2,1]) == flip +altFun perm = lamE pat rhs + where pat = map varP $ fn:xs + rhs = foldl appE (varE fn) $ map varE ps +-- rhs = appE (varE fn) (varE $ xs!!1) + mx = maximum perm + xs = [ mkName $ "x" ++ show j | j <- [1..mx] ] + ps = [ xs !! (j-1) | j <- perm ] + fn = mkName "fn" + diff --git a/src/Foundation.hs b/src/Foundation.hs index 2ee4eaa30..74d78907b 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -166,11 +166,16 @@ instance Yesod UniWorX where isAuthorized (StaticR _) _ = return Authorized isAuthorized ProfileR _ = isAuthenticated - -- TODO: change to Assistants - isAuthorized NewCourseR _ = return Authorized - isAuthorized EditTermR _ = return Authorized - isAuthorized (EditTermExistR _) _ = return Authorized - isAuthorized ShowTermsR _ = return Authorized + + -- TODO: all? + isAuthorized TermShowR _ = return Authorized + isAuthorized CourseShowR _ = return Authorized + -- TODO: change to Assistants + isAuthorized TermEditR _ = return Authorized + isAuthorized (TermEditExistR _) _ = return Authorized + isAuthorized CourseEditR _ = return Authorized + isAuthorized (CourseEditExistR _ _) _ = return Authorized + -- This function creates static content files in the static folder -- and names them based on a hash of their content. This allows diff --git a/src/Handler/Assist.hs b/src/Handler/Assist.hs deleted file mode 100644 index 37a58dc2a..000000000 --- a/src/Handler/Assist.hs +++ /dev/null @@ -1,99 +0,0 @@ -{-# LANGUAGE NoImplicitPrelude #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE TypeFamilies #-} -module Handler.Assist where - -import Import -import Handler.Utils -import qualified Data.Text as T --- import Data.Maybe -import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3) --- import Text.Julius (RawJS (..)) - --- TODO: Move elsewhere - - - - --- Handler for Assistants - -data NewCourseForm = NewCourseForm - { ncf_user :: UserId - , ncf_term :: TermIdentifier - , ncf_name :: Text - , ncf_short :: Text - , ncf_description :: Textarea - , ncf_homepage :: Maybe Text - , ncf_html :: Html - , ncf_capacity :: Maybe Int - } - -newCourseForm :: UserId -> Form NewCourseForm -newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm - <$> pure uid - <*> areq termExistsField (set "Semester") Nothing --- <*> areq textField (set "Semester") Nothing - <*> areq textField (set "Name des Kurses") Nothing - <*> areq textField (set "Kurs Kürzel (3-4 Zeichen)") Nothing - <*> areq textareaField (set "Beschreibung des Kurses") Nothing - <*> aopt urlField (set "Externe Kurshomepage") Nothing - <*> areq htmlField (set "Beschreibung in HTML") Nothing - <*> aopt intField (set "Maximale Teilnehmer") Nothing - -- Add attributes like the placeholder and CSS classes. - where set txt = FieldSettings - { fsLabel = txt - , fsTooltip = Nothing - , fsId = Nothing - , fsName = Nothing - , fsAttrs = - [ ("class", "form-control") - ] - } - -getShowCourseR :: CourseId -> Handler Html -getShowCourseR courseId = do - defaultLayout $ do - [whamlet| - TODO unfinished - |] - -getNewCourseR :: Handler Html -getNewCourseR = do - aid <- requireAuthId - (formWidget, formEnctype) <- generateFormPost $ newCourseForm aid - defaultLayout $ do - setTitle "Neuen Kurs anlegen" - [whamlet| - User: #{show aid} - |] - $(widgetFile "newCourse") - -postNewCourseR :: Handler Html -postNewCourseR = do - aid <- requireAuthId - ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm aid - case result of - FormSuccess res -> defaultLayout $ do - setMessage "Got something!" - $(widgetFile "newCourse") - FormMissing -> defaultLayout $ do - setMessage "Keine Formulardaten erhalten." - $(widgetFile "newCourse") - FormFailure errorMsgs -> defaultLayout $ do - setMessage [shamlet| Fehler: -