Hierarchical submission routes
This commit is contained in:
Gregor Kleen
parent
381f24797d
commit
c72b9ef385
15
routes
15
routes
@ -58,16 +58,19 @@
|
||||
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
/sub/new SubmissionNewR GET POST !timeANDregistered
|
||||
/sub/own SubmissionOwnR GET !free
|
||||
!/sub/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !owner !corrector
|
||||
!/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector
|
||||
!/sub/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/subs SSubsR GET POST
|
||||
/subs/new SubmissionNewR GET POST !timeANDregistered
|
||||
/subs/own SubmissionOwnR GET !free
|
||||
/sub/#CryptoFileNameSubmission SubmissionR !corrector:
|
||||
/ SubShowR GET POST !owner
|
||||
/archive SubArchiveR GET !owner
|
||||
/correction CorrectionR GET POST !ownerANDisRead
|
||||
!/#SubmissionFileType/*FilePath SubDownloadR GET !owner
|
||||
/correctors SCorrR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
|
||||
/corrections CorrectionsR GET POST !free
|
||||
/corrections/upload CorrectionsUploadR GET POST !free
|
||||
|
||||
|
||||
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
|
||||
|
||||
@ -126,6 +126,9 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils
|
||||
pattern CSheetR tid csh shn ptn
|
||||
= CourseR tid csh (SheetR shn ptn)
|
||||
|
||||
pattern CSubmissionR tid csh shn cid ptn
|
||||
= CSheetR tid csh shn (SubmissionR cid ptn)
|
||||
|
||||
-- Menus and Favourites
|
||||
data MenuItem = MenuItem
|
||||
{ menuItemLabel :: Text
|
||||
@ -174,9 +177,9 @@ instance RenderMessage UniWorX SheetFileType where
|
||||
|
||||
-- Access Control
|
||||
data AccessPredicate
|
||||
= APPure (Route UniWorX -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Route UniWorX -> Handler AuthResult)
|
||||
| APDB (Route UniWorX -> DB AuthResult)
|
||||
= APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
|
||||
| APHandler (Route UniWorX -> Bool -> Handler AuthResult)
|
||||
| APDB (Route UniWorX -> Bool -> DB AuthResult)
|
||||
|
||||
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
|
||||
orAR _ Authorized _ = Authorized
|
||||
@ -199,22 +202,22 @@ liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult)
|
||||
-> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
|
||||
-> AccessPredicate -> AccessPredicate -> AccessPredicate
|
||||
-- Ensure to first evaluate Pure conditions, then Handler before DB
|
||||
liftAR ops sc (APPure f) (APPure g) = APPure $ \r -> shortCircuitM sc (f r) (g r) . ops =<< ask
|
||||
liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer
|
||||
liftAR ops sc (APDB f) (APDB g) = APDB $ \r -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer
|
||||
liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r -> runReader (f r) <$> getMsgRenderer) apg
|
||||
liftAR ops sc (APPure f) (APPure g) = APPure $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< ask
|
||||
liftAR ops sc (APHandler f) (APHandler g) = APHandler $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
|
||||
liftAR ops sc (APDB f) (APDB g) = APDB $ \r w -> shortCircuitM sc (f r w) (g r w) . ops =<< getMsgRenderer
|
||||
liftAR ops sc (APPure f) apg = liftAR ops sc (APHandler $ \r w -> runReader (f r w) <$> getMsgRenderer) apg
|
||||
liftAR ops sc apf apg@(APPure _) = liftAR ops sc apg apf
|
||||
liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ lift . f) apdb
|
||||
liftAR ops sc (APHandler f) apdb = liftAR ops sc (APDB $ \r w -> lift $ f r w) apdb
|
||||
liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb
|
||||
|
||||
|
||||
trueAP,falseAP :: AccessPredicate
|
||||
trueAP = APPure . const $ return Authorized
|
||||
falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead
|
||||
trueAP = APPure . const . const $ return Authorized
|
||||
falseAP = APPure . const . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead
|
||||
|
||||
|
||||
adminAP :: AccessPredicate -- access for admins (of appropriate school in case of course-routes)
|
||||
adminAP = APDB $ \case
|
||||
adminAP = APDB $ \route _ -> case route of
|
||||
-- Courses: access only to school admins
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
@ -237,13 +240,13 @@ adminAP = APDB $ \case
|
||||
knownTags :: Map (CI Text) AccessPredicate
|
||||
knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
|
||||
[("free", trueAP)
|
||||
,("deprecated", APHandler $ \r -> do
|
||||
,("deprecated", APHandler $ \r _ -> do
|
||||
$logWarnS "AccessControl" ("deprecated route: " <> tshow r)
|
||||
addMessageI "error" MsgDeprecatedRoute
|
||||
allow <- appAllowDeprecated . appSettings <$> getYesod
|
||||
return $ bool (Unauthorized "Deprecated Route") Authorized allow
|
||||
)
|
||||
,("lecturer", APDB $ \case
|
||||
,("lecturer", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do
|
||||
@ -259,7 +262,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
|
||||
return Authorized
|
||||
)
|
||||
,("corrector", APDB $ \route -> exceptT return return $ do
|
||||
,("corrector", APDB $ \route _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId
|
||||
@ -270,7 +273,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
resMap :: Map CourseId (Set SheetId)
|
||||
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
|
||||
case route of
|
||||
CSheetR _ _ _ (SubmissionR cID) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||
CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
|
||||
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
Submission{..} <- MaybeT . lift $ get sid
|
||||
guard $ maybe False (== authId) submissionRatingBy
|
||||
@ -288,7 +291,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
|
||||
return Authorized
|
||||
)
|
||||
,("time", APDB $ \case
|
||||
,("time", APDB $ \route _ -> case route of
|
||||
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
|
||||
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
|
||||
@ -314,7 +317,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
$logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("registered", APDB $ \case
|
||||
,("registered", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> exceptT return return $ do
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do
|
||||
@ -329,7 +332,7 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
$logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("materials", APDB $ \case
|
||||
,("materials", APDB $ \route _ -> case route of
|
||||
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
|
||||
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
|
||||
guard courseMaterialFree
|
||||
@ -338,8 +341,8 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
$logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("owner", APDB $ \case
|
||||
CSheetR _ _ _ (SubmissionR cID) -> exceptT return return $ do
|
||||
,("owner", APDB $ \route _ -> case route of
|
||||
CSubmissionR _ _ _ cID _ -> exceptT return return $ do
|
||||
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
|
||||
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
|
||||
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid
|
||||
@ -349,24 +352,15 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
|
||||
$logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
|
||||
unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("isRead", APHandler $ \route ->
|
||||
bool <$> return Authorized
|
||||
<*> unauthorizedI MsgUnauthorizedWrite
|
||||
<*> isWriteRequest route
|
||||
)
|
||||
,("isWrite", APHandler $ \route -> do
|
||||
write <- isWriteRequest route
|
||||
if write
|
||||
then return Authorized
|
||||
else unauthorizedI MsgUnauthorized
|
||||
)
|
||||
,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
|
||||
,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
|
||||
]
|
||||
|
||||
|
||||
tag2ap :: Text -> AccessPredicate
|
||||
tag2ap t = case Map.lookup (CI.mk t) knownTags of
|
||||
(Just acp) -> acp
|
||||
Nothing -> APHandler $ \_route -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
|
||||
Nothing -> APHandler $ \_route _isWrite -> do -- Can this be pure like falseAP? GK: not if we want to log a message (which we definitely should)
|
||||
$logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
|
||||
unauthorizedI MsgUnauthorized
|
||||
|
||||
@ -376,17 +370,17 @@ route2ap r = foldr orAP adminAP attrsAND -- adminAP causes all to be in DB!!! GK
|
||||
attrsAND = map splitAND $ Set.toList $ routeAttrs r
|
||||
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
|
||||
|
||||
evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
|
||||
evalAccessDB r = case route2ap r of
|
||||
(APPure p) -> lift $ runReader (p r) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p r
|
||||
(APDB p) -> p r
|
||||
evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
|
||||
evalAccessDB r w = case route2ap r of
|
||||
(APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
|
||||
(APHandler p) -> lift $ p r w
|
||||
(APDB p) -> p r w
|
||||
|
||||
evalAccess :: Route UniWorX -> Handler AuthResult
|
||||
evalAccess r = case route2ap r of
|
||||
(APPure p) -> runReader (p r) <$> getMsgRenderer
|
||||
(APHandler p) -> p r
|
||||
(APDB p) -> runDB $ p r
|
||||
evalAccess :: Route UniWorX -> Bool -> Handler AuthResult
|
||||
evalAccess r w = case route2ap r of
|
||||
(APPure p) -> runReader (p r w) <$> getMsgRenderer
|
||||
(APHandler p) -> p r w
|
||||
(APDB p) -> runDB $ p r w
|
||||
|
||||
|
||||
|
||||
@ -534,7 +528,7 @@ instance Yesod UniWorX where
|
||||
-- The page to be redirected to when authentication is required.
|
||||
authRoute _ = Just $ AuthR LoginR
|
||||
|
||||
isAuthorized route _isWrite = evalAccess route
|
||||
isAuthorized = evalAccess
|
||||
|
||||
-- This function creates static content files in the static folder
|
||||
-- and names them based on a hash of their content. This allows
|
||||
@ -609,7 +603,7 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSubmissionR tid csh shn _ SubShowR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
-- Others
|
||||
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
|
||||
|
||||
@ -789,7 +783,7 @@ pageHeading (CSheetR tid csh shn SubmissionNewR)
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
|
||||
pageHeading (CSheetR tid csh shn SubmissionOwnR)
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
|
||||
pageHeading (CSheetR tid csh shn (SubmissionR _)) -- TODO: Rethink this one!
|
||||
pageHeading (CSubmissionR tid csh shn _ SubShowR) -- TODO: Rethink this one!
|
||||
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
|
||||
|
||||
-- TODO: add headings for more single course- and single term-pages
|
||||
@ -834,6 +828,18 @@ defaultLinks = -- Define the menu items of the header.
|
||||
, menuItemRoute = TermShowR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, NavbarAside $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, NavbarAside $ MenuItem
|
||||
{ menuItemLabel = "Korrekturen hochladen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CorrectionsUploadR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, NavbarAside $ MenuItem
|
||||
{ menuItemLabel = "Benutzer"
|
||||
, menuItemIcon = Just "users"
|
||||
|
||||
@ -33,7 +33,7 @@ import qualified Data.Map as Map
|
||||
-- import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
-- import Yesod.Colonnade
|
||||
--
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
@ -108,7 +108,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
csh = E.unValue $ course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
cid <- encrypt (entityKey submission :: SubmissionId)
|
||||
[whamlet|<a href=@{CSheetR tid csh shn (SubmissionR cid)}>#{display cid}|]
|
||||
[whamlet|<a href=@{CSubmissionR tid csh shn cid SubShowR}>#{display cid}|]
|
||||
|
||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId
|
||||
@ -340,3 +340,15 @@ postSSubsR tid csh shn = do
|
||||
, assignAction (Right shid)
|
||||
, autoAssignAction shid
|
||||
]
|
||||
|
||||
getCorrectionR, getCorrectionUserR, postCorrectionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
|
||||
getCorrectionR tid csh shn cid = do
|
||||
mayPost <- isAuthorized (CSubmissionR tid csh shn cid CorrectionR) True
|
||||
bool getCorrectionUserR postCorrectionR (mayPost == Authorized) tid csh shn cid
|
||||
postCorrectionR tid csh shn cid = undefined
|
||||
getCorrectionUserR tid csh shn cid = undefined
|
||||
|
||||
|
||||
getCorrectionsUploadR, postCorrectionsUploadR :: Handler Html
|
||||
getCorrectionsUploadR = postCorrectionsUploadR
|
||||
postCorrectionsUploadR = undefined
|
||||
|
||||
@ -43,7 +43,7 @@ instance CryptoRoute UUID SubmissionId where
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CSheetR tid csh shn $ SubmissionR cID'
|
||||
return $ CSubmissionR tid csh shn cID' SubShowR
|
||||
|
||||
instance CryptoRoute (CI FilePath) SubmissionId where
|
||||
cryptoIDRoute _ (CryptoID -> cID) = do
|
||||
@ -53,7 +53,7 @@ instance CryptoRoute (CI FilePath) SubmissionId where
|
||||
Sheet{..} <- get404 shid
|
||||
Course{..} <- get404 sheetCourse
|
||||
return (courseTerm, courseShorthand, sheetName)
|
||||
return $ CSheetR tid csh shn $ SubmissionR cID
|
||||
return $ CSubmissionR tid csh shn cID SubShowR
|
||||
|
||||
instance CryptoRoute UUID UserId where
|
||||
cryptoIDRoute _ (CryptoID -> cID) = do
|
||||
|
||||
@ -29,6 +29,7 @@ import Control.Monad.Trans.Maybe
|
||||
import Control.Monad.State.Class
|
||||
import Control.Monad.Trans.State.Strict (StateT)
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
import qualified Data.Maybe
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Text.Encoding as Text
|
||||
@ -53,6 +54,8 @@ import Colonnade hiding (bool)
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
import Text.Shakespeare.Text (st)
|
||||
|
||||
|
||||
numberOfSubmissionEditDates :: Int64
|
||||
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production.
|
||||
@ -80,9 +83,9 @@ getSubmissionNewR = postSubmissionNewR
|
||||
postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
|
||||
|
||||
|
||||
getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubmissionR = postSubmissionR
|
||||
postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
|
||||
getSubShowR, postSubShowR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
|
||||
getSubShowR = postSubShowR
|
||||
postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
|
||||
|
||||
getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html
|
||||
getSubmissionOwnR tid csh shn = do
|
||||
@ -98,7 +101,7 @@ getSubmissionOwnR tid csh shn = do
|
||||
((E.Value sid):_) -> return sid
|
||||
[] -> notFound
|
||||
cID <- encrypt sid
|
||||
redirect . CourseR tid csh . SheetR shn $ SubmissionR cID
|
||||
redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
|
||||
submissionHelper :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
|
||||
submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
@ -136,10 +139,11 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
(E.Value smid:_) -> do
|
||||
cID <- encrypt smid
|
||||
addMessageI "info" $ MsgSubmissionAlreadyExists
|
||||
redirect $ CSheetR tid csh shn $ SubmissionR cID
|
||||
redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
(Just smid) -> do
|
||||
submissionMatchesSheet tid csh shn (fromJust mcid)
|
||||
|
||||
shid' <- submissionSheet <$> get404 smid
|
||||
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
-- fetch buddies from current submission
|
||||
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
|
||||
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
|
||||
@ -227,11 +231,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
_other -> return Nothing
|
||||
|
||||
case mCID of
|
||||
Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID
|
||||
Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR
|
||||
Nothing -> return ()
|
||||
|
||||
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
|
||||
|
||||
let pageTitle = MsgSubmissionEditHead tid csh shn
|
||||
let formTitle = pageTitle
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
@ -240,9 +242,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
|
||||
colonnadeFiles cid = mconcat
|
||||
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ SubmissionDownloadSingleR cid fileTitle)
|
||||
(\(Entity _ File{..}) -> str2widget fileTitle)
|
||||
, sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ SubmissionFile{..}, Entity _ File{..}) -> CSubmissionR tid csh shn cid $ SubDownloadR (isUpdateSubmissionFileType submissionFileIsUpdate) fileTitle)
|
||||
(\(_, Entity _ File{..}) -> str2widget fileTitle)
|
||||
, sortable (Just "time") "Modifikation" $ \(_, Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
|
||||
]
|
||||
smid2ArchiveTable (smid,cid) = DBTable
|
||||
{ dbtSQLQuery = submissionFileQuery smid
|
||||
@ -264,10 +266,10 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
setTitleI pageTitle
|
||||
$(widgetFile "formPageI18n")
|
||||
[whamlet|
|
||||
$maybe arCid <- mArCid
|
||||
$maybe cid <- mcid
|
||||
<hr>
|
||||
<h2>
|
||||
<a href=@{CSheetR tid csh shn (SubmissionDownloadArchiveR arCid)}>Archiv
|
||||
<a href=@{CSubmissionR tid csh shn cid SubArchiveR}>Archiv
|
||||
$forall (name,time) <- lastEdits
|
||||
<div>last edited by #{name} at #{formatTimeGerDTlong time}
|
||||
$maybe fileTable <- mFileTable
|
||||
@ -276,14 +278,12 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
|]
|
||||
|
||||
|
||||
getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent
|
||||
getSubmissionDownloadSingleR tid csh shn cID path = do
|
||||
getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
submissionID <- decrypt cID
|
||||
|
||||
runDB $ do
|
||||
shid <- fetchSheetId tid csh shn
|
||||
Submission{..} <- get404 submissionID
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
submissionMatchesSheet tid csh shn cID
|
||||
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
case isRating of
|
||||
@ -291,13 +291,13 @@ getSubmissionDownloadSingleR tid csh shn cID path = do
|
||||
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
|
||||
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
|
||||
False -> do
|
||||
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
results <- E.select . E.from $ \(sf `E.InnerJoin` f) -> do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID)
|
||||
E.where_ (f E.^. FileTitle E.==. E.val path)
|
||||
E.where_ . E.not_ . E.isNothing $ f E.^. FileContent
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. f E.^. FileTitle E.==. E.val path
|
||||
E.&&. E.not_ (E.isNothing $ f E.^. FileContent)
|
||||
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||||
return f
|
||||
|
||||
let fileName = Text.pack $ takeFileName path
|
||||
@ -305,15 +305,14 @@ getSubmissionDownloadSingleR tid csh shn cID path = do
|
||||
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
|
||||
_ -> notFound
|
||||
|
||||
getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent
|
||||
getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do
|
||||
getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler TypedContent
|
||||
getSubArchiveR tid csh shn cID@CryptoID{..} = do
|
||||
submissionID <- decrypt cID
|
||||
cUUID <- encrypt submissionID
|
||||
|
||||
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}.zip"|]
|
||||
|
||||
respondSourceDB "application/zip" $ do
|
||||
lift $ do
|
||||
shid <- fetchSheetId tid csh shn
|
||||
Submission{..} <- get404 submissionID
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
lift $ submissionMatchesSheet tid csh shn cID
|
||||
|
||||
rating <- lift $ getRating submissionID
|
||||
case rating of
|
||||
@ -321,5 +320,5 @@ getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do
|
||||
Just rating' -> do
|
||||
let fileEntitySource' :: Source (YesodDB UniWorX) File
|
||||
fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
|
||||
info = ZipInfo { zipComment = Text.encodeUtf8 . pack . CI.foldedCase $ ciphertext (cUUID :: CryptoFileNameSubmission) }
|
||||
info = ZipInfo { zipComment = Text.encodeUtf8 . pack $ CI.foldedCase ciphertext }
|
||||
fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
|
||||
|
||||
@ -19,6 +19,7 @@ module Handler.Utils.Submission
|
||||
, submissionMultiArchive
|
||||
, SubmissionSinkException(..)
|
||||
, sinkSubmission
|
||||
, submissionMatchesSheet
|
||||
) where
|
||||
|
||||
import Import hiding ((.=), joinPath)
|
||||
@ -46,6 +47,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
import Handler.Utils.Rating
|
||||
import Handler.Utils.Zip
|
||||
import Handler.Utils.Sheet
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
@ -119,16 +121,16 @@ assignSubmissions sid restriction = do
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
||||
submissionFileSource = E.selectSource . E.from . submissionFileQuery
|
||||
submissionFileSource = E.selectSource . fmap snd . E.from . submissionFileQuery
|
||||
|
||||
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity File))
|
||||
-> E.SqlQuery (E.SqlExpr (Entity SubmissionFile), E.SqlExpr (Entity File))
|
||||
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
return f
|
||||
return (sf, f)
|
||||
|
||||
submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
|
||||
submissionMultiArchive (Set.toList -> ids) = do
|
||||
@ -378,6 +380,8 @@ sinkMultiSubmission :: UserId
|
||||
-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
|
||||
--
|
||||
-- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
|
||||
--
|
||||
-- In contrast to `sinkSubmission` this function does authorization-checks against `CorrectionR` -- TODO
|
||||
sinkMultiSubmission userId isUpdate = do
|
||||
let
|
||||
feed :: SubmissionId
|
||||
@ -410,3 +414,10 @@ sinkMultiSubmission userId isUpdate = do
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
|
||||
lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' }
|
||||
fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks
|
||||
|
||||
submissionMatchesSheet :: TermId -> Text -> Text -> CryptoFileNameSubmission -> DB ()
|
||||
submissionMatchesSheet tid csh shn cid = do
|
||||
sid <- decrypt cid
|
||||
shid <- fetchSheetId tid csh shn
|
||||
Submission{..} <- get404 sid
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
|
||||
@ -73,6 +73,9 @@ data SheetGroup
|
||||
deriveJSON defaultOptions ''SheetGroup
|
||||
derivePersistFieldJSON "SheetGroup"
|
||||
|
||||
enumFromPathPiece :: (PathPiece a, Enum a, Bounded a) => Text -> Maybe a
|
||||
enumFromPathPiece t = lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
|
||||
|
||||
data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
derivePersistField "SheetFileType"
|
||||
@ -82,8 +85,7 @@ instance PathPiece SheetFileType where
|
||||
toPathPiece SheetHint = "hint"
|
||||
toPathPiece SheetSolution = "solution"
|
||||
toPathPiece SheetMarking = "marking"
|
||||
fromPathPiece t =
|
||||
lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
|
||||
fromPathPiece = enumFromPathPiece
|
||||
|
||||
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
|
||||
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation
|
||||
@ -92,6 +94,26 @@ instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instan
|
||||
display SheetSolution = "Musterlösung"
|
||||
display SheetMarking = "Korrekturhinweise"
|
||||
|
||||
data SubmissionFileType = SubmissionOriginal | SubmissionCorrected
|
||||
deriving (Show, Read, Eq, Ord, Enum, Bounded)
|
||||
|
||||
submissionFileTypeIsUpdate :: SubmissionFileType -> Bool
|
||||
submissionFileTypeIsUpdate SubmissionOriginal = False
|
||||
submissionFileTypeIsUpdate SubmissionCorrected = True
|
||||
|
||||
isUpdateSubmissionFileType :: Bool -> SubmissionFileType
|
||||
isUpdateSubmissionFileType False = SubmissionOriginal
|
||||
isUpdateSubmissionFileType True = SubmissionCorrected
|
||||
|
||||
instance PathPiece SubmissionFileType where
|
||||
toPathPiece SubmissionOriginal = "file"
|
||||
toPathPiece SubmissionCorrected = "corrected"
|
||||
fromPathPiece = enumFromPathPiece
|
||||
|
||||
instance DisplayAble SubmissionFileType where
|
||||
display SubmissionOriginal = "Abgabe"
|
||||
display SubmissionCorrected = "Korrektur"
|
||||
|
||||
{-
|
||||
data DA = forall a . (DisplayAble a) => DA a
|
||||
|
||||
|
||||
Loading…
Reference in New Issue
Block a user