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

Fixes to Course New/Edit handling. Update not yet working!

Browse Source
This commit is contained in:
SJost 2018-03-14 18:34:42 +01:00
parent 1c052087fd
commit 8247c6c6d4
13 changed files with 176 additions and 114 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
.directory Normal file
View File

@ -0,0 +1,6 @@
[Dolphin]
Timestamp=2018,3,14,10,57,55
Version=4
[Settings]
HiddenFilesShown=true

4
.kateproject Normal file
View File

@ -0,0 +1,4 @@
{
"name": "ReWorX"
, "files": [ { "git": 1, "filters": ["*.hs", "*.hamlet", "*.lucius", "*.cassius", "*.julius"], "recursive": 1 } ]
}

11
FragenSJ.txt Normal file
View File

@ -0,0 +1,11 @@
** i18n:
- Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel?
- Was ist mit PageTitles, z.B. in Handler.Term.termEditHandler:
-- setTitle [whamlet| _{MsgTermNewTitle} |] -- TODO, does not work
** FORMS
- Handler.Utils.Form.FormIdentifier: Still needed?
- Verification of Ownership during Edit?

16
README.md
View File

@ -52,7 +52,7 @@ Assuming Ubuntu or similar
Build the app:<br>
`stack build`
Run the app (with environment variable DUMMY_LUGIN set to true):<br>
Run the app (with environment variable DUMMY_LOGIN set to true):<br>
`env DUMMY_LOGIN=true stack exec -- yesod devel`
`Devel application launched: http://localhost:3000`<br>
@ -86,5 +86,19 @@ psql -U uniworx -d uniworx -h 127.0.0.1 -w
--Zeige Tabellen
\dt
--Zeige Tabellen Inhalt:
TABEL "user";
-- Die Anführungszeichen können manchmal weggelassen werden, aber
-- bei user sind sie notwendig, da es auch Schlüsselwort in sql ist.
--Lösche Tabelle "course" und alle davon abhängigen:
DROP TABLE "course" CASCADE;
-- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer)
INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1);
-- Beenden:
\q
-- Hilfe:
\help

8
messages/de.msg
View File

@ -1,3 +1,9 @@
SummerTerm year@Integer: Sommersemester #{tshow year}
WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
SemesterEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
TermNewTitle: Semester editiere/anlegen.
InvalidInput: Eingaben bitte korrigieren.
CourseNewOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
CourseEditOk tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
CourseNewDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.

4
models
View File

@ -30,8 +30,8 @@ StudyTerms
name Text Maybe
Primary key
Term json
name TermIdentifier
start Day
name TermIdentifier -- unTermKey :: TermId -> TermIdentifier
start Day -- TermKey :: TermIdentifier -< TermId
end Day
holidays [Day]
lectureStart Day

10
routes
View File

@ -13,10 +13,10 @@
/term/#TermId/edit TermEditExistR GET
/course/ CourseListR GET
!/course/new CourseEditR GET POST
!/course/#TermId CourseListTermR GET
/course/#TermId/#Text/edit CourseEditExistR GET
/course/#TermId/#Text/show CourseShowR GET POST
!/course/new CourseNewR GET POST
!/course/#TermId CourseListTermR GET
/course/#TermId/#Text/edit CourseEditR GET
/course/#TermId/#Text/show CourseShowR GET POST
/course/#TermId/#Text/sheet/ SheetListR GET
/course/#TermId/#Text/sheet/#Text/show SheetShowR GET
@ -34,4 +34,4 @@
!/#UUID CryptoUUIDDispatchR GET
-- For demonstration
/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET
/course/#CryptoUUIDCourse/edit CourseEditIDR GET

14
src/Foundation.hs
View File

