DeleteRedirct, fetchSheet caching, etc.
This commit is contained in:
SJost
parent
710b8334e5
commit
ad2b7ae866
@ -1,4 +1,4 @@
|
||||
** Sicherheitsabfragen?`
|
||||
** Sicherheitsabfragen?
|
||||
- Verschlüsselung des Zugriffs?
|
||||
|
||||
- SheetDelR tid csh sn : GET zeigt Sicherheitsabfrage
|
||||
@ -12,9 +12,7 @@
|
||||
- Handler.Sheet.postSheetDelR: deleteCascade für Files? Klappt das?
|
||||
Kann man abfragen, was bei deleteCascade alles gelöscht wird?
|
||||
|
||||
- Verständnis: Getrennte Handler get/post Handler in SheetEditR haben nicht funktioniert. Warum?
|
||||
|
||||
- Sheets.redirectBack(): Wollen wir das wirklich? Schöner?
|
||||
|
||||
** i18n:
|
||||
- i18n der
|
||||
|
||||
12
models
12
models
@ -103,11 +103,15 @@ Sheet
|
||||
activeTo UTCTime
|
||||
hintFrom UTCTime Maybe
|
||||
solutionFrom UTCTime Maybe
|
||||
created UTCTime
|
||||
changed UTCTime
|
||||
createdBy UserId
|
||||
changedBy UserId
|
||||
created UTCTime -- delete
|
||||
changed UTCTime -- delete
|
||||
createdBy UserId -- delete
|
||||
changedBy UserId -- delete
|
||||
CourseSheet courseId name
|
||||
SheetEdit
|
||||
sheet SheetId
|
||||
user UserId
|
||||
time UTCTime
|
||||
SheetFile
|
||||
sheetId SheetId
|
||||
fileId FileId
|
||||
|
||||
11
routes
11
routes
@ -15,9 +15,20 @@
|
||||
/course/ CourseListR GET
|
||||
!/course/new CourseNewR GET POST
|
||||
!/course/#TermId CourseListTermR GET
|
||||
|
||||
-- /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
|
||||
|
||||
@ -232,7 +232,7 @@ adminAccess school = do
|
||||
adrights <- selectList ((UserAdminUser ==. authId) : maybe [] (\s -> [UserAdminSchool ==. s]) school) []
|
||||
return $ if (not $ null adrights)
|
||||
then Authorized
|
||||
else Unauthorized "No admin access"
|
||||
else Unauthorized "No admin access" -- TODO internationalize
|
||||
|
||||
lecturerAccess :: Maybe SchoolId
|
||||
-> YesodDB UniWorX AuthResult
|
||||
@ -241,11 +241,10 @@ lecturerAccess school = do
|
||||
lecrights <- selectList ((UserLecturerUser ==. authId) : maybe [] (\s -> [UserLecturerSchool ==. s]) school) []
|
||||
return $ if (not $ null lecrights)
|
||||
then Authorized
|
||||
else Unauthorized "No lecturer access"
|
||||
else Unauthorized "No lecturer access" -- TODO internationalize
|
||||
|
||||
lecturerAccess' :: SchoolId -> YesodDB UniWorX AuthResult
|
||||
lecturerAccess' = authorizedFor UniqueSchoolLecturer MsgUnauthorizedSchoolLecturer
|
||||
-- Continue here
|
||||
|
||||
courseLecturerAccess :: CourseId -> YesodDB UniWorX AuthResult
|
||||
courseLecturerAccess = authorizedFor UniqueLecturer MsgUnauthorizedLecturer
|
||||
@ -256,7 +255,10 @@ courseCorrectorAccess = authorizedFor UniqueCorrector MsgUnauthorizedCorrect
|
||||
courseParticipantAccess :: CourseId -> YesodDB UniWorX AuthResult
|
||||
courseParticipantAccess = authorizedFor UniqueParticipant MsgUnauthorizedParticipant
|
||||
|
||||
authorizedFor :: (PersistEntityBackend record ~ BaseBackend backend, RenderMessage master msg, PersistEntity record, YesodAuth master, PersistUniqueRead backend)
|
||||
authorizedFor :: ( PersistEntityBackend record ~ BaseBackend backend
|
||||
, PersistEntity record, PersistUniqueRead backend
|
||||
, YesodAuth master, RenderMessage master msg
|
||||
)
|
||||
=> (AuthId master -> t -> Unique record) -> msg -> t -> ReaderT backend (HandlerT master IO) AuthResult
|
||||
authorizedFor authType msg courseId = do
|
||||
authId <- lift requireAuthId
|
||||
|
||||
@ -27,6 +27,7 @@ import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
import Network.Mime
|
||||
|
||||
@ -107,12 +108,35 @@ makeSheetForm template = identForm FIDsheet $ \html -> do
|
||||
] ]
|
||||
|
||||
|
||||
fetchSheetAux :: ( BaseBackend backend ~ SqlBackend
|
||||
, E.SqlSelect b a
|
||||
, Typeable a, MonadHandler m, IsPersistBackend backend
|
||||
, PersistQueryRead backend, PersistUniqueRead backend
|
||||
)
|
||||
=> (E.SqlExpr (Entity Sheet) -> b)
|
||||
-> Key Term -> Text -> Text -> ReaderT backend m a
|
||||
fetchSheetAux prj tid csh shn =
|
||||
let cachId = encodeUtf8 $ tshow (tid,csh,shn)
|
||||
in cachedBy cachId $ do
|
||||
-- Mit Yesod:
|
||||
-- cid <- getKeyBy404 $ CourseTermShort tid csh
|
||||
-- getBy404 $ CourseSheet cid shn
|
||||
-- Mit Esqueleto:
|
||||
sheetList <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourseId
|
||||
E.where_ $ course E.^. CourseTermId E.==. E.val tid
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
return $ prj sheet
|
||||
case sheetList of
|
||||
[sheet] -> return sheet
|
||||
_other -> notFound
|
||||
|
||||
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
|
||||
cid <- getKeyBy404 $ CourseTermShort tid csh
|
||||
getBy404 $ CourseSheet cid shn
|
||||
fetchSheet = fetchSheetAux id
|
||||
|
||||
fetchSheetId :: TermId -> Text -> Text -> YesodDB UniWorX (Key Sheet)
|
||||
fetchSheetId tid cid shn = E.unValue <$> fetchSheetAux (E.^. SheetId) tid cid shn
|
||||
|
||||
-- List Sheets
|
||||
getSheetListCID :: CourseId -> Handler Html
|
||||
@ -150,7 +174,8 @@ getSheetList courseEnt = do
|
||||
, headed "" $ \s -> linkButton "Delete" BCLink $ SheetDelR tid csh $ sheetName $ snd3 s
|
||||
]
|
||||
showAdmin <- case sheets of
|
||||
((_,firstSheet,_):_) ->
|
||||
((_,firstSheet,_):_) -> do
|
||||
setUltDestCurrent
|
||||
(Authorized ==) <$> isAuthorized (SheetEditR tid csh $ sheetName firstSheet) False
|
||||
_otherwise -> return False
|
||||
let colSheets = if showAdmin
|
||||
@ -252,8 +277,7 @@ getSheetEditR tid csh shn = do
|
||||
}
|
||||
let action newSheet = do
|
||||
replaceRes <- myReplaceUnique sid $ newSheet
|
||||
{ sheetCourseId = sheetCourseId
|
||||
, sheetCreated = sheetCreated
|
||||
{ sheetCreated = sheetCreated
|
||||
, sheetCreatedBy = sheetChangedBy }
|
||||
case replaceRes of
|
||||
Nothing -> return $ Just sid
|
||||
@ -286,7 +310,7 @@ handleSheetEdit tid csh template dbAction = do
|
||||
, sheetActiveTo = sfActiveTo
|
||||
, sheetHintFrom = sfHintFrom
|
||||
, sheetSolutionFrom = sfSolutionFrom
|
||||
, sheetCreated = actTime -- dbAction adjusts this for replacement
|
||||
, sheetCreated = actTime -- dbAction adjusts this for replacement, TODO: eigene Tabelle für changedBy
|
||||
, sheetChanged = actTime
|
||||
, sheetCreatedBy = aid -- dbAction adjusts this for replacement
|
||||
, sheetChangedBy = aid
|
||||
@ -317,21 +341,17 @@ handleSheetEdit tid csh template dbAction = do
|
||||
getSheetDelR :: TermId -> Text -> Text -> Handler Html
|
||||
getSheetDelR tid csh shn = do
|
||||
let tident = unTermKey tid
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete )
|
||||
((result,formWidget), formEnctype) <- runFormPost (buttonForm :: Form BtnDelete)
|
||||
case result of
|
||||
(FormSuccess BtnAbort) -> redirectBack
|
||||
(FormSuccess BtnAbort) -> redirectUltDest $ SheetShowR tid csh shn
|
||||
(FormSuccess BtnDelete) -> do
|
||||
runDB $ do
|
||||
-- (Entity cid _course) <- getBy404 $ CourseTermShort tid csh
|
||||
cid <- getKeyBy404 $ CourseTermShort tid csh
|
||||
sid <- getKeyBy404 $ CourseSheet cid shn
|
||||
-- deleteBy $ CourseSheet cid shn
|
||||
deleteCascade sid
|
||||
runDB $ fetchSheetId tid csh shn >>= deleteCascade
|
||||
-- TODO: deleteCascade löscht aber nicht die hochgeladenen Dateien!!!
|
||||
setMessageI $ MsgSheetDelOk tident csh shn
|
||||
redirect $ SheetListR tid csh
|
||||
_other -> do
|
||||
submissionno <- runDB $ do
|
||||
Entity { entityKey = sid } <- fetchSheet tid csh shn
|
||||
sid <- fetchSheetId tid csh shn
|
||||
count [SubmissionSheetId ==. sid]
|
||||
let formTitle = MsgSheetDelTitle tident csh shn
|
||||
let formText = Just $ MsgSheetDelText submissionno
|
||||
@ -343,6 +363,8 @@ getSheetDelR tid csh shn = do
|
||||
postSheetDelR :: TermId -> Text -> Text -> Handler Html
|
||||
postSheetDelR = getSheetDelR
|
||||
|
||||
|
||||
|
||||
insertSheetFile :: SheetId -> SheetFileType -> FileInfo -> YesodDB UniWorX ()
|
||||
insertSheetFile sid ftype finfo = do
|
||||
runConduit $ (sourceFiles finfo) =$= C.mapM_ finsert
|
||||
@ -351,12 +373,3 @@ insertSheetFile sid ftype finfo = do
|
||||
fid <- insert file
|
||||
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|
||||
|
||||
|
||||
-- TODO: Move below to utils, did not work somehow
|
||||
redirectBack :: Handler Html
|
||||
-- -- redirectBack :: HandlerT UniWorX IO Html
|
||||
redirectBack = defaultLayout $ do
|
||||
toWidget [julius| window.history.go(-2); |]
|
||||
[whamlet| BACK |] -- TODO
|
||||
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user