diff --git a/.gitignore b/.gitignore
index f4c2d62c0..6338c36b4 100644
--- a/.gitignore
+++ b/.gitignore
@@ -26,4 +26,5 @@ uniworx.nix
.dbsettings.yml
*.kate-swp
src/Handler/Assist.bak
-src/Handler/Course.SnapCustom.hs
\ No newline at end of file
+src/Handler/Course.SnapCustom.hs
+*.orig
diff --git a/models b/models
index 66142172b..b910cb843 100644
--- a/models
+++ b/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
diff --git a/routes b/routes
index 0d1caa0c8..8c074546b 100644
--- a/routes
+++ b/routes
@@ -10,20 +10,20 @@
/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/#TermId CourseListTermR GET
+/course/#TermId/#Text/edit CourseEditExistR GET
+/course/#TermId/#Text/show CourseShowR GET POST
-/course/#TermIdentifier/#Text/sheet/ SheetListR GET
-/course/#TermIdentifier/#Text/sheet/#Text/show SheetShowR GET
-/course/#TermIdentifier/#Text/sheet/#Text/#SheetFileType/#FilePath SheetFileR GET
-/course/#TermIdentifier/#Text/sheet/new SheetNewR GET POST
-/course/#TermIdentifier/#Text/sheet/#SheetId/edit SheetEditR GET POST
-/course/#TermIdentifier/#Text/sheet/#SheetId/delete SheetDelR 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
diff --git a/src/Foundation.hs b/src/Foundation.hs
index 3af180e40..edd590f15 100644
--- a/src/Foundation.hs
+++ b/src/Foundation.hs
@@ -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
@@ -185,8 +185,8 @@ isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (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 (SheetNewR 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
@@ -242,7 +242,7 @@ 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)
diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs
index db7f4d597..5a3030c21 100644
--- a/src/Handler/Course.hs
+++ b/src/Handler/Course.hs
@@ -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| #{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
diff --git a/src/Handler/Sheet.hs b/src/Handler/Sheet.hs
index 7f3e3e4dd..28bacf0b3 100644
--- a/src/Handler/Sheet.hs
+++ b/src/Handler/Sheet.hs
@@ -86,10 +86,10 @@ makeSheetForm cid template = identForm FIDsheet $ \html -> do
validateSheet _ = [] -- TODO
-fetchSheet :: TermIdentifier -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
+fetchSheet :: TermId -> Text -> Text -> YesodDB UniWorX (Entity Sheet)
fetchSheet tid csh shn = do
-- TODO: More efficient with Esquleto?
- (Entity cid _course) <- getBy404 $ CourseTermShort (TermKey tid) csh
+ (Entity cid _course) <- getBy404 $ CourseTermShort tid csh
getBy404 $ CourseSheet cid shn
-- List Sheets
@@ -97,9 +97,9 @@ getSheetListCID :: CourseId -> Handler Html
getSheetListCID cid = getSheetList =<<
(Entity cid) <$> (runDB $ get404 cid)
-getSheetListR :: TermIdentifier -> Text -> Handler Html
+getSheetListR :: TermId -> Text -> Handler Html
getSheetListR tid csh = getSheetList =<<
- (runDB $ getBy404 $ CourseTermShort (TermKey tid) csh)
+ (runDB $ getBy404 $ CourseTermShort tid csh)
getSheetList :: Entity Course -> Handler Html
getSheetList courseEnt = do
@@ -107,7 +107,7 @@ getSheetList courseEnt = do
let cid = entityKey courseEnt
let course = entityVal courseEnt
let csh = courseShorthand course
- let tid = unTermKey $ courseTermId course
+ let tid = courseTermId course
sheets <- runDB $ do
rawSheets <- selectList [SheetCourseId ==. cid] [Desc SheetActiveFrom]
forM rawSheets $ \(Entity sid sheet) -> do
@@ -132,7 +132,7 @@ getSheetList courseEnt = do
else encodeHeadedWidgetTable tableDefault colSheets sheets
-- Show single sheet
-getSheetShowR :: TermIdentifier -> Text -> Text -> Handler Html
+getSheetShowR :: TermId -> Text -> Text -> Handler Html
getSheetShowR tid csh shn = getSheetShow =<<
(runDB $ fetchSheet tid csh shn)
@@ -157,7 +157,7 @@ getSheetShow entSheet = do
[whamlet| Under Construction !!! |] -- TODO
$(widgetFile "sheetAdmin")
-getSheetFileR :: TermIdentifier -> Text -> Text -> SheetFileType -> FilePath -> Handler TypedContent
+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
@@ -170,7 +170,7 @@ getSheetFileR tid csh shn typ title = do
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 (TermKey tid))
+ E.&&. (course E.^. CourseTermId E.==. E.val tid )
)
-- return desired columns
return $ file E.^. FileContent
@@ -182,9 +182,9 @@ getSheetFileR tid csh shn typ title = do
[] -> notFound
_other -> error "Multiple matching files found."
-getSheetNewR :: TermIdentifier -> Text -> Handler Html
+getSheetNewR :: TermId -> Text -> Handler Html
getSheetNewR tid csh = do
- (Entity cid course) <- runDB $ getBy404 $ CourseTermShort (TermKey tid) csh
+ (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
@@ -211,27 +211,27 @@ getSheetNewR tid csh = do
defaultLayout $ do
$(widgetFile "newSheet")
-postSheetNewR :: TermIdentifier -> Text -> Handler Html
+postSheetNewR :: TermId -> Text -> Handler Html
postSheetNewR = getSheetNewR
-getSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
+getSheetEditR :: TermId -> Text -> SheetId -> Handler Html
getSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
-postSheetEditR :: TermIdentifier -> Text -> SheetId -> Handler Html
+postSheetEditR :: TermId -> Text -> SheetId -> Handler Html
postSheetEditR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
-getSheetDelR :: TermIdentifier -> Text -> SheetId -> Handler Html
+getSheetDelR :: TermId -> Text -> SheetId -> Handler Html
getSheetDelR _ _ _ = defaultLayout [whamlet| Under Construction !!! |] -- TODO
-- Sicherheitsabfrage
-postSheetDelR :: TermIdentifier -> Text -> SheetId -> Handler Html
+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
diff --git a/src/Handler/Submission.hs b/src/Handler/Submission.hs
index c46cc5727..d7d3cf468 100644
--- a/src/Handler/Submission.hs
+++ b/src/Handler/Submission.hs
@@ -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
diff --git a/src/Handler/Term.hs b/src/Handler/Term.hs
index f468c88c6..aafa70cd7 100644
--- a/src/Handler/Term.hs
+++ b/src/Handler/Term.hs
@@ -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
-
+
#{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|
-
+
#{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
diff --git a/src/Handler/Utils/Term.hs b/src/Handler/Utils/Term.hs
index b3c9c4f9d..fa2186bf0 100644
--- a/src/Handler/Utils/Term.hs
+++ b/src/Handler/Utils/Term.hs
@@ -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