TermIdentifier -> TermId in routes
This commit is contained in:
SJost
parent
272bc7f6c5
commit
8d221600d3
3
.gitignore
vendored
3
.gitignore
vendored
@ -26,4 +26,5 @@ uniworx.nix
|
||||
.dbsettings.yml
|
||||
*.kate-swp
|
||||
src/Handler/Assist.bak
|
||||
src/Handler/Course.SnapCustom.hs
|
||||
src/Handler/Course.SnapCustom.hs
|
||||
*.orig
|
||||
|
||||
4
models
4
models
@ -37,8 +37,8 @@ Term json
|
||||
lectureStart Day
|
||||
lectureEnd Day
|
||||
active Bool
|
||||
Primary name
|
||||
deriving Show
|
||||
Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
|
||||
deriving Show -- type TermId = Key Term
|
||||
School json
|
||||
name Text
|
||||
shorthand Text
|
||||
|
||||
20
routes
20
routes
@ -6,22 +6,24 @@
|
||||
|
||||
/ HomeR GET POST
|
||||
/profile ProfileR GET
|
||||
/users UsersR GET
|
||||
|
||||
/term TermShowR GET
|
||||
/term/edit TermEditR GET POST
|
||||
/term/#TermIdentifier/edit TermEditExistR GET
|
||||
/term/#TermId/edit TermEditExistR GET
|
||||
|
||||
/course/ CourseListR GET
|
||||
!/course/new CourseEditR GET POST
|
||||
!/course/#TermIdentifier CourseListTermR GET
|
||||
/course/#TermIdentifier/#Text/edit CourseEditExistR GET
|
||||
/course/#TermIdentifier/#Text/show CourseShowR GET POST
|
||||
|
||||
/course/#TermIdentifier/#Text/sheet/ SheetListR GET
|
||||
/course/#TermIdentifier/#Text/sheet/new SheetNewR GET
|
||||
/course/#TermIdentifier/#Text/sheet/#SheetId/show SheetShowR GET
|
||||
/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR GET
|
||||
!/course/#TermId CourseListTermR GET
|
||||
/course/#TermId/#Text/edit CourseEditExistR GET
|
||||
/course/#TermId/#Text/show CourseShowR GET POST
|
||||
|
||||
/course/#TermId/#Text/sheet/ SheetListR GET
|
||||
/course/#TermId/#Text/sheet/#Text/show SheetShowR GET
|
||||
/course/#TermId/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET
|
||||
/course/#TermId/#Text/sheet/new SheetNewR GET POST
|
||||
/course/#TermId/#Text/sheet/#SheetId/edit SheetEditR GET POST
|
||||
/course/#TermId/#Text/sheet/#SheetId/delete SheetDelR GET POST
|
||||
|
||||
/submission SubmissionListR GET POST
|
||||
/submission/#CryptoUUIDSubmission SubmissionR GET POST
|
||||
|
||||
@ -75,7 +75,7 @@ data UniWorX = UniWorX
|
||||
--
|
||||
-- This function also generates the following type synonyms:
|
||||
-- type Handler = HandlerT UniWorX IO
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
-- type Widget = WidgetT UniWorX IO ()
|
||||
mkYesodData "UniWorX" $(parseRoutesFile "routes")
|
||||
|
||||
data MenuItem = MenuItem
|
||||
@ -178,17 +178,19 @@ instance Yesod UniWorX where
|
||||
makeLogger = return . appLogger
|
||||
|
||||
isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
|
||||
isAuthorizedDB UsersR _ = adminAccess Nothing
|
||||
isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID
|
||||
isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
|
||||
isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
|
||||
isAuthorizedDB TermEditR _ = adminAccess Nothing
|
||||
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
|
||||
isAuthorizedDB CourseEditR _ = lecturerAccess Nothing
|
||||
isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort (TermKey t) c)
|
||||
isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
|
||||
isAuthorizedDB (CourseEditExistIDR cID) _ = do
|
||||
courseId <- decrypt cID
|
||||
courseLecturerAccess courseId
|
||||
isAuthorizedDB route isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
|
||||
isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
|
||||
|
||||
submissionAccess :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult
|
||||
submissionAccess cID = do
|
||||
@ -240,11 +242,14 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurs", Just HomeR)
|
||||
breadcrumb (CourseListTermR term) = return (termToText term, Just TermShowR)
|
||||
breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
|
||||
breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term)
|
||||
breadcrumb CourseEditR = return ("Neu", Just CourseListR)
|
||||
breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR)
|
||||
|
||||
breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh)
|
||||
breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh)
|
||||
|
||||
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
|
||||
breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
|
||||
|
||||
@ -266,6 +271,11 @@ defaultLinks = -- Define the menu items of the header.
|
||||
, menuItemRoute = CourseListR
|
||||
, menuItemAccessCallback = return True
|
||||
}
|
||||
, NavbarRight $ MenuItem
|
||||
{ menuItemLabel = "Users"
|
||||
, menuItemRoute = UsersR
|
||||
, menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
|
||||
}
|
||||
, NavbarRight $ MenuItem
|
||||
{ menuItemLabel = "Profile"
|
||||
, menuItemRoute = ProfileR
|
||||
@ -384,7 +394,7 @@ instance YesodAuth UniWorX where
|
||||
authHttpManager = getHttpManager
|
||||
|
||||
ldapConfig :: UniWorX -> LDAPConfig
|
||||
ldapConfig app@(appSettings -> settings) = LDAPConfig
|
||||
ldapConfig _app@(appSettings -> settings) = LDAPConfig
|
||||
{ usernameFilter = \u -> principalName <> "=" <> u
|
||||
, identifierModifier
|
||||
, ldapUri = appLDAPURI settings
|
||||
|
||||
@ -26,20 +26,20 @@ import qualified Data.UUID.Cryptographic as UUID
|
||||
getCourseListR :: Handler TypedContent
|
||||
getCourseListR = redirect TermShowR
|
||||
|
||||
getCourseListTermR :: TermIdentifier -> Handler Html
|
||||
getCourseListTermR :: TermId -> Handler Html
|
||||
getCourseListTermR tidini = do
|
||||
(term,courses) <- runDB $ (,)
|
||||
<$> get (TermKey tidini)
|
||||
<*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand]
|
||||
<$> get tidini
|
||||
<*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand]
|
||||
when (isNothing term) $ do
|
||||
addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |]
|
||||
addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
|
||||
redirect TermShowR
|
||||
-- TODO: several runDBs per TableRow are probably too inefficient!
|
||||
let colonnadeTerms = mconcat
|
||||
[ headed "Kürzel" $ (\ckv ->
|
||||
let c = entityVal ckv
|
||||
shd = courseShorthand c
|
||||
tid = unTermKey $ courseTermId c
|
||||
tid = courseTermId c
|
||||
in [whamlet| <a href=@{CourseShowR tid shd}>#{shd} |] )
|
||||
-- , headed "Institut" $ [shamlet| #{course} |]
|
||||
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
|
||||
@ -52,7 +52,7 @@ getCourseListTermR tidini = do
|
||||
, headed " " $ (\ckv ->
|
||||
let c = entityVal ckv
|
||||
shd = courseShorthand c
|
||||
tid = unTermKey $ courseTermId c
|
||||
tid = courseTermId c
|
||||
in do
|
||||
adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
|
||||
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
|
||||
@ -76,11 +76,11 @@ getCourseListTermR tidini = do
|
||||
linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
|
||||
encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
|
||||
|
||||
getCourseShowR :: TermIdentifier -> Text -> Handler Html
|
||||
getCourseShowR :: TermId -> Text -> Handler Html
|
||||
getCourseShowR tid csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
|
||||
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
|
||||
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
|
||||
dependent <- (,,)
|
||||
<$> get (courseSchoolId course) -- join
|
||||
<*> count [CourseParticipantCourseId ==. cid] -- join
|
||||
@ -93,7 +93,7 @@ getCourseShowR tid csh = do
|
||||
let course = entityVal courseEnt
|
||||
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
|
||||
defaultLayout $ do
|
||||
setTitle $ [shamlet| #{termToText tid} - #{csh}|]
|
||||
setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
|
||||
$(widgetFile "course")
|
||||
|
||||
registerButton :: Bool -> Form ()
|
||||
@ -104,11 +104,11 @@ registerButton registered =
|
||||
msg = if registered then "Abmelden" else "Anmelden"
|
||||
regMsg = msg :: BootstrapSubmit Text
|
||||
|
||||
postCourseShowR :: TermIdentifier -> Text -> Handler Html
|
||||
postCourseShowR :: TermId -> Text -> Handler Html
|
||||
postCourseShowR tid csh = do
|
||||
aid <- requireAuthId
|
||||
(cid, registered) <- runDB $ do
|
||||
(Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh
|
||||
(Entity cid _) <- getBy404 $ CourseTermShort tid csh
|
||||
registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid)
|
||||
return (cid, registered)
|
||||
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
|
||||
@ -133,9 +133,9 @@ getCourseEditR = do
|
||||
postCourseEditR :: Handler Html
|
||||
postCourseEditR = courseEditHandler Nothing
|
||||
|
||||
getCourseEditExistR :: TermIdentifier -> Text -> Handler Html
|
||||
getCourseEditExistR :: TermId -> Text -> Handler Html
|
||||
getCourseEditExistR tid csh = do
|
||||
course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh
|
||||
course <- runDB $ getBy $ CourseTermShort tid csh
|
||||
courseEditHandler course
|
||||
|
||||
getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
|
||||
@ -155,12 +155,12 @@ courseEditHandler course = do
|
||||
| fAct == formActionDelete
|
||||
, Just cid <- cfCourseId res -> do
|
||||
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
|
||||
let cti = termToText $ cfTerm res
|
||||
let cti = toPathPiece $ cfTerm res
|
||||
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
|
||||
redirect $ CourseListTermR $ cfTerm res
|
||||
| fAct == formActionSave
|
||||
, Just cid <- cfCourseId res -> do
|
||||
let tid = TermKey $ cfTerm res
|
||||
let tid = cfTerm res
|
||||
actTime <- liftIO getCurrentTime
|
||||
updateokay <- runDB $ do
|
||||
exists <- getBy $ CourseTermShort tid $ cfShort res
|
||||
@ -179,7 +179,7 @@ courseEditHandler course = do
|
||||
, CourseChanged =. actTime
|
||||
]
|
||||
return upokay
|
||||
let cti = termToText $ cfTerm res
|
||||
let cti = toPathPiece $ cfTerm res
|
||||
if updateokay
|
||||
then do
|
||||
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
|
||||
@ -195,7 +195,7 @@ courseEditHandler course = do
|
||||
, courseDescription = cfDesc res
|
||||
, courseLinkExternal = cfLink res
|
||||
, courseShorthand = cfShort res
|
||||
, courseTermId = TermKey $ cfTerm res
|
||||
, courseTermId = cfTerm res
|
||||
, courseSchoolId = cfSchool res
|
||||
, courseCapacity = cfCapacity res
|
||||
, courseHasRegistration = cfHasReg res
|
||||
@ -209,11 +209,11 @@ courseEditHandler course = do
|
||||
case insertOkay of
|
||||
(Just cid) -> do
|
||||
runDB $ insert_ $ Lecturer aid cid
|
||||
let cti = termToText $ cfTerm res
|
||||
let cti = toPathPiece $ cfTerm res
|
||||
addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|]
|
||||
redirect $ CourseListTermR $ cfTerm res
|
||||
Nothing -> do
|
||||
let cti = termToText $ cfTerm res
|
||||
let cti = toPathPiece $ cfTerm res
|
||||
addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|]
|
||||
(FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."
|
||||
_other -> return ()
|
||||
@ -231,7 +231,7 @@ data CourseForm = CourseForm
|
||||
, cfDesc :: Maybe Html
|
||||
, cfLink :: Maybe Text
|
||||
, cfShort :: Text
|
||||
, cfTerm :: TermIdentifier
|
||||
, cfTerm :: TermId
|
||||
, cfSchool :: SchoolId
|
||||
, cfCapacity :: Maybe Int
|
||||
, cfHasReg :: Bool
|
||||
@ -250,7 +250,7 @@ courseToForm cEntity = CourseForm
|
||||
, cfDesc = courseDescription course
|
||||
, cfLink = courseLinkExternal course
|
||||
, cfShort = courseShorthand course
|
||||
, cfTerm = unTermKey $ courseTermId course
|
||||
, cfTerm = courseTermId course
|
||||
, cfSchool = courseSchoolId course
|
||||
, cfCapacity = courseCapacity course
|
||||
, cfHasReg = courseHasRegistration course
|
||||
|
||||
@ -1,3 +1,6 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE RecordWildCards #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
@ -8,17 +11,23 @@ module Handler.Sheet where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Zip
|
||||
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
import Yesod.Form.Bootstrap3
|
||||
--
|
||||
-- import Colonnade hiding (fromMaybe)
|
||||
-- import Yesod.Colonnade
|
||||
import Colonnade -- hiding (fromMaybe)
|
||||
import Yesod.Colonnade
|
||||
--
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Network.Mime
|
||||
|
||||
{-
|
||||
* Implement Handlers
|
||||
@ -26,23 +35,203 @@ import Handler.Utils
|
||||
* Implement Access in Foundation
|
||||
-}
|
||||
|
||||
data SheetForm = SheetForm
|
||||
{ sfName :: Text
|
||||
, sfComment :: Maybe Html
|
||||
, sfType :: SheetType
|
||||
, sfMarkingText :: Maybe Html
|
||||
, sfActiveFrom :: UTCTime
|
||||
, sfActiveTo :: UTCTime
|
||||
, sfSheetF :: Maybe FileInfo
|
||||
, sfHintFrom :: Maybe UTCTime
|
||||
, sfHintF :: Maybe FileInfo
|
||||
, sfSolutionFrom :: Maybe UTCTime
|
||||
, sfSolutionF :: Maybe FileInfo
|
||||
}
|
||||
|
||||
getSheetListR :: TermIdentifier -> Text -> Handler Html
|
||||
getSheetListR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
getSheetNewR :: TermIdentifier -> Text -> Handler Html
|
||||
getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
|
||||
makeSheetForm cid template = identForm FIDsheet $ \html -> do
|
||||
-- TODO: Yesod.Form.MassInput.inputList arbeitet Server-seitig :(
|
||||
-- Erstmal nur mit ZIP arbeiten
|
||||
(result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ SheetForm
|
||||
<$> areq textField (fsb "Name") (sfName <$> template)
|
||||
<*> aopt htmlField (fsb "Hinweise für Teilnehmer") (sfMarkingText <$> template)
|
||||
<*> sheetTypeAFormReq (fsb "Bewertung") (sfType <$> template)
|
||||
--TODO: SICHTBARKEIT hinzunehmen
|
||||
<*> aopt htmlField (fsb "Hinweise für Korrektoren") (sfMarkingText <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabe ab") (sfActiveFrom <$> template)
|
||||
<*> areq utcTimeField (fsb "Abgabefrist") (sfActiveTo <$> template)
|
||||
<*> fileAFormOpt (fsb "Aufgaben")
|
||||
<*> aopt utcTimeField (fsb "Hinweis ab") (sfHintFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Hinweis")
|
||||
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Lösung")
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
| errorMsgs <- validateSheet sheetResult
|
||||
, not $ null errorMsgs ->
|
||||
(FormFailure errorMsgs,
|
||||
[whamlet|
|
||||
<div class="alert alert-danger">
|
||||
<h4> Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
^{widget}
|
||||
|]
|
||||
)
|
||||
_ -> (result, widget)
|
||||
where
|
||||
validateSheet _ = [] -- TODO
|
||||
|
||||
getSheetShowR :: TermIdentifier -> Text -> SheetId -> Handler Html
|
||||
getSheetShowR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
|
||||
fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
|
||||
fetchSheet tid csh shn = do
|
||||
-- TODO: More efficient with Esquleto?
|
||||
(Entity cid _course) <- getBy404 $ CourseTermShort tid csh
|
||||
getBy404 $ CourseSheet cid shn
|
||||
|
||||
-- List Sheets
|
||||
getSheetListCID :: CourseId -> Handler Html
|
||||
getSheetListCID cid = getSheetList =<<
|
||||
(Entity cid) <$> (runDB $ get404 cid)
|
||||
|
||||
getSheetListR :: TermId -> Text -> Handler Html
|
||||
getSheetListR tid csh = getSheetList =<<
|
||||
(runDB $ getBy404 $ CourseTermShort tid csh)
|
||||
|
||||
getSheetList :: Entity Course -> Handler Html
|
||||
getSheetList courseEnt = do
|
||||
-- mbAid <- maybeAuthId
|
||||
let cid = entityKey courseEnt
|
||||
let course = entityVal courseEnt
|
||||
let csh = courseShorthand course
|
||||
let tid = courseTermId course
|
||||
sheets <- runDB $ do
|
||||
rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
|
||||
forM rawSheets $ \(Entity sid sheet) -> do
|
||||
let sheetsub = [SubmissionSheetId ==. sid]
|
||||
submissions <- count sheetsub
|
||||
rated <- count $ (SubmissionRatingTime !=. Nothing):sheetsub
|
||||
return (sid, sheet, (submissions, rated))
|
||||
let colSheets = mconcat
|
||||
[ headed "Blatt" $ toWgt . sheetName . snd3
|
||||
, headed "Abgabe ab" $ toWgt . formatTimeGerWD . sheetActiveFrom . snd3
|
||||
, headed "Abgabe bis" $ toWgt . formatTimeGerWD . sheetActiveTo . snd3
|
||||
, headed "Bewertung" $ toWgt . show . sheetType . snd3
|
||||
, headed "Korrigiert" $ toWgt . snd . trd3
|
||||
, headed "Eingereicht" $ toWgt . fst . trd3
|
||||
-- TODO: only show edit button for allowed course assistants
|
||||
, headed "" $ \s -> linkButton "Edit" BCLink $ SheetEditR tid csh $ fst3 s
|
||||
]
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ T.append "Übungsblätter " csh
|
||||
if null sheets
|
||||
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
||||
else encodeHeadedWidgetTable tableDefault colSheets sheets
|
||||
|
||||
-- Show single sheet
|
||||
getSheetShowR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetShowR tid csh shn = getSheetShow =<<
|
||||
(runDB $ fetchSheet tid csh shn)
|
||||
|
||||
{- Nur per UUID
|
||||
getSheetIdShowR :: SheetId -> Handler Html
|
||||
getSheetIdShowR sheetId = getSheetShow =<<
|
||||
(Entity sheetId) <$> (runDB $ get404 sheetId)\
|
||||
-}{-
|
||||
getSheetUUIDShowR :: CryptoUUIDSheet -> Handler Html
|
||||
getSheetUUIDShowR sUUID = do
|
||||
cIDKey <- getsYesod appCryptoIDKey
|
||||
sheetId <- UUID.decrypt cIDKey sUUID
|
||||
sheetEnt <- runDB $ get404 sheetId
|
||||
getSheetShow $ Entity sheetId sheetEnt
|
||||
-}
|
||||
|
||||
getSheetShow :: (Entity Sheet) -> Handler Html
|
||||
getSheetShow entSheet = do
|
||||
let sheet = entityVal entSheet
|
||||
defaultLayout $ do
|
||||
setTitle $ toHtml $ T.append "Übung " $ sheetName sheet
|
||||
[whamlet| Under Construction !!! |] -- TODO
|
||||
$(widgetFile "sheetAdmin")
|
||||
|
||||
getSheetFileR :: TermId -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
|
||||
getSheetFileR tid csh shn typ title = do
|
||||
content <- runDB $ E.select $ E.from $
|
||||
\(course `E.InnerJoin` sheet `E.InnerJoin` sheetFile `E.InnerJoin` file) -> do
|
||||
-- Restrict to consistent rows that correspond to each other
|
||||
E.on (file E.^. FileId E.==. sheetFile E.^. SheetFileFileId)
|
||||
E.on (sheetFile E.^. SheetFileSheetId E.==. sheet E.^. SheetId)
|
||||
E.on (sheet E.^. SheetCourseId E.==. course E.^. CourseId)
|
||||
-- filter to requested file
|
||||
E.where_ ((file E.^. FileTitle E.==. E.val title)
|
||||
E.&&. (sheetFile E.^. SheetFileType E.==. E.val typ )
|
||||
E.&&. (sheet E.^. SheetName E.==. E.val shn )
|
||||
E.&&. (course E.^. CourseShorthand E.==. E.val csh )
|
||||
E.&&. (course E.^. CourseTermId E.==. E.val tid )
|
||||
)
|
||||
-- return desired columns
|
||||
return $ file E.^. FileContent
|
||||
let mimeType = defaultMimeLookup $ pack title
|
||||
case content of
|
||||
[E.Value (Just nochmalContent)] -> do
|
||||
addHeader "Content-Disposition" "attachment"
|
||||
respond mimeType nochmalContent
|
||||
[] -> notFound
|
||||
_other -> error "Multiple matching files found."
|
||||
|
||||
getSheetNewR :: TermId -> Text -> Handler Html
|
||||
getSheetNewR tid csh = do
|
||||
(Entity cid course) <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
let template = Nothing -- TODO: provide convenience by interpolating name/nr/dates+7days
|
||||
((res,wdgt), enc) <- runFormPost $ makeSheetForm cid template
|
||||
|
||||
case res of
|
||||
(FormSuccess SheetForm{..}) -> do
|
||||
|
||||
|
||||
let sid = undefined -- TODO after first insert
|
||||
let sname = undefined -- TODO after first insert
|
||||
|
||||
-- Prüfe, das FileTitle innerhalb des Sheets eindeutig ist für diesen SheetFileTpye
|
||||
whenIsJust sfSheetF $ \sinfo -> do
|
||||
let sheetInsert file = do
|
||||
fid <- insert file
|
||||
void . insert $ SheetFile sid fid SheetExercise
|
||||
runDB . runConduit $ (sourceFiles sinfo) =$= C.mapM_ sheetInsert
|
||||
|
||||
|
||||
|
||||
addMessage "info" "Blatt angelegt"
|
||||
redirect $ SheetShowR tid csh sname
|
||||
(FormFailure msgs) -> forM_ msgs $ (addMessage "warning") . toHtml
|
||||
_ -> return ()
|
||||
defaultLayout $ do
|
||||
$(widgetFile "newSheet")
|
||||
|
||||
postSheetNewR :: TermId -> Text -> Handler Html
|
||||
postSheetNewR = getSheetNewR
|
||||
|
||||
getSheetEditR :: TermId -> Text -> SheetId -> Handler Html
|
||||
getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
postSheetEditR :: TermId -> Text -> SheetId -> Handler Html
|
||||
postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
|
||||
|
||||
getSheetDelR :: TermId -> Text -> SheetId -> Handler Html
|
||||
getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
-- Sicherheitsabfrage
|
||||
|
||||
postSheetDelR :: TermId -> Text -> SheetId -> Handler Html
|
||||
postSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
|
||||
-- Tatsächlich löschen
|
||||
|
||||
|
||||
{-
|
||||
getCourseShowR :: TermIdentifier -> Text -> Handler Html
|
||||
getCourseShowR :: TermId -> Text -> Handler Html
|
||||
getCourseShowR tid csh = do
|
||||
mbAid <- maybeAuthId
|
||||
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
|
||||
|
||||
@ -53,7 +53,7 @@ submissionTable = do
|
||||
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
||||
|
||||
let
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand
|
||||
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
||||
anchorSubmission (_, cUUID, _) = SubmissionR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
|
||||
@ -39,12 +39,12 @@ getTermShowR = do
|
||||
provideRep $ return $ toJSON $ map fst termData
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
[ headed "Kürzel" $ \(Entity _ Term{..},_) -> do
|
||||
[ headed "Kürzel" $ \(Entity tid Term{..},_) -> do
|
||||
-- Scrap this if to slow, create term edit page instead
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR termName) False
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
||||
[whamlet|
|
||||
$if adminLink == Authorized
|
||||
<a href=@{TermEditExistR termName}>
|
||||
<a href=@{TermEditExistR tid}>
|
||||
#{termToText termName}
|
||||
$else
|
||||
#{termToText termName}
|
||||
@ -55,9 +55,9 @@ getTermShowR = do
|
||||
fromString $ formatTimeGerWD termLectureEnd
|
||||
, headed "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
bool "" tickmark termActive
|
||||
, headed "Kursliste" $ \(Entity _ Term{..}, E.Value numCourses) ->
|
||||
, headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
|
||||
[whamlet|
|
||||
<a href=@{CourseListTermR termName}>
|
||||
<a href=@{CourseListTermR tid}>
|
||||
#{show numCourses} Kurse
|
||||
|]
|
||||
, headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
@ -80,9 +80,9 @@ getTermEditR = do
|
||||
postTermEditR :: Handler Html
|
||||
postTermEditR = termEditHandler Nothing
|
||||
|
||||
getTermEditExistR :: TermIdentifier -> Handler Html
|
||||
getTermEditExistR :: TermId -> Handler Html
|
||||
getTermEditExistR tid = do
|
||||
term <- runDB $ get $ TermKey tid
|
||||
term <- runDB $ get tid
|
||||
termEditHandler term
|
||||
|
||||
|
||||
|
||||
@ -13,8 +13,11 @@ import Model.Types
|
||||
-- import Data.Maybe
|
||||
|
||||
|
||||
termActiveField :: Field Handler TermIdentifier
|
||||
termActiveField = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
termActiveField :: Field Handler TermId
|
||||
termActiveField = selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termActiveOld :: Field Handler TermIdentifier
|
||||
termActiveOld = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName
|
||||
|
||||
termNewField :: Field Handler TermIdentifier
|
||||
termNewField = checkMMap checkTerm termToText textField
|
||||
|
||||
Loading…
Reference in New Issue
Block a user