@ -198,10 +198,10 @@ isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cI
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 t c)
isAuthorizedDB CourseNewR _ = lecturerAccess Nothing
isAuthorizedDB (CourseEditR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (SheetNewR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
isAuthorizedDB (CourseEditExistIDR cID) _ = do
isAuthorizedDB (CourseEditIDR cID) _ = do
courseId <- decrypt cID
courseLecturerAccess courseId
isAuthorizedDB _route _isWrite = return $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
@ -255,11 +255,11 @@ instance YesodBreadcrumbs UniWorX where
breadcrumb TermEditR = return ("Neu", Just TermShowR)
breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
breadcrumb CourseListR = return ("Kurs", Just HomeR)
breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
breadcrumb CourseListR = return ("Kurs", Just HomeR)
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 CourseNewR = return ("Neu", Just CourseListR)
breadcrumb (CourseEditR _ _) = 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)

184
src/Handler/Course.hs
View File

@ -54,26 +54,26 @@ getCourseListTermR tidini = do
shd = courseShorthand c
tid = courseTermId c
in do
adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
adminLink <- handlerToWidget $ isAuthorized (CourseEditR tid shd ) False
-- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
[whamlet|
$if adminLink == Authorized
<a href=@{CourseEditExistR tid shd}>
<a href=@{CourseEditR tid shd}>
editieren
|]
)
]
let pageLinks =
let pageActions =
[ NavbarLeft $ MenuItem
{ menuItemLabel = "Neuer Kurs"
, menuItemRoute = CourseEditR
, menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseEditR False
, menuItemRoute = CourseNewR
, menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
}
]
defaultLinkLayout pageLinks $ do
defaultLinkLayout pageActions $ do
-- defaultLayout $ do
setTitle "Semesterkurse"
linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
linkButton "Neuen Kurs anlegen" BCPrimary CourseNewR
encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
getCourseShowR :: TermId -> Text -> Handler Html
@ -124,101 +124,107 @@ postCourseShowR tid csh = do
-- redirect or not?! I guess not, since we want GET now
getCourseShowR tid csh
getCourseEditR :: Handler Html
getCourseEditR = do
getCourseNewR :: Handler Html
getCourseNewR = do
-- TODO: Defaults für Semester hier ermitteln und übergeben
courseEditHandler Nothing
postCourseNewR :: Handler Html
postCourseNewR = courseEditHandler Nothing
postCourseEditR :: Handler Html
postCourseEditR = courseEditHandler Nothing
getCourseEditExistR :: TermId -> Text -> Handler Html
getCourseEditExistR tid csh = do
getCourseEditR :: TermId -> Text -> Handler Html
getCourseEditR tid csh = do
course <- runDB $ getBy $ CourseTermShort tid csh
courseEditHandler course
getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
getCourseEditExistIDR cID = do
getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
getCourseEditIDR cID = do
cIDKey <- getsYesod appCryptoIDKey
courseID <- UUID.decrypt cIDKey cID
courseEditHandler =<< runDB (getEntity courseID)
courseEditHandler :: Maybe (Entity Course) -> Handler Html
courseEditHandler course = do
aid <- requireAuthId
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
action <- lookupPostParam "formaction"
case (result,action) of
(FormSuccess res, fAct)
| fAct == formActionDelete
, Just cid <- cfCourseId res -> do
courseDeleteHandler :: Handler Html -- not called anywhere yet
courseDeleteHandler = undefined
{- TODO
| False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
, Just cid <- cfCourseId res -> do
runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
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 = cfTerm res
actTime <- liftIO getCurrentTime
updateokay <- runDB $ do
exists <- getBy $ CourseTermShort tid $ cfShort res
let upokay = isNothing exists
when upokay $ update cid
[ CourseName =. cfName res
, CourseDescription =. cfDesc res
, CourseLinkExternal =. cfLink res
, CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?!
, CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?!
, CourseSchoolId =. cfSchool res
, CourseCapacity =. cfCapacity res
, CourseRegisterFrom =. cfRegFrom res
, CourseRegisterTo =. cfRegTo res
, CourseChangedBy =. aid
, CourseChanged =. actTime
]
return upokay
let cti = toPathPiece $ cfTerm res
if updateokay
then do
addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
redirect $ CourseListTermR $ cfTerm res
else do
addMessage "danger" [shamlet| Kurs #{cti}/#{cfShort res} konnte nicht geändert werden.
\ Es gibt bereits einen anderen Kurs mit diesem Kürzel in diesem Semester.|]
| fAct == formActionSave
, Nothing <- cfCourseId res -> do
actTime <- liftIO getCurrentTime
insertOkay <- runDB $ insertUnique $ Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTermId = cfTerm res
, courseSchoolId = cfSchool res
, courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseCreated = actTime
, courseChanged = actTime
, courseCreatedBy = aid
, courseChangedBy = aid
}
case insertOkay of
(Just cid) -> do
runDB $ insert_ $ Lecturer aid cid
let cti = toPathPiece $ cfTerm res
addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|]
redirect $ CourseListTermR $ cfTerm res
Nothing -> do
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 ()
-}
courseEditHandler :: Maybe (Entity Course) -> Handler Html
courseEditHandler course = do
aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
case result of
(FormSuccess res@(
CourseForm { cfCourseId = Nothing
, cfShort = csh
, cfTerm = tid
})) -> do -- create new course
let tident = unTermKey tid
actTime <- liftIO getCurrentTime
insertOkay <- runDB $ insertUnique $ Course
{ courseName = cfName res
, courseDescription = cfDesc res
, courseLinkExternal = cfLink res
, courseShorthand = cfShort res
, courseTermId = cfTerm res
, courseSchoolId = cfSchool res
, courseCapacity = cfCapacity res
, courseHasRegistration = cfHasReg res
, courseRegisterFrom = cfRegFrom res
, courseRegisterTo = cfRegTo res
, courseCreated = actTime
, courseChanged = actTime
, courseCreatedBy = aid
, courseChangedBy = aid
}
case insertOkay of
(Just cid) -> do
runDB $ insert_ $ Lecturer aid cid
addMessageI "info" $ MsgCourseNewOk tident csh
redirect $ CourseListTermR tid
Nothing ->
addMessageI "danger" $ MsgCourseNewDupShort tident csh
(FormSuccess res@(
CourseForm { cfCourseId = Just cid
, cfShort = csh
, cfTerm = tid
})) -> do -- edit existing course
let tident = unTermKey tid
actTime <- liftIO getCurrentTime
addMessage "info" [shamlet| #{show res}|]
runDB $ do
-- existing <- getBy $ CourseTermShort tid csh
-- if ((entityKey <$> existing) /= Just cid)
-- then addMessageI "danger" $ MsgCourseEditDupShort tident csh
-- else do
addMessage "info" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
update cid
[ CourseName =. cfName res
, CourseDescription =. cfDesc res
, CourseLinkExternal =. cfLink res
, CourseShorthand =. cfShort res -- TODO: change here should generate a warning, or only allowed for Admins?!
, CourseTermId =. tid -- TODO: change here should generate a warning, or only allowed for Admins?!
, CourseSchoolId =. cfSchool res
, CourseCapacity =. cfCapacity res
, CourseRegisterFrom =. cfRegFrom res
, CourseRegisterTo =. cfRegTo res
, CourseChangedBy =. aid
, CourseChanged =. actTime
]
addMessageI "info" $ MsgCourseEditOk tident csh
redirect $ CourseListTermR tid
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
other -> addMessage "error" $ [shamlet| Error: #{show other}|]
let formTitle = "Kurs editieren/anlegen" :: Text
let actionUrl = CourseEditR
let formActions = defaultFormActions
let actionUrl = CourseNewR -- CourseEditR -- TODO
defaultLayout $ do
setTitle [shamlet| #{formTitle} |]
$(widgetFile "formPage")
@ -282,7 +288,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
<*> areq checkBoxField (fsb "Anmeldung") (cfHasReg <$> template)
<*> aopt utcTimeField (fsb "Anmeldung von:") (cfRegFrom <$> template)
<*> aopt utcTimeField (fsb "Anmeldung bis:") (cfRegTo <$> template)
-- <* bootstrapSubmit (bsSubmit (show cid))
<* submitButton
return $ case result of
FormSuccess courseResult
| errorMsgs <- validateCourse courseResult

18
src/Handler/Term.hs
View File

@ -12,7 +12,7 @@ module Handler.Term where
import Import
import Handler.Utils
import qualified Data.Text as T
-- import qualified Data.Text as T
import Yesod.Form.Bootstrap3
import Colonnade hiding (bool)
@ -67,8 +67,15 @@ getTermShowR = do
, headed "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
fromString $ (intercalate ", ") $ map formatTimeGerWD termHolidays
]
defaultLayout $ do
setTitle "Freigeschaltete Semester"
let pageActions =
[ NavbarLeft $ MenuItem
{ menuItemLabel = "Neues Semester"
, menuItemRoute = TermEditR
, menuItemAccessCallback = (== Authorized) <$> isAuthorized TermEditR True
}
]
defaultLinkLayout pageActions $ do
setTitle "Freigeschaltete Semester"
encodeWidgetTable tableDefault colonnadeTerms termData
@ -98,14 +105,15 @@ termEditHandler term = do
-- let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
-- addMessage "success" [shamlet| #{msg} |]
-- MIT INTERNATIONALISIERUNG:
addMessageI "success" $ MsgSemesterEdited $ termName res
addMessageI "success" $ MsgTermEdited $ termName res
redirect TermShowR
(FormMissing ) -> return ()
(FormFailure _) -> addMessage "warning" "Bitte Eingabe korrigieren."
(FormFailure _) -> addMessageI "warning" MsgInvalidInput
let formTitle = "Semester editieren/anlegen" :: Text
let actionUrl = TermEditR
defaultLayout $ do
setTitle [shamlet| #{formTitle} |]
-- setTitle [whamlet| _{MsgTermNewTitle} |] -- TODO, does not work
$(widgetFile "formPage")
newTermForm :: Maybe Term -> Form Term

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

@ -28,14 +28,14 @@ import qualified Text.Blaze.Internal as Blaze (null)
import Web.PathPieces (showToPathPiece, readFromPathPiece)
------------------------------------------------
-- Unique Form Identifiers to avoid accidents --
-- Unique Form Identifiers to avoid aSccidents --
------------------------------------------------
data FormIdentifier = FIDcourse | FIDsheet
deriving (Enum, Eq, Ord, Bounded, Read, Show)
identForm :: FormIdentifier -> Form a -> Form a
identForm :: FormIdentifier -> Form a -> Form a -- TODO: Still needed?
identForm fid = identifyForm (T.pack $ show fid)
-------------------
@ -244,6 +244,9 @@ postButtonForm lblId = identifyForm lblId buttonF
natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
natField d = checkBool (>= 0) (T.append d " muss eine natürliche Zahl sein.") $ intField
natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
natIntField = natField
posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
posIntField d = checkBool (>= 1) (T.append d " muss eine positive Zahl sein.") $ intField

4
src/Model/Types.hs
View File

@ -96,6 +96,10 @@ data TermIdentifier = TermIdentifier
, season :: Season
} deriving (Show, Read, Eq, Ord, Generic, Typeable)
-- Conversion TermId <-> TermIdentifier::
-- from_TermId_to_TermIdentifier = unTermKey
-- from_TermIdentifier_to_TermId = TermKey
--TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
termToText :: TermIdentifier -> Text
termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year

4
templates/home.hamlet
View File

@ -61,7 +61,7 @@
<li .list-group-item>
<a href=@{CourseEditR}>Kurse anlegen
<a href=@{CourseNewR}>Kurse anlegen
editieren und anzeigen
<li .list-group-item>
@ -77,6 +77,6 @@
^{btnWdgt}
<li .list-group-item>
<a href=@{CourseEditR}>Kurse anlegen
<a href=@{CourseNewR}>Kurse anlegen
editieren und anzeigen