fraport/fradrive-old
Archived
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

TermIdentifier -> TermId in routes

Browse Source
This commit is contained in:
SJost 2018-02-19 17:58:55 +01:00
parent 272bc7f6c5
commit 8d221600d3
9 changed files with 266 additions and 61 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
.gitignore vendored
View File

@ -27,3 +27,4 @@ uniworx.nix
*.kate-swp *.kate-swp
src/Handler/Assist.bak src/Handler/Assist.bak
src/Handler/Course.SnapCustom.hs src/Handler/Course.SnapCustom.hs
*.orig

4
models
View File

@ -37,8 +37,8 @@ Term json
lectureStart Day lectureStart Day
lectureEnd Day lectureEnd Day
active Bool active Bool
Primary name Primary name -- newtype Key Term = TermKey { unTermKey :: TermIdentifier }
deriving Show deriving Show -- type TermId = Key Term
School json School json
name Text name Text
shorthand Text shorthand Text

20
routes
View File

@ -6,22 +6,24 @@
/ HomeR GET POST / HomeR GET POST
/profile ProfileR GET /profile ProfileR GET
/users UsersR GET
/term TermShowR GET /term TermShowR GET
/term/edit TermEditR GET POST /term/edit TermEditR GET POST
/term/#TermIdentifier/edit TermEditExistR GET /term/#TermId/edit TermEditExistR GET
/course/ CourseListR GET /course/ CourseListR GET
!/course/new CourseEditR GET POST !/course/new CourseEditR GET POST
!/course/#TermIdentifier CourseListTermR GET !/course/#TermId CourseListTermR GET
/course/#TermIdentifier/#Text/edit CourseEditExistR GET /course/#TermId/#Text/edit CourseEditExistR GET
/course/#TermIdentifier/#Text/show CourseShowR GET POST /course/#TermId/#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/#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 SubmissionListR GET POST
/submission/#CryptoUUIDSubmission SubmissionR GET POST /submission/#CryptoUUIDSubmission SubmissionR GET POST

20
src/Foundation.hs
View File

