From d10a629fa2694cb58ff624ef16edf3dcbc0d60ff Mon Sep 17 00:00:00 2001 From: SJost Date: Mon, 9 Oct 2017 16:16:00 +0200 Subject: [PATCH] Term Handler cleaned again; small changes to Model (Maybe added for some Text Types, courseOwner dropped). --- models | 11 +++---- routes | 9 +++--- src/Foundation.hs | 3 +- src/Handler/Term.hs | 66 ++++++++++++++++++-------------------- src/Handler/Utils/Table.hs | 6 ++-- src/Model/Types.hs | 7 +--- 6 files changed, 45 insertions(+), 57 deletions(-) diff --git a/models b/models index c03087e76..d08da58a6 100644 --- a/models +++ b/models @@ -27,12 +27,11 @@ DegreeCourse json degreeId DegreeId courseId CourseId UniqueDegreeCourse degreeId courseId -Course json +Course name Text shorthand Text - description Textarea - linkexternal Text - owner UserId + description Html Maybe + linkexternal Text Maybe schoolId SchoolId termId TermId -- TermId ist jetzt Text als Typ capacity Int Maybe @@ -60,7 +59,7 @@ Sheet hintId FileId Maybe solutionId FileId Maybe markingId FileId Maybe - markingText Text + markingText Text Maybe activeFrom UTCTime activeTo UTCTime hintFrom UTCTime Maybe @@ -129,7 +128,7 @@ Booking Room name Text capacity Int Maybe - building Text + building Text Maybe -- BookingRoom -- subject RoomForId -- roomId RoomId diff --git a/routes b/routes index 1c63b0e37..a9f0a8b76 100644 --- a/routes +++ b/routes @@ -8,9 +8,8 @@ /profile ProfileR GET -/showterms ShowTermsR GET +/term ShowTermsR GET +/term/edit EditTermR GET POST +/term/#TermIdentifier/edit EditTermExistR GET -/assist/newcourse NewCourseR GET POST -/assist/newterm NewTermR GET -/assist/editterm EditTermR GET POST -/assist/editterm/#TermIdentifier EditTermExistR GET +/assist/newcourse NewCourseR GET POST diff --git a/src/Foundation.hs b/src/Foundation.hs index 259e36048..2ee4eaa30 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -167,8 +167,7 @@ instance Yesod UniWorX where isAuthorized ProfileR _ = isAuthenticated -- TODO: change to Assistants - isAuthorized NewCourseR _ = return Authorized - isAuthorized NewTermR _ = return Authorized + isAuthorized NewCourseR _ = return Authorized isAuthorized EditTermR _ = return Authorized isAuthorized (EditTermExistR _) _ = return Authorized isAuthorized ShowTermsR _ = return Authorized diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs index 7e1127144..be73ea0d1 100644 --- a/src/Handler/Term.hs +++ b/src/Handler/Term.hs @@ -23,11 +23,17 @@ getShowTermsR = do terms <- runDB $ selectList [] [Desc TermStart] selectRep $ do provideRep $ return $ toJSON terms - provideRep $ do + provideRep $ do let colonnadeTerms = mconcat - -- TODO Edit-Links only $if isAdmin, otherwise breadcrumb navigation - [ headed "Kürzel" $ (\t -> let tn = termName t in - [whamlet| #{termToText tn}|] ) + [ headed "Kürzel" $ (\t -> let tn = termName t in do + adminLink <- handlerToWidget $ isAuthorized (EditTermExistR tn) False + [whamlet| + $if adminLink == Authorized + + #{termToText tn} + $else + #{termToText tn} + |] ) , headed "Beginn Vorlesungen" $ fromString.formatTimeGerWD.termLectureStart , headed "Ende Vorlesungen" $ fromString.formatTimeGerWD.termLectureEnd , headed "Aktiv" (\t -> if termActive t then tickmark else "") @@ -42,36 +48,23 @@ getShowTermsR = do encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal terms) -getNewTermR :: Handler Html -getNewTermR = do - -- TODO: Defaults für Semester hier ermitteln und übergeben - getEditTermMaybeR Nothing - - getEditTermR :: Handler Html getEditTermR = do -- TODO: Defaults für Semester hier ermitteln und übergeben - getEditTermMaybeR Nothing + termEditHandler Nothing +postEditTermR :: Handler Html +postEditTermR = termEditHandler Nothing getEditTermExistR :: TermIdentifier -> Handler Html getEditTermExistR tid = do term <- runDB $ get $ TermKey tid - getEditTermMaybeR term + termEditHandler term - -getEditTermMaybeR :: Maybe Term -> Handler Html -getEditTermMaybeR mbTerm= do - aid <- requireAuthId - -- TODO: verify Admin - (formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm - wdgtTermForm formWidget formEnctype - -postEditTermR :: Handler Html -postEditTermR = do - aid <- requireAuthId - -- TODO: verify Admin - ((result, formWidget), formEnctype) <- runFormPost $ newTermForm Nothing + +termEditHandler :: Maybe Term -> Handler Html +termEditHandler term = do + ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term action <- lookupPostParam "formaction" case (result,action) of (FormSuccess res, fAct) @@ -79,7 +72,7 @@ postEditTermR = do runDB $ delete (TermKey $ termName res) let tid = termToText $ termName res let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht." - setMessage [shamlet| #{msg} |] + setMessage $ [shamlet| #{msg} |] redirect ShowTermsR | fAct == formActionSave -> do -- term <- runDB $ get $ TermKey termName @@ -88,15 +81,17 @@ postEditTermR = do let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert." setMessage [shamlet| #{msg} |] redirect ShowTermsR - | otherwise -> redirect ShowTermsR - (FormMissing,_) -> do - setMessage "Keine Formulardaten erhalten." - wdgtTermForm formWidget formEnctype - - (FormFailure _,_) -> do - setMessage "Bitte Eingabe korrigieren." - wdgtTermForm formWidget formEnctype + | otherwise -> redirect ShowTermsR + (FormMissing,_) -> return () + (FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren." + let formTitle = "Semester editieren/anlegen" :: Text + let actionUrl = EditTermR + let formActions = defaultFormActions + defaultLayout $ do + setTitle [shamlet| #{formTitle} |] + $(widgetFile "generic_form") +{- wdgtTermForm :: (ToWidget UniWorX a) => a -> Enctype -> Handler Html wdgtTermForm formWidget formEnctype = do let formTitle = "Semester editieren/anlegen" :: Text @@ -105,7 +100,8 @@ wdgtTermForm formWidget formEnctype = do defaultLayout $ do setTitle [shamlet| #{formTitle} |] $(widgetFile "generic_form") - +-} + newTermForm :: Maybe Term -> Form Term newTermForm template html = do (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term diff --git a/src/Handler/Utils/Table.hs b/src/Handler/Utils/Table.hs index f64af26a3..3ed97eb88 100644 --- a/src/Handler/Utils/Table.hs +++ b/src/Handler/Utils/Table.hs @@ -5,7 +5,7 @@ module Handler.Utils.Table where -- General Utilities for Tables import Import hiding ((<>)) -import Data.Monoid ((<>)) +-- import Data.Monoid ((<>)) import Data.Profunctor import Text.Blaze as B @@ -31,7 +31,7 @@ encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site encodeHeadedWidgetTableNumbered attrs colo tdata = encodeHeadedWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata) where - numberCol = headed "Nr" (fromString.show.fst) - + numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ()) + numberCol = headed "Nr" (fromString.show.fst) diff --git a/src/Model/Types.hs b/src/Model/Types.hs index f3751c05a..e887a515e 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -58,7 +58,7 @@ seasonFromChar c data TermIdentifier = TermIdentifier { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar' , season :: Season - } deriving (Show, Read, Eq, Generic, Typeable) + } deriving (Show, Read, Eq, Ord, Generic, Typeable) --TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls termToText :: TermIdentifier -> Text @@ -71,11 +71,6 @@ termFromText t , Right season <- seasonFromChar s = Right TermIdentifier{..} | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”" - -instance Ord TermIdentifier where - ti1 <= ti2 = - year ti1 <= year ti2 || - (year ti1 == year ti2 || season ti1 <= season ti2) instance PersistField TermIdentifier where toPersistValue = PersistText . termToText