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

Hierarchical submission routes

Browse Source
This commit is contained in:
Gregor Kleen 2018-07-01 00:23:38 +02:00
parent 381f24797d
commit c72b9ef385
7 changed files with 146 additions and 93 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

15
routes
View File

@ -58,16 +58,19 @@
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector /show SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST /edit SEditR GET POST
/delete SDelR 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 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 !/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
/corrections CorrectionsR GET POST !free /corrections CorrectionsR GET POST !free
/corrections/upload CorrectionsUploadR GET POST !free
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect !/#UUID CryptoUUIDDispatchR GET !free -- just redirect

96
src/Foundation.hs
View File

@ -126,6 +126,9 @@ type MsgRenderer = MsgRendererS UniWorX -- see Utils
pattern CSheetR tid csh shn ptn pattern CSheetR tid csh shn ptn
= CourseR tid csh (SheetR 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 -- Menus and Favourites
data MenuItem = MenuItem data MenuItem = MenuItem
{ menuItemLabel :: Text { menuItemLabel :: Text
@ -174,9 +177,9 @@ instance RenderMessage UniWorX SheetFileType where
-- Access Control -- Access Control
data AccessPredicate data AccessPredicate
= APPure (Route UniWorX -> Reader MsgRenderer AuthResult) = APPure (Route UniWorX -> Bool -> Reader MsgRenderer AuthResult)
| APHandler (Route UniWorX -> Handler AuthResult) | APHandler (Route UniWorX -> Bool -> Handler AuthResult)
| APDB (Route UniWorX -> DB AuthResult) | APDB (Route UniWorX -> Bool -> DB AuthResult)
orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult orAR, andAR :: MsgRenderer -> AuthResult -> AuthResult -> AuthResult
orAR _ Authorized _ = Authorized orAR _ Authorized _ = Authorized
@ -199,22 +202,22 @@ liftAR :: (MsgRenderer -> AuthResult -> AuthResult -> AuthResult)
-> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument -> (AuthResult -> Bool) -- ^ Predicate to Short-Circuit on first argument
-> AccessPredicate -> AccessPredicate -> AccessPredicate -> AccessPredicate -> AccessPredicate -> AccessPredicate
-- Ensure to first evaluate Pure conditions, then Handler before DB -- 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 (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 -> shortCircuitM sc (f r) (g r) . ops =<< getMsgRenderer 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 -> shortCircuitM sc (f r) (g r) . 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 -> runReader (f r) <$> getMsgRenderer) apg 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 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 liftAR ops sc apdb apg@(APHandler _) = liftAR ops sc apg apdb
trueAP,falseAP :: AccessPredicate trueAP,falseAP :: AccessPredicate
trueAP = APPure . const $ return Authorized trueAP = APPure . const . const $ return Authorized
falseAP = APPure . const $ Unauthorized . ($ MsgUnauthorized) . render <$> ask -- always use adminAP instead 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 :: 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 -- Courses: access only to school admins
CourseR tid csh _ -> exceptT return return $ do CourseR tid csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
@ -237,13 +240,13 @@ adminAP = APDB $ \case
knownTags :: Map (CI Text) AccessPredicate knownTags :: Map (CI Text) AccessPredicate
knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or requireAuthId
[("free", trueAP) [("free", trueAP)
,("deprecated", APHandler $ \r -> do ,("deprecated", APHandler $ \r _ -> do
$logWarnS "AccessControl" ("deprecated route: " <> tshow r) $logWarnS "AccessControl" ("deprecated route: " <> tshow r)
addMessageI "error" MsgDeprecatedRoute addMessageI "error" MsgDeprecatedRoute
allow <- appAllowDeprecated . appSettings <$> getYesod allow <- appAllowDeprecated . appSettings <$> getYesod
return $ bool (Unauthorized "Deprecated Route") Authorized allow return $ bool (Unauthorized "Deprecated Route") Authorized allow
) )
,("lecturer", APDB $ \case ,("lecturer", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` lecturer) -> do [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] [] void . maybeMExceptT (unauthorizedI MsgUnauthorizedSchoolLecturer) $ selectFirst [UserLecturerUser ==. authId] []
return Authorized return Authorized
) )
,("corrector", APDB $ \route -> exceptT return return $ do ,("corrector", APDB $ \route _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do resList <- lift . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector) -> do
E.on $ sheetCorrector E.^. SheetCorrectorSheet E.==. sheet E.^. SheetId 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 CourseId (Set SheetId)
resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ] resMap = Map.fromListWith Set.union [ (cid, Set.singleton sid) | (E.Value cid, E.Value sid) <- resList ]
case route of case route of
CSheetR _ _ _ (SubmissionR cID) -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do CSubmissionR _ _ _ cID _ -> maybeT (unauthorizedI MsgUnauthorizedSubmissionCorrector) $ do
sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMaybeT (const True :: CryptoIDError -> Bool) $ decrypt cID
Submission{..} <- MaybeT . lift $ get sid Submission{..} <- MaybeT . lift $ get sid
guard $ maybe False (== authId) submissionRatingBy 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) guardMExceptT (not $ Map.null resMap) (unauthorizedI MsgUnauthorizedCorrectorAny)
return Authorized return Authorized
) )
,("time", APDB $ \case ,("time", APDB $ \route _ -> case route of
CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn 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 $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized unauthorizedI MsgUnauthorized
) )
,("registered", APDB $ \case ,("registered", APDB $ \route _ -> case route of
CourseR tid csh _ -> exceptT return return $ do CourseR tid csh _ -> exceptT return return $ do
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
[E.Value c] <- lift . E.select . E.from $ \(course `E.InnerJoin` courseParticipant) -> do [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 $logErrorS "AccessControl" $ "'!registered' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized unauthorizedI MsgUnauthorized
) )
,("materials", APDB $ \case ,("materials", APDB $ \route _ -> case route of
CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do CourseR tid csh _ -> maybeT (unauthorizedI MsgUnfreeMaterials) $ do
Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh Entity _ Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
guard courseMaterialFree 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 $logErrorS "AccessControl" $ "'!materials' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized unauthorizedI MsgUnauthorized
) )
,("owner", APDB $ \case ,("owner", APDB $ \route _ -> case route of
CSheetR _ _ _ (SubmissionR cID) -> exceptT return return $ do CSubmissionR _ _ _ cID _ -> exceptT return return $ do
sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID sid <- catchIfMExceptT (const $ unauthorizedI MsgUnauthorizedSubmissionOwner) (const True :: CryptoIDError -> Bool) $ decrypt cID
authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId authId <- maybeExceptT AuthenticationRequired $ lift maybeAuthId
void . maybeMExceptT (unauthorizedI MsgUnauthorizedSubmissionOwner) . getBy $ UniqueSubmissionUser authId sid 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 $logErrorS "AccessControl" $ "'!owner' used on route that doesn't support it: " <> tshow r
unauthorizedI MsgUnauthorized unauthorizedI MsgUnauthorized
) )
,("isRead", APHandler $ \route -> ,("isRead", APHandler . const $ bool (return Authorized) (unauthorizedI MsgUnauthorizedWrite))
bool <$> return Authorized ,("isWrite", APHandler . const $ bool (unauthorizedI MsgUnauthorized) (return Authorized))
<*> unauthorizedI MsgUnauthorizedWrite
<*> isWriteRequest route
)
,("isWrite", APHandler $ \route -> do
write <- isWriteRequest route
if write
then return Authorized
else unauthorizedI MsgUnauthorized
)
] ]
tag2ap :: Text -> AccessPredicate tag2ap :: Text -> AccessPredicate
tag2ap t = case Map.lookup (CI.mk t) knownTags of tag2ap t = case Map.lookup (CI.mk t) knownTags of
(Just acp) -> acp (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" $logWarnS "AccessControl" $ "'" <> t <> "' not known to access control"
unauthorizedI MsgUnauthorized 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 attrsAND = map splitAND $ Set.toList $ routeAttrs r
splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND" splitAND = foldr1 andAP . map tag2ap . Text.splitOn "AND"
evalAccessDB :: Route UniWorX -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise evalAccessDB :: Route UniWorX -> Bool -> DB AuthResult -- all requests, regardless of POST/GET, use isWriteRequest otherwise
evalAccessDB r = case route2ap r of evalAccessDB r w = case route2ap r of
(APPure p) -> lift $ runReader (p r) <$> getMsgRenderer (APPure p) -> lift $ runReader (p r w) <$> getMsgRenderer
(APHandler p) -> lift $ p r (APHandler p) -> lift $ p r w
(APDB p) -> p r (APDB p) -> p r w
evalAccess :: Route UniWorX -> Handler AuthResult evalAccess :: Route UniWorX -> Bool -> Handler AuthResult
evalAccess r = case route2ap r of evalAccess r w = case route2ap r of
(APPure p) -> runReader (p r) <$> getMsgRenderer (APPure p) -> runReader (p r w) <$> getMsgRenderer
(APHandler p) -> p r (APHandler p) -> p r w
(APDB p) -> runDB $ p r (APDB p) -> runDB $ p r w
@ -534,7 +528,7 @@ instance Yesod UniWorX where
-- The page to be redirected to when authentication is required. -- The page to be redirected to when authentication is required.
authRoute _ = Just $ AuthR LoginR authRoute _ = Just $ AuthR LoginR
isAuthorized route _isWrite = evalAccess route isAuthorized = evalAccess
-- This function creates static content files in the static folder -- This function creates static content files in the static folder
-- and names them based on a hash of their content. This allows -- 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 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 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 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 -- Others
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all 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 = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
pageHeading (CSheetR tid csh shn SubmissionOwnR) pageHeading (CSheetR tid csh shn SubmissionOwnR)
= Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn = 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 = Just $ i18nHeading $ MsgSubmissionEditHead tid csh shn
-- TODO: add headings for more single course- and single term-pages -- 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 , menuItemRoute = TermShowR
, menuItemAccessCallback' = return True , 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 , NavbarAside $ MenuItem
{ menuItemLabel = "Benutzer" { menuItemLabel = "Benutzer"
, menuItemIcon = Just "users" , menuItemIcon = Just "users"

16
src/Handler/Corrections.hs
View File

@ -33,7 +33,7 @@ import qualified Data.Map as Map
-- import qualified Data.Text as T -- import qualified Data.Text as T
-- import Data.Function ((&)) -- import Data.Function ((&))
-- --
import Colonnade hiding (fromMaybe, singleton) import Colonnade hiding (fromMaybe, singleton, bool)
-- import Yesod.Colonnade -- import Yesod.Colonnade
-- --
-- import qualified Data.UUID.Cryptographic as UUID -- import qualified Data.UUID.Cryptographic as UUID
@ -108,7 +108,7 @@ colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
csh = E.unValue $ course ^. _2 csh = E.unValue $ course ^. _2
shn = sheetName $ entityVal sheet shn = sheetName $ entityVal sheet
cid <- encrypt (entityKey submission :: SubmissionId) 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 :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId
@ -340,3 +340,15 @@ postSSubsR tid csh shn = do
, assignAction (Right shid) , assignAction (Right shid)
, autoAssignAction 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

4
src/Handler/CryptoIDDispatch.hs
View File

@ -43,7 +43,7 @@ instance CryptoRoute UUID SubmissionId where
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) return (courseTerm, courseShorthand, sheetName)
return $ CSheetR tid csh shn $ SubmissionR cID' return $ CSubmissionR tid csh shn cID' SubShowR
instance CryptoRoute (CI FilePath) SubmissionId where instance CryptoRoute (CI FilePath) SubmissionId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ (CryptoID -> cID) = do
@ -53,7 +53,7 @@ instance CryptoRoute (CI FilePath) SubmissionId where
Sheet{..} <- get404 shid Sheet{..} <- get404 shid
Course{..} <- get404 sheetCourse Course{..} <- get404 sheetCourse
return (courseTerm, courseShorthand, sheetName) return (courseTerm, courseShorthand, sheetName)
return $ CSheetR tid csh shn $ SubmissionR cID return $ CSubmissionR tid csh shn cID SubShowR
instance CryptoRoute UUID UserId where instance CryptoRoute UUID UserId where
cryptoIDRoute _ (CryptoID -> cID) = do cryptoIDRoute _ (CryptoID -> cID) = do

65
src/Handler/Submission.hs
View File

@ -29,6 +29,7 @@ import Control.Monad.Trans.Maybe
import Control.Monad.State.Class import Control.Monad.State.Class
import Control.Monad.Trans.State.Strict (StateT) import Control.Monad.Trans.State.Strict (StateT)
import Data.Maybe (fromJust)
import qualified Data.Maybe import qualified Data.Maybe
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding 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 Yesod.Colonnade as Yesod
import qualified Text.Blaze.Html5.Attributes as HA import qualified Text.Blaze.Html5.Attributes as HA
import Text.Shakespeare.Text (st)
numberOfSubmissionEditDates :: Int64 numberOfSubmissionEditDates :: Int64
numberOfSubmissionEditDates = 3 -- for debugging only, should be 1 in production. 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 postSubmissionNewR tid csh shn = submissionHelper tid csh shn NewSubmission
getSubmissionR, postSubmissionR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html getSubShowR, postSubShowR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler Html
getSubmissionR = postSubmissionR getSubShowR = postSubShowR
postSubmissionR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid postSubShowR tid csh shn cid = submissionHelper tid csh shn $ ExistingSubmission cid
getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html getSubmissionOwnR :: TermId -> Text -> Text -> Handler Html
getSubmissionOwnR tid csh shn = do getSubmissionOwnR tid csh shn = do
@ -98,7 +101,7 @@ getSubmissionOwnR tid csh shn = do
((E.Value sid):_) -> return sid ((E.Value sid):_) -> return sid
[] -> notFound [] -> notFound
cID <- encrypt sid 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 :: TermId -> Text -> Text -> SubmissionMode -> Handler Html
submissionHelper tid csh shn (SubmissionMode mcid) = do submissionHelper tid csh shn (SubmissionMode mcid) = do
@ -136,10 +139,11 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
redirect $ CSheetR tid csh shn $ SubmissionR cID redirect $ CSubmissionR tid csh shn cID SubShowR
(Just smid) -> do (Just smid) -> do
submissionMatchesSheet tid csh shn (fromJust mcid)
shid' <- submissionSheet <$> get404 smid shid' <- submissionSheet <$> get404 smid
when (shid /= shid') $ invalidArgsI [MsgSubmissionWrongSheet]
-- fetch buddies from current submission -- fetch buddies from current submission
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
@ -227,11 +231,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
_other -> return Nothing _other -> return Nothing
case mCID of case mCID of
Just cID -> redirect $ CSheetR tid csh shn $ SubmissionR cID Just cID -> redirect $ CSubmissionR tid csh shn cID SubShowR
Nothing -> return () Nothing -> return ()
mArCid <- fmap ZIPArchiveName <$> traverse encrypt msmid
let pageTitle = MsgSubmissionEditHead tid csh shn let pageTitle = MsgSubmissionEditHead tid csh shn
let formTitle = pageTitle let formTitle = pageTitle
let formText = Nothing :: Maybe UniWorXMessage let formText = Nothing :: Maybe UniWorXMessage
@ -240,9 +242,9 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ()) let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
colonnadeFiles cid = mconcat colonnadeFiles cid = mconcat
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype -- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ SubmissionDownloadSingleR cid fileTitle) [ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ SubmissionFile{..}, Entity _ File{..}) -> CSubmissionR tid csh shn cid $ SubDownloadR (isUpdateSubmissionFileType submissionFileIsUpdate) fileTitle)
(\(Entity _ File{..}) -> str2widget fileTitle) (\(_, Entity _ File{..}) -> str2widget fileTitle)
, sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified , sortable (Just "time") "Modifikation" $ \(_, Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
] ]
smid2ArchiveTable (smid,cid) = DBTable smid2ArchiveTable (smid,cid) = DBTable
{ dbtSQLQuery = submissionFileQuery smid { dbtSQLQuery = submissionFileQuery smid
@ -264,10 +266,10 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
setTitleI pageTitle setTitleI pageTitle
$(widgetFile "formPageI18n") $(widgetFile "formPageI18n")
[whamlet| [whamlet|
$maybe arCid <- mArCid $maybe cid <- mcid
<hr> <hr>
<h2> <h2>
<a href=@{CSheetR tid csh shn (SubmissionDownloadArchiveR arCid)}>Archiv <a href=@{CSubmissionR tid csh shn cid SubArchiveR}>Archiv
$forall (name,time) <- lastEdits $forall (name,time) <- lastEdits
<div>last edited by #{name} at #{formatTimeGerDTlong time} <div>last edited by #{name} at #{formatTimeGerDTlong time}
$maybe fileTable <- mFileTable $maybe fileTable <- mFileTable
@ -276,14 +278,12 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|] |]
getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent getSubDownloadR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
getSubmissionDownloadSingleR tid csh shn cID path = do getSubDownloadR tid csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
submissionID <- decrypt cID submissionID <- decrypt cID
runDB $ do runDB $ do
shid <- fetchSheetId tid csh shn submissionMatchesSheet tid csh shn cID
Submission{..} <- get404 submissionID
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
isRating <- maybe False (== submissionID) <$> isRatingFile path isRating <- maybe False (== submissionID) <$> isRatingFile path
case isRating of case isRating of
@ -291,13 +291,13 @@ getSubmissionDownloadSingleR tid csh shn cID path = do
file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID) file <- runMaybeT $ lift . ratingFile cID =<< MaybeT (getRating submissionID)
maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file maybe notFound (return . toTypedContent . Text.decodeUtf8) $ fileContent =<< file
False -> do 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.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionID) E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
E.where_ (f E.^. FileTitle E.==. E.val path) E.&&. f E.^. FileTitle E.==. E.val path
E.where_ . E.not_ . E.isNothing $ f E.^. FileContent E.&&. E.not_ (E.isNothing $ f E.^. FileContent)
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
return f return f
let fileName = Text.pack $ takeFileName path 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) [Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
_ -> notFound _ -> notFound
getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent getSubArchiveR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> Handler TypedContent
getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do getSubArchiveR tid csh shn cID@CryptoID{..} = do
submissionID <- decrypt cID submissionID <- decrypt cID
cUUID <- encrypt submissionID
addHeader "Content-Disposition" [st|attachment; filename="#{toPathPiece cID}.zip"|]
respondSourceDB "application/zip" $ do respondSourceDB "application/zip" $ do
lift $ do lift $ submissionMatchesSheet tid csh shn cID
shid <- fetchSheetId tid csh shn
Submission{..} <- get404 submissionID
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
rating <- lift $ getRating submissionID rating <- lift $ getRating submissionID
case rating of case rating of
@ -321,5 +320,5 @@ getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do
Just rating' -> do Just rating' -> do
let fileEntitySource' :: Source (YesodDB UniWorX) File let fileEntitySource' :: Source (YesodDB UniWorX) File
fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating') 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 fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder

17
src/Handler/Utils/Submission.hs
View File

@ -19,6 +19,7 @@ module Handler.Utils.Submission
, submissionMultiArchive , submissionMultiArchive
, SubmissionSinkException(..) , SubmissionSinkException(..)
, sinkSubmission , sinkSubmission
, submissionMatchesSheet
) where ) where
import Import hiding ((.=), joinPath) import Import hiding ((.=), joinPath)
@ -46,6 +47,7 @@ import Generics.Deriving.Monoid (memptydefault, mappenddefault)
import Handler.Utils.Rating import Handler.Utils.Rating
import Handler.Utils.Zip import Handler.Utils.Zip
import Handler.Utils.Sheet
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
@ -119,16 +121,16 @@ assignSubmissions sid restriction = do
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File) 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) 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 submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile) E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID 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.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 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 SubmissionId -> Handler TypedContent
submissionMultiArchive (Set.toList -> ids) = do 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'. -- ^ 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). -- 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 sinkMultiSubmission userId isUpdate = do
let let
feed :: SubmissionId feed :: SubmissionId
@ -410,3 +414,10 @@ sinkMultiSubmission userId isUpdate = do
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle (msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' } lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' }
fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks 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]

26
src/Model/Types.hs
View File

@ -73,6 +73,9 @@ data SheetGroup
deriveJSON defaultOptions ''SheetGroup deriveJSON defaultOptions ''SheetGroup
derivePersistFieldJSON "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 data SheetFileType = SheetExercise | SheetHint | SheetSolution | SheetMarking
deriving (Show, Read, Eq, Ord, Enum, Bounded) deriving (Show, Read, Eq, Ord, Enum, Bounded)
derivePersistField "SheetFileType" derivePersistField "SheetFileType"
@ -82,8 +85,7 @@ instance PathPiece SheetFileType where
toPathPiece SheetHint = "hint" toPathPiece SheetHint = "hint"
toPathPiece SheetSolution = "solution" toPathPiece SheetSolution = "solution"
toPathPiece SheetMarking = "marking" toPathPiece SheetMarking = "marking"
fromPathPiece t = fromPathPiece = enumFromPathPiece
lookup (CI.mk t) [(CI.mk $ toPathPiece ty,ty) | ty <- [minBound..maxBound]]
-- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType) -- $(deriveSimpleWith ''DisplayAble 'display (drop 17) ''SheetFileType)
instance DisplayAble SheetFileType where -- deprecated, see RenderMessage instance in Foundation 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 SheetSolution = "Musterlösung"
display SheetMarking = "Korrekturhinweise" 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 data DA = forall a . (DisplayAble a) => DA a