Hierarchical Routes
This commit is contained in:
SJost
parent
217ae28d9e
commit
5f6640148c
29
routes
29
routes
@ -15,26 +15,17 @@
|
||||
/course/ CourseListR GET
|
||||
!/course/new CourseNewR GET POST
|
||||
!/course/#TermId CourseListTermR GET
|
||||
/course/#TermId/#Text CourseR:
|
||||
/show CourseShowR GET POST
|
||||
/edit CourseEditR GET POST
|
||||
|
||||
-- /course/#TermId/#Text CourseR !tag:
|
||||
-- /edit CourseEditR GET POST
|
||||
-- /show CourseShowR GET POST -- CourseR tid csh CourseShowR
|
||||
-- /ex/#Text SheetR: !registered
|
||||
-- /show
|
||||
-- /edit -- CourseR tid csg (SheetR csh SheetEditR)
|
||||
-- /delete
|
||||
|
||||
/course/#TermId/#Text/edit CourseEditR GET
|
||||
/course/#TermId/#Text/show CourseShowR GET POST
|
||||
|
||||
|
||||
|
||||
/course/#TermId/#Text/ex/ SheetListR GET
|
||||
/course/#TermId/#Text/ex/#Text/show SheetShowR GET
|
||||
/course/#TermId/#Text/ex/#Text/#SheetFileType/#FilePath SheetFileR GET
|
||||
/course/#TermId/#Text/ex/new SheetNewR GET POST
|
||||
/course/#TermId/#Text/ex/#Text/edit SheetEditR GET POST
|
||||
/course/#TermId/#Text/ex/#Text/delete SheetDelR GET POST
|
||||
/ex SheetR !registered:
|
||||
/ SheetListR GET
|
||||
/new SheetNewR GET POST !lecturer
|
||||
/#Text/show SheetShowR GET
|
||||
/#Text/#SheetFileType/#FilePath SheetFileR GET
|
||||
/#Text/edit SheetEditR GET POST !lecturer
|
||||
/#Text/delete SheetDelR GET POST !lecturer
|
||||
|
||||
/submission SubmissionListR GET POST
|
||||
/submission/#CryptoUUIDSubmission SubmissionR GET POST
|
||||
|
||||
@ -4,6 +4,7 @@
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE DataKinds #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE NamedFieldPuns #-}
|
||||
@ -53,6 +54,9 @@ import System.FilePath
|
||||
|
||||
import Handler.Utils.Templates
|
||||
|
||||
-- infixl 9 :$:
|
||||
-- pattern a :$: b = a b
|
||||
|
||||
-- | The foundation datatype for your application. This can be a good place to
|
||||
-- keep settings and values requiring initialization before your application
|
||||
-- starts running, such as database connections. Every handler will have
|
||||
@ -80,7 +84,9 @@ data UniWorX = UniWorX
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
type DB a = YesodDB UniWorX a
|
||||
-- Pattern Synonyms for convenience
|
||||
pattern CSheetR tid csh ptn = CourseR tid csh (SheetR ptn)
|
||||
|
||||
|
||||
data MenuItem = MenuItem
|
||||
{ menuItemLabel :: Text
|
||||
@ -95,7 +101,8 @@ data MenuTypes
|
||||
| NavbarExtra { menuItem :: MenuItem }
|
||||
| NavbarSecondary { menuItem :: MenuItem }
|
||||
|
||||
-- | A convenient synonym for creating forms.
|
||||
-- | Convenient Type Synonyms:
|
||||
type DB a = YesodDB UniWorX a
|
||||
type Form x = Html -> MForm (HandlerT UniWorX IO) (FormResult x, Widget)
|
||||
|
||||
mkMessage "UniWorX" "messages" "de"
|
||||
@ -151,7 +158,7 @@ instance Yesod UniWorX where
|
||||
isAuthorized TermShowR _ = return Authorized
|
||||
isAuthorized CourseListR _ = return Authorized
|
||||
isAuthorized (CourseListTermR _) _ = return Authorized
|
||||
isAuthorized (CourseShowR _ _) _ = return Authorized
|
||||
isAuthorized (CourseR _ _ CourseShowR) _ = return Authorized
|
||||
isAuthorized (CryptoUUIDDispatchR _) _ = return Authorized
|
||||
isAuthorized SubmissionListR _ = isAuthenticated
|
||||
isAuthorized SubmissionDownloadMultiArchiveR _ = isAuthenticated
|
||||
@ -205,14 +212,14 @@ isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _
|
||||
isAuthorizedDB TermEditR _ = adminAccess Nothing
|
||||
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
|
||||
isAuthorizedDB CourseNewR _ = lecturerAccess Nothing
|
||||
isAuthorizedDB (CourseEditR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetListR t c) False = return Authorized --
|
||||
isAuthorizedDB (SheetShowR t c s) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (SheetFileR t c s _ _) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (SheetListR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetEditR t c s) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetDelR t c s) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c CourseEditR) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetListR)) False = return Authorized --
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetListR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetShowR s))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetFileR s _ _))) _ = return Authorized -- TODO: nur für angemeldete Kursteilnehmer falls sichtbar, sonst nur Lectrurer oder Korrektor
|
||||
isAuthorizedDB (CourseR t c (SheetR SheetNewR)) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetEditR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseR t c (SheetR (SheetDelR s))) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseEditIDR cID) _ = do
|
||||
courseId <- decrypt cID
|
||||
courseLecturerAccess courseId
|
||||
@ -285,15 +292,15 @@ instance YesodBreadcrumbs UniWorX where
|
||||
|
||||
breadcrumb CourseListR = return ("Kurs", Just HomeR)
|
||||
breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
|
||||
breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term)
|
||||
breadcrumb (CourseR term course CourseShowR) = return (course, Just $ CourseListTermR term)
|
||||
breadcrumb CourseNewR = return ("Neu", Just CourseListR)
|
||||
breadcrumb (CourseEditR _ _) = return ("Editieren", Just CourseListR)
|
||||
breadcrumb (CourseR _ _ CourseEditR) = return ("Editieren", Just CourseListR)
|
||||
|
||||
breadcrumb (SheetListR tid csh) = return ("Übungen",Just $ CourseShowR tid csh)
|
||||
breadcrumb (SheetNewR tid csh) = return ("Neu", Just $ SheetListR tid csh)
|
||||
breadcrumb (SheetShowR tid csh shn) = return (shn, Just $ SheetListR tid csh)
|
||||
breadcrumb (SheetEditR tid csh shn) = return ("Edit", Just $ SheetShowR tid csh shn)
|
||||
breadcrumb (SheetDelR tid csh shn) = return ("DELETE", Just $ SheetShowR tid csh shn)
|
||||
breadcrumb (CourseR tid csh (SheetR SheetListR)) = return ("Übungen",Just $ CourseR tid csh CourseShowR)
|
||||
breadcrumb (CourseR tid csh (SheetR SheetNewR )) = return ("Neu", Just $ CourseR tid csh $ SheetR SheetListR)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetShowR shn))) = return (shn, Just $ CourseR tid csh $ SheetR SheetListR)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetEditR shn))) = return ("Edit", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
breadcrumb (CourseR tid csh (SheetR (SheetDelR shn))) = return ("DELETE", Just $ CourseR tid csh $ SheetR $ SheetShowR shn)
|
||||
|
||||
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
|
||||
breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
|
||||
|
||||
@ -40,7 +40,7 @@ getCourseListTermR tidini = do
|
||||
let c = entityVal ckv
|
||||
shd = courseShorthand c
|
||||
tid = courseTermId c
|
||||
in [whamlet| <a href=@{CourseShowR tid shd}>#{shd} |] )
|
||||
in [whamlet| <a href=@{CourseR tid shd CourseShowR}>#{shd} |] )
|
||||
-- , headed "Institut" $ [shamlet| #{course} |]
|
||||
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
|
||||
, headed "Ende Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterTo.entityVal
|
||||
@ -54,11 +54,11 @@ getCourseListTermR tidini = do
|
||||
shd = courseShorthand c
|
||||
tid = courseTermId c
|
||||
in do
|
||||
adminLink <- handlerToWidget $ isAuthorized (CourseEditR tid shd ) False
|
||||
adminLink <- handlerToWidget $ isAuthorized (CourseR tid shd CourseEditR) False
|
||||
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{CourseEditR tid shd}>
|
||||
<a href=@{CourseR tid shd CourseEditR}>
|
||||
editieren
|
||||
|]
|
||||
)
|
||||
@ -96,8 +96,8 @@ getCourseShowR tid csh = do
|
||||
[ NavbarAside $ MenuItem
|
||||
{ menuItemLabel = "Übungsblätter"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SheetListR tid csh
|
||||
, menuItemAccessCallback = (== Authorized) <$> isAuthorized (SheetListR tid csh) False
|
||||
, menuItemRoute = CSheetR tid csh SheetListR
|
||||
, menuItemAccessCallback = (== Authorized) <$> isAuthorized (CSheetR tid csh SheetListR) False
|
||||
}
|
||||
]
|
||||
defaultLinkLayout pageActions $ do
|
||||
@ -145,6 +145,9 @@ getCourseEditR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler course
|
||||
|
||||
postCourseEditR :: TermId -> Text -> Handler Html
|
||||
postCourseEditR = getCourseEditR
|
||||
|
||||
getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
|
||||
getCourseEditIDR cID = do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
@ -256,7 +259,7 @@ courseEditHandler course = do
|
||||
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
|
||||
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
|
||||
let formTitle = "Kurs editieren/anlegen" :: Text
|
||||
let actionUrl = CourseNewR -- CourseEditR -- TODO
|
||||
actionUrl <- fromMaybe CourseNewR <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitle [shamlet| #{formTitle} |]
|
||||
$(widgetFile "formPage")
|
||||
|
||||
@ -74,7 +74,7 @@ makeSheetForm template = identForm FIDsheet $ \html -> do
|
||||
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
||||
<*> fileAFormOpt (fsb "Aufgabenstellung")
|
||||
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
||||
<*> aopt utcTimeField (fsb "Hinweise ab") (sfHintFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Hinweis")
|
||||
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Lösung")
|
||||
@ -162,7 +162,7 @@ getSheetList courseEnt = do
|
||||
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
||||
return (sid, sheet, (submissions, rated))
|
||||
let colBase = mconcat
|
||||
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ SheetShowR tid csh (sheetName sheet)
|
||||
[ headed "Blatt" $ \(sid,sheet,_) -> linkButton (toWgt $ sheetName sheet) BCLink $ CourseR tid csh $ SheetR $ SheetShowR $ sheetName sheet
|
||||
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
||||
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
||||
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
||||
@ -170,13 +170,13 @@ getSheetList courseEnt = do
|
||||
, headed "Eingereicht" $ toWgt . fst . trd3
|
||||
]
|
||||
let colAdmin = mconcat -- only show edit button for allowed course assistants
|
||||
[ headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ sheetName $ snd3 s
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ SheetDelR tid csh $ sheetName $ snd3 s
|
||||
[ headed "" $ \s -> linkButton "Edit" BCLink $ CourseR tid csh $ SheetR $ SheetEditR $ sheetName $ snd3 s
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ CourseR tid csh $ SheetR $ SheetDelR $ sheetName $ snd3 s
|
||||
]
|
||||
showAdmin <- case sheets of
|
||||
((_,firstSheet,_):_) -> do
|
||||
setUltDestCurrent
|
||||
(Authorized ==) <$> isAuthorized (SheetEditR tid csh $ sheetName firstSheet) False
|
||||
(Authorized ==) <$> isAuthorized (CourseR tid csh $ SheetR $ SheetEditR $ sheetName firstSheet) False
|
||||
_otherwise -> return False
|
||||
let colSheets = if showAdmin
|
||||
then colBase `mappend` colAdmin
|
||||
@ -185,7 +185,7 @@ getSheetList courseEnt = do
|
||||
[ NavbarAside $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SheetNewR tid csh
|
||||
, menuItemRoute = CSheetR tid csh SheetNewR
|
||||
, menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
|
||||
}
|
||||
]
|
||||
@ -211,7 +211,7 @@ getSheetShowR tid csh shn = do
|
||||
E.where_ (sheet E.^. SheetId E.==. E.val sid )
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, sheetFile E.^. SheetFileType)
|
||||
let fileLinks = map (\(E.Value fName, E.Value fType) -> SheetFileR tid csh shn fType fName) fileNameTypes
|
||||
let fileLinks = map (\(E.Value fName, E.Value fType) -> CSheetR tid csh (SheetFileR shn fType fName)) fileNameTypes
|
||||
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
||||
@ -325,14 +325,14 @@ handleSheetEdit tid csh template dbAction = do
|
||||
whenIsJust sfSolutionF $ insertSheetFile sid SheetSolution
|
||||
addMessageI "info" $ MsgSheetEditOk tident csh sfName
|
||||
return True
|
||||
when saveOkay $ redirect $ SheetShowR tid csh sfName -- redirect must happen outside of runDB
|
||||
when saveOkay $ redirect $ CSheetR tid csh $ SheetShowR sfName -- redirect must happen outside of runDB
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
let pageTitle = maybe (MsgSheetTitleNew tident csh)
|
||||
(MsgSheetTitle tident csh) mbshn
|
||||
let formTitle = pageTitle
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- fromMaybe (SheetNewR tid csh) <$> getCurrentRoute
|
||||
actionUrl <- fromMaybe (CSheetR tid csh SheetNewR) <$> getCurrentRoute
|
||||
defaultLayout $ do
|
||||
setTitleI pageTitle
|
||||
$(widgetFile "formPageI18n")
|
||||
@ -344,19 +344,19 @@ getSheetDelR tid csh shn = do
|
||||
let tident = unTermKey tid
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ SheetShowR tid csh shn
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ CSheetR tid csh $ SheetShowR shn
|
||||
(FormSuccess BtnDelete) -> do
|
||||
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
||||
setMessageI $ MsgSheetDelOk tident csh shn
|
||||
redirect $ SheetListR tid csh
|
||||
redirect $ CSheetR tid csh SheetListR
|
||||
_other -> do
|
||||
submissionno <- runDB $ do
|
||||
sid <- fetchSheetId tid csh shn
|
||||
count [SubmissionSheetId ==. sid]
|
||||
let formTitle = MsgSheetDelTitle tident csh shn
|
||||
let formText = Just $ MsgSheetDelText submissionno
|
||||
let actionUrl = SheetDelR tid csh shn
|
||||
let actionUrl = CSheetR tid csh $ SheetDelR shn
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetTitle tident csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
@ -53,7 +53,7 @@ submissionTable = do
|
||||
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
||||
|
||||
let
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTermId courseShorthand CourseShowR
|
||||
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
||||
anchorSubmission (_, cUUID, _) = SubmissionR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
|
||||
@ -55,7 +55,7 @@ deriveJSON defaultOptions ''SheetType
|
||||
derivePersistFieldJSON "SheetType"
|
||||
|
||||
data SheetGroup
|
||||
= Arbitrary { maxParticipants :: Int }
|
||||
= Arbitrary { maxParticipants :: Int } -- Distinguish Limited/Arbitrary
|
||||
| RegisteredGroups
|
||||
| NoGroups
|
||||
deriving (Show, Read, Eq)
|
||||
|
||||
@ -16,7 +16,7 @@
|
||||
\ bis #{formatTimeGerWD regTo}
|
||||
|
||||
<div>
|
||||
<form method=post action=@{CourseShowR tid csh} enctype=#{regEnctype}>
|
||||
<form method=post action=@{CourseR tid csh CourseShowR} enctype=#{regEnctype}>
|
||||
^{regWidget}
|
||||
|
||||
<div .course-header__title>
|
||||
|
||||
@ -29,7 +29,7 @@
|
||||
$forall fileLink <- fileLinks
|
||||
<li>
|
||||
$case fileLink
|
||||
$of SheetFileR _ _ _ typ name
|
||||
$of CourseR _ _ (SheetR (SheetFileR _ typ name))
|
||||
#{toPathPiece typ}
|
||||
<a href=@{fileLink}>#{name}
|
||||
$of other
|
||||
|
||||
Loading…
Reference in New Issue
Block a user