@ -75,7 +75,7 @@ data UniWorX = UniWorX
-- --
-- This function also generates the following type synonyms: -- This function also generates the following type synonyms:
-- type Handler = HandlerT UniWorX IO -- type Handler = HandlerT UniWorX IO
-- type Widget = WidgetT UniWorX IO () -- type Widget = WidgetT UniWorX IO ()
mkYesodData "UniWorX" $(parseRoutesFile "routes") mkYesodData "UniWorX" $(parseRoutesFile "routes")
data MenuItem = MenuItem data MenuItem = MenuItem
@ -178,17 +178,19 @@ instance Yesod UniWorX where
makeLogger = return . appLogger makeLogger = return . appLogger
isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult isAuthorizedDB :: Route UniWorX -> Bool -> YesodDB UniWorX AuthResult
isAuthorizedDB UsersR _ = adminAccess Nothing
isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionR cID) _ = submissionAccess $ Right cID
isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cID
isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
isAuthorizedDB TermEditR _ = adminAccess Nothing isAuthorizedDB TermEditR _ = adminAccess Nothing
isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing isAuthorizedDB (TermEditExistR _) _ = adminAccess Nothing
isAuthorizedDB CourseEditR _ = lecturerAccess 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 isAuthorizedDB (CourseEditExistIDR cID) _ = do
courseId <- decrypt cID courseId <- decrypt cID
courseLecturerAccess courseId 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 :: Either CryptoFileNameSubmission CryptoUUIDSubmission -> YesodDB UniWorX AuthResult
submissionAccess cID = do submissionAccess cID = do
@ -240,11 +242,14 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR) breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
breadcrumb CourseListR = return ("Kurs", Just HomeR) 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 (CourseShowR term course) = return (course, Just $ CourseListTermR term)
breadcrumb CourseEditR = return ("Neu", Just CourseListR) breadcrumb CourseEditR = return ("Neu", Just CourseListR)
breadcrumb (CourseEditExistR _ _) = return ("Editieren", 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 SubmissionListR = return ("Abgaben", Just HomeR)
breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR) breadcrumb (SubmissionR _) = return ("Abgabe", Just SubmissionListR)
@ -266,6 +271,11 @@ defaultLinks = -- Define the menu items of the header.
, menuItemRoute = CourseListR , menuItemRoute = CourseListR
, menuItemAccessCallback = return True , menuItemAccessCallback = return True
} }
, NavbarRight $ MenuItem
{ menuItemLabel = "Users"
, menuItemRoute = UsersR
, menuItemAccessCallback = return True -- Creates a LOOP: (Authorized ==) <$> isAuthorized UsersR False
}
, NavbarRight $ MenuItem , NavbarRight $ MenuItem
{ menuItemLabel = "Profile" { menuItemLabel = "Profile"
, menuItemRoute = ProfileR , menuItemRoute = ProfileR
@ -384,7 +394,7 @@ instance YesodAuth UniWorX where
authHttpManager = getHttpManager authHttpManager = getHttpManager
ldapConfig :: UniWorX -> LDAPConfig ldapConfig :: UniWorX -> LDAPConfig
ldapConfig app@(appSettings -> settings) = LDAPConfig ldapConfig _app@(appSettings -> settings) = LDAPConfig
{ usernameFilter = \u -> principalName <> "=" <> u { usernameFilter = \u -> principalName <> "=" <> u
, identifierModifier , identifierModifier
, ldapUri = appLDAPURI settings , ldapUri = appLDAPURI settings

42
src/Handler/Course.hs
View File

@ -26,20 +26,20 @@ import qualified Data.UUID.Cryptographic as UUID
getCourseListR :: Handler TypedContent getCourseListR :: Handler TypedContent
getCourseListR = redirect TermShowR getCourseListR = redirect TermShowR
getCourseListTermR :: TermIdentifier -> Handler Html getCourseListTermR :: TermId -> Handler Html
getCourseListTermR tidini = do getCourseListTermR tidini = do
(term,courses) <- runDB $ (,) (term,courses) <- runDB $ (,)
<$> get (TermKey tidini) <$> get tidini
<*> selectList [CourseTermId ==. TermKey tidini] [Asc CourseShorthand] <*> selectList [CourseTermId ==. tidini] [Asc CourseShorthand]
when (isNothing term) $ do when (isNothing term) $ do
addMessage "warning" [shamlet| Semester #{termToText tidini} nicht gefunden. |] addMessage "warning" [shamlet| Semester #{toPathPiece tidini} nicht gefunden. |]
redirect TermShowR redirect TermShowR
-- TODO: several runDBs per TableRow are probably too inefficient! -- TODO: several runDBs per TableRow are probably too inefficient!
let colonnadeTerms = mconcat let colonnadeTerms = mconcat
[ headed "Kürzel" $ (\ckv -> [ headed "Kürzel" $ (\ckv ->
let c = entityVal ckv let c = entityVal ckv
shd = courseShorthand c shd = courseShorthand c
tid = unTermKey $ courseTermId c tid = courseTermId c
in [whamlet| <a href=@{CourseShowR tid shd}>#{shd} |] ) in [whamlet| <a href=@{CourseShowR tid shd}>#{shd} |] )
-- , headed "Institut" $ [shamlet| #{course} |] -- , headed "Institut" $ [shamlet| #{course} |]
, headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal , headed "Beginn Anmeldung" $ fromString.(maybe "" formatTimeGerWD).courseRegisterFrom.entityVal
@ -52,7 +52,7 @@ getCourseListTermR tidini = do
, headed " " $ (\ckv -> , headed " " $ (\ckv ->
let c = entityVal ckv let c = entityVal ckv
shd = courseShorthand c shd = courseShorthand c
tid = unTermKey $ courseTermId c tid = courseTermId c
in do in do
adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else "" -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
@ -76,11 +76,11 @@ getCourseListTermR tidini = do
linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses) encodeHeadedWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
getCourseShowR :: TermIdentifier -> Text -> Handler Html getCourseShowR :: TermId -> Text -> Handler Html
getCourseShowR tid csh = do getCourseShowR tid csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
dependent <- (,,) dependent <- (,,)
<$> get (courseSchoolId course) -- join <$> get (courseSchoolId course) -- join
<*> count [CourseParticipantCourseId ==. cid] -- join <*> count [CourseParticipantCourseId ==. cid] -- join
@ -93,7 +93,7 @@ getCourseShowR tid csh = do
let course = entityVal courseEnt let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
defaultLayout $ do defaultLayout $ do
setTitle $ [shamlet| #{termToText tid} - #{csh}|] setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course") $(widgetFile "course")
registerButton :: Bool -> Form () registerButton :: Bool -> Form ()
@ -104,11 +104,11 @@ registerButton registered =
msg = if registered then "Abmelden" else "Anmelden" msg = if registered then "Abmelden" else "Anmelden"
regMsg = msg :: BootstrapSubmit Text regMsg = msg :: BootstrapSubmit Text
postCourseShowR :: TermIdentifier -> Text -> Handler Html postCourseShowR :: TermId -> Text -> Handler Html
postCourseShowR tid csh = do postCourseShowR tid csh = do
aid <- requireAuthId aid <- requireAuthId
(cid, registered) <- runDB $ do (cid, registered) <- runDB $ do
(Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh (Entity cid _) <- getBy404 $ CourseTermShort tid csh
registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid) registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid)
return (cid, registered) return (cid, registered)
((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
@ -133,9 +133,9 @@ getCourseEditR = do
postCourseEditR :: Handler Html postCourseEditR :: Handler Html
postCourseEditR = courseEditHandler Nothing postCourseEditR = courseEditHandler Nothing
getCourseEditExistR :: TermIdentifier -> Text -> Handler Html getCourseEditExistR :: TermId -> Text -> Handler Html
getCourseEditExistR tid csh = do getCourseEditExistR tid csh = do
course <- runDB $ getBy $ CourseTermShort (TermKey tid) csh course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler course courseEditHandler course
getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
@ -155,12 +155,12 @@ courseEditHandler course = do
| fAct == formActionDelete | fAct == formActionDelete
, Just cid <- cfCourseId res -> do , Just cid <- cfCourseId res -> do
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen! 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!|] addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
redirect $ CourseListTermR $ cfTerm res redirect $ CourseListTermR $ cfTerm res
| fAct == formActionSave | fAct == formActionSave
, Just cid <- cfCourseId res -> do , Just cid <- cfCourseId res -> do
let tid = TermKey $ cfTerm res let tid = cfTerm res
actTime <- liftIO getCurrentTime actTime <- liftIO getCurrentTime
updateokay <- runDB $ do updateokay <- runDB $ do
exists <- getBy $ CourseTermShort tid $ cfShort res exists <- getBy $ CourseTermShort tid $ cfShort res
@ -179,7 +179,7 @@ courseEditHandler course = do
, CourseChanged =. actTime , CourseChanged =. actTime
] ]
return upokay return upokay
let cti = termToText $ cfTerm res let cti = toPathPiece $ cfTerm res
if updateokay if updateokay
then do then do
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |] addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
@ -195,7 +195,7 @@ courseEditHandler course = do
, courseDescription = cfDesc res , courseDescription = cfDesc res
, courseLinkExternal = cfLink res , courseLinkExternal = cfLink res
, courseShorthand = cfShort res , courseShorthand = cfShort res
, courseTermId = TermKey $ cfTerm res , courseTermId = cfTerm res
, courseSchoolId = cfSchool res , courseSchoolId = cfSchool res
, courseCapacity = cfCapacity res , courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res , courseHasRegistration = cfHasReg res
@ -209,11 +209,11 @@ courseEditHandler course = do
case insertOkay of case insertOkay of
(Just cid) -> do (Just cid) -> do
runDB $ insert_ $ Lecturer aid cid runDB $ insert_ $ Lecturer aid cid
let cti = termToText $ cfTerm res let cti = toPathPiece $ cfTerm res
addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|] addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|]
redirect $ CourseListTermR $ cfTerm res redirect $ CourseListTermR $ cfTerm res
Nothing -> do 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}.|] addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|]
(FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren." (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."
_other -> return () _other -> return ()
@ -231,7 +231,7 @@ data CourseForm = CourseForm
, cfDesc :: Maybe Html , cfDesc :: Maybe Html
, cfLink :: Maybe Text , cfLink :: Maybe Text
, cfShort :: Text , cfShort :: Text
, cfTerm :: TermIdentifier , cfTerm :: TermId
, cfSchool :: SchoolId , cfSchool :: SchoolId
, cfCapacity :: Maybe Int , cfCapacity :: Maybe Int
, cfHasReg :: Bool , cfHasReg :: Bool
@ -250,7 +250,7 @@ courseToForm cEntity = CourseForm
, cfDesc = courseDescription course , cfDesc = courseDescription course
, cfLink = courseLinkExternal course , cfLink = courseLinkExternal course
, cfShort = courseShorthand course , cfShort = courseShorthand course
, cfTerm = unTermKey $ courseTermId course , cfTerm = courseTermId course
, cfSchool = courseSchoolId course , cfSchool = courseSchoolId course
, cfCapacity = courseCapacity course , cfCapacity = courseCapacity course
, cfHasReg = courseHasRegistration course , cfHasReg = courseHasRegistration course

215
src/Handler/Sheet.hs
View File

@ -1,3 +1,6 @@
{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE MultiParamTypeClasses #-}
@ -8,17 +11,23 @@ module Handler.Sheet where
import Import import Import
import Handler.Utils import Handler.Utils
import Handler.Utils.Zip
-- import Data.Time -- import Data.Time
-- import qualified Data.Text as T import qualified Data.Text as T
-- import Data.Function ((&)) -- import Data.Function ((&))
-- import Yesod.Form.Bootstrap3 import Yesod.Form.Bootstrap3
-- --
-- import Colonnade hiding (fromMaybe) import Colonnade -- hiding (fromMaybe)
-- import Yesod.Colonnade 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 * Implement Handlers
@ -26,23 +35,203 @@ import Handler.Utils
* Implement Access in Foundation * 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 makeSheetForm :: CourseId -> Maybe SheetForm -> Form SheetForm
getSheetNewR _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO 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 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 getCourseShowR tid csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do

2
src/Handler/Submission.hs
View File

@ -53,7 +53,7 @@ submissionTable = do
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s (,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
let let
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR (unTermKey courseTermId) courseShorthand anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseShowR courseTermId courseShorthand
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
anchorSubmission (_, cUUID, _) = SubmissionR cUUID anchorSubmission (_, cUUID, _) = SubmissionR cUUID
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID

14
src/Handler/Term.hs
View File

@ -39,12 +39,12 @@ getTermShowR = do
provideRep $ return $ toJSON $ map fst termData provideRep $ return $ toJSON $ map fst termData
provideRep $ do provideRep $ do
let colonnadeTerms = mconcat 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 -- Scrap this if to slow, create term edit page instead
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR termName) False adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
[whamlet| [whamlet|
$if adminLink == Authorized $if adminLink == Authorized
<a href=@{TermEditExistR termName}> <a href=@{TermEditExistR tid}>
#{termToText termName} #{termToText termName}
$else $else
#{termToText termName} #{termToText termName}
@ -55,9 +55,9 @@ getTermShowR = do
fromString $ formatTimeGerWD termLectureEnd fromString $ formatTimeGerWD termLectureEnd
, headed "Aktiv" $ \(Entity _ Term{..},_) -> , headed "Aktiv" $ \(Entity _ Term{..},_) ->
bool "" tickmark termActive bool "" tickmark termActive
, headed "Kursliste" $ \(Entity _ Term{..}, E.Value numCourses) -> , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
[whamlet| [whamlet|
<a href=@{CourseListTermR termName}> <a href=@{CourseListTermR tid}>
#{show numCourses} Kurse #{show numCourses} Kurse
|] |]
, headed "Semesteranfang" $ \(Entity _ Term{..},_) -> , headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
@ -80,9 +80,9 @@ getTermEditR = do
postTermEditR :: Handler Html postTermEditR :: Handler Html
postTermEditR = termEditHandler Nothing postTermEditR = termEditHandler Nothing
getTermEditExistR :: TermIdentifier -> Handler Html getTermEditExistR :: TermId -> Handler Html
getTermEditExistR tid = do getTermEditExistR tid = do
term <- runDB $ get $ TermKey tid term <- runDB $ get tid
termEditHandler term termEditHandler term

7
src/Handler/Utils/Term.hs
View File

@ -13,8 +13,11 @@ import Model.Types
-- import Data.Maybe -- import Data.Maybe
termActiveField :: Field Handler TermIdentifier termActiveField :: Field Handler TermId
termActiveField = convertField unTermKey TermKey $ selectField $ optionsPersistKey [TermActive ==. True] [Desc TermStart] termName 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 :: Field Handler TermIdentifier
termNewField = checkMMap checkTerm termToText textField termNewField = checkMMap checkTerm termToText textField