feat: allow separating user generated content into separate domain
This commit is contained in:
Gregor Kleen
parent
b36ddce3e3
commit
707b41d4ec
@ -249,3 +249,5 @@ token-buckets:
|
||||
initial-value: 0
|
||||
|
||||
fallback-personalised-sheet-files-keys-expire: 2419200
|
||||
|
||||
download-token-expire: 14400
|
||||
|
||||
@ -367,5 +367,5 @@ sheetZipURI :: ReaderT SimulationContext IO URI
|
||||
sheetZipURI = do
|
||||
LoadOptions{..} <- asks loadOptions
|
||||
let zipURI = nullURI { uriPath = unpack . Text.intercalate "/" $ "." : zipPath }
|
||||
where (zipPath, _) = renderRoute . CSheetR loadTerm loadSchool loadCourse loadSheet $ SZipR SheetExercise
|
||||
where (zipPath, _) = renderRoute . CSheetR loadTerm loadSchool loadCourse loadSheet $ SZipR SheetExercise -- FIXME: Broken with ApprootUserGenerated
|
||||
return $ zipURI `relativeTo` loadBaseURI
|
||||
|
||||
@ -466,6 +466,7 @@ UnauthorizedTokenInvalidNoAuthority: Ihr Authorisierungs-Token nennt keine Nutze
|
||||
UnauthorizedTokenInvalidAuthority: Ihr Authorisierungs-Token basiert auf den Rechten eines Nutzers, der nicht mehr existiert.
|
||||
UnauthorizedTokenInvalidAuthorityGroup: Ihr Authorisierungs-Token basiert auf den Rechten einer Gruppe von Nutzern, die nicht mehr existiert.
|
||||
UnauthorizedTokenInvalidAuthorityValue: Ihr Authorisierungs-Token basiert auf Rechten, deren Spezifikation nicht interpretiert werden konnte.
|
||||
UnauthorizedTokenInvalidImpersonation: Ihr Authorisierungs-Token enthält die Anweisung sich als ein Nutzer auszugeben, dies ist jedoch nicht allen Benutzern, auf deren Rechten ihr Authorisierungs-Token basiert, erlaubt.
|
||||
UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
|
||||
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
|
||||
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.
|
||||
|
||||
@ -463,6 +463,7 @@ UnauthorizedTokenInvalidNoAuthority: Your authorisation-token does not list any
|
||||
UnauthorizedTokenInvalidAuthority: Your authorisation-token is based in an user's rights who does not exist anymore.
|
||||
UnauthorizedTokenInvalidAuthorityGroup: Your authorisation-token is based in an user groups rights which does not exist anymore.
|
||||
UnauthorizedTokenInvalidAuthorityValue: The specification of the rights in which your authorisation-token is based, could not be interpreted.
|
||||
UnauthorizedTokenInvalidImpersonation: Your authorisation-token contains an instruction to impersonate an user. Not all users on whose rights your token is based however are permitted to do so.
|
||||
UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
|
||||
UnauthorizedSiteAdmin: You are no system-wide administrator.
|
||||
UnauthorizedSchoolAdmin: You are no administrator for this department.
|
||||
|
||||
@ -22,8 +22,11 @@ instance (Eq a, Hashable a, Finite a, ToJSON b, ToJSONKey a) => ToJSON (a -> b)
|
||||
toJSON f = toJSON $ HashMap.fromList [(k, f k) | k <- universeF]
|
||||
|
||||
instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where
|
||||
parseJSON val = do
|
||||
vMap <- parseJSON val :: Parser (HashMap a b)
|
||||
unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
|
||||
fail "Not all required keys found"
|
||||
return (vMap !)
|
||||
parseJSON val = asObject <|> asConst
|
||||
where
|
||||
asObject = do
|
||||
vMap <- parseJSON val :: Parser (HashMap a b)
|
||||
unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
|
||||
fail "Not all required keys found"
|
||||
return (vMap !)
|
||||
asConst = const <$> parseJSON val
|
||||
|
||||
@ -17,6 +17,7 @@ module Foundation.Authorization
|
||||
, evalWorkflowRoleFor, evalWorkflowRoleFor'
|
||||
, hasWorkflowRole
|
||||
, mayViewWorkflowAction
|
||||
, authoritiveApproot
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (Last(..))
|
||||
@ -218,15 +219,32 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
|
||||
where
|
||||
validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult
|
||||
validateBearer' mAuthId route isWrite BearerToken{..} = lift . exceptT return return $ do
|
||||
guardMExceptT (maybe True (HashSet.member route) bearerRoutes) (unauthorizedI MsgUnauthorizedTokenInvalidRoute)
|
||||
iforM_ bearerRoutes $ \case
|
||||
BearerTokenRouteEval -> \routes -> guardMExceptT (HashSet.member route routes) $ unauthorizedI MsgUnauthorizedTokenInvalidRoute
|
||||
BearerTokenRouteAccess -> \routes -> maybeTMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidRoute) $ do
|
||||
cRoute <- MaybeT getCurrentRoute
|
||||
guard $ HashSet.member cRoute routes
|
||||
|
||||
bearerAuthority' <- flip foldMapM bearerAuthority $ \case
|
||||
Left tVal
|
||||
| JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do
|
||||
Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active
|
||||
return $ Set.singleton userGroupMemberUser
|
||||
| JSON.Success groupName <- JSON.fromJSON tVal -> do
|
||||
Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active
|
||||
case bearerImpersonate of
|
||||
Nothing -> return . Set.singleton $ userGroupMemberUser primary
|
||||
Just iuid | iuid == userGroupMemberUser primary -> return . Set.singleton $ userGroupMemberUser primary
|
||||
| otherwise -> do
|
||||
unlessM (lift $ exists [UserGroupMemberUser ==. iuid, UserGroupMemberGroup ==. groupName]) $
|
||||
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
|
||||
return $ Set.singleton iuid
|
||||
| otherwise -> throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityValue
|
||||
Right uid -> return $ Set.singleton uid
|
||||
Right uid -> case bearerImpersonate of
|
||||
Just iuid | uid == iuid -> return $ Set.singleton uid
|
||||
| otherwise -> do
|
||||
cID <- encrypt iuid
|
||||
unlessM (is _Authorized <$> evalAccessWithFor [(AuthToken, False)] (Just uid) (AdminHijackUserR cID) True) $
|
||||
throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidImpersonation
|
||||
return $ Set.singleton iuid
|
||||
Nothing -> return $ Set.singleton uid
|
||||
|
||||
let
|
||||
-- Prevent infinite loops
|
||||
@ -269,7 +287,7 @@ requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
|
||||
=> m (BearerToken UniWorX)
|
||||
requireBearerToken = liftHandler $ do
|
||||
bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe
|
||||
mAuthId <- maybeAuthId
|
||||
mAuthId <- defaultMaybeAuthId -- `maybeAuthId` would be an infinite loop; this is equivalent to `maybeAuthId` but ignoring `bearerImpersonate` from any valid token
|
||||
currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
|
||||
isWrite <- isWriteRequest currentRoute
|
||||
guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer
|
||||
@ -1726,3 +1744,19 @@ mayViewWorkflowAction mAuthId wwId WorkflowAction{..} = withReaderT (projectBack
|
||||
lift $ anyM wpvViewers evalWorkflowRole'
|
||||
]
|
||||
return True
|
||||
|
||||
authoritiveApproot :: Route UniWorX -> ApprootScope
|
||||
authoritiveApproot = \case
|
||||
CourseR _ _ _ (MaterialR _ (MFileR _)) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (MaterialR _ MArchiveR) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (SheetR _ (SFileR _ _)) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (SheetR _ (SZipR _)) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (SheetR _ (SubmissionR _ (SubDownloadR _ _))) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (SheetR _ (SubmissionR _ (SubArchiveR _))) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (CourseNewsR _ (CNFileR _)) -> ApprootUserGenerated
|
||||
CourseR _ _ _ (CourseNewsR _ CNArchiveR) -> ApprootUserGenerated
|
||||
CourseR _ _ _ CRegisterTemplateR -> ApprootUserGenerated
|
||||
CourseR _ _ _ CAppsFilesR -> ApprootUserGenerated
|
||||
CourseR _ _ _ (CourseApplicationR _ CAFilesR) -> ApprootUserGenerated
|
||||
route | Just (_, WorkflowWorkflowR _ (WWFilesR _ _)) <- route ^? _WorkflowScopeRoute -> ApprootUserGenerated
|
||||
_other -> ApprootDefault
|
||||
|
||||
@ -79,10 +79,19 @@ instance Yesod UniWorX where
|
||||
-- Controls the base of generated URLs. For more information on modifying,
|
||||
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
|
||||
approot = ApprootRequest $ \app req ->
|
||||
case app ^. _appRoot of
|
||||
case app ^. _appRoot . to ($ ApprootDefault) of
|
||||
Nothing -> getApprootText guessApproot app req
|
||||
Just root -> root
|
||||
|
||||
urlParamRenderOverride app route params = do
|
||||
rApproot <- case authoritiveApproot route of
|
||||
ApprootDefault -> mzero
|
||||
rApproot -> return rApproot
|
||||
guard $ views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app
|
||||
approotText <- app ^. _appRoot . to ($ rApproot)
|
||||
let (ps, params') = renderRoute route
|
||||
return . joinPath app approotText ps $ params ++ params'
|
||||
|
||||
makeSessionBackend = UniWorX.makeSessionBackend
|
||||
|
||||
maximumContentLength app _ = app ^. _appMaximumContentLength
|
||||
@ -181,6 +190,11 @@ instance YesodAuth UniWorX where
|
||||
_other -> Auth.germanMessage
|
||||
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
|
||||
|
||||
maybeAuthId = runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId
|
||||
where authIdFromBearer = do
|
||||
BearerToken{..} <- MaybeT maybeBearerToken
|
||||
hoistMaybe bearerImpersonate
|
||||
|
||||
instance YesodAuthPersist UniWorX where
|
||||
getAuthEntity = liftHandler . runDBRead . get
|
||||
|
||||
|
||||
File diff suppressed because it is too large
Load Diff
@ -192,7 +192,7 @@ siteLayout' overrideHeading widget = do
|
||||
. observeFavouritesQuickActionsDuration $ do
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
|
||||
items' <- pageQuickActions NavQuickViewFavourite courseRoute
|
||||
items <- forM items' $ \n@NavLink{navLabel} -> (mr navLabel,) <$> toTextUrl n
|
||||
items <- forM items' $ \n@NavLink{navLabel} -> fmap (mr navLabel,) $ toTextUrl =<< navLinkRoute n
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
|
||||
return items
|
||||
$logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
|
||||
@ -203,7 +203,7 @@ siteLayout' overrideHeading widget = do
|
||||
, maybe (return []) pageActions mcurrentRoute
|
||||
]
|
||||
nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav''
|
||||
nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse toTextUrl (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> toTextUrl nc) (n ^. _navChildren)
|
||||
nav <- forM nav' $ \n -> (n,,,) <$> newIdent <*> traverse (toTextUrl <=< navLinkRoute) (n ^? _navLink) <*> traverse (\nc -> (nc,, ) <$> newIdent <*> (toTextUrl <=< navLinkRoute) nc) (n ^. _navChildren)
|
||||
|
||||
mmsgs <- if
|
||||
| isModal -> return mempty
|
||||
@ -225,9 +225,9 @@ siteLayout' overrideHeading widget = do
|
||||
-- ^ highlight last route in breadcrumbs, favorites taking priority
|
||||
highlight = (highR ==) . Just . urlRoute
|
||||
where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents
|
||||
navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to urlRoute) nav
|
||||
navItems = map (view _2) favourites ++ toListOf (folded . typesUsing @NavChildren @NavLink . to navBaseRoute) nav
|
||||
highR = find (`elem` navItems) . uncurry (++) $ partition (`elem` map (view _2) favourites) crumbs
|
||||
highlightNav = (||) <$> navForceActive <*> highlight
|
||||
highlightNav = (||) <$> navForceActive <*> (highlight . navBaseRoute)
|
||||
favouriteTermReason :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
|
||||
favouriteTermReason tid favReason' = favourites
|
||||
& filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
|
||||
@ -243,15 +243,16 @@ siteLayout' overrideHeading widget = do
|
||||
navWidget (n, navIdent, navRoute', navChildren') = case n of
|
||||
NavHeader{ navLink = navLink@NavLink{..}, .. }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/item")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
, navModal -> do
|
||||
modalContent <- liftHandler $ Left <$> navLinkRoute navLink
|
||||
customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/item")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
@ -259,14 +260,15 @@ siteLayout' overrideHeading widget = do
|
||||
NavPageActionPrimary{ navLink = navLink@NavLink{..} }
|
||||
-> let pWidget
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
= customModal Modal
|
||||
, navModal = do
|
||||
modalContent <- liftHandler $ Left <$> navLinkRoute navLink
|
||||
customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/primary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
, modalContent
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
= let route = navRoute'
|
||||
@ -279,15 +281,16 @@ siteLayout' overrideHeading widget = do
|
||||
in $(widgetFile "widgets/pageaction/primary-wrapper")
|
||||
NavPageActionSecondary{ navLink = navLink@NavLink{..} }
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/secondary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute navLink
|
||||
}
|
||||
, navModal -> do
|
||||
modalContent <- liftHandler $ Left <$> navLinkRoute navLink
|
||||
customModal Modal
|
||||
{ modalTriggerId = Just navIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/pageaction/secondary")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = navRoute'
|
||||
ident = navIdent
|
||||
@ -307,25 +310,27 @@ siteLayout' overrideHeading widget = do
|
||||
navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
|
||||
NavHeaderContainer{}
|
||||
| NavTypeLink{..} <- navType
|
||||
, navModal
|
||||
-> customModal Modal
|
||||
{ modalTriggerId = Just iNavIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent = Left $ SomeRoute iN
|
||||
}
|
||||
, navModal -> do
|
||||
modalContent <- liftHandler $ Left <$> navLinkRoute iN
|
||||
customModal Modal
|
||||
{ modalTriggerId = Just iNavIdent
|
||||
, modalId = Nothing
|
||||
, modalTrigger = \mroute ident -> case mroute of
|
||||
Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
Nothing -> error "navWidget with non-link modal"
|
||||
, modalContent
|
||||
}
|
||||
| NavTypeLink{} <- navType
|
||||
-> let route = iNavRoute
|
||||
ident = iNavIdent
|
||||
in $(widgetFile "widgets/navbar/navbar-container-item--link")
|
||||
| NavTypeButton{..} <- navType -> do
|
||||
csrfToken <- reqToken <$> getRequest
|
||||
formAction <- liftHandler $ Just <$> navLinkRoute iN
|
||||
wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
|
||||
{ formMethod = navMethod
|
||||
, formSubmit = FormNoSubmit
|
||||
, formAction = Just $ SomeRoute iN
|
||||
, formAction
|
||||
}
|
||||
_other -> error "not implemented"
|
||||
|
||||
|
||||
@ -87,9 +87,14 @@ yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . ob
|
||||
csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
|
||||
csrfMiddleware handler = do
|
||||
hasBearer <- is _Just <$> lookupBearerAuth
|
||||
reqHost <- W.requestHeaderHost <$> waiRequest
|
||||
userGeneratedHost <- getsYesod $ \app ->
|
||||
guardOnM (views _appRoot ($ ApprootDefault) app /= views _appRoot ($ ApprootUserGenerated) app) $ approotScopeHost ApprootUserGenerated app
|
||||
|
||||
if | hasBearer -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
|
||||
| otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
|
||||
if | hasBearer || fromMaybe False ((==) <$> reqHost <*> userGeneratedHost)
|
||||
-> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
|
||||
| otherwise
|
||||
-> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
|
||||
where
|
||||
csrfSetCookieMiddleware' handler' = do
|
||||
mcsrf <- reqToken <$> getRequest
|
||||
@ -150,7 +155,8 @@ routeNormalizers :: forall m backend.
|
||||
, BearerAuthSite UniWorX
|
||||
) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
|
||||
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
|
||||
[ normalizeRender
|
||||
[ normalizeApproot
|
||||
, normalizeRender
|
||||
, ncSchool
|
||||
, ncAllocation
|
||||
, ncCourse
|
||||
@ -169,6 +175,12 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
|
||||
, verifyMaterialVideo
|
||||
]
|
||||
where
|
||||
normalizeApproot route = (route <$) . runMaybeT $ do
|
||||
reqHost <- MaybeT $ W.requestHeaderHost <$> waiRequest
|
||||
approotHost <- MaybeT . getsYesod . approotScopeHost $ authoritiveApproot route
|
||||
when (approotHost /= reqHost) $
|
||||
tell $ Any True
|
||||
|
||||
normalizeRender :: Route UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
|
||||
normalizeRender route = route <$ do
|
||||
YesodRequest{..} <- liftHandler getRequest
|
||||
|
||||
@ -17,46 +17,60 @@ import Web.Cookie
|
||||
|
||||
|
||||
makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
cfg = JwtSession.ServerSessionJwtConfig
|
||||
{ sJwtJwkSet = appJSONWebKeySet
|
||||
, sJwtStart = Nothing
|
||||
, sJwtExpiration = appSessionTokenExpiration
|
||||
, sJwtEncoding = appSessionTokenEncoding
|
||||
, sJwtIssueBy = appInstanceID
|
||||
, sJwtIssueFor = appClusterID
|
||||
}
|
||||
mkBackend :: forall sto.
|
||||
( ServerSession.SessionData sto ~ Map Text ByteString
|
||||
, ServerSession.Storage sto
|
||||
)
|
||||
=> ServerSession.State sto -> IO (Maybe SessionBackend)
|
||||
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
|
||||
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
|
||||
stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
|
||||
sameSite
|
||||
| Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= strictSameSiteSessions
|
||||
| Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= laxSameSiteSessions
|
||||
| otherwise
|
||||
= id
|
||||
notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
||||
notForBearer = fmap $ fmap notForBearer'
|
||||
where notForBearer' :: SessionBackend -> SessionBackend
|
||||
notForBearer' (SessionBackend load)
|
||||
= let load' req
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just . W.extractBearerAuth) aHdrs
|
||||
= return (mempty, const $ return [])
|
||||
| otherwise
|
||||
= load req
|
||||
in SessionBackend load'
|
||||
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of
|
||||
SessionStorageMemcachedSql sqlStore
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore
|
||||
SessionStorageAcid acidStore
|
||||
| appServerSessionAcidFallback
|
||||
-> mkBackend . stateSettings =<< ServerSession.createState acidStore
|
||||
_other
|
||||
-> return Nothing
|
||||
where
|
||||
cfg = JwtSession.ServerSessionJwtConfig
|
||||
{ sJwtJwkSet = appJSONWebKeySet
|
||||
, sJwtStart = Nothing
|
||||
, sJwtExpiration = appSessionTokenExpiration
|
||||
, sJwtEncoding = appSessionTokenEncoding
|
||||
, sJwtIssueBy = appInstanceID
|
||||
, sJwtIssueFor = appClusterID
|
||||
}
|
||||
mkBackend :: forall sto.
|
||||
( ServerSession.SessionData sto ~ Map Text ByteString
|
||||
, ServerSession.Storage sto
|
||||
)
|
||||
=> ServerSession.State sto -> IO (Maybe SessionBackend)
|
||||
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
|
||||
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
|
||||
stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
|
||||
sameSite
|
||||
| Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= strictSameSiteSessions
|
||||
| Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
|
||||
= laxSameSiteSessions
|
||||
| otherwise
|
||||
= id
|
||||
|
||||
notFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
|
||||
notFor f = fmap $ fmap notFor'
|
||||
where notFor' :: SessionBackend -> SessionBackend
|
||||
notFor' (SessionBackend load) = SessionBackend $ \req -> do
|
||||
pMatches <- f req
|
||||
if | not pMatches -> load req
|
||||
| otherwise -> return (mempty, const $ return [])
|
||||
|
||||
|
||||
isBearer req = return $ if
|
||||
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req
|
||||
, any (is _Just . W.extractBearerAuth) aHdrs
|
||||
-> True
|
||||
| otherwise
|
||||
-> False
|
||||
|
||||
isUserGenerated req = return $ if
|
||||
| Just approotHost <- approotScopeHost ApprootUserGenerated app
|
||||
, Just reqHost <- W.requestHeaderHost req
|
||||
, views _appRoot ($ ApprootUserGenerated) app /= views _appRoot ($ ApprootDefault) app
|
||||
, reqHost == approotHost
|
||||
-> True
|
||||
| otherwise
|
||||
-> False
|
||||
|
||||
@ -86,7 +86,7 @@ postAdminTokensR = do
|
||||
& HashSet.insert (Right uid)
|
||||
& HashSet.map (left toJSON)
|
||||
|
||||
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' btfRoutes btfAddAuth btfExpiresAt btfStartsAt
|
||||
fmap Just . encodeBearer . set _bearerRestrictions btfRestrict =<< bearerToken btfAuthority' Nothing (maybe HashMap.empty (HashMap.singleton BearerTokenRouteEval) btfRoutes) btfAddAuth btfExpiresAt btfStartsAt
|
||||
|
||||
siteLayoutMsg MsgMenuAdminTokens $ do
|
||||
setTitleI MsgMenuAdminTokens
|
||||
|
||||
@ -13,6 +13,8 @@ import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import Handler.Course.Show
|
||||
|
||||
|
||||
data AllocationAddUserForm = AllocationAddUserForm
|
||||
{ aauUser :: UserId
|
||||
@ -115,7 +117,12 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
|
||||
afmApplicantEdit = True
|
||||
afmLecturer = True
|
||||
|
||||
appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> over _2 (course, allocCourse, hasApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
|
||||
appsRes' <- iforM courses $ \cId (course, allocCourse, hasApplicationTemplate) -> do
|
||||
mApplicationTemplate <- runMaybeT $ do
|
||||
guard hasApplicationTemplate
|
||||
let Course{..} = course
|
||||
liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
||||
over _2 (course, allocCourse, mApplicationTemplate, ) <$> applicationForm (Just aId) cId Nothing ApplicationFormMode{..} Nothing
|
||||
let appsRes = sequenceA $ view _1 <$> appsRes'
|
||||
appsViews = view _2 <$> appsRes'
|
||||
|
||||
@ -123,7 +130,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
|
||||
[whamlet|
|
||||
$newline never
|
||||
<div .allocation__courses>
|
||||
$forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, hasApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
|
||||
$forall (Course{courseTerm, courseSchool, courseShorthand, courseName, courseApplicationsInstructions}, AllocationCourse{allocationCourseAcceptSubstitutes}, mApplicationTemplate, ApplicationFormView{afvPriority, afvForm}) <- Map.elems appsViews
|
||||
<div .allocation-course>
|
||||
<div .allocation-course__priority-label .allocation__label>
|
||||
_{MsgAllocationPriority}
|
||||
@ -141,16 +148,16 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
|
||||
_{MsgCourseAllocationCourseAcceptsSubstitutesNever}
|
||||
$if allocationCourseAcceptSubstitutes >= Just now
|
||||
\ ^{iconOK}
|
||||
$if hasApplicationTemplate || is _Just courseApplicationsInstructions
|
||||
$if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
|
||||
<div .allocation-course__instructions-label .allocation__label>
|
||||
_{MsgCourseApplicationInstructionsApplication}
|
||||
<div .allocation-course__instructions>
|
||||
$maybe aInst <- courseApplicationsInstructions
|
||||
<p>
|
||||
#{aInst}
|
||||
$if hasApplicationTemplate
|
||||
$maybe templateUrl <- mApplicationTemplate
|
||||
<p>
|
||||
<a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
|
||||
<a href=#{templateUrl}>
|
||||
#{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
|
||||
<div .allocation-course__application-label .interactive-fieldset__target .allocation__label uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
||||
_{MsgCourseApplication}
|
||||
|
||||
@ -138,13 +138,15 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
|
||||
| otherwise
|
||||
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)
|
||||
|
||||
hasFiles <- for mApp $ \(Entity appId _)
|
||||
-> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
|
||||
appCID <- for mApp $ encrypt . entityKey
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do
|
||||
hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
|
||||
appCID <- encrypt appId
|
||||
appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
|
||||
return (hasFiles, appFilesLink)
|
||||
let hasFiles = maybe False (view _1) appFilesInfo
|
||||
|
||||
filesLinkView <- if
|
||||
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
| hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
|
||||
-> let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
@ -153,8 +155,8 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
|
||||
= [whamlet|
|
||||
$newline never
|
||||
$case appFilesInfo
|
||||
$of Just (True, appCID)
|
||||
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
|
||||
$of Just (True, appFilesLink)
|
||||
<a ##{theId} *{attrs} href=#{appFilesLink}>
|
||||
_{MsgCourseApplicationFiles}
|
||||
$of _
|
||||
<span ##{theId} *{attrs}>
|
||||
@ -165,7 +167,7 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
|
||||
-> return Nothing
|
||||
|
||||
filesWarningView <- if
|
||||
| Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
| hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
|
||||
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
@ -15,6 +15,8 @@ import Handler.Allocation.Application
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Course.Show
|
||||
|
||||
|
||||
data NotifyNewCourseButton
|
||||
= BtnNotifyNewCourseForceOn
|
||||
@ -174,6 +176,10 @@ postAShowR tid ssh ash = do
|
||||
tRoute <- case mApp of
|
||||
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
|
||||
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR
|
||||
mApplicationTemplate <- runMaybeT $ do
|
||||
guard hasApplicationTemplate
|
||||
liftHandler . runDB $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource courseTerm courseSchool courseShorthand) $ CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR
|
||||
|
||||
let mApplyFormView' = view _1 <$> mApplyFormView
|
||||
overrideVisible = not mayApply && is _Just mApp
|
||||
case mApplyFormView of
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Handler.Course.News.Download
|
||||
( getCNArchiveR
|
||||
, getCNFileR
|
||||
( getCNArchiveR, cnArchiveSource
|
||||
, getCNFileR, cnFileSource
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -11,6 +11,11 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
|
||||
cnArchiveSource :: CourseNewsId -> ConduitT () CourseNewsFile (YesodDB UniWorX) ()
|
||||
cnArchiveSource nId = (.| C.map entityVal) . E.selectSource . E.from $ \newsFile -> do
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
return newsFile
|
||||
|
||||
getCNArchiveR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent
|
||||
getCNArchiveR tid ssh csh cID = do
|
||||
nId <- decrypt cID
|
||||
@ -18,22 +23,16 @@ getCNArchiveR tid ssh csh cID = do
|
||||
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseNewsArchiveName tid ssh csh (fromMaybe (toPathPiece courseNewsLastEdit) courseNewsTitle)
|
||||
|
||||
let getFilesQuery = (.| C.map entityVal) . E.selectSource . E.from $
|
||||
\newsFile -> do
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
return newsFile
|
||||
|
||||
serveSomeFiles archiveName getFilesQuery
|
||||
serveSomeFiles archiveName $ cnArchiveSource nId
|
||||
|
||||
|
||||
cnFileSource :: CourseNewsId -> FilePath -> ConduitT () CourseNewsFile (YesodDB UniWorX) ()
|
||||
cnFileSource nId fPath = (.| C.map entityVal) . E.selectSource . E.from $ \newsFile -> do
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
E.&&. newsFile E.^. CourseNewsFileTitle E.==. E.val fPath
|
||||
return newsFile
|
||||
|
||||
getCNFileR :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
|
||||
getCNFileR _ _ _ cID title = do
|
||||
getCNFileR _ _ _ cID fPath = do
|
||||
nId <- decrypt cID
|
||||
|
||||
let
|
||||
fileQuery = E.selectSource . E.from $ \newsFile -> do
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
E.&&. newsFile E.^. CourseNewsFileTitle E.==. E.val title
|
||||
return newsFile
|
||||
|
||||
serveOneFile $ fileQuery .| C.map entityVal
|
||||
serveOneFile $ cnFileSource nId fPath
|
||||
|
||||
@ -101,31 +101,33 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
|
||||
| otherwise
|
||||
-> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)
|
||||
|
||||
hasFiles <- for application $ \(Entity appId _)
|
||||
-> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ]
|
||||
appCID <- for application $ encrypt . entityKey
|
||||
let appFilesInfo = (,) <$> hasFiles <*> appCID
|
||||
appFilesInfo <- for application $ \(Entity appId _) -> liftHandler . runDB $ do
|
||||
hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
|
||||
appCID <- encrypt appId
|
||||
appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
|
||||
return (hasFiles, appFilesLink)
|
||||
let hasFiles = maybe False (view _1) appFilesInfo
|
||||
filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
|
||||
|
||||
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $
|
||||
when (isn't _NoUpload courseApplicationsFiles || hasFiles) $
|
||||
let filesLinkField = Field{..}
|
||||
where
|
||||
fieldParse _ _ = return $ Right Nothing
|
||||
fieldEnctype = mempty
|
||||
fieldView theId _ attrs _ _
|
||||
= [whamlet|
|
||||
$newline never
|
||||
$case appFilesInfo
|
||||
$of Just (True, appCID)
|
||||
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}>
|
||||
_{filesMsg}
|
||||
$of _
|
||||
<span ##{theId} *{attrs}>
|
||||
_{MsgCourseApplicationNoFiles}
|
||||
|]
|
||||
fieldView theId _ attrs _ _ =
|
||||
[whamlet|
|
||||
$newline never
|
||||
$case appFilesInfo
|
||||
$of Just (True, appFilesLink)
|
||||
<a ##{theId} *{attrs} href=#{appFilesLink}>
|
||||
_{filesMsg}
|
||||
$of _
|
||||
<span ##{theId} *{attrs}>
|
||||
_{MsgCourseApplicationNoFiles}
|
||||
|]
|
||||
in void $ wforced filesLinkField (fslI filesMsg) Nothing
|
||||
|
||||
when (Just True == hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
when (hasFiles && isn't _NoUpload courseApplicationsFiles) $
|
||||
wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
|
||||
|
||||
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Handler.Course.Show
|
||||
( getCShowR
|
||||
, getCRegisterTemplateR
|
||||
, getCRegisterTemplateR, courseRegisterTemplateSource
|
||||
) where
|
||||
|
||||
import Import
|
||||
@ -25,12 +25,14 @@ import qualified Data.Conduit.List as C
|
||||
|
||||
import Handler.Exam.List (mkExamTable)
|
||||
|
||||
import Handler.Course.News.Download
|
||||
|
||||
|
||||
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCShowR tid ssh csh = do
|
||||
mbAid <- maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
(cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do
|
||||
(cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister,(mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial)) <- runDB . maybeT notFound $ do
|
||||
[(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
|
||||
<- lift . E.select . E.from $
|
||||
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
|
||||
@ -76,6 +78,9 @@ getCShowR tid ssh csh = do
|
||||
return allocation
|
||||
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
|
||||
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid
|
||||
mApplicationTemplate <- runMaybeT $ do
|
||||
guard hasApplicationTemplate
|
||||
lift . lift $ toTextUrl <=< withFileDownloadToken (courseRegisterTemplateSource tid ssh csh) $ CourseR tid ssh csh CRegisterTemplateR
|
||||
mApplication <- lift . fmap (listToMaybe =<<) . for mbAid $ \uid -> selectList [CourseApplicationCourse ==. cid, CourseApplicationUser ==. uid, CourseApplicationAllocation ==. Nothing] []
|
||||
news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
|
||||
cTime <- NTop . Just <$> liftIO getCurrentTime
|
||||
@ -86,14 +91,17 @@ getCShowR tid ssh csh = do
|
||||
files' <- lift . lift . E.select . E.from $ \newsFile -> do
|
||||
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
|
||||
return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle)
|
||||
let files = files'
|
||||
let files'' = files'
|
||||
& over (mapped . _1) E.unValue
|
||||
& over (mapped . _2) E.unValue
|
||||
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
|
||||
mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
|
||||
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR
|
||||
|
||||
return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete)
|
||||
files <- lift . lift $ forM files'' $ \f@(_isDir, fPath) -> fmap (f ,) . toTextUrl <=< withFileDownloadToken (cnFileSource nId fPath) . CNewsR tid ssh csh cID $ CNFileR fPath
|
||||
archiveUrl <- lift . lift $ toTextUrl <=< withFileDownloadToken (cnArchiveSource nId) $ CNewsR tid ssh csh cID CNArchiveR
|
||||
|
||||
return (cID, n, visible, files, lastEditText, mayEditNews, mayDelete, archiveUrl)
|
||||
|
||||
events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do
|
||||
E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid
|
||||
@ -127,7 +135,7 @@ getCShowR tid ssh csh = do
|
||||
return $ material E.^. MaterialName
|
||||
mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR
|
||||
|
||||
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,hasApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial))
|
||||
return (cid,course,courseVisible,schoolName,participants,registration,lecturers,assistants,correctors,tutors,mAllocation,mApplicationTemplate,mApplication,news,events,submissionGroup,hasAllocationRegistrationOpen,mayReRegister, (mayViewSheets, mayViewAnySheet), (mayViewMaterials, mayViewAnyMaterial))
|
||||
|
||||
let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
|
||||
mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
|
||||
@ -244,7 +252,7 @@ getCShowR tid ssh csh = do
|
||||
showNewsFiles fs = and
|
||||
[ not $ null fs
|
||||
, length fs <= 3
|
||||
, all (notElem pathSeparator . view _2) fs
|
||||
, all (views (_1 . _2) $ notElem pathSeparator) fs
|
||||
]
|
||||
hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events
|
||||
Course{courseVisibleFrom,courseVisibleTo} = course
|
||||
@ -263,13 +271,15 @@ getCShowR tid ssh csh = do
|
||||
setTitleI $ prependCourseTitle tid ssh csh (""::Text)
|
||||
$(widgetFile "course")
|
||||
|
||||
courseRegisterTemplateSource :: TermId -> SchoolId -> CourseShorthand -> ConduitT () CourseAppInstructionFile (YesodDB UniWorX) ()
|
||||
courseRegisterTemplateSource tid ssh csh = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return courseAppInstructionFile
|
||||
|
||||
getCRegisterTemplateR :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
|
||||
getCRegisterTemplateR tid ssh csh = do
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh
|
||||
let source = (.| C.map entityVal) . E.selectSource . E.from $ \(courseAppInstructionFile `E.InnerJoin` course) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseAppInstructionFile E.^. CourseAppInstructionFileCourse
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
return courseAppInstructionFile
|
||||
serveSomeFiles archiveName source
|
||||
serveSomeFiles archiveName $ courseRegisterTemplateSource tid ssh csh
|
||||
|
||||
@ -1,4 +1,12 @@
|
||||
module Handler.Material where
|
||||
module Handler.Material
|
||||
( getMaterialListR
|
||||
, getMFileR, getMVideoR
|
||||
, getMShowR
|
||||
, getMEditR, postMEditR
|
||||
, getMaterialNewR, postMaterialNewR
|
||||
, getMDelR, postMDelR
|
||||
, getMArchiveR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
@ -58,11 +66,6 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
|
||||
<*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template)
|
||||
(fslI MsgMaterialFiles) (mfFiles <$> template)
|
||||
|
||||
getMaterialKeyBy404 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Key Material)
|
||||
getMaterialKeyBy404 tid ssh csh mnm = do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
getKeyBy404 $ UniqueMaterial cid mnm
|
||||
|
||||
fetchMaterial :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
|
||||
fetchMaterial tid ssh csh mnm =
|
||||
maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints
|
||||
@ -80,8 +83,9 @@ getMaterialListR tid ssh csh = do
|
||||
let matLink :: MaterialName -> Route UniWorX
|
||||
matLink = CourseR tid ssh csh . flip MaterialR MShowR
|
||||
|
||||
filesLink :: MaterialName -> Route UniWorX
|
||||
filesLink = CourseR tid ssh csh . flip MaterialR MArchiveR
|
||||
filesLink :: (MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
=> MaterialName -> m (SomeRoute UniWorX)
|
||||
filesLink mnm = liftHandler . runDB $ withFileDownloadToken (materialArchiveSource tid ssh csh mnm) . CourseR tid ssh csh $ MaterialR mnm MArchiveR
|
||||
|
||||
materialModDateCell :: IsDBTable m a => Material -> DBCell m a
|
||||
materialModDateCell Material{materialVisibleFrom, materialLastEdit}
|
||||
@ -120,7 +124,7 @@ getMaterialListR tid ssh csh = do
|
||||
, sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles))
|
||||
$ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
|
||||
| fileNum == 0 -> mempty
|
||||
| otherwise -> fileCell $ filesLink materialName
|
||||
| otherwise -> anchorCellM (filesLink materialName) iconFileDownload
|
||||
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
|
||||
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
|
||||
, sortable (Just "last-edit") (i18nCell MsgFileModified)
|
||||
@ -173,9 +177,12 @@ getMFileR tid ssh csh mnm title = serveOneFile $ fileQuery .| C.map entityVal
|
||||
getMVideoR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
|
||||
getMVideoR tid ssh csh mnm cID = do
|
||||
mfId <- decrypt cID
|
||||
MaterialFile{..} <- runDB $ get404 mfId
|
||||
mf@MaterialFile{..} <- runDB $ get404 mfId
|
||||
let mimeType = mimeLookup $ pack materialFileTitle
|
||||
mfile = CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
mfile <- withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
let mfileDownload = mfile & over (urlRouteParams $ Proxy @UniWorX) (\params -> bool ((toPathPiece GetDownload, mempty) : ) id (anyOf (folded . _1) (== toPathPiece GetDownload) params) params)
|
||||
mfileText <- toTextUrl mfile
|
||||
mfileDownloadText <- toTextUrl mfileDownload
|
||||
unless (mimeType `Set.member` videoTypes) $
|
||||
redirectWith movedPermanently301 mfile
|
||||
siteLayout' Nothing $ do
|
||||
@ -185,10 +192,10 @@ getMVideoR tid ssh csh mnm cID = do
|
||||
<section>
|
||||
<div .video-container>
|
||||
<video controls autoplay preload=auto>
|
||||
<source src=@{mfile} type=#{decodeUtf8 mimeType}>
|
||||
<source src=#{mfileText} type=#{decodeUtf8 mimeType}>
|
||||
_{MsgMaterialVideoUnsupported}
|
||||
<section>
|
||||
<a .btn href=@{mfile} download target=_blank>
|
||||
<a .btn href=#{mfileDownloadText}>
|
||||
^{iconFileDownload} #
|
||||
_{MsgMaterialVideoDownload}
|
||||
|]
|
||||
@ -196,13 +203,10 @@ getMVideoR tid ssh csh mnm cID = do
|
||||
|
||||
getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
|
||||
getMShowR tid ssh csh mnm = do
|
||||
let zipLink :: Route UniWorX
|
||||
zipLink = CMaterialR tid ssh csh mnm MArchiveR
|
||||
|
||||
seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
|
||||
|
||||
( Entity _mid material@Material{materialType, materialDescription}
|
||||
, (Any hasFiles,fileTable)) <- runDB $ do
|
||||
(Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do
|
||||
zipLink <- withFileDownloadToken (materialArchiveSource tid ssh csh mnm) $ CMaterialR tid ssh csh mnm MArchiveR
|
||||
matEnt <- fetchMaterial tid ssh csh mnm
|
||||
let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
|
||||
materialModDateCol = if seeAllModificationTimestamps
|
||||
@ -213,25 +217,25 @@ getMShowR tid ssh csh mnm = do
|
||||
{ dbtSQLQuery = \matFile -> do
|
||||
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
|
||||
E.&&. E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories
|
||||
return (matFile E.^. MaterialFileId, matFile E.^. MaterialFileTitle, matFile E.^. MaterialFileModified)
|
||||
return matFile
|
||||
, dbtRowKey = (E.^. MaterialFileId)
|
||||
, dbtColonnade = widgetColonnade $ mconcat
|
||||
[ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \DBRow{..}
|
||||
-> let matLink = CourseR tid ssh csh . MaterialR mnm <$> if
|
||||
[ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId mf@MaterialFile{..})
|
||||
-> let matLink
|
||||
| isVideo
|
||||
-> MVideoR <$> encrypt (dbrOutput ^. _1 . _Value)
|
||||
| otherwise -> return $ MFileR fileTitle
|
||||
= SomeRoute . CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
|
||||
| otherwise
|
||||
= withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
|
||||
wgt = [whamlet|
|
||||
$newline never
|
||||
<span .file-path>
|
||||
#{fileTitle}
|
||||
#{materialFileTitle}
|
||||
$if isVideo
|
||||
\ ^{iconVideo}
|
||||
|]
|
||||
isVideo = mimeLookup (pack fileTitle) `Set.member` videoTypes
|
||||
fileTitle = unpack $ dbrOutput ^. _2 . _Value
|
||||
isVideo = mimeLookup (pack materialFileTitle) `Set.member` videoTypes
|
||||
in anchorCellM matLink wgt
|
||||
, materialModDateCol (view $ _dbrOutput . _3)
|
||||
, materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
|
||||
]
|
||||
, dbtProj = return
|
||||
, dbtStyle = def
|
||||
@ -246,7 +250,7 @@ getMShowR tid ssh csh mnm = do
|
||||
, dbtCsvEncode = noCsvEncode
|
||||
, dbtCsvDecode = Nothing
|
||||
}
|
||||
return (matEnt,fileTable')
|
||||
return (matEnt,fileTable',zipLink)
|
||||
-- File table has no filtering by access, because we assume that
|
||||
-- access rights to material and material-files are identical.
|
||||
|
||||
@ -366,20 +370,22 @@ postMDelR tid ssh csh mnm = do
|
||||
, drDelete = const id -- TODO: audit
|
||||
}
|
||||
|
||||
materialArchiveSource :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> ConduitT () MaterialFile (YesodDB UniWorX) ()
|
||||
materialArchiveSource tid ssh csh mnm = (.| C.map entityVal) . E.selectSource . E.from $
|
||||
\(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do
|
||||
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
|
||||
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. material E.^. MaterialName E.==. E.val mnm
|
||||
return materialFile
|
||||
|
||||
-- | Serve all material-files
|
||||
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
|
||||
getMArchiveR tid ssh csh mnm = do
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm
|
||||
|
||||
let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $
|
||||
\(course `E.InnerJoin` material `E.InnerJoin` materialFile) -> do
|
||||
E.on $ material E.^. MaterialId E.==. materialFile E.^. MaterialFileMaterial
|
||||
E.on $ material E.^. MaterialCourse E.==. course E.^. CourseId
|
||||
E.where_ $ course E.^. CourseTerm E.==. E.val tid
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. material E.^. MaterialName E.==. E.val mnm
|
||||
return materialFile
|
||||
|
||||
let getMatQuery = materialArchiveSource tid ssh csh mnm
|
||||
serveSomeFiles archiveName getMatQuery
|
||||
|
||||
|
||||
@ -9,6 +9,7 @@ import qualified Network.Wai.Middleware.Prometheus as Prometheus
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -28,7 +29,7 @@ getMetricsR = selectRep $ do
|
||||
uid <- MaybeT maybeAuthId
|
||||
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid
|
||||
|
||||
encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) (Just $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
|
||||
encodeBearer =<< bearerToken (HashSet.singleton . Left $ toJSON UserGroupMetrics) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton MetricsR) Nothing (Just Nothing) Nothing
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI MsgTitleMetrics
|
||||
|
||||
@ -54,10 +54,10 @@ getSheetListR tid ssh csh = do
|
||||
[ icnCell & addIconFixedWidth
|
||||
| let existingSFTs = hasSFT existFiles
|
||||
, sft <- [minBound..maxBound]
|
||||
, let link = CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh sheetName muid sft) . CSheetR tid ssh csh sheetName $ SZipR sft
|
||||
, let icn = toWgt $ sheetFile2markup sft
|
||||
, let icnCell = if sft `elem` existingSFTs
|
||||
then linkEitherCell link (icn, [whamlet| |])
|
||||
then linkEitherCellM link (icn, [whamlet| |])
|
||||
else spacerCell
|
||||
] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
|
||||
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
|
||||
|
||||
@ -46,22 +46,23 @@ getSShowR tid ssh csh shn = do
|
||||
return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle]
|
||||
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified]
|
||||
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType]
|
||||
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileContent, sheetFile E.?. SheetFileContent]
|
||||
)
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) ->
|
||||
let link = CSheetR tid ssh csh shn $ SZipR ftype in
|
||||
tellCell (Any True) $
|
||||
anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype, _) ->
|
||||
let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh shn muid ftype) . CSheetR tid ssh csh shn $ SZipR ftype
|
||||
in tellCell (Any True) $
|
||||
anchorCellM link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
|
||||
-- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True))
|
||||
|
||||
-- , colFilePath (view _1) (\row -> let fType = view _3 row in let fName = view _1 row in (CSheetR tid ssh csh shn (SFileR (E.unValue fType) (E.unValue fName))))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,_,E.Value fType) -> anchorCell
|
||||
(CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
, sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,E.Value fMod,E.Value fType, E.Value fRef) -> anchorCellM
|
||||
(withFileDownloadToken (yield $ FileReference fName fRef fMod) $ CSheetR tid ssh csh shn (SFileR fType fName))
|
||||
(str2widget fName)
|
||||
, sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
|
||||
$ \(_, _ , E.Value ftype) -> sftVisible ftype
|
||||
$ \(_, _ , E.Value ftype, _) -> sftVisible ftype
|
||||
, sortable (Just "time") (i18nCell MsgFileModified)
|
||||
$ \(_,E.Value modified, E.Value ftype) -> sftModification ftype modified
|
||||
$ \(_,E.Value modified, E.Value ftype, _) -> sftModification ftype modified
|
||||
-- , colFileModification (view _2)
|
||||
]
|
||||
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
|
||||
@ -70,11 +71,11 @@ getSShowR tid ssh csh shn = do
|
||||
{ dbtSQLQuery = fileData
|
||||
, dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
|
||||
, dbtColonnade = colonnadeFiles
|
||||
, dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
|
||||
, dbtProj = return . dbrOutput :: DBRow _ -> DB (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))
|
||||
, dbtStyle = def
|
||||
, dbtFilter = mconcat
|
||||
[ singletonMap "may-access" . FilterProjected $ \(Any b) r ->
|
||||
let (E.Value fName, _, E.Value fType) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType)
|
||||
let (E.Value fName, _, E.Value fType, _) = r :: (E.Value FilePath, E.Value UTCTime, E.Value SheetFileType, E.Value (Maybe FileContentReference))
|
||||
in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
|
||||
]
|
||||
, dbtFilterUI = mempty
|
||||
|
||||
@ -17,6 +17,8 @@ import qualified Control.Monad.State.Class as State
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
|
||||
import Handler.Submission.Download
|
||||
|
||||
|
||||
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _
|
||||
correctionData tid ssh csh shn sub = E.select . E.from $ \((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) -> do
|
||||
@ -50,7 +52,7 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
|
||||
MsgRenderer mr <- getMsgRenderer
|
||||
case results of
|
||||
[(Entity cId Course{..}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
||||
[(Entity cId Course{}, Entity shId Sheet{..}, Entity _ subm@Submission{..}, corrector, E.Value filesCorrected)] -> do
|
||||
let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
|
||||
pointsForm = case sheetType of
|
||||
NotGraded
|
||||
@ -144,14 +146,11 @@ postCorrectionR tid ssh csh shn cid = do
|
||||
|]
|
||||
siteLayout headingWgt $ do
|
||||
setTitleI heading
|
||||
urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource tid ssh csh shn cid SubmissionCorrected) . CSubmissionR tid ssh csh shn cid $ SubArchiveR SubmissionCorrected
|
||||
let userCorrection = $(widgetFile "correction-user")
|
||||
$(widgetFile "correction")
|
||||
_ -> notFound
|
||||
|
||||
|
||||
getCorrectionUserR tid ssh csh shn cid = do
|
||||
|
||||
|
||||
sub <- decrypt cid
|
||||
|
||||
results <- runDB $ correctionData tid ssh csh shn sub
|
||||
@ -159,5 +158,7 @@ getCorrectionUserR tid ssh csh shn cid = do
|
||||
case results of
|
||||
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] ->
|
||||
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
||||
in defaultLayout $(widgetFile "correction-user")
|
||||
in defaultLayout $ do
|
||||
urlArchive <- toTextUrl <=< liftHandler . runDB . withFileDownloadToken' (subArchiveSource courseTerm courseSchool courseShorthand sheetName cid SubmissionCorrected) . CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected
|
||||
$(widgetFile "correction-user")
|
||||
_ -> notFound
|
||||
|
||||
@ -1,6 +1,6 @@
|
||||
module Handler.Submission.Download
|
||||
( getSubDownloadR
|
||||
, getSubArchiveR
|
||||
( getSubDownloadR, subDownloadSource
|
||||
, getSubArchiveR, subArchiveSource
|
||||
, getCorrectionsDownloadR
|
||||
) where
|
||||
|
||||
@ -16,8 +16,28 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Data.Conduit.Combinators as Conduit
|
||||
|
||||
|
||||
subDownloadSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> ConduitT () SubmissionFile (YesodDB UniWorX) ()
|
||||
subDownloadSource tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
(submissionID, isRating) <- lift $ do
|
||||
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
isRating <- (== Just submissionID) <$> isRatingFile path
|
||||
|
||||
when (isUpdate || isRating) $
|
||||
guardAuthResult =<< evalAccessDB (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
return (submissionID, isRating)
|
||||
|
||||
unless isRating $ (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileTitle E.==. E.val path
|
||||
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||||
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
|
||||
return sf
|
||||
|
||||
getSubDownloadR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> FilePath -> Handler TypedContent
|
||||
getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
getSubDownloadR tid ssh csh shn cID sft@(submissionFileTypeIsUpdate -> isUpdate) path = do
|
||||
(submissionID, isRating) <- runDB $ do
|
||||
submissionID <- submissionMatchesSheet tid ssh csh shn cID
|
||||
|
||||
@ -33,16 +53,26 @@ getSubDownloadR tid ssh csh shn cID (submissionFileTypeIsUpdate -> isUpdate) pat
|
||||
| isUpdate -> maybe notFound sendThisFile <=< runDB . runMaybeT $
|
||||
lift . ratingFile cID =<< MaybeT (getRating submissionID)
|
||||
| otherwise -> notFound
|
||||
False -> do
|
||||
let results = (.| Conduit.map entityVal) . E.selectSource . E.from $ \sf -> do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileTitle E.==. E.val path
|
||||
E.&&. E.not_ (sf E.^. SubmissionFileIsDeletion)
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val isUpdate
|
||||
-- E.&&. E.not_ (E.isNothing $ f E.^. FileContent) -- This is fine, we just return 204
|
||||
return sf
|
||||
False -> serveOneFile $ subDownloadSource tid ssh csh shn cID sft path
|
||||
|
||||
serveOneFile results
|
||||
|
||||
subArchiveSource :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> ConduitT () (Either SubmissionFile DBFile) (YesodDB UniWorX) ()
|
||||
subArchiveSource tid ssh csh shn cID sfType = do
|
||||
when (sfType == SubmissionCorrected) $
|
||||
guardAuthResult =<< evalAccess (CSubmissionR tid ssh csh shn cID CorrectionR) False
|
||||
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
case sfType of
|
||||
SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
|
||||
return sf
|
||||
_other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal)
|
||||
|
||||
when (sfType == SubmissionCorrected) $
|
||||
maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating
|
||||
|
||||
getSubArchiveR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent
|
||||
getSubArchiveR tid ssh csh shn cID sfType = do
|
||||
@ -52,21 +82,7 @@ getSubArchiveR tid ssh csh shn cID sfType = do
|
||||
sfType' <- ap getMessageRender $ pure sfType
|
||||
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType'
|
||||
|
||||
let source = do
|
||||
submissionID <- lift $ submissionMatchesSheet tid ssh csh shn cID
|
||||
rating <- lift $ getRating submissionID
|
||||
|
||||
case sfType of
|
||||
SubmissionOriginal -> (.| Conduit.map (Left . entityVal)) . E.selectSource . E.from $ \sf -> do
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.&&. sf E.^. SubmissionFileIsUpdate E.==. E.val False
|
||||
return sf
|
||||
_other -> E.selectSource (E.from $ submissionFileQuery submissionID) .| Conduit.map (Left . entityVal)
|
||||
|
||||
when (sfType == SubmissionCorrected) $
|
||||
maybe (return ()) (yieldM . fmap Right . ratingFile cID) rating
|
||||
|
||||
serveSomeFiles' archiveName source
|
||||
serveSomeFiles' archiveName $ subArchiveSource tid ssh csh shn cID sfType
|
||||
|
||||
|
||||
getCorrectionsDownloadR :: Handler TypedContent
|
||||
|
||||
@ -28,6 +28,7 @@ import qualified Data.Aeson.Types as JSON
|
||||
import Data.Aeson.Lens
|
||||
|
||||
|
||||
import Handler.Submission.Download
|
||||
import Handler.Submission.SubmissionUserInvite
|
||||
|
||||
|
||||
@ -490,14 +491,12 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
|
||||
Just isFile = origIsFile <|> corrIsFile
|
||||
in if
|
||||
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle')
|
||||
[whamlet|#{fileTitle'}|]
|
||||
| Just True <- origIsFile -> anchorCellM (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
|
||||
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
|
||||
, guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of
|
||||
Nothing -> cell mempty
|
||||
Just (Entity _ SubmissionFile{..})
|
||||
| isJust submissionFileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected submissionFileTitle)
|
||||
[whamlet|_{MsgFileCorrected}|]
|
||||
| isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
|
||||
| otherwise -> i18nCell MsgCorrected
|
||||
, Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let
|
||||
origTime = submissionFileModified . entityVal <$> mOrig
|
||||
@ -505,6 +504,8 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
|
||||
in dateTimeCell fileTime
|
||||
]
|
||||
subDownloadLink :: _ -> _ -> _ -> WidgetFor UniWorX _
|
||||
subDownloadLink cid sft fileTitle' = liftHandler . runDB . withFileDownloadToken (subDownloadSource tid ssh csh shn cid sft fileTitle') . CSubmissionR tid ssh csh shn cid $ SubDownloadR sft fileTitle'
|
||||
submissionFiles :: _ -> _ -> E.SqlQuery _
|
||||
submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
|
||||
E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle
|
||||
@ -550,16 +551,13 @@ submissionHelper tid ssh csh shn mcid = do
|
||||
E.where_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId
|
||||
E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (E.val subId)
|
||||
|
||||
let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
|
||||
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
||||
courseTerm = tid
|
||||
courseSchool = ssh
|
||||
courseShorthand = csh
|
||||
in $(widgetFile "correction-user")
|
||||
|
||||
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSubmissionEditHead tid ssh csh shn
|
||||
let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected
|
||||
urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal
|
||||
(urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
|
||||
-> let mkUrl sft = toTextUrl <=< withFileDownloadToken' (subArchiveSource tid ssh csh shn cID sft) . CSubmissionR tid ssh csh shn cID $ SubArchiveR sft
|
||||
in liftHandler . runDB $ (,) <$> mkUrl SubmissionCorrected <*> mkUrl SubmissionOriginal
|
||||
let correctionWdgt = guardOnM (showCorrection && maybe False submissionRatingDone msubmission) ((,) <$> msubmission <*> mcid) <&> \(Submission{..}, cid) ->
|
||||
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment
|
||||
in $(widgetFile "correction-user")
|
||||
$(widgetFile "submission")
|
||||
|
||||
@ -4,12 +4,9 @@ module Handler.Utils
|
||||
|
||||
import Import hiding (link)
|
||||
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Handler.Utils.DateTime as Handler.Utils
|
||||
import Handler.Utils.Form as Handler.Utils
|
||||
@ -27,85 +24,13 @@ import Handler.Utils.Database as Handler.Utils
|
||||
import Handler.Utils.Occurrences as Handler.Utils
|
||||
import Handler.Utils.Memcached as Handler.Utils
|
||||
import Handler.Utils.Files as Handler.Utils
|
||||
import Handler.Utils.Download as Handler.Utils
|
||||
|
||||
import Handler.Utils.Term as Handler.Utils
|
||||
|
||||
import Control.Monad.Logger
|
||||
|
||||
|
||||
-- | Simply send a `File`-Value
|
||||
sendThisFile :: DBFile -> Handler TypedContent
|
||||
sendThisFile File{..}
|
||||
| Just fileContent' <- fileContent = do
|
||||
setCSPSandbox
|
||||
setContentDisposition' . Just $ takeFileName fileTitle
|
||||
let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
|
||||
respondSourceDB cType $
|
||||
fileContent' .| Conduit.map toFlushBuilder
|
||||
| otherwise = sendResponseStatus noContent204 ()
|
||||
|
||||
sendFileReference :: forall file a. HasFileReference file => file -> Handler a
|
||||
sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
|
||||
when (is _Just fileReferenceContent) $ do
|
||||
setCSPSandbox
|
||||
setContentDisposition' . Just $ takeFileName fileReferenceTitle
|
||||
let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8"
|
||||
join . runDB $ respondFileConditional Nothing cType fRef
|
||||
|
||||
-- | Serve a single file, identified through a given DB query
|
||||
serveOneFile :: forall file. HasFileReference file => ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveOneFile source = do
|
||||
results <- runDB . runConduit $ source .| Conduit.take 2 -- We don't need more than two files to make a decision below
|
||||
case results of
|
||||
[file] -> sendFileReference file
|
||||
[] -> notFound
|
||||
_other -> do
|
||||
$logErrorS "SFileR" "Multiple matching files found."
|
||||
error "Multiple matching files found."
|
||||
|
||||
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
|
||||
serveSomeFiles :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left
|
||||
|
||||
serveSomeFiles' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveSomeFiles' archiveName source = do
|
||||
(source', results) <- runDB $ runPeekN 2 source
|
||||
|
||||
$logDebugS "serveSomeFiles" . tshow $ length results
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
[file] -> either sendFileReference sendThisFile file
|
||||
_moreFiles -> do
|
||||
setCSPSandbox
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB typeZip $ do
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
|
||||
serveZipArchive :: forall file. HasFileReference file => FilePath -> ConduitT () file (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left
|
||||
|
||||
serveZipArchive' :: forall file. HasFileReference file => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> Handler TypedContent
|
||||
serveZipArchive' archiveName source = do
|
||||
(source', results) <- runDB $ runPeekN 1 source
|
||||
|
||||
$logDebugS "serveZipArchive" . tshow $ length results
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
_moreFiles -> do
|
||||
setCSPSandbox
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB typeZip $ do
|
||||
let zipComment = T.encodeUtf8 $ pack archiveName
|
||||
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
-- | Prefix a message with a short course id,
|
||||
-- eg. for window title bars, etc.
|
||||
|
||||
@ -3,10 +3,11 @@ module Handler.Utils.ContentDisposition
|
||||
, setContentDisposition'
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
|
||||
-- | Check whether the user's preference for files is inline-viewing or downloading
|
||||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m Bool
|
||||
downloadFiles = do
|
||||
mauth <- liftHandler maybeAuth
|
||||
case mauth of
|
||||
@ -15,8 +16,8 @@ downloadFiles = do
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
return userDefaultDownloadFiles
|
||||
|
||||
setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX) => Maybe FilePath -> m ()
|
||||
setContentDisposition' :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Maybe FilePath -> m ()
|
||||
setContentDisposition' mFileName = do
|
||||
wantsDownload <- downloadFiles
|
||||
wantsDownload <- or2M (hasGlobalGetParam GetDownload) downloadFiles
|
||||
setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName
|
||||
|
||||
|
||||
@ -19,7 +19,8 @@ module Handler.Utils.DateTime
|
||||
, formatGregorianW
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
|
||||
import Data.Time.Zones
|
||||
import qualified Data.Time.Zones as TZ
|
||||
@ -77,13 +78,13 @@ formatTime' fmtStr t = fmap fromString $ Time.formatTime <$> getTimeLocale <*> p
|
||||
|
||||
-- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
|
||||
-- Restricted type for safety
|
||||
formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> t -> m Text
|
||||
formatTime :: (HasLocalTime t, MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> m Text
|
||||
formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj)
|
||||
|
||||
-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
|
||||
-- formatTimeH = formatTime
|
||||
|
||||
formatTimeW :: (HasLocalTime t) => SelDateTimeFormat -> t -> Widget
|
||||
formatTimeW :: (HasLocalTime t, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> WidgetFor UniWorX ()
|
||||
formatTimeW s t = toWidget =<< formatTime s t
|
||||
|
||||
formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text
|
||||
@ -92,7 +93,7 @@ formatTimeMail sel t = fmap fromString $ Time.formatTime <$> (getTimeLocale' . v
|
||||
getTimeLocale :: MonadHandler m => m TimeLocale
|
||||
getTimeLocale = getTimeLocale' <$> languages
|
||||
|
||||
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX) => SelDateTimeFormat -> m DateTimeFormat
|
||||
getDateTimeFormat :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> m DateTimeFormat
|
||||
getDateTimeFormat sel = do
|
||||
mauth <- liftHandler maybeAuth
|
||||
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
|
||||
@ -110,7 +111,7 @@ getDateTimeFormat sel = do
|
||||
SelFormatTime -> userDefaultTimeFormat
|
||||
return fmt
|
||||
|
||||
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX) => m DateTimeFormatter
|
||||
getDateTimeFormatter :: (MonadHandler m, HandlerSite m ~ UniWorX, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => m DateTimeFormatter
|
||||
getDateTimeFormatter = do
|
||||
locale <- getTimeLocale
|
||||
formatMap <- traverse getDateTimeFormat id
|
||||
@ -280,6 +281,7 @@ formatTimeRange' cont proj startT endT = do
|
||||
formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
|
||||
, MonadHandler m
|
||||
, HandlerSite m ~ UniWorX
|
||||
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
||||
)
|
||||
=> SelDateTimeFormat
|
||||
-> t -- ^ Start
|
||||
@ -287,14 +289,14 @@ formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
|
||||
-> m Text
|
||||
formatTimeRange = formatTimeRange' formatTime
|
||||
|
||||
formatTimeRangeW :: (HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> Widget
|
||||
formatTimeRangeW :: (HasLocalTime t, HasLocalTime t', YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => SelDateTimeFormat -> t -> Maybe t' -> WidgetFor UniWorX ()
|
||||
formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t'
|
||||
|
||||
formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text
|
||||
formatTimeRangeMail = formatTimeRange' formatTimeMail
|
||||
|
||||
|
||||
formatGregorianW :: Integer -> Int -> Int -> Widget
|
||||
formatGregorianW :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId) => Integer -> Int -> Int -> WidgetFor UniWorX ()
|
||||
formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
|
||||
|
||||
instance Csv.ToField ZonedTime where
|
||||
|
||||
217
src/Handler/Utils/Download.hs
Normal file
217
src/Handler/Utils/Download.hs
Normal file
@ -0,0 +1,217 @@
|
||||
module Handler.Utils.Download
|
||||
( withFileDownloadTokenMaybe', withFileDownloadToken, withFileDownloadToken'
|
||||
, sendThisFile
|
||||
, sendFileReference
|
||||
, serveOneFile
|
||||
, serveSomeFiles
|
||||
, serveSomeFiles'
|
||||
, serveZipArchive
|
||||
, serveZipArchive'
|
||||
) where
|
||||
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
import Foundation.Authorization
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
|
||||
import Handler.Utils.Zip
|
||||
import Handler.Utils.ContentDisposition
|
||||
import Handler.Utils.Files
|
||||
|
||||
|
||||
data DownloadTokenRestriction
|
||||
= DownloadRestrictSingle { downloadRestrictReference :: FileContentReference }
|
||||
| DownloadRestrictMultiple
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 2
|
||||
, fieldLabelModifier = camelToPathPiece' 2
|
||||
} ''DownloadTokenRestriction
|
||||
|
||||
withFileDownloadTokenMaybe' :: forall url m.
|
||||
( HasRoute UniWorX url
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
||||
)
|
||||
=> Maybe (ConduitT () (Either FileReference DBFile) m ())
|
||||
-> url
|
||||
-> m (SomeRoute UniWorX)
|
||||
withFileDownloadTokenMaybe' mSource route = maybeT (return $ SomeRoute route) $ do
|
||||
let rApproot = authoritiveApproot $ urlRoute route
|
||||
case rApproot of
|
||||
ApprootDefault -> mzero
|
||||
_other -> return ()
|
||||
guardM . getsYesod $ \app -> views _appRoot (is _Just . ($ rApproot)) app
|
||||
&& views _appRoot ($ ApprootDefault) app /= views _appRoot ($ rApproot) app
|
||||
|
||||
uid <- MaybeT maybeAuthId
|
||||
now <- liftIO getCurrentTime
|
||||
expireOffset <- getsYesod $ view _appDownloadTokenExpire
|
||||
restr <- case mSource of
|
||||
Just source -> do
|
||||
results <- lift . runConduit $ source .| C.take 2 .| C.foldMap (pure . either Just (const Nothing))
|
||||
return $ case results of
|
||||
[Just (FileReference{ fileReferenceContent = Just ref })] -> DownloadRestrictSingle ref
|
||||
_other -> DownloadRestrictMultiple
|
||||
Nothing -> return DownloadRestrictMultiple
|
||||
bearer <- lift $ bearerRestrict (urlRoute route) restr <$> bearerToken
|
||||
(HashSet.singleton $ Right uid)
|
||||
(Just uid)
|
||||
(HashMap.singleton BearerTokenRouteAccess . HashSet.singleton $ urlRoute route)
|
||||
Nothing
|
||||
(Just . Just $ addUTCTime expireOffset now)
|
||||
(Just now)
|
||||
encodedBearer <- lift $ encodeBearer bearer
|
||||
|
||||
lift . setDownload $ SomeRoute @UniWorX route
|
||||
& over (urlRouteParams $ Proxy @UniWorX) ((toPathPiece GetBearer, toPathPiece encodedBearer) :)
|
||||
|
||||
where
|
||||
setDownload :: SomeRoute UniWorX -> m (SomeRoute UniWorX)
|
||||
setDownload route' = do
|
||||
wantsDownload <- downloadFiles
|
||||
return $ route'
|
||||
& over (urlRouteParams $ Proxy @UniWorX) (bool id addDownload wantsDownload)
|
||||
where
|
||||
addDownload params | anyOf (folded . _1) (== toPathPiece GetDownload) params = params
|
||||
| otherwise = (toPathPiece GetDownload, mempty) : params
|
||||
|
||||
withFileDownloadToken' :: forall file url m.
|
||||
( HasFileReference file
|
||||
, HasRoute UniWorX url
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
|
||||
)
|
||||
=> ConduitT () (Either file DBFile) m ()
|
||||
-> url
|
||||
-> m (SomeRoute UniWorX)
|
||||
withFileDownloadToken' = withFileDownloadTokenMaybe' . Just . (.| C.map (first . view $ _FileReference . _1))
|
||||
|
||||
|
||||
withFileDownloadToken :: forall file url m.
|
||||
( HasFileReference file
|
||||
, HasRoute UniWorX url
|
||||
, MonadHandler m, HandlerSite m ~ UniWorX
|
||||
, MonadCrypto m
|
||||
, MonadCryptoKey m ~ CryptoIDKey
|
||||
, BearerAuthSite UniWorX
|
||||
)
|
||||
=> ConduitT () file m ()
|
||||
-> url
|
||||
-> m (SomeRoute UniWorX)
|
||||
withFileDownloadToken = withFileDownloadToken' . (.| C.map Left)
|
||||
|
||||
-- | Simply send a `File`-Value
|
||||
sendThisFile :: (YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId, YesodPersistRunner UniWorX) => DBFile -> HandlerFor UniWorX TypedContent
|
||||
sendThisFile File{..}
|
||||
| Just fileContent' <- fileContent = do
|
||||
setCSPSandbox
|
||||
setContentDisposition' . Just $ takeFileName fileTitle
|
||||
let cType = simpleContentType (mimeLookup $ pack fileTitle) <> "; charset=utf-8"
|
||||
respondSourceDB cType $
|
||||
fileContent' .| C.map toFlushBuilder
|
||||
| otherwise = sendResponseStatus noContent204 ()
|
||||
|
||||
sendFileReference :: forall file a.
|
||||
( HasFileReference file
|
||||
, BearerAuthSite UniWorX
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, YesodPersistRunner UniWorX
|
||||
)
|
||||
=> file -> HandlerFor UniWorX a
|
||||
sendFileReference (view (_FileReference . _1) -> fRef@FileReference{..}) = do
|
||||
whenIsJust fileReferenceContent $ \fRef' -> do
|
||||
dlRestr <- maybeCurrentBearerRestrictions
|
||||
case dlRestr of
|
||||
Just (DownloadRestrictSingle restrRef) | restrRef == fRef' -> return ()
|
||||
_other -> setCSPSandbox
|
||||
setContentDisposition' . Just $ takeFileName fileReferenceTitle
|
||||
let cType = simpleContentType (mimeLookup $ pack fileReferenceTitle) <> "; charset=utf-8"
|
||||
join . runDB $ respondFileConditional Nothing cType fRef
|
||||
|
||||
-- | Serve a single file, identified through a given DB query
|
||||
serveOneFile :: forall file.
|
||||
( HasFileReference file
|
||||
, BearerAuthSite UniWorX
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, YesodPersistRunner UniWorX
|
||||
) => ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveOneFile source = do
|
||||
results <- runDB . runConduit $ source .| C.take 2 .| C.foldMap pure -- We don't need more than two files to make a decision below
|
||||
case results of
|
||||
[file] -> sendFileReference file
|
||||
[] -> notFound
|
||||
_other -> do
|
||||
$logErrorS "SFileR" "Multiple matching files found."
|
||||
error "Multiple matching files found."
|
||||
|
||||
-- | Serve one file directly or a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveOneFile`, but sends a zip-archive if multiple results are returned
|
||||
serveSomeFiles :: forall file.
|
||||
( HasFileReference file
|
||||
, BearerAuthSite UniWorX
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, YesodPersistRunner UniWorX
|
||||
) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveSomeFiles archiveName source = serveSomeFiles' archiveName $ source .| C.map Left
|
||||
|
||||
serveSomeFiles' :: forall file.
|
||||
( HasFileReference file
|
||||
, BearerAuthSite UniWorX
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, YesodPersistRunner UniWorX
|
||||
) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveSomeFiles' archiveName source = do
|
||||
(source', results) <- runDB $ runPeekN 2 source
|
||||
|
||||
$logDebugS "serveSomeFiles" . tshow $ length results
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
[file] -> either sendFileReference sendThisFile file
|
||||
_moreFiles -> do
|
||||
setCSPSandbox
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB typeZip $ do
|
||||
let zipComment = encodeUtf8 $ pack archiveName
|
||||
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder
|
||||
|
||||
-- | Serve any number of files as a zip-archive of files, identified through a given DB query
|
||||
--
|
||||
-- Like `serveSomeFiles`, but always sends a zip-archive, even if a single file is returned
|
||||
serveZipArchive :: forall file.
|
||||
( HasFileReference file
|
||||
, BearerAuthSite UniWorX
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, YesodPersistRunner UniWorX
|
||||
) => FilePath -> ConduitT () file (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveZipArchive archiveName source = serveZipArchive' archiveName $ source .| C.map Left
|
||||
|
||||
serveZipArchive' :: forall file.
|
||||
( HasFileReference file
|
||||
, BearerAuthSite UniWorX
|
||||
, YesodPersistBackend UniWorX ~ SqlBackend
|
||||
, YesodPersistRunner UniWorX
|
||||
) => FilePath -> ConduitT () (Either file DBFile) (YesodDB UniWorX) () -> HandlerFor UniWorX TypedContent
|
||||
serveZipArchive' archiveName source = do
|
||||
(source', results) <- runDB $ runPeekN 1 source
|
||||
|
||||
$logDebugS "serveZipArchive" . tshow $ length results
|
||||
|
||||
case results of
|
||||
[] -> notFound
|
||||
_moreFiles -> do
|
||||
setCSPSandbox
|
||||
setContentDisposition' $ Just archiveName
|
||||
respondSourceDB typeZip $ do
|
||||
let zipComment = encodeUtf8 $ pack archiveName
|
||||
source' .| eitherC sourceFiles' (C.map id) .| produceZip ZipInfo{..} .| C.map toFlushBuilder
|
||||
@ -7,7 +7,9 @@ module Handler.Utils.Files
|
||||
, respondFileConditional
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import.NoFoundation
|
||||
import Foundation.Type
|
||||
import Utils.Metrics
|
||||
|
||||
import qualified Data.Conduit.Combinators as C
|
||||
import qualified Data.Conduit.List as C (unfoldM)
|
||||
@ -77,10 +79,11 @@ sourceFileMinio fileReference = do
|
||||
in go
|
||||
|
||||
|
||||
sourceFiles :: Monad m => ConduitT FileReference DBFile m ()
|
||||
sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m ()
|
||||
sourceFiles = C.map sourceFile
|
||||
|
||||
sourceFile :: FileReference -> DBFile
|
||||
sourceFile :: YesodPersistBackend UniWorX ~ SqlBackend
|
||||
=> FileReference -> DBFile
|
||||
sourceFile FileReference{..} = File
|
||||
{ fileTitle = fileReferenceTitle
|
||||
, fileModified = fileReferenceModified
|
||||
@ -94,16 +97,16 @@ sourceFile FileReference{..} = File
|
||||
inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
|
||||
bool sourceFileMinio sourceFileDB inDB fileReference
|
||||
|
||||
sourceFiles' :: forall file m. (HasFileReference file, Monad m) => ConduitT file DBFile m ()
|
||||
sourceFiles' :: forall file m. (HasFileReference file, Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT file DBFile m ()
|
||||
sourceFiles' = C.map sourceFile'
|
||||
|
||||
sourceFile' :: forall file. HasFileReference file => file -> DBFile
|
||||
sourceFile' :: forall file. (HasFileReference file, YesodPersistBackend UniWorX ~ SqlBackend) => file -> DBFile
|
||||
sourceFile' = sourceFile . view (_FileReference . _1)
|
||||
|
||||
respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX)
|
||||
respondFileConditional :: (MonadThrow m, MonadHandler m, HandlerSite m ~ UniWorX, YesodPersistBackend UniWorX ~ SqlBackend, YesodPersistRunner UniWorX)
|
||||
=> Maybe UTCTime -> MimeType
|
||||
-> FileReference
|
||||
-> SqlPersistT m (Handler a)
|
||||
-> SqlPersistT m (HandlerFor UniWorX a)
|
||||
respondFileConditional representationLastModified cType FileReference{..} = do
|
||||
if
|
||||
| Just fileContent <- fileReferenceContent
|
||||
|
||||
@ -26,6 +26,7 @@ import Text.Hamlet
|
||||
import qualified Data.Conduit.List as C
|
||||
import qualified Data.List.NonEmpty as NonEmpty
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Aeson (fromJSON)
|
||||
@ -215,7 +216,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
|
||||
jInviter <- liftHandler maybeAuthId
|
||||
route <- mapReaderT liftHandler $ invitationRoute fEnt dat
|
||||
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig fEnt dat
|
||||
protoToken <- bearerToken itAuthority (Just . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
protoToken <- bearerToken itAuthority Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ urlRoute route) itAddAuth itExpiresAt itStartsAt
|
||||
let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
|
||||
bearer <- encodeBearer token
|
||||
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])
|
||||
|
||||
@ -104,11 +104,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
|
||||
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
|
||||
|
||||
-- | for simple file downloads
|
||||
fileCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
||||
fileCell :: IsDBTable m a => (Route UniWorX, [(Text, Text)]) -> DBCell m a
|
||||
fileCell route = anchorCell route iconFileDownload
|
||||
|
||||
-- | for zip-archive downloads
|
||||
zipCell :: IsDBTable m a => Route UniWorX -> DBCell m a
|
||||
zipCell :: IsDBTable m a => (Route UniWorX, [(Text, Text)]) -> DBCell m a
|
||||
zipCell route = anchorCell route iconFileZip
|
||||
|
||||
-- | for csv downloads
|
||||
|
||||
@ -25,6 +25,7 @@ import Handler.Utils.Form
|
||||
import Handler.Utils.Widgets
|
||||
import Handler.Utils.DateTime
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Handler.Utils.Download
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -375,7 +376,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
|
||||
| showLink
|
||||
-> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
|
||||
cID <- encrypt appId
|
||||
return $ CApplicationR tid ssh csh cID CAFilesR
|
||||
liftHandler . runDB . withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR tid ssh csh cID CAFilesR
|
||||
| otherwise
|
||||
-> mempty
|
||||
|
||||
|
||||
@ -31,11 +31,13 @@ visibleUTCTime dtf t = do
|
||||
|
||||
|
||||
-- | Simple link to a known route
|
||||
simpleLink :: Widget -> Route UniWorX -> Widget
|
||||
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|]
|
||||
simpleLink :: RedirectUrl UniWorX url => Widget -> url -> Widget
|
||||
simpleLink lbl url = do
|
||||
tUrl <- toTextUrl url
|
||||
[whamlet|<a href=#{tUrl}>^{lbl}|]
|
||||
|
||||
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget
|
||||
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{lbl}|]
|
||||
simpleLinkI :: (RenderMessage UniWorX msg, RedirectUrl UniWorX url) => msg -> url -> Widget
|
||||
simpleLinkI = simpleLink . i18n
|
||||
|
||||
-- | toWidget-Version of @nameHtml@, for convenience
|
||||
nameWidget :: Text -- ^ userDisplayName
|
||||
|
||||
@ -11,7 +11,7 @@ module Handler.Utils.Zip
|
||||
, receiveFiles, acceptFile
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Import.NoFoundation
|
||||
|
||||
import Handler.Utils.Files (acceptFile)
|
||||
import Handler.Utils.DateTime (localTimeToUTCSimple, utcToLocalTime)
|
||||
|
||||
@ -4,7 +4,7 @@ module Handler.Workflow.Workflow.Workflow
|
||||
, workflowR
|
||||
) where
|
||||
|
||||
import Import hiding (Last(..))
|
||||
import Import hiding (Last(..), Encoding(None))
|
||||
|
||||
import Utils.Form
|
||||
import Utils.Workflow
|
||||
@ -44,7 +44,7 @@ data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHI
|
||||
data WorkflowHistoryItem = WorkflowHistoryItem
|
||||
{ whiUser :: Maybe WorkflowHistoryItemActor
|
||||
, whiTime :: UTCTime
|
||||
, whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))]
|
||||
, whiPayloadChanges :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
|
||||
, whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
|
||||
, whiVia :: Maybe Text
|
||||
, whiTo :: Maybe Text
|
||||
@ -53,11 +53,27 @@ data WorkflowHistoryItem = WorkflowHistoryItem
|
||||
data WorkflowCurrentState = WorkflowCurrentState
|
||||
{ wcsState :: Maybe Text
|
||||
, wcsMessages :: Set Message
|
||||
, wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))]
|
||||
, wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
|
||||
}
|
||||
|
||||
makePrisms ''WorkflowHistoryItemActor
|
||||
|
||||
data OneOrMany a = None | One a | Many
|
||||
deriving (Eq, Ord, Read, Show, Functor, Traversable, Foldable, Generic, Typeable)
|
||||
|
||||
instance Semigroup (OneOrMany a) where
|
||||
None <> x = x
|
||||
x <> None = x
|
||||
_ <> _ = Many
|
||||
instance Monoid (OneOrMany a) where
|
||||
mempty = None
|
||||
|
||||
oneOrMany :: b -> (a -> b) -> b -> OneOrMany a -> b
|
||||
oneOrMany onNone onOne onMany = \case
|
||||
None -> onNone
|
||||
One x -> onOne x
|
||||
Many -> onMany
|
||||
|
||||
|
||||
getGWWWorkflowR, postGWWWorkflowR :: CryptoFileNameWorkflowWorkflow -> Handler Html
|
||||
getGWWWorkflowR = postGWWWorkflowR
|
||||
@ -155,6 +171,8 @@ workflowR rScope cID = do
|
||||
-> WorkflowFieldPayloadW Void (Maybe (Entity User))
|
||||
-> Ordering
|
||||
payloadSort (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of
|
||||
(WFPFile a', _ ) -> absurd a'
|
||||
(_, WFPFile a' ) -> absurd a'
|
||||
(WFPText a', WFPText b' ) -> compareUnicode a' b'
|
||||
(WFPText{}, _ ) -> LT
|
||||
(WFPNumber a', WFPNumber b') -> compare a' b'
|
||||
@ -169,7 +187,6 @@ workflowR rScope cID = do
|
||||
(WFPDay{}, WFPNumber{} ) -> GT
|
||||
(WFPDay{}, WFPBool{} ) -> GT
|
||||
(WFPDay{}, _ ) -> LT
|
||||
(WFPFile a', _ ) -> absurd a'
|
||||
(WFPUser a', WFPUser b' ) -> case (a', b') of
|
||||
(Nothing, _) -> GT
|
||||
(_, Nothing) -> LT
|
||||
@ -178,13 +195,13 @@ workflowR rScope cID = do
|
||||
<> (compareUnicode `on` userDisplayName) uA uB
|
||||
<> comparing userIdent uA uB
|
||||
(WFPUser{}, _ ) -> GT
|
||||
forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort) . over _2 (bool Nothing (Just fRoute). getAny)) . execWriterT . forM_ payloads $ \case
|
||||
WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
|
||||
WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True)
|
||||
WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
|
||||
forM payload' $ \(lblText, (otoList -> payloads, fRoute)) -> fmap ((lblText, ) . over _1 (sortBy payloadSort)) . mapMOf _2 (traverse toTextUrl <=< oneOrMany (return Nothing) (\fRef -> Just <$> withFileDownloadToken (yield fRef) fRoute) (Just <$> withFileDownloadTokenMaybe' Nothing fRoute)) <=< execWriterT @_ @(_, OneOrMany FileReference). forM_ payloads $ \case
|
||||
WorkflowFieldPayloadW (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
|
||||
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
|
||||
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
|
||||
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
|
||||
WorkflowFieldPayloadW (WFPFile fRef) -> tell (mempty, One fRef)
|
||||
WorkflowFieldPayloadW (WFPUser uid ) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
|
||||
|
||||
payloadChanges <- State.state $ \oldPayload ->
|
||||
( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload
|
||||
|
||||
@ -13,6 +13,7 @@ import Utils.Frontend.Notification as Import
|
||||
import Utils.Lens as Import
|
||||
import Utils.Failover as Import
|
||||
import Utils.Room as Import
|
||||
import Utils.Approot as Import
|
||||
|
||||
import Settings as Import
|
||||
import Settings.StaticFiles as Import
|
||||
|
||||
@ -6,13 +6,14 @@ import Import
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> JobHandler UniWorX
|
||||
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do
|
||||
bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) (Just $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
|
||||
bearer <- bearerRestrict SetDisplayEmailR jDisplayEmail <$> bearerToken (HashSet.singleton $ Right jUser) Nothing (HashMap.singleton BearerTokenRouteEval $ HashSet.singleton SetDisplayEmailR) Nothing Nothing Nothing
|
||||
jwt <- encodeBearer bearer
|
||||
let
|
||||
setDisplayEmailUrl :: SomeRoute UniWorX
|
||||
|
||||
@ -8,6 +8,7 @@ import Import
|
||||
import Text.Hamlet
|
||||
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
|
||||
ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX)
|
||||
@ -16,7 +17,7 @@ ihamletSomeMessage f trans = f $ trans . SomeMessage
|
||||
mkEditNotifications :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
|
||||
mkEditNotifications uid = liftHandler $ do
|
||||
cID <- encrypt uid
|
||||
jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) (Just . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
|
||||
jwt <- encodeBearer =<< bearerToken (HashSet.singleton $ Right uid) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserNotificationR cID) Nothing Nothing Nothing
|
||||
let
|
||||
editNotificationsUrl :: SomeRoute UniWorX
|
||||
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])
|
||||
|
||||
@ -10,6 +10,7 @@ import Handler.Utils.Users
|
||||
import qualified Data.ByteString.Base64 as Base64
|
||||
import qualified Data.ByteArray as BA
|
||||
import qualified Data.HashSet as HashSet
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Text.Hamlet
|
||||
|
||||
@ -29,7 +30,7 @@ dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecip
|
||||
LTUUnique utc' _ -> utc'
|
||||
_other -> UTCTime (addDays 2 $ utctDay now) 0
|
||||
|
||||
resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) (Just . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
|
||||
resetBearer' <- bearerToken (HashSet.singleton $ Right jRecipient) Nothing (HashMap.singleton BearerTokenRouteEval . HashSet.singleton $ UserPasswordR cID) Nothing (Just $ Just tomorrowEndOfDay) Nothing
|
||||
let resetBearer = resetBearer'
|
||||
& bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
|
||||
encodedBearer <- encodeBearer resetBearer
|
||||
|
||||
@ -82,7 +82,7 @@ dispatchHealthCheckMatchingClusterConfig
|
||||
|
||||
dispatchHealthCheckHTTPReachable :: Handler HealthReport
|
||||
dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _appHealthCheckHTTPReachableTimeout) (Just False) $ do
|
||||
staticAppRoot <- getsYesod $ view _appRoot
|
||||
staticAppRoot <- getsYesod $ views _appRoot ($ ApprootDefault)
|
||||
doHTTP <- getsYesod $ view _appHealthCheckHTTP
|
||||
for (staticAppRoot <* guard doHTTP) $ \_ -> do
|
||||
url <- getUrlRender <*> pure InstanceR
|
||||
|
||||
@ -2,7 +2,7 @@
|
||||
{-# LANGUAGE UndecidableInstances #-}
|
||||
|
||||
module Model.Tokens.Bearer
|
||||
( BearerToken(..)
|
||||
( BearerToken(..), BearerTokenRouteMode(..)
|
||||
, _bearerIdentifier, _bearerAuthority, _bearerRoutes, _bearerAddAuth, _bearerRestrictions, _bearerRestrictionIx, _bearerRestrictionAt, _bearerIssuedAt, _bearerIssuedBy, _bearerExpiresAt, _bearerStartsAt
|
||||
, bearerRestrict
|
||||
, bearerToJSON, bearerParseJSON
|
||||
@ -16,6 +16,9 @@ import Model.Tokens.Lens
|
||||
import Utils (assertM', foldMapM)
|
||||
import Utils.Lens hiding ((.=))
|
||||
import Data.Aeson.Lens (AsJSON(..))
|
||||
import Utils.PathPiece
|
||||
|
||||
import Data.Universe
|
||||
|
||||
import Yesod.Auth (AuthId)
|
||||
|
||||
@ -42,13 +45,26 @@ import qualified Data.CryptoID.Class.ImplicitNamespace as I
|
||||
|
||||
|
||||
|
||||
data BearerTokenRouteMode
|
||||
= BearerTokenRouteEval -- ^ Token is not to be evaluated for routes outside of the given restriction
|
||||
| BearerTokenRouteAccess -- ^ Token may be evaluated for routes outside of the given restriction, but not if the initial request was outside the restriction
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, Hashable, Binary)
|
||||
nullaryPathPiece ''BearerTokenRouteMode $ camelToPathPiece' 3
|
||||
pathPieceJSON ''BearerTokenRouteMode
|
||||
pathPieceJSONKey ''BearerTokenRouteMode
|
||||
instance Default BearerTokenRouteMode where
|
||||
def = BearerTokenRouteEval
|
||||
|
||||
-- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
|
||||
data BearerToken site = BearerToken
|
||||
{ bearerIdentifier :: TokenId
|
||||
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
|
||||
, bearerAuthority :: HashSet (Either Value (AuthId site))
|
||||
-- ^ Tokens only grant rights the `bearerAuthority` has (i.e. `AuthTag`s are evaluated with the user set to `bearerAuthority`)
|
||||
, bearerRoutes :: Maybe (HashSet (Route site))
|
||||
, bearerImpersonate :: Maybe (AuthId site)
|
||||
-- ^ Token doubles as session token; i.e. if presented `maybeAuthId` etc. should evaluate to the given value
|
||||
, bearerRoutes :: HashMap BearerTokenRouteMode (HashSet (Route site))
|
||||
-- ^ Tokens can optionally be restricted to only be usable on a subset of routes
|
||||
, bearerAddAuth :: Maybe AuthDNF
|
||||
-- ^ Tokens can specify an additional predicate logic formula of `AuthTag`s that needs to evaluate to `Authorized` in order for the token to be valid.
|
||||
@ -125,9 +141,12 @@ bearerToJSON BearerToken{..} = do
|
||||
|
||||
authorityToJSON auths | [auth] <- otoList auths = either toJSON toJSON auth
|
||||
| otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths
|
||||
iCID <- traverse I.encrypt bearerImpersonate :: m (Maybe (CryptoUUID (AuthId (HandlerSite m))))
|
||||
|
||||
return . JSON.object $
|
||||
catMaybes [ Just $ "authority" .= authorityToJSON cID
|
||||
, ("routes" .=) <$> bearerRoutes
|
||||
, ("impersonate" .=) <$> iCID
|
||||
, ("routes" .=) <$> assertM' (not . HashMap.null) bearerRoutes
|
||||
, ("add-auth" .=) <$> bearerAddAuth
|
||||
, ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions
|
||||
]
|
||||
@ -154,7 +173,9 @@ bearerParseJSON v@(Object o) = do
|
||||
] :: ReaderT CryptoIDKey Parser (HashSet (Either Value (CryptoUUID (AuthId site))))
|
||||
bearerAuthority <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.decrypt)) bearerAuthority'
|
||||
|
||||
bearerRoutes <- lift $ o .:? "routes"
|
||||
bearerImpersonate <- traverse I.decrypt <=< lift $ (o .:? "impersonate" :: Parser (Maybe (CryptoUUID (AuthId site))))
|
||||
bearerRoutes <- lift $ (o .:? "routes" .!= HashMap.empty)
|
||||
<|> (maybe HashMap.empty (HashMap.singleton def) <$> o .:? "routes")
|
||||
bearerAddAuth <- lift $ o .:? "add-auth"
|
||||
bearerRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
|
||||
Jose.JwtClaims{..} <- lift $ parseJSON v
|
||||
|
||||
@ -94,7 +94,7 @@ data AppSettings = AppSettings
|
||||
-- ^ Configuration settings for accessing a SMTP Mailserver
|
||||
, appWidgetMemcachedConf :: Maybe WidgetMemcachedConf
|
||||
-- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent`
|
||||
, appRoot :: Maybe Text
|
||||
, appRoot :: ApprootScope -> Maybe Text
|
||||
-- ^ Base for all generated URLs. If @Nothing@, determined
|
||||
-- from the request headers.
|
||||
, appHost :: HostPreference
|
||||
@ -196,10 +196,16 @@ data AppSettings = AppSettings
|
||||
|
||||
, appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime
|
||||
|
||||
, appDownloadTokenExpire :: NominalDiffTime
|
||||
|
||||
, appInitialInstanceID :: Maybe (Either FilePath UUID)
|
||||
, appRibbon :: Maybe Text
|
||||
} deriving Show
|
||||
|
||||
data ApprootScope = ApprootUserGenerated | ApprootDefault
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
|
||||
deriving anyclass (Universe, Finite, Hashable)
|
||||
|
||||
|
||||
newtype ServerSessionSettings
|
||||
= ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
|
||||
@ -308,6 +314,12 @@ data VerpMode = VerpNone
|
||||
| Verp { verpPrefix :: Text, verpSeparator :: Char }
|
||||
deriving (Eq, Show, Read, Generic)
|
||||
|
||||
nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
|
||||
pathPieceJSON ''ApprootScope
|
||||
pathPieceJSONKey ''ApprootScope
|
||||
pathPieceBinary ''ApprootScope
|
||||
pathPieceHttpApiData ''ApprootScope
|
||||
|
||||
deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
, fieldLabelModifier = camelToPathPiece' 1
|
||||
@ -456,7 +468,7 @@ instance FromJSON AppSettings where
|
||||
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
|
||||
appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
|
||||
appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached"
|
||||
appRoot <- o .:? "approot"
|
||||
appRoot <- o .:? "approot" .!= const Nothing
|
||||
appHost <- fromString <$> o .: "host"
|
||||
appPort <- o .: "port"
|
||||
appIpFromHeader <- o .: "ip-from-header"
|
||||
@ -564,6 +576,8 @@ instance FromJSON AppSettings where
|
||||
|
||||
appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire"
|
||||
|
||||
appDownloadTokenExpire <- o .: "download-token-expire"
|
||||
|
||||
return AppSettings{..}
|
||||
|
||||
makeClassy_ ''AppSettings
|
||||
|
||||
18
src/Utils/Approot.hs
Normal file
18
src/Utils/Approot.hs
Normal file
@ -0,0 +1,18 @@
|
||||
module Utils.Approot
|
||||
( approotScopeHost
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
import Settings
|
||||
|
||||
import qualified Network.URI as URI
|
||||
|
||||
import Control.Lens
|
||||
|
||||
|
||||
approotScopeHost :: HasAppSettings site => ApprootScope -> site -> Maybe ByteString
|
||||
approotScopeHost rApproot app = do
|
||||
approotText <- views _appRoot ($ rApproot) app
|
||||
approotURI <- URI.parseURI $ unpack approotText
|
||||
approotAuthority <- URI.uriAuthority approotURI
|
||||
return . encodeUtf8 . pack $ URI.uriRegName approotAuthority <> URI.uriPort approotAuthority
|
||||
@ -21,7 +21,7 @@ import Data.Universe
|
||||
import Control.Monad.Trans.Maybe (MaybeT(..))
|
||||
|
||||
|
||||
data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun
|
||||
data GlobalGetParam = GetLang | GetReferer | GetBearer | GetRecipient | GetCsvExampleData | GetDryRun | GetDownload
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic)
|
||||
deriving anyclass (Universe, Finite)
|
||||
|
||||
|
||||
@ -2,22 +2,40 @@ module Utils.Route where
|
||||
|
||||
import Control.Lens
|
||||
import ClassyPrelude.Yesod -- hiding (foldlM)
|
||||
import Data.Kind (Type)
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
class RedirectUrl site url => HasRoute site url where
|
||||
type RouteWithParams site url :: Type
|
||||
type RouteWithParams site url = (Route site, [(Text, Text)])
|
||||
urlRoute :: url -> Route site
|
||||
urlRouteParams :: forall p. p site -> Lens url (RouteWithParams site url) [(Text, Text)] [(Text, Text)]
|
||||
default urlRouteParams :: forall p.
|
||||
RouteWithParams site url ~ (Route site, [(Text, Text)])
|
||||
=> p site
|
||||
-> Lens url (RouteWithParams site url) [(Text, Text)] [(Text, Text)]
|
||||
urlRouteParams _ = lens (const []) (\(urlRoute -> route') params -> (route', params))
|
||||
|
||||
instance HasRoute site (Route site) where
|
||||
urlRoute = id
|
||||
-- | for GET-Parameters
|
||||
instance (key ~ Text) => HasRoute site (Route site, Map key Text) where
|
||||
urlRoute = view _1
|
||||
urlRouteParams _ = lens (views _2 Map.toList) (\(route, _) params -> (route, params))
|
||||
-- | for GET-Parameters
|
||||
instance (key ~ Text) => HasRoute site (Route site, [(key, Text)]) where
|
||||
urlRoute = view _1
|
||||
urlRouteParams _ = _2
|
||||
-- | for PageAnchors, implemented through Fragments
|
||||
instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where
|
||||
type RouteWithParams site (Fragment a b) = Fragment (RouteWithParams site a) b
|
||||
urlRoute (a :#: _) = urlRoute a
|
||||
urlRouteParams pSite = fragRoute . urlRouteParams pSite
|
||||
where
|
||||
fragRoute :: forall a1 a2 b'. Lens (Fragment a1 b') (Fragment a2 b') a1 a2
|
||||
fragRoute = lens (\(a :#: _) -> a) (\(_ :#: f) a' -> a' :#: f)
|
||||
|
||||
data SomeRoute site = forall url. HasRoute site url => SomeRoute url
|
||||
deriving (Typeable)
|
||||
@ -25,4 +43,6 @@ data SomeRoute site = forall url. HasRoute site url => SomeRoute url
|
||||
instance RedirectUrl site (SomeRoute site) where
|
||||
toTextUrl (SomeRoute url) = toTextUrl url
|
||||
instance HasRoute site (SomeRoute site) where
|
||||
type RouteWithParams site (SomeRoute site) = SomeRoute site
|
||||
urlRoute (SomeRoute url) = urlRoute url
|
||||
urlRouteParams pSite = lens (\(SomeRoute url) -> withLens (urlRouteParams pSite) $ \g _ -> g url) (\(SomeRoute url) params -> SomeRoute (urlRoute url :: Route site, params))
|
||||
|
||||
@ -53,14 +53,15 @@ bearerToken :: forall m.
|
||||
, HasClusterID (HandlerSite m) ClusterId
|
||||
, HasAppSettings (HandlerSite m)
|
||||
)
|
||||
=> HashSet (Either Value (AuthId (HandlerSite m)))
|
||||
-> Maybe (HashSet (Route (HandlerSite m)))
|
||||
-> Maybe AuthDNF
|
||||
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically
|
||||
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately
|
||||
=> HashSet (Either Value (AuthId (HandlerSite m))) -- ^ Authority
|
||||
-> Maybe (AuthId (HandlerSite m)) -- ^ Impersonate
|
||||
-> HashMap BearerTokenRouteMode (HashSet (Route (HandlerSite m)))
|
||||
-> Maybe AuthDNF -- ^ Additional auth
|
||||
-> Maybe (Maybe UTCTime) -- ^ Expiration; @Nothing@ determines default expiry time automatically
|
||||
-> Maybe UTCTime -- ^ Start of Validity; @Nothing@ means token starts to be valid immediately
|
||||
-> m (BearerToken (HandlerSite m))
|
||||
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict`
|
||||
bearerToken bearerAuthority bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
|
||||
bearerToken bearerAuthority bearerImpersonate bearerRoutes bearerAddAuth mBearerExpiresAt bearerStartsAt = do
|
||||
bearerIdentifier <- liftIO getRandom
|
||||
bearerIssuedAt <- liftIO getCurrentTime
|
||||
bearerIssuedBy <- getsYesod $ view instanceID
|
||||
|
||||
@ -40,9 +40,9 @@ $if hasApplicationTemplate || is _Just courseApplicationsInstructions
|
||||
$maybe aInst <- courseApplicationsInstructions
|
||||
<p>
|
||||
#{aInst}
|
||||
$if hasApplicationTemplate
|
||||
$maybe templateUrl <- mApplicationTemplate
|
||||
<p>
|
||||
<a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}>
|
||||
<a href=#{templateUrl}>
|
||||
#{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
|
||||
$maybe ApplicationFormView{ ..} <- mApplyFormView'
|
||||
<div .allocation-course__application-label .allocation__label :not overrideVisible:uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>
|
||||
|
||||
@ -44,7 +44,7 @@
|
||||
<tr .table__row>
|
||||
<th .table__th>_{MsgRatingFiles}
|
||||
<td .table__td>
|
||||
<a href=@{CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected}>
|
||||
<a href=#{urlArchive}>
|
||||
_{MsgRatingUpdatedFiles}
|
||||
|
||||
$maybe comment <- ratingComment
|
||||
|
||||
@ -8,7 +8,7 @@ $newline never
|
||||
<dd .deflist__dd>
|
||||
$if not (null news)
|
||||
<ul .course-news .list--iconless>
|
||||
$forall (cID, CourseNews{courseNewsTitle, courseNewsSummary, courseNewsContent}, isVisible, files, lastEditText, mayEditNews, mayDelete) <- news
|
||||
$forall (cID, CourseNews{courseNewsTitle, courseNewsSummary, courseNewsContent}, isVisible, files, lastEditText, mayEditNews, mayDelete, archiveUrl) <- news
|
||||
<li .course-news-item ##{"news-" <> toPathPiece cID}>
|
||||
$case (courseNewsTitle, courseNewsSummary)
|
||||
$# $of (Just title, Just summary)
|
||||
@ -39,13 +39,13 @@ $# #{summary}
|
||||
#{courseNewsContent}
|
||||
$if showNewsFiles files
|
||||
<ul .course-news-item__files-links .list--inline .list--comma-separated>
|
||||
$forall (_, fp) <- filter (not . view _1) files
|
||||
$forall ((_, fp), fileUrl) <- filter (not . view (_1 . _1)) files
|
||||
<li .course-news-item__file-link>
|
||||
<a href=@{CNewsR tid ssh csh cID (CNFileR fp)}>
|
||||
<a href=#{fileUrl}>
|
||||
#{fp}
|
||||
$elseif not (null files)
|
||||
<p .course-news-item__files-link>
|
||||
<a href=@{CNewsR tid ssh csh cID CNArchiveR}>
|
||||
<a href=#{archiveUrl}>
|
||||
#{iconFileZip}
|
||||
\ _{MsgCourseNewsFiles}
|
||||
<p .course-news-item__last-edit>
|
||||
@ -178,23 +178,23 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
|
||||
<dd .deflist__dd>
|
||||
<div>
|
||||
#{aInst}
|
||||
$if hasApplicationTemplate
|
||||
$maybe templateUrl <- mApplicationTemplate
|
||||
<p>
|
||||
<a href=@{CourseR tid ssh csh CRegisterTemplateR}>
|
||||
<a href=#{templateUrl}>
|
||||
#{iconRegisterTemplate} #
|
||||
$if courseApplicationsRequired course
|
||||
_{MsgCourseApplicationTemplateApplication}
|
||||
$else
|
||||
_{MsgCourseApplicationTemplateRegistration}
|
||||
$nothing
|
||||
$if hasApplicationTemplate
|
||||
$maybe templateUrl <- mApplicationTemplate
|
||||
<dt .deflist__dt>
|
||||
$if courseApplicationsRequired course
|
||||
_{MsgCourseApplicationInstructionsApplication}
|
||||
$else
|
||||
_{MsgCourseApplicationInstructionsRegistration}
|
||||
<dd .deflist__dd>
|
||||
<a href=@{CourseR tid ssh csh CRegisterTemplateR}>
|
||||
<a href=#{templateUrl}>
|
||||
#{iconRegisterTemplate} #
|
||||
$if courseApplicationsRequired course
|
||||
_{MsgCourseApplicationTemplateApplication}
|
||||
|
||||
@ -15,7 +15,4 @@ $newline never
|
||||
<p>
|
||||
<a href=@{CSheetR tid ssh csh shn SShowR}>
|
||||
#{sheetName}
|
||||
<p>
|
||||
<a href=@{CSheetR tid ssh csh shn (SZipR SheetExercise)}>
|
||||
_{MsgSheetExercise}
|
||||
^{editNotifications}
|
||||
|
||||
@ -15,7 +15,4 @@ $newline never
|
||||
<p>
|
||||
<a href=@{CSheetR tid ssh csh shn SShowR}>
|
||||
#{sheetName}
|
||||
<p>
|
||||
<a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
|
||||
_{MsgSheetHint}
|
||||
^{editNotifications}
|
||||
|
||||
@ -15,7 +15,4 @@ $newline never
|
||||
<p>
|
||||
<a href=@{CSheetR tid ssh csh shn SShowR}>
|
||||
#{sheetName}
|
||||
<p>
|
||||
<a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
|
||||
_{MsgSheetSolution}
|
||||
^{editNotifications}
|
||||
|
||||
@ -1,5 +1,5 @@
|
||||
$newline never
|
||||
$maybe cID <- mcid
|
||||
$maybe _ <- mcid
|
||||
$maybe wdgt <- correctionWdgt
|
||||
<section>
|
||||
<h2>_{MsgRating}
|
||||
@ -18,12 +18,15 @@ $maybe cID <- mcid
|
||||
_{MsgSubmissionFiles}
|
||||
<p>
|
||||
$if showCorrection
|
||||
<a href=@{urlArchive cID}>_{MsgSubmissionArchiveCorrected}
|
||||
$maybe url <- urlArchive
|
||||
<a href=#{url}>_{MsgSubmissionArchiveCorrected}
|
||||
\ (
|
||||
<a href=@{urlOriginal cID}>_{MsgSubmissionOriginal}
|
||||
$maybe url <- urlOriginal
|
||||
<a href=#{url}>_{MsgSubmissionOriginal}
|
||||
)
|
||||
$else
|
||||
<a href=@{urlOriginal cID}>_{MsgSubmissionArchive}
|
||||
$maybe url <- urlOriginal
|
||||
<a href=#{url}>_{MsgSubmissionArchive}
|
||||
|
||||
$maybe fileTable <- mFileTable
|
||||
^{fileTable}
|
||||
|
||||
@ -33,7 +33,7 @@ $maybe WorkflowCurrentState{..} <- workflowState
|
||||
<ul .list--iconless>
|
||||
$maybe fileRoute <- mFileRoute
|
||||
<li>
|
||||
<a href=@{fileRoute}>
|
||||
<a href=#{fileRoute}>
|
||||
_{MsgWorkflowPayloadFiles}
|
||||
$forall pItem <- newPayload
|
||||
<li>
|
||||
|
||||
@ -65,7 +65,7 @@ $newline never
|
||||
<ul .list--iconless>
|
||||
$maybe fileRoute <- mFileRoute
|
||||
<li>
|
||||
<a href=@{fileRoute}>
|
||||
<a href=#{fileRoute}>
|
||||
_{MsgWorkflowPayloadFiles}
|
||||
$forall pItem <- newPayload
|
||||
<li>
|
||||
|
||||
Loading…
Reference in New Issue
Block a user