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

feat: allow separating user generated content into separate domain

Browse Source
This commit is contained in:
Gregor Kleen 2020-12-02 16:58:52 +01:00
parent b36ddce3e3
commit 707b41d4ec
56 changed files with 964 additions and 413 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
config/settings.yml
View File

@ -249,3 +249,5 @@ token-buckets:
initial-value: 0 initial-value: 0
fallback-personalised-sheet-files-keys-expire: 2419200 fallback-personalised-sheet-files-keys-expire: 2419200
download-token-expire: 14400

2
load/Load.hs
View File

@ -367,5 +367,5 @@ sheetZipURI :: ReaderT SimulationContext IO URI
sheetZipURI = do sheetZipURI = do
LoadOptions{..} <- asks loadOptions LoadOptions{..} <- asks loadOptions
let zipURI = nullURI { uriPath = unpack . Text.intercalate "/" $ "." : zipPath } 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 return $ zipURI `relativeTo` loadBaseURI

1
messages/uniworx/de-de-formal.msg
View File

@ -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. 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. 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. 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. UnauthorizedToken404: Authorisierungs-Tokens können nicht auf Fehlerseiten ausgewertet werden.
UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator. UnauthorizedSiteAdmin: Sie sind kein System-weiter Administrator.
UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen. UnauthorizedSchoolAdmin: Sie sind nicht als Administrator für dieses Institut eingetragen.

1
messages/uniworx/en-eu.msg
View File

@ -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. 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. 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. 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. UnauthorizedToken404: Authorisation-tokens cannot be processed on error pages.
UnauthorizedSiteAdmin: You are no system-wide administrator. UnauthorizedSiteAdmin: You are no system-wide administrator.
UnauthorizedSchoolAdmin: You are no administrator for this department. UnauthorizedSchoolAdmin: You are no administrator for this department.

13
src/Data/Universe/Instances/Reverse/JSON.hs
View File

@ -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] 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 instance (Eq a, Hashable a, Finite a, FromJSON b, FromJSONKey a) => FromJSON (a -> b) where
parseJSON val = do parseJSON val = asObject <|> asConst
vMap <- parseJSON val :: Parser (HashMap a b) where
unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $ asObject = do
fail "Not all required keys found" vMap <- parseJSON val :: Parser (HashMap a b)
return (vMap !) unless (HashSet.fromMap (HashMap.map (const ()) vMap) == HashSet.fromList universeF) $
fail "Not all required keys found"
return (vMap !)
asConst = const <$> parseJSON val

46
src/Foundation/Authorization.hs
View File

@ -17,6 +17,7 @@ module Foundation.Authorization
, evalWorkflowRoleFor, evalWorkflowRoleFor' , evalWorkflowRoleFor, evalWorkflowRoleFor'
, hasWorkflowRole , hasWorkflowRole
, mayViewWorkflowAction , mayViewWorkflowAction
, authoritiveApproot
) where ) where
import Import.NoFoundation hiding (Last(..)) import Import.NoFoundation hiding (Last(..))
@ -218,15 +219,32 @@ validateBearer mAuthId' route' isWrite' token' = $runCachedMemoT $ for4 memo val
where where
validateBearer' :: _ -> _ -> _ -> _ -> CachedMemoT (Maybe (AuthId UniWorX), Route UniWorX, Bool, BearerToken UniWorX) AuthResult (ReaderT SqlReadBackend (HandlerFor UniWorX)) AuthResult 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 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 bearerAuthority' <- flip foldMapM bearerAuthority $ \case
Left tVal Left tVal
| JSON.Success groupName <- JSON.fromJSON tVal -> maybeT (throwError =<< unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . hoist lift $ do | JSON.Success groupName <- JSON.fromJSON tVal -> do
Entity _ UserGroupMember{..} <- MaybeT . getBy $ UniquePrimaryUserGroupMember groupName Active Entity _ primary <- maybeMExceptT (unauthorizedI MsgUnauthorizedTokenInvalidAuthorityGroup) . getBy $ UniquePrimaryUserGroupMember groupName Active
return $ Set.singleton userGroupMemberUser 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 | 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 let
-- Prevent infinite loops -- Prevent infinite loops
@ -269,7 +287,7 @@ requireBearerToken :: ( MonadHandler m, HandlerSite m ~ UniWorX
=> m (BearerToken UniWorX) => m (BearerToken UniWorX)
requireBearerToken = liftHandler $ do requireBearerToken = liftHandler $ do
bearer <- exceptT (guardAuthResult >=> error "askToken should not throw `Authorized`") return askBearerUnsafe 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 currentRoute <- maybe (permissionDeniedI MsgUnauthorizedToken404) return =<< getCurrentRoute
isWrite <- isWriteRequest currentRoute isWrite <- isWriteRequest currentRoute
guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer guardAuthResult <=< runDBRead $ validateBearer mAuthId currentRoute isWrite bearer
@ -1726,3 +1744,19 @@ mayViewWorkflowAction mAuthId wwId WorkflowAction{..} = withReaderT (projectBack
lift $ anyM wpvViewers evalWorkflowRole' lift $ anyM wpvViewers evalWorkflowRole'
] ]
return True 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

16
src/Foundation/Instances.hs
View File

@ -79,10 +79,19 @@ instance Yesod UniWorX where
-- Controls the base of generated URLs. For more information on modifying, -- Controls the base of generated URLs. For more information on modifying,
-- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot -- see: https://github.com/yesodweb/yesod/wiki/Overriding-approot
approot = ApprootRequest $ \app req -> approot = ApprootRequest $ \app req ->
case app ^. _appRoot of case app ^. _appRoot . to ($ ApprootDefault) of
Nothing -> getApprootText guessApproot app req Nothing -> getApprootText guessApproot app req
Just root -> root 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 makeSessionBackend = UniWorX.makeSessionBackend
maximumContentLength app _ = app ^. _appMaximumContentLength maximumContentLength app _ = app ^. _appMaximumContentLength
@ -181,6 +190,11 @@ instance YesodAuth UniWorX where
_other -> Auth.germanMessage _other -> Auth.germanMessage
where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls where lang = Text.splitOn "-" $ selectLanguage' appLanguages ls
maybeAuthId = runMaybeT $ authIdFromBearer <|> MaybeT defaultMaybeAuthId
where authIdFromBearer = do
BearerToken{..} <- MaybeT maybeBearerToken
hoistMaybe bearerImpersonate
instance YesodAuthPersist UniWorX where instance YesodAuthPersist UniWorX where
getAuthEntity = liftHandler . runDBRead . get getAuthEntity = liftHandler . runDBRead . get

183
src/Foundation/Navigation.hs
View File

File diff suppressed because it is too large Load Diff

75
src/Foundation/SiteLayout.hs
View File

@ -192,7 +192,7 @@ siteLayout' overrideHeading widget = do
. observeFavouritesQuickActionsDuration $ do . observeFavouritesQuickActionsDuration $ do
$logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..." $logDebugS "FavouriteQuickActions" $ tshow cK <> " Starting..."
items' <- pageQuickActions NavQuickViewFavourite courseRoute 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." $logDebugS "FavouriteQuickActions" $ tshow cK <> " Done."
return items return items
$logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items) $logDebugS "FavouriteQuickActions" $ tshow cK <> " returning " <> tshow (is _Just items)
@ -203,7 +203,7 @@ siteLayout' overrideHeading widget = do
, maybe (return []) pageActions mcurrentRoute , maybe (return []) pageActions mcurrentRoute
] ]
nav' <- catMaybes <$> mapM (runMaybeT . navAccess) nav'' 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 mmsgs <- if
| isModal -> return mempty | isModal -> return mempty
@ -225,9 +225,9 @@ siteLayout' overrideHeading widget = do
-- ^ highlight last route in breadcrumbs, favorites taking priority -- ^ highlight last route in breadcrumbs, favorites taking priority
highlight = (highR ==) . Just . urlRoute highlight = (highR ==) . Just . urlRoute
where crumbs = mcons mcurrentRoute $ view _1 <$> reverse parents 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 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 :: TermIdentifier -> FavouriteReason -> [(Course, Route UniWorX, Maybe [(Text, Text)], FavouriteReason, Bool, Bool, Bool)]
favouriteTermReason tid favReason' = favourites favouriteTermReason tid favReason' = favourites
& filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason') & filter (\(Course{..}, _, _, favReason, _, _, _) -> unTermKey courseTerm == tid && favReason == favReason')
@ -243,15 +243,16 @@ siteLayout' overrideHeading widget = do
navWidget (n, navIdent, navRoute', navChildren') = case n of navWidget (n, navIdent, navRoute', navChildren') = case n of
NavHeader{ navLink = navLink@NavLink{..}, .. } NavHeader{ navLink = navLink@NavLink{..}, .. }
| NavTypeLink{..} <- navType | NavTypeLink{..} <- navType
, navModal , navModal -> do
-> customModal Modal modalContent <- liftHandler $ Left <$> navLinkRoute navLink
{ modalTriggerId = Just navIdent customModal Modal
, modalId = Nothing { modalTriggerId = Just navIdent
, modalTrigger = \mroute ident -> case mroute of , modalId = Nothing
Just route -> $(widgetFile "widgets/navbar/item") , modalTrigger = \mroute ident -> case mroute of
Nothing -> error "navWidget with non-link modal" Just route -> $(widgetFile "widgets/navbar/item")
, modalContent = Left $ SomeRoute navLink Nothing -> error "navWidget with non-link modal"
} , modalContent
}
| NavTypeLink{} <- navType | NavTypeLink{} <- navType
-> let route = navRoute' -> let route = navRoute'
ident = navIdent ident = navIdent
@ -259,14 +260,15 @@ siteLayout' overrideHeading widget = do
NavPageActionPrimary{ navLink = navLink@NavLink{..} } NavPageActionPrimary{ navLink = navLink@NavLink{..} }
-> let pWidget -> let pWidget
| NavTypeLink{..} <- navType | NavTypeLink{..} <- navType
, navModal , navModal = do
= customModal Modal modalContent <- liftHandler $ Left <$> navLinkRoute navLink
customModal Modal
{ modalTriggerId = Just navIdent { modalTriggerId = Just navIdent
, modalId = Nothing , modalId = Nothing
, modalTrigger = \mroute ident -> case mroute of , modalTrigger = \mroute ident -> case mroute of
Just route -> $(widgetFile "widgets/pageaction/primary") Just route -> $(widgetFile "widgets/pageaction/primary")
Nothing -> error "navWidget with non-link modal" Nothing -> error "navWidget with non-link modal"
, modalContent = Left $ SomeRoute navLink , modalContent
} }
| NavTypeLink{} <- navType | NavTypeLink{} <- navType
= let route = navRoute' = let route = navRoute'
@ -279,15 +281,16 @@ siteLayout' overrideHeading widget = do
in $(widgetFile "widgets/pageaction/primary-wrapper") in $(widgetFile "widgets/pageaction/primary-wrapper")
NavPageActionSecondary{ navLink = navLink@NavLink{..} } NavPageActionSecondary{ navLink = navLink@NavLink{..} }
| NavTypeLink{..} <- navType | NavTypeLink{..} <- navType
, navModal , navModal -> do
-> customModal Modal modalContent <- liftHandler $ Left <$> navLinkRoute navLink
{ modalTriggerId = Just navIdent customModal Modal
, modalId = Nothing { modalTriggerId = Just navIdent
, modalTrigger = \mroute ident -> case mroute of , modalId = Nothing
Just route -> $(widgetFile "widgets/pageaction/secondary") , modalTrigger = \mroute ident -> case mroute of
Nothing -> error "navWidget with non-link modal" Just route -> $(widgetFile "widgets/pageaction/secondary")
, modalContent = Left $ SomeRoute navLink Nothing -> error "navWidget with non-link modal"
} , modalContent
}
| NavTypeLink{} <- navType | NavTypeLink{} <- navType
-> let route = navRoute' -> let route = navRoute'
ident = navIdent ident = navIdent
@ -307,25 +310,27 @@ siteLayout' overrideHeading widget = do
navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of navContainerItemWidget (n, _navIdent, _navRoute', _navChildren') (iN@NavLink{..}, iNavIdent, iNavRoute) = case n of
NavHeaderContainer{} NavHeaderContainer{}
| NavTypeLink{..} <- navType | NavTypeLink{..} <- navType
, navModal , navModal -> do
-> customModal Modal modalContent <- liftHandler $ Left <$> navLinkRoute iN
{ modalTriggerId = Just iNavIdent customModal Modal
, modalId = Nothing { modalTriggerId = Just iNavIdent
, modalTrigger = \mroute ident -> case mroute of , modalId = Nothing
Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link") , modalTrigger = \mroute ident -> case mroute of
Nothing -> error "navWidget with non-link modal" Just route -> $(widgetFile "widgets/navbar/navbar-container-item--link")
, modalContent = Left $ SomeRoute iN Nothing -> error "navWidget with non-link modal"
} , modalContent
}
| NavTypeLink{} <- navType | NavTypeLink{} <- navType
-> let route = iNavRoute -> let route = iNavRoute
ident = iNavIdent ident = iNavIdent
in $(widgetFile "widgets/navbar/navbar-container-item--link") in $(widgetFile "widgets/navbar/navbar-container-item--link")
| NavTypeButton{..} <- navType -> do | NavTypeButton{..} <- navType -> do
csrfToken <- reqToken <$> getRequest csrfToken <- reqToken <$> getRequest
formAction <- liftHandler $ Just <$> navLinkRoute iN
wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def wrapForm $(widgetFile "widgets/navbar/navbar-container-item--button") def
{ formMethod = navMethod { formMethod = navMethod
, formSubmit = FormNoSubmit , formSubmit = FormNoSubmit
, formAction = Just $ SomeRoute iN , formAction
} }
_other -> error "not implemented" _other -> error "not implemented"

18
src/Foundation/Yesod/Middleware.hs
View File

@ -87,9 +87,14 @@ yesodMiddleware = storeBearerMiddleware . csrfMiddleware . dryRunMiddleware . ob
csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a csrfMiddleware :: HandlerFor UniWorX a -> HandlerFor UniWorX a
csrfMiddleware handler = do csrfMiddleware handler = do
hasBearer <- is _Just <$> lookupBearerAuth 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 if | hasBearer || fromMaybe False ((==) <$> reqHost <*> userGeneratedHost)
| otherwise -> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler -> local (\HandlerData{..} -> HandlerData{ handlerRequest = handlerRequest { reqToken = Nothing }, .. }) handler
| otherwise
-> csrfSetCookieMiddleware' . defaultCsrfCheckMiddleware $ handler
where where
csrfSetCookieMiddleware' handler' = do csrfSetCookieMiddleware' handler' = do
mcsrf <- reqToken <$> getRequest mcsrf <- reqToken <$> getRequest
@ -150,7 +155,8 @@ routeNormalizers :: forall m backend.
, BearerAuthSite UniWorX , BearerAuthSite UniWorX
) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)] ) => [Route UniWorX -> WriterT Any (ReaderT backend m) (Route UniWorX)]
routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .) routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .)
[ normalizeRender [ normalizeApproot
, normalizeRender
, ncSchool , ncSchool
, ncAllocation , ncAllocation
, ncCourse , ncCourse
@ -169,6 +175,12 @@ routeNormalizers = map (hoist (hoist liftHandler . withReaderT projectBackend) .
, verifyMaterialVideo , verifyMaterialVideo
] ]
where 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 UniWorX -> WriterT Any (ReaderT SqlReadBackend (HandlerFor UniWorX)) (Route UniWorX)
normalizeRender route = route <$ do normalizeRender route = route <$ do
YesodRequest{..} <- liftHandler getRequest YesodRequest{..} <- liftHandler getRequest

100
src/Foundation/Yesod/Session.hs
View File

@ -17,46 +17,60 @@ import Web.Cookie
makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend) makeSessionBackend :: Yesod UniWorX => UniWorX -> IO (Maybe SessionBackend)
makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notForBearer . sameSite $ case appSessionStore of makeSessionBackend app@UniWorX{ appSettings' = AppSettings{..}, ..} = notFor isUserGenerated . notFor isBearer . sameSite $ case appSessionStore of
SessionStorageMemcachedSql sqlStore SessionStorageMemcachedSql sqlStore
-> mkBackend . stateSettings =<< ServerSession.createState sqlStore -> mkBackend . stateSettings =<< ServerSession.createState sqlStore
SessionStorageAcid acidStore SessionStorageAcid acidStore
| appServerSessionAcidFallback | appServerSessionAcidFallback
-> mkBackend . stateSettings =<< ServerSession.createState acidStore -> mkBackend . stateSettings =<< ServerSession.createState acidStore
_other _other
-> return Nothing -> return Nothing
where where
cfg = JwtSession.ServerSessionJwtConfig cfg = JwtSession.ServerSessionJwtConfig
{ sJwtJwkSet = appJSONWebKeySet { sJwtJwkSet = appJSONWebKeySet
, sJwtStart = Nothing , sJwtStart = Nothing
, sJwtExpiration = appSessionTokenExpiration , sJwtExpiration = appSessionTokenExpiration
, sJwtEncoding = appSessionTokenEncoding , sJwtEncoding = appSessionTokenEncoding
, sJwtIssueBy = appInstanceID , sJwtIssueBy = appInstanceID
, sJwtIssueFor = appClusterID , sJwtIssueFor = appClusterID
} }
mkBackend :: forall sto. mkBackend :: forall sto.
( ServerSession.SessionData sto ~ Map Text ByteString ( ServerSession.SessionData sto ~ Map Text ByteString
, ServerSession.Storage sto , ServerSession.Storage sto
) )
=> ServerSession.State sto -> IO (Maybe SessionBackend) => ServerSession.State sto -> IO (Maybe SessionBackend)
mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app) mkBackend = JwtSession.backend cfg (JwtSession.siteApproot app)
stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto stateSettings :: forall sto. ServerSession.State sto -> ServerSession.State sto
stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig stateSettings = ServerSession.setCookieName (toPathPiece CookieSession) . applyServerSessionSettings appServerSessionConfig
sameSite sameSite
| Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession) | Just sameSiteStrict == cookieSameSite (getCookieSettings app CookieSession)
= strictSameSiteSessions = strictSameSiteSessions
| Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession) | Just sameSiteLax == cookieSameSite (getCookieSettings app CookieSession)
= laxSameSiteSessions = laxSameSiteSessions
| otherwise | otherwise
= id = id
notForBearer :: IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
notForBearer = fmap $ fmap notForBearer' notFor :: (W.Request -> IO Bool) -> IO (Maybe SessionBackend) -> IO (Maybe SessionBackend)
where notForBearer' :: SessionBackend -> SessionBackend notFor f = fmap $ fmap notFor'
notForBearer' (SessionBackend load) where notFor' :: SessionBackend -> SessionBackend
= let load' req notFor' (SessionBackend load) = SessionBackend $ \req -> do
| aHdrs <- mapMaybe (\(h, v) -> v <$ guard (h == W.hAuthorization)) $ W.requestHeaders req pMatches <- f req
, any (is _Just . W.extractBearerAuth) aHdrs if | not pMatches -> load req
= return (mempty, const $ return []) | otherwise -> return (mempty, const $ return [])
| otherwise
= load req
in SessionBackend load' 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

2
src/Handler/Admin/Tokens.hs
View File

@ -86,7 +86,7 @@ postAdminTokensR = do
& HashSet.insert (Right uid) & HashSet.insert (Right uid)
& HashSet.map (left toJSON) & 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 siteLayoutMsg MsgMenuAdminTokens $ do
setTitleI MsgMenuAdminTokens setTitleI MsgMenuAdminTokens

17
src/Handler/Allocation/AddUser.hs
View File

@ -13,6 +13,8 @@ import qualified Data.Conduit.Combinators as C
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import Handler.Course.Show
data AllocationAddUserForm = AllocationAddUserForm data AllocationAddUserForm = AllocationAddUserForm
{ aauUser :: UserId { aauUser :: UserId
@ -115,7 +117,12 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
afmApplicantEdit = True afmApplicantEdit = True
afmLecturer = 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' let appsRes = sequenceA $ view _1 <$> appsRes'
appsViews = view _2 <$> appsRes' appsViews = view _2 <$> appsRes'
@ -123,7 +130,7 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
[whamlet| [whamlet|
$newline never $newline never
<div .allocation__courses> <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>
<div .allocation-course__priority-label .allocation__label> <div .allocation-course__priority-label .allocation__label>
_{MsgAllocationPriority} _{MsgAllocationPriority}
@ -141,16 +148,16 @@ allocationApplicationsForm aId courses FieldSettings{..} fvRequired = formToAFor
_{MsgCourseAllocationCourseAcceptsSubstitutesNever} _{MsgCourseAllocationCourseAcceptsSubstitutesNever}
$if allocationCourseAcceptSubstitutes >= Just now $if allocationCourseAcceptSubstitutes >= Just now
\ ^{iconOK} \ ^{iconOK}
$if hasApplicationTemplate || is _Just courseApplicationsInstructions $if is _Just mApplicationTemplate || is _Just courseApplicationsInstructions
<div .allocation-course__instructions-label .allocation__label> <div .allocation-course__instructions-label .allocation__label>
_{MsgCourseApplicationInstructionsApplication} _{MsgCourseApplicationInstructionsApplication}
<div .allocation-course__instructions> <div .allocation-course__instructions>
$maybe aInst <- courseApplicationsInstructions $maybe aInst <- courseApplicationsInstructions
<p> <p>
#{aInst} #{aInst}
$if hasApplicationTemplate $maybe templateUrl <- mApplicationTemplate
<p> <p>
<a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}> <a href=#{templateUrl}>
#{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} #{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> <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} _{MsgCourseApplication}

18
src/Handler/Allocation/Application.hs
View File

@ -138,13 +138,15 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
| otherwise | otherwise
-> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal) -> over _2 Just . over (_1 . _FormSuccess) (assertM $ not . Text.null) <$> mopt textField' textFs (Just $ mApp >>= courseApplicationText . entityVal)
hasFiles <- for mApp $ \(Entity appId _) appFilesInfo <- for mApp $ \(Entity appId _) -> liftHandler . runDB $ do
-> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
appCID <- for mApp $ encrypt . entityKey appCID <- encrypt appId
let appFilesInfo = (,) <$> hasFiles <*> appCID appFilesLink <- toTextUrl <=< withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR
return (hasFiles, appFilesLink)
let hasFiles = maybe False (view _1) appFilesInfo
filesLinkView <- if filesLinkView <- if
| Just True == hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit) | hasFiles || (isn't _NoUpload courseApplicationsFiles && not afmApplicantEdit)
-> let filesLinkField = Field{..} -> let filesLinkField = Field{..}
where where
fieldParse _ _ = return $ Right Nothing fieldParse _ _ = return $ Right Nothing
@ -153,8 +155,8 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
= [whamlet| = [whamlet|
$newline never $newline never
$case appFilesInfo $case appFilesInfo
$of Just (True, appCID) $of Just (True, appFilesLink)
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}> <a ##{theId} *{attrs} href=#{appFilesLink}>
_{MsgCourseApplicationFiles} _{MsgCourseApplicationFiles}
$of _ $of _
<span ##{theId} *{attrs}> <span ##{theId} *{attrs}>
@ -165,7 +167,7 @@ applicationForm maId@(is _Just -> isAlloc) cid muid ApplicationFormMode{..} mcsr
-> return Nothing -> return Nothing
filesWarningView <- if filesWarningView <- if
| Just True == hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit | hasFiles && isn't _NoUpload courseApplicationsFiles && afmApplicantEdit
-> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload -> fmap (Just . snd) . formMessage =<< messageIconI Info IconFileUpload MsgCourseApplicationFilesNeedReupload
| otherwise | otherwise
-> return Nothing -> return Nothing

6
src/Handler/Allocation/Show.hs
View File

@ -15,6 +15,8 @@ import Handler.Allocation.Application
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Handler.Course.Show
data NotifyNewCourseButton data NotifyNewCourseButton
= BtnNotifyNewCourseForceOn = BtnNotifyNewCourseForceOn
@ -174,6 +176,10 @@ postAShowR tid ssh ash = do
tRoute <- case mApp of tRoute <- case mApp of
Nothing -> return . AllocationR tid ssh ash $ AApplyR cID Nothing -> return . AllocationR tid ssh ash $ AApplyR cID
Just (Entity appId _) -> CApplicationR courseTerm courseSchool courseShorthand <$> encrypt appId <*> pure CAEditR 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 let mApplyFormView' = view _1 <$> mApplyFormView
overrideVisible = not mayApply && is _Just mApp overrideVisible = not mayApply && is _Just mApp
case mApplyFormView of case mApplyFormView of

31
src/Handler/Course/News/Download.hs
View File

@ -1,6 +1,6 @@
module Handler.Course.News.Download module Handler.Course.News.Download
( getCNArchiveR ( getCNArchiveR, cnArchiveSource
, getCNFileR , getCNFileR, cnFileSource
) where ) where
import Import import Import
@ -11,6 +11,11 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.List as C 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 :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> Handler TypedContent
getCNArchiveR tid ssh csh cID = do getCNArchiveR tid ssh csh cID = do
nId <- decrypt cID 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) 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 $ serveSomeFiles archiveName $ cnArchiveSource nId
\newsFile -> do
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
return newsFile
serveSomeFiles archiveName getFilesQuery
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 :: TermId -> SchoolId -> CourseShorthand -> CryptoUUIDCourseNews -> FilePath -> Handler TypedContent
getCNFileR _ _ _ cID title = do getCNFileR _ _ _ cID fPath = do
nId <- decrypt cID nId <- decrypt cID
serveOneFile $ cnFileSource nId fPath
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

36
src/Handler/Course/Register.hs
View File

@ -101,31 +101,33 @@ courseRegisterForm (Entity cid Course{..}) = liftHandler $ do
| otherwise | otherwise
-> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal) -> fmap (assertM (not . Text.null) . fmap Text.strip) <$> wopt textField' fs (Just $ application >>= courseApplicationText . entityVal)
hasFiles <- for application $ \(Entity appId _) appFilesInfo <- for application $ \(Entity appId _) -> liftHandler . runDB $ do
-> fmap (not . null) . liftHandler . runDB $ selectKeysList [ CourseApplicationFileApplication ==. appId ] [ LimitTo 1 ] hasFiles <- exists [ CourseApplicationFileApplication ==. appId ]
appCID <- for application $ encrypt . entityKey appCID <- encrypt appId
let appFilesInfo = (,) <$> hasFiles <*> appCID 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 filesMsg = bool MsgCourseRegistrationFiles MsgCourseApplicationFiles courseApplicationsRequired
when (isn't _NoUpload courseApplicationsFiles || Just True == hasFiles) $ when (isn't _NoUpload courseApplicationsFiles || hasFiles) $
let filesLinkField = Field{..} let filesLinkField = Field{..}
where where
fieldParse _ _ = return $ Right Nothing fieldParse _ _ = return $ Right Nothing
fieldEnctype = mempty fieldEnctype = mempty
fieldView theId _ attrs _ _ fieldView theId _ attrs _ _ =
= [whamlet| [whamlet|
$newline never $newline never
$case appFilesInfo $case appFilesInfo
$of Just (True, appCID) $of Just (True, appFilesLink)
<a ##{theId} *{attrs} href=@{CApplicationR courseTerm courseSchool courseShorthand appCID CAFilesR}> <a ##{theId} *{attrs} href=#{appFilesLink}>
_{filesMsg} _{filesMsg}
$of _ $of _
<span ##{theId} *{attrs}> <span ##{theId} *{attrs}>
_{MsgCourseApplicationNoFiles} _{MsgCourseApplicationNoFiles}
|] |]
in void $ wforced filesLinkField (fslI filesMsg) Nothing 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 wformMessage <=< messageIconI Info IconFileUpload $ bool MsgCourseRegistrationFilesNeedReupload MsgCourseApplicationFilesNeedReupload courseApplicationsRequired
appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive appFilesRes <- let mkFs | courseApplicationsRequired = bool MsgCourseApplicationFile MsgCourseApplicationArchive

36
src/Handler/Course/Show.hs
View File

@ -1,6 +1,6 @@
module Handler.Course.Show module Handler.Course.Show
( getCShowR ( getCShowR
, getCRegisterTemplateR , getCRegisterTemplateR, courseRegisterTemplateSource
) where ) where
import Import import Import
@ -25,12 +25,14 @@ import qualified Data.Conduit.List as C
import Handler.Exam.List (mkExamTable) import Handler.Exam.List (mkExamTable)
import Handler.Course.News.Download
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do getCShowR tid ssh csh = do
mbAid <- maybeAuthId mbAid <- maybeAuthId
now <- liftIO getCurrentTime 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)] [(E.Entity cid course, E.Value courseVisible, E.Value schoolName, E.Value participants, fmap entityVal -> registration, E.Value hasAllocationRegistrationOpen)]
<- lift . E.select . E.from $ <- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
@ -76,6 +78,9 @@ getCShowR tid ssh csh = do
return allocation return allocation
hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile -> hasApplicationTemplate <- lift . E.selectExists . E.from $ \courseAppInstructionFile ->
E.where_ $ courseAppInstructionFile E.^. CourseAppInstructionFileCourse E.==. E.val cid 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] [] 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 ] news' <- lift $ selectList [ CourseNewsCourse ==. cid ] [ Desc CourseNewsVisibleFrom, Desc CourseNewsTitle, Desc CourseNewsSummary, Desc CourseNewsContent ]
cTime <- NTop . Just <$> liftIO getCurrentTime cTime <- NTop . Just <$> liftIO getCurrentTime
@ -86,14 +91,17 @@ getCShowR tid ssh csh = do
files' <- lift . lift . E.select . E.from $ \newsFile -> do files' <- lift . lift . E.select . E.from $ \newsFile -> do
E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId E.where_ $ newsFile E.^. CourseNewsFileNews E.==. E.val nId
return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle) return (E.isNothing $ newsFile E.^. CourseNewsFileContent, newsFile E.^. CourseNewsFileTitle)
let files = files' let files'' = files'
& over (mapped . _1) E.unValue & over (mapped . _1) E.unValue
& over (mapped . _2) E.unValue & over (mapped . _2) E.unValue
lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit lastEditText <- formatTime SelFormatDateTime $ maybe id max (guardOn visible =<< courseNewsVisibleFrom) courseNewsLastEdit
mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR mayEditNews <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNEditR
mayDelete <- hasWriteAccessTo $ CNewsR tid ssh csh cID CNDeleteR 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 events' <- fmap (sortOn $ courseEventTime . entityVal . view _1) . lift . E.select . E.from $ \courseEvent -> do
E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid E.where_ $ courseEvent E.^. CourseEventCourse E.==. E.val cid
@ -127,7 +135,7 @@ getCShowR tid ssh csh = do
return $ material E.^. MaterialName return $ material E.^. MaterialName
mayViewAnyMaterial <- anyM materials $ \(E.Value mnm) -> hasReadAccessTo $ CMaterialR tid ssh csh mnm MShowR 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 let mDereg' = maybe id min (allocationOverrideDeregister =<< mAllocation) <$> courseDeregisterUntil course
mDereg <- traverse (formatTime SelFormatDateTime) mDereg' mDereg <- traverse (formatTime SelFormatDateTime) mDereg'
@ -244,7 +252,7 @@ getCShowR tid ssh csh = do
showNewsFiles fs = and showNewsFiles fs = and
[ not $ null fs [ not $ null fs
, length fs <= 3 , length fs <= 3
, all (notElem pathSeparator . view _2) fs , all (views (_1 . _2) $ notElem pathSeparator) fs
] ]
hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events hiddenEventNotes = all (\(_,CourseEvent{..},_) -> is _Nothing courseEventNote) events
Course{courseVisibleFrom,courseVisibleTo} = course Course{courseVisibleFrom,courseVisibleTo} = course
@ -263,13 +271,15 @@ getCShowR tid ssh csh = do
setTitleI $ prependCourseTitle tid ssh csh (""::Text) setTitleI $ prependCourseTitle tid ssh csh (""::Text)
$(widgetFile "course") $(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 :: TermId -> SchoolId -> CourseShorthand -> Handler TypedContent
getCRegisterTemplateR tid ssh csh = do getCRegisterTemplateR tid ssh csh = do
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgCourseApplicationTemplateArchiveName tid ssh csh 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 serveSomeFiles archiveName $ courseRegisterTemplateSource tid ssh csh
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

82
src/Handler/Material.hs
View File

@ -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 import Import
@ -58,11 +66,6 @@ makeMaterialForm cid template = identifyForm FIDmaterial $ \html -> do
<*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template) <*> aopt (multiFileField' . fromMaybe (return ()) $ mfFiles =<< template)
(fslI MsgMaterialFiles) (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 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> DB (Entity Material)
fetchMaterial tid ssh csh mnm = fetchMaterial tid ssh csh mnm =
maybe notFound return . listToMaybe <=< E.select . E.from $ -- uniqueness guaranteed by DB constraints 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 let matLink :: MaterialName -> Route UniWorX
matLink = CourseR tid ssh csh . flip MaterialR MShowR matLink = CourseR tid ssh csh . flip MaterialR MShowR
filesLink :: MaterialName -> Route UniWorX filesLink :: (MonadHandler m, HandlerSite m ~ UniWorX)
filesLink = CourseR tid ssh csh . flip MaterialR MArchiveR => 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 :: IsDBTable m a => Material -> DBCell m a
materialModDateCell Material{materialVisibleFrom, materialLastEdit} 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)) , sortable (toNothingS "zip-archive") (mempty & cellAttrs <>~ pure ("uw-hide-columns--hider-label", mr MsgMaterialFiles))
$ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if $ \DBRow{ dbrOutput = (Entity _ Material{..}, E.Value fileNum) } -> if
| fileNum == 0 -> mempty | fileNum == 0 -> mempty
| otherwise -> fileCell $ filesLink materialName | otherwise -> anchorCellM (filesLink materialName) iconFileDownload
, sortable (Just "visible-from") (i18nCell MsgAccessibleSince) , sortable (Just "visible-from") (i18nCell MsgAccessibleSince)
$ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material $ foldMap (dateTimeCellVisible now) . materialVisibleFrom . row2material
, sortable (Just "last-edit") (i18nCell MsgFileModified) , 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 :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> CryptoUUIDMaterialFile -> Handler Html
getMVideoR tid ssh csh mnm cID = do getMVideoR tid ssh csh mnm cID = do
mfId <- decrypt cID mfId <- decrypt cID
MaterialFile{..} <- runDB $ get404 mfId mf@MaterialFile{..} <- runDB $ get404 mfId
let mimeType = mimeLookup $ pack materialFileTitle 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) $ unless (mimeType `Set.member` videoTypes) $
redirectWith movedPermanently301 mfile redirectWith movedPermanently301 mfile
siteLayout' Nothing $ do siteLayout' Nothing $ do
@ -185,10 +192,10 @@ getMVideoR tid ssh csh mnm cID = do
<section> <section>
<div .video-container> <div .video-container>
<video controls autoplay preload=auto> <video controls autoplay preload=auto>
<source src=@{mfile} type=#{decodeUtf8 mimeType}> <source src=#{mfileText} type=#{decodeUtf8 mimeType}>
_{MsgMaterialVideoUnsupported} _{MsgMaterialVideoUnsupported}
<section> <section>
<a .btn href=@{mfile} download target=_blank> <a .btn href=#{mfileDownloadText}>
^{iconFileDownload} # ^{iconFileDownload} #
_{MsgMaterialVideoDownload} _{MsgMaterialVideoDownload}
|] |]
@ -196,13 +203,10 @@ getMVideoR tid ssh csh mnm cID = do
getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html getMShowR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler Html
getMShowR tid ssh csh mnm = do 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 seeAllModificationTimestamps <- hasReadAccessTo $ CourseR tid ssh csh CNotesR -- ordinary users should not see modification dates older than visibility
( Entity _mid material@Material{materialType, materialDescription} (Entity _mid material@Material{materialType, materialDescription}, (Any hasFiles,fileTable), zipLink) <- runDB $ do
, (Any hasFiles,fileTable)) <- runDB $ do zipLink <- withFileDownloadToken (materialArchiveSource tid ssh csh mnm) $ CMaterialR tid ssh csh mnm MArchiveR
matEnt <- fetchMaterial tid ssh csh mnm matEnt <- fetchMaterial tid ssh csh mnm
let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c) let materialModDateCol :: (IsDBTable m c) => (t -> E.Value UTCTime) -> Colonnade Sortable t (DBCell m c)
materialModDateCol = if seeAllModificationTimestamps materialModDateCol = if seeAllModificationTimestamps
@ -213,25 +217,25 @@ getMShowR tid ssh csh mnm = do
{ dbtSQLQuery = \matFile -> do { dbtSQLQuery = \matFile -> do
E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt) E.where_ $ matFile E.^. MaterialFileMaterial E.==. E.val (entityKey matEnt)
E.&&. E.not_ (E.isNothing $ matFile E.^. MaterialFileContent) -- don't show directories 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) , dbtRowKey = (E.^. MaterialFileId)
, dbtColonnade = widgetColonnade $ mconcat , dbtColonnade = widgetColonnade $ mconcat
[ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \DBRow{..} [ fmap (<> indicatorCell) . sortable (Just "path") (i18nCell MsgFileTitle) $ \(dbrOutput -> Entity mfId mf@MaterialFile{..})
-> let matLink = CourseR tid ssh csh . MaterialR mnm <$> if -> let matLink
| isVideo | isVideo
-> MVideoR <$> encrypt (dbrOutput ^. _1 . _Value) = SomeRoute . CourseR tid ssh csh . MaterialR mnm . MVideoR <$> encrypt mfId
| otherwise -> return $ MFileR fileTitle | otherwise
= withFileDownloadToken (views (_FileReference . _1) yield mf) . CMaterialR tid ssh csh mnm $ MFileR materialFileTitle
wgt = [whamlet| wgt = [whamlet|
$newline never $newline never
<span .file-path> <span .file-path>
#{fileTitle} #{materialFileTitle}
$if isVideo $if isVideo
\ ^{iconVideo} \ ^{iconVideo}
|] |]
isVideo = mimeLookup (pack fileTitle) `Set.member` videoTypes isVideo = mimeLookup (pack materialFileTitle) `Set.member` videoTypes
fileTitle = unpack $ dbrOutput ^. _2 . _Value
in anchorCellM matLink wgt in anchorCellM matLink wgt
, materialModDateCol (view $ _dbrOutput . _3) , materialModDateCol (view $ _dbrOutput . _entityVal . to (E.Value . materialFileModified))
] ]
, dbtProj = return , dbtProj = return
, dbtStyle = def , dbtStyle = def
@ -246,7 +250,7 @@ getMShowR tid ssh csh mnm = do
, dbtCsvEncode = noCsvEncode , dbtCsvEncode = noCsvEncode
, dbtCsvDecode = Nothing , dbtCsvDecode = Nothing
} }
return (matEnt,fileTable') return (matEnt,fileTable',zipLink)
-- File table has no filtering by access, because we assume that -- File table has no filtering by access, because we assume that
-- access rights to material and material-files are identical. -- access rights to material and material-files are identical.
@ -366,20 +370,22 @@ postMDelR tid ssh csh mnm = do
, drDelete = const id -- TODO: audit , 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 -- | Serve all material-files
getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent getMArchiveR :: TermId -> SchoolId -> CourseShorthand -> MaterialName -> Handler TypedContent
getMArchiveR tid ssh csh mnm = do getMArchiveR tid ssh csh mnm = do
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack). ap getMessageRender . pure $ MsgMaterialArchiveName tid ssh csh mnm
let getMatQuery = (.| C.map entityVal) . E.selectSource . E.from $ let getMatQuery = materialArchiveSource tid ssh csh mnm
\(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
serveSomeFiles archiveName getMatQuery serveSomeFiles archiveName getMatQuery

3
src/Handler/Metrics.hs
View File

@ -9,6 +9,7 @@ import qualified Network.Wai.Middleware.Prometheus as Prometheus
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set import qualified Data.Set as Set
@ -28,7 +29,7 @@ getMetricsR = selectRep $ do
uid <- MaybeT maybeAuthId uid <- MaybeT maybeAuthId
guardM . lift . existsBy $ UniqueUserGroupMember UserGroupMetrics uid 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 defaultLayout $ do
setTitleI MsgTitleMetrics setTitleI MsgTitleMetrics

4
src/Handler/Sheet/List.hs
View File

@ -54,10 +54,10 @@ getSheetListR tid ssh csh = do
[ icnCell & addIconFixedWidth [ icnCell & addIconFixedWidth
| let existingSFTs = hasSFT existFiles | let existingSFTs = hasSFT existFiles
, sft <- [minBound..maxBound] , 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 icn = toWgt $ sheetFile2markup sft
, let icnCell = if sft `elem` existingSFTs , let icnCell = if sft `elem` existingSFTs
then linkEitherCell link (icn, [whamlet|&emsp;|]) then linkEitherCellM link (icn, [whamlet|&emsp;|])
else spacerCell else spacerCell
] id & cellAttrs <>~ [("class","list--inline list--space-separated")] ] id & cellAttrs <>~ [("class","list--inline list--space-separated")]
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)

21
src/Handler/Sheet/Show.hs
View File

@ -46,22 +46,23 @@ getSShowR tid ssh csh shn = do
return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle] return ( E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileTitle, sheetFile E.?. SheetFileTitle]
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified] , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileModified, sheetFile E.?. SheetFileModified]
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType] , E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileType, sheetFile E.?. SheetFileType]
, E.unsafeCoalesce [psFile E.?. PersonalisedSheetFileContent, sheetFile E.?. SheetFileContent]
) )
let colonnadeFiles = widgetColonnade $ mconcat let colonnadeFiles = widgetColonnade $ mconcat
[ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype) -> [ sortable (Just "type") (i18nCell MsgSheetFileTypeHeader) $ \(_,_, E.Value ftype, _) ->
let link = CSheetR tid ssh csh shn $ SZipR ftype in let link = liftHandler . runDB . withFileDownloadToken (sheetFilesAllQuery tid ssh csh shn muid ftype) . CSheetR tid ssh csh shn $ SZipR ftype
tellCell (Any True) $ in tellCell (Any True) $
anchorCell link [whamlet|#{sheetFile2markup ftype} _{ftype}|] anchorCellM link [whamlet|#{sheetFile2markup ftype} _{ftype}|]
-- i18nCell ftype & cellContents %~ (\act -> act <* tell (Any True)) -- 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)))) -- , 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 , sortable (Just "path") (i18nCell MsgFileTitle) $ \(E.Value fName,E.Value fMod,E.Value fType, E.Value fRef) -> anchorCellM
(CSheetR tid ssh csh shn (SFileR fType fName)) (withFileDownloadToken (yield $ FileReference fName fRef fMod) $ CSheetR tid ssh csh shn (SFileR fType fName))
(str2widget fName) (str2widget fName)
, sortable (toNothing "visible") (i18nCell MsgVisibleFrom) , sortable (toNothing "visible") (i18nCell MsgVisibleFrom)
$ \(_, _ , E.Value ftype) -> sftVisible ftype $ \(_, _ , E.Value ftype, _) -> sftVisible ftype
, sortable (Just "time") (i18nCell MsgFileModified) , 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) -- , colFileModification (view _2)
] ]
let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"] let psValidator = def & defaultSorting [SortAscBy "type", SortAscBy "path"]
@ -70,11 +71,11 @@ getSShowR tid ssh csh shn = do
{ dbtSQLQuery = fileData { dbtSQLQuery = fileData
, dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId) , dbtRowKey = \(sheetFile `E.FullOuterJoin` psFile) -> (sheetFile E.?. SheetFileId, psFile E.?. PersonalisedSheetFileId)
, dbtColonnade = colonnadeFiles , 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 , dbtStyle = def
, dbtFilter = mconcat , dbtFilter = mconcat
[ singletonMap "may-access" . FilterProjected $ \(Any b) r -> [ 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 in (==b) <$> hasReadAccessTo (CSheetR tid ssh csh shn $ SFileR fType fName) :: DB Bool
] ]
, dbtFilterUI = mempty , dbtFilterUI = mempty

13
src/Handler/Submission/Correction.hs
View File

@ -17,6 +17,8 @@ import qualified Control.Monad.State.Class as State
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Utils as E import qualified Database.Esqueleto.Utils as E
import Handler.Submission.Download
correctionData :: TermId -> SchoolId -> CourseShorthand -> SheetName -> _ -- CryptoFileNameSubmission -> _ 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 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 MsgRenderer mr <- getMsgRenderer
case results of 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 let ratingComment = submissionRatingComment >>= (\c -> c <$ guard (not $ null c)) . Text.strip
pointsForm = case sheetType of pointsForm = case sheetType of
NotGraded NotGraded
@ -144,14 +146,11 @@ postCorrectionR tid ssh csh shn cid = do
|] |]
siteLayout headingWgt $ do siteLayout headingWgt $ do
setTitleI heading 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") let userCorrection = $(widgetFile "correction-user")
$(widgetFile "correction") $(widgetFile "correction")
_ -> notFound _ -> notFound
getCorrectionUserR tid ssh csh shn cid = do getCorrectionUserR tid ssh csh shn cid = do
sub <- decrypt cid sub <- decrypt cid
results <- runDB $ correctionData tid ssh csh shn sub results <- runDB $ correctionData tid ssh csh shn sub
@ -159,5 +158,7 @@ getCorrectionUserR tid ssh csh shn cid = do
case results of case results of
[(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] -> [(Entity _ Course{..}, Entity _ Sheet{..}, Entity _ Submission{..}, corrector@(Just _), E.Value filesCorrected)] ->
let ratingComment = assertM (not . null) $ Text.strip <$> submissionRatingComment 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 _ -> notFound

70
src/Handler/Submission/Download.hs
View File

@ -1,6 +1,6 @@
module Handler.Submission.Download module Handler.Submission.Download
( getSubDownloadR ( getSubDownloadR, subDownloadSource
, getSubArchiveR , getSubArchiveR, subArchiveSource
, getCorrectionsDownloadR , getCorrectionsDownloadR
) where ) where
@ -16,8 +16,28 @@ import qualified Database.Esqueleto as E
import qualified Data.Conduit.Combinators as Conduit 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 :: 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, isRating) <- runDB $ do
submissionID <- submissionMatchesSheet tid ssh csh shn cID 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 $ | isUpdate -> maybe notFound sendThisFile <=< runDB . runMaybeT $
lift . ratingFile cID =<< MaybeT (getRating submissionID) lift . ratingFile cID =<< MaybeT (getRating submissionID)
| otherwise -> notFound | otherwise -> notFound
False -> do False -> serveOneFile $ subDownloadSource tid ssh csh shn cID sft path
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
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 :: TermId -> SchoolId -> CourseShorthand -> SheetName -> CryptoFileNameSubmission -> SubmissionFileType -> Handler TypedContent
getSubArchiveR tid ssh csh shn cID sfType = do 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 sfType' <- ap getMessageRender $ pure sfType
archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType' archiveName <- fmap (flip addExtension (unpack extensionZip) . unpack) . ap getMessageRender . pure $ MsgSubmissionTypeArchiveName tid ssh csh shn cID sfType'
let source = do serveSomeFiles' archiveName $ subArchiveSource tid ssh csh shn cID sfType
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
getCorrectionsDownloadR :: Handler TypedContent getCorrectionsDownloadR :: Handler TypedContent

24
src/Handler/Submission/Helper.hs
View File

@ -28,6 +28,7 @@ import qualified Data.Aeson.Types as JSON
import Data.Aeson.Lens import Data.Aeson.Lens
import Handler.Submission.Download
import Handler.Submission.SubmissionUserInvite import Handler.Submission.SubmissionUserInvite
@ -490,14 +491,12 @@ submissionHelper tid ssh csh shn mcid = do
corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr corrIsFile = fmap (isJust . submissionFileContent . entityVal) mCorr
Just isFile = origIsFile <|> corrIsFile Just isFile = origIsFile <|> corrIsFile
in if in if
| Just True <- origIsFile -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionOriginal fileTitle') | Just True <- origIsFile -> anchorCellM (subDownloadLink cid SubmissionOriginal fileTitle') [whamlet|#{fileTitle'}|]
[whamlet|#{fileTitle'}|]
| otherwise -> textCell $ bool (<> "/") id isFile fileTitle' | otherwise -> textCell $ bool (<> "/") id isFile fileTitle'
, guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of , guardOn showCorrection . sortable (toNothing "state") (i18nCell MsgCorState) $ \(_, mCorr) -> case mCorr of
Nothing -> cell mempty Nothing -> cell mempty
Just (Entity _ SubmissionFile{..}) Just (Entity _ SubmissionFile{..})
| isJust submissionFileContent -> anchorCell (CSubmissionR tid ssh csh shn cid $ SubDownloadR SubmissionCorrected submissionFileTitle) | isJust submissionFileContent -> anchorCellM (subDownloadLink cid SubmissionCorrected submissionFileTitle) (i18n MsgFileCorrected :: Widget)
[whamlet|_{MsgFileCorrected}|]
| otherwise -> i18nCell MsgCorrected | otherwise -> i18nCell MsgCorrected
, Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let , Just . sortable (Just "time") (i18nCell MsgFileModified) $ \(mOrig, mCorr) -> let
origTime = submissionFileModified . entityVal <$> mOrig origTime = submissionFileModified . entityVal <$> mOrig
@ -505,6 +504,8 @@ submissionHelper tid ssh csh shn mcid = do
Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime Just fileTime = (max <$> origTime <*> corrTime) <|> origTime <|> corrTime
in dateTimeCell fileTime 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 :: _ -> _ -> E.SqlQuery _
submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do submissionFiles smid (sf1 `E.FullOuterJoin` sf2) = do
E.on $ sf1 E.?. SubmissionFileTitle E.==. sf2 E.?. SubmissionFileTitle 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_ $ sFile1 E.^. SubmissionFileSubmission E.==. E.val subId
E.where_ $ sFile2 E.?. SubmissionFileSubmission E.==. E.just (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 defaultLayout $ do
setTitleI $ MsgSubmissionEditHead tid ssh csh shn setTitleI $ MsgSubmissionEditHead tid ssh csh shn
let urlArchive cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionCorrected (urlArchive, urlOriginal) <- fmap ((,) <$> preview (_Just . _1) <*> preview (_Just . _2)) . for mcid $ \cID
urlOriginal cID = CSubmissionR tid ssh csh shn cID $ SubArchiveR SubmissionOriginal -> 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") $(widgetFile "submission")

77
src/Handler/Utils.hs
View File

@ -4,12 +4,9 @@ module Handler.Utils
import Import hiding (link) import Import hiding (link)
import qualified Data.Text.Encoding as T
import Data.Map ((!)) import Data.Map ((!))
import qualified Data.Map as Map import qualified Data.Map as Map
import qualified Data.Set as Set 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.DateTime as Handler.Utils
import Handler.Utils.Form 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.Occurrences as Handler.Utils
import Handler.Utils.Memcached as Handler.Utils import Handler.Utils.Memcached as Handler.Utils
import Handler.Utils.Files 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 Handler.Utils.Term as Handler.Utils
import Control.Monad.Logger 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, -- | Prefix a message with a short course id,
-- eg. for window title bars, etc. -- eg. for window title bars, etc.

9
src/Handler/Utils/ContentDisposition.hs
View File

@ -3,10 +3,11 @@ module Handler.Utils.ContentDisposition
, setContentDisposition' , setContentDisposition'
) where ) where
import Import import Import.NoFoundation
import Foundation.Type
-- | Check whether the user's preference for files is inline-viewing or downloading -- | 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 downloadFiles = do
mauth <- liftHandler maybeAuth mauth <- liftHandler maybeAuth
case mauth of case mauth of
@ -15,8 +16,8 @@ downloadFiles = do
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
return userDefaultDownloadFiles 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 setContentDisposition' mFileName = do
wantsDownload <- downloadFiles wantsDownload <- or2M (hasGlobalGetParam GetDownload) downloadFiles
setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName setContentDisposition (bool ContentInline ContentAttachment wantsDownload) mFileName

16
src/Handler/Utils/DateTime.hs
View File

@ -19,7 +19,8 @@ module Handler.Utils.DateTime
, formatGregorianW , formatGregorianW
) where ) where
import Import import Import.NoFoundation
import Foundation.Type
import Data.Time.Zones import Data.Time.Zones
import qualified Data.Time.Zones as TZ 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 -- formatTime :: (FormatTime t, MonadHandler m, HandlerSite m ~ UniWorX, IsString str) => (DateTimeFormat -> String) -> t -> m str
-- Restricted type for safety -- 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) formatTime proj t = flip formatTime' t =<< (unDateTimeFormat <$> getDateTimeFormat proj)
-- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text -- formatTimeH :: (HasLocalTime t) => SelDateTimeFormat -> t -> Handler Text
-- formatTimeH = formatTime -- 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 formatTimeW s t = toWidget =<< formatTime s t
formatTimeMail :: (MonadMail m, HasLocalTime t) => SelDateTimeFormat -> t -> m Text 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 :: MonadHandler m => m TimeLocale
getTimeLocale = getTimeLocale' <$> languages 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 getDateTimeFormat sel = do
mauth <- liftHandler maybeAuth mauth <- liftHandler maybeAuth
UserDefaultConf{..} <- getsYesod $ view _appUserDefaults UserDefaultConf{..} <- getsYesod $ view _appUserDefaults
@ -110,7 +111,7 @@ getDateTimeFormat sel = do
SelFormatTime -> userDefaultTimeFormat SelFormatTime -> userDefaultTimeFormat
return fmt 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 getDateTimeFormatter = do
locale <- getTimeLocale locale <- getTimeLocale
formatMap <- traverse getDateTimeFormat id formatMap <- traverse getDateTimeFormat id
@ -280,6 +281,7 @@ formatTimeRange' cont proj startT endT = do
formatTimeRange :: ( HasLocalTime t, HasLocalTime t' formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
, MonadHandler m , MonadHandler m
, HandlerSite m ~ UniWorX , HandlerSite m ~ UniWorX
, YesodAuthPersist UniWorX, AuthEntity UniWorX ~ User, AuthId UniWorX ~ UserId
) )
=> SelDateTimeFormat => SelDateTimeFormat
-> t -- ^ Start -> t -- ^ Start
@ -287,14 +289,14 @@ formatTimeRange :: ( HasLocalTime t, HasLocalTime t'
-> m Text -> m Text
formatTimeRange = formatTimeRange' formatTime 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' formatTimeRangeW s t t' = toWidget =<< formatTimeRange s t t'
formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text formatTimeRangeMail :: (MonadMail m, HasLocalTime t, HasLocalTime t') => SelDateTimeFormat -> t -> Maybe t' -> m Text
formatTimeRangeMail = formatTimeRange' formatTimeMail 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 formatGregorianW y m d = formatTimeW SelFormatDate $ fromGregorian y m d
instance Csv.ToField ZonedTime where instance Csv.ToField ZonedTime where

217
src/Handler/Utils/Download.hs Normal file
View 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

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

@ -7,7 +7,9 @@ module Handler.Utils.Files
, respondFileConditional , respondFileConditional
) where ) where
import Import import Import.NoFoundation
import Foundation.Type
import Utils.Metrics
import qualified Data.Conduit.Combinators as C import qualified Data.Conduit.Combinators as C
import qualified Data.Conduit.List as C (unfoldM) import qualified Data.Conduit.List as C (unfoldM)
@ -77,10 +79,11 @@ sourceFileMinio fileReference = do
in go in go
sourceFiles :: Monad m => ConduitT FileReference DBFile m () sourceFiles :: (Monad m, YesodPersistBackend UniWorX ~ SqlBackend) => ConduitT FileReference DBFile m ()
sourceFiles = C.map sourceFile sourceFiles = C.map sourceFile
sourceFile :: FileReference -> DBFile sourceFile :: YesodPersistBackend UniWorX ~ SqlBackend
=> FileReference -> DBFile
sourceFile FileReference{..} = File sourceFile FileReference{..} = File
{ fileTitle = fileReferenceTitle { fileTitle = fileReferenceTitle
, fileModified = fileReferenceModified , 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 inDB <- lift . E.selectExists . E.from $ \fileContentEntry -> E.where_ $ fileContentEntry E.^. FileContentEntryHash E.==. E.val fileReference
bool sourceFileMinio sourceFileDB inDB 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' 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) 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 => Maybe UTCTime -> MimeType
-> FileReference -> FileReference
-> SqlPersistT m (Handler a) -> SqlPersistT m (HandlerFor UniWorX a)
respondFileConditional representationLastModified cType FileReference{..} = do respondFileConditional representationLastModified cType FileReference{..} = do
if if
| Just fileContent <- fileReferenceContent | Just fileContent <- fileReferenceContent

3
src/Handler/Utils/Invitations.hs
View File

@ -26,6 +26,7 @@ import Text.Hamlet
import qualified Data.Conduit.List as C import qualified Data.Conduit.List as C
import qualified Data.List.NonEmpty as NonEmpty import qualified Data.List.NonEmpty as NonEmpty
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Aeson (fromJSON) import Data.Aeson (fromJSON)
@ -215,7 +216,7 @@ sinkInvitations InvitationConfig{..} = determineExists .| sinkInvitations'
jInviter <- liftHandler maybeAuthId jInviter <- liftHandler maybeAuthId
route <- mapReaderT liftHandler $ invitationRoute fEnt dat route <- mapReaderT liftHandler $ invitationRoute fEnt dat
InvitationTokenConfig{..} <- mapReaderT liftHandler $ invitationTokenConfig 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) let token = protoToken & bearerRestrict (urlRoute route) (InvitationTokenRestriction jInvitee $ dat ^. _invitationTokenData)
bearer <- encodeBearer token bearer <- encodeBearer token
jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)]) jInvitationUrl <- toTextUrl (route, [(toPathPiece GetBearer, toPathPiece bearer)])

4
src/Handler/Utils/Table/Cells.hs
View File

@ -104,11 +104,11 @@ isVisibleCell False = (cell . toWidget $ isVisible False) & addUrgencyClass
addUrgencyClass = addCellClass $ statusToUrgencyClass Warning addUrgencyClass = addCellClass $ statusToUrgencyClass Warning
-- | for simple file downloads -- | 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 fileCell route = anchorCell route iconFileDownload
-- | for zip-archive downloads -- | 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 zipCell route = anchorCell route iconFileZip
-- | for csv downloads -- | for csv downloads

3
src/Handler/Utils/Table/Columns.hs
View File

@ -25,6 +25,7 @@ import Handler.Utils.Form
import Handler.Utils.Widgets import Handler.Utils.Widgets
import Handler.Utils.DateTime import Handler.Utils.DateTime
import Handler.Utils.StudyFeatures import Handler.Utils.StudyFeatures
import Handler.Utils.Download
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
@ -375,7 +376,7 @@ colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
| showLink | showLink
-> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do -> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
cID <- encrypt appId cID <- encrypt appId
return $ CApplicationR tid ssh csh cID CAFilesR liftHandler . runDB . withFileDownloadToken (selectSource [ CourseApplicationFileApplication ==. appId ] []) $ CApplicationR tid ssh csh cID CAFilesR
| otherwise | otherwise
-> mempty -> mempty

10
src/Handler/Utils/Widgets.hs
View File

@ -31,11 +31,13 @@ visibleUTCTime dtf t = do
-- | Simple link to a known route -- | Simple link to a known route
simpleLink :: Widget -> Route UniWorX -> Widget simpleLink :: RedirectUrl UniWorX url => Widget -> url -> Widget
simpleLink lbl url = [whamlet|<a href=@{url}>^{lbl}|] simpleLink lbl url = do
tUrl <- toTextUrl url
[whamlet|<a href=#{tUrl}>^{lbl}|]
simpleLinkI :: SomeMessage UniWorX -> Route UniWorX -> Widget simpleLinkI :: (RenderMessage UniWorX msg, RedirectUrl UniWorX url) => msg -> url -> Widget
simpleLinkI lbl url = [whamlet|<a href=@{url}>_{lbl}|] simpleLinkI = simpleLink . i18n
-- | toWidget-Version of @nameHtml@, for convenience -- | toWidget-Version of @nameHtml@, for convenience
nameWidget :: Text -- ^ userDisplayName nameWidget :: Text -- ^ userDisplayName

2
src/Handler/Utils/Zip.hs
View File

@ -11,7 +11,7 @@ module Handler.Utils.Zip
, receiveFiles, acceptFile , receiveFiles, acceptFile
) where ) where
import Import import Import.NoFoundation
import Handler.Utils.Files (acceptFile) import Handler.Utils.Files (acceptFile)
import Handler.Utils.DateTime (localTimeToUTCSimple, utcToLocalTime) import Handler.Utils.DateTime (localTimeToUTCSimple, utcToLocalTime)

39
src/Handler/Workflow/Workflow/Workflow.hs
View File

@ -4,7 +4,7 @@ module Handler.Workflow.Workflow.Workflow
, workflowR , workflowR
) where ) where
import Import hiding (Last(..)) import Import hiding (Last(..), Encoding(None))
import Utils.Form import Utils.Form
import Utils.Workflow import Utils.Workflow
@ -44,7 +44,7 @@ data WorkflowHistoryItemActor = WHIASelf | WHIAOther (Maybe (Entity User)) | WHI
data WorkflowHistoryItem = WorkflowHistoryItem data WorkflowHistoryItem = WorkflowHistoryItem
{ whiUser :: Maybe WorkflowHistoryItemActor { whiUser :: Maybe WorkflowHistoryItemActor
, whiTime :: UTCTime , 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 , whiFrom :: Maybe (Maybe Text) -- ^ outer maybe encodes existence, inner maybe encodes permission to view
, whiVia :: Maybe Text , whiVia :: Maybe Text
, whiTo :: Maybe Text , whiTo :: Maybe Text
@ -53,11 +53,27 @@ data WorkflowHistoryItem = WorkflowHistoryItem
data WorkflowCurrentState = WorkflowCurrentState data WorkflowCurrentState = WorkflowCurrentState
{ wcsState :: Maybe Text { wcsState :: Maybe Text
, wcsMessages :: Set Message , wcsMessages :: Set Message
, wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe (Route UniWorX)))] , wcsPayload :: [(Text, ([WorkflowFieldPayloadW Void (Maybe (Entity User))], Maybe Text))]
} }
makePrisms ''WorkflowHistoryItemActor 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 :: CryptoFileNameWorkflowWorkflow -> Handler Html
getGWWWorkflowR = postGWWWorkflowR getGWWWorkflowR = postGWWWorkflowR
@ -155,6 +171,8 @@ workflowR rScope cID = do
-> WorkflowFieldPayloadW Void (Maybe (Entity User)) -> WorkflowFieldPayloadW Void (Maybe (Entity User))
-> Ordering -> Ordering
payloadSort (WorkflowFieldPayloadW a) (WorkflowFieldPayloadW b) = case (a, b) of 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 a', WFPText b' ) -> compareUnicode a' b'
(WFPText{}, _ ) -> LT (WFPText{}, _ ) -> LT
(WFPNumber a', WFPNumber b') -> compare a' b' (WFPNumber a', WFPNumber b') -> compare a' b'
@ -169,7 +187,6 @@ workflowR rScope cID = do
(WFPDay{}, WFPNumber{} ) -> GT (WFPDay{}, WFPNumber{} ) -> GT
(WFPDay{}, WFPBool{} ) -> GT (WFPDay{}, WFPBool{} ) -> GT
(WFPDay{}, _ ) -> LT (WFPDay{}, _ ) -> LT
(WFPFile a', _ ) -> absurd a'
(WFPUser a', WFPUser b' ) -> case (a', b') of (WFPUser a', WFPUser b' ) -> case (a', b') of
(Nothing, _) -> GT (Nothing, _) -> GT
(_, Nothing) -> LT (_, Nothing) -> LT
@ -178,13 +195,13 @@ workflowR rScope cID = do
<> (compareUnicode `on` userDisplayName) uA uB <> (compareUnicode `on` userDisplayName) uA uB
<> comparing userIdent uA uB <> comparing userIdent uA uB
(WFPUser{}, _ ) -> GT (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 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 (WFPText t ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPText t)
WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n) WorkflowFieldPayloadW (WFPNumber n ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPNumber n)
WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b) WorkflowFieldPayloadW (WFPBool b ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPBool b)
WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d) WorkflowFieldPayloadW (WFPDay d ) -> tell . (, mempty) . pure $ WorkflowFieldPayloadW (WFPDay d)
WorkflowFieldPayloadW (WFPFile _ ) -> tell (mempty, Any True) WorkflowFieldPayloadW (WFPFile fRef) -> tell (mempty, One fRef)
WorkflowFieldPayloadW (WFPUser uid) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid) WorkflowFieldPayloadW (WFPUser uid ) -> tell . (, mempty) . pure . review (_WorkflowFieldPayloadW . _WorkflowFieldPayload) =<< lift (lift . lift $ getEntity uid)
payloadChanges <- State.state $ \oldPayload -> payloadChanges <- State.state $ \oldPayload ->
( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload ( Map.filterWithKey (\k v -> Map.findWithDefault Set.empty k oldPayload /= v) currentPayload

1
src/Import/NoFoundation.hs
View File

@ -13,6 +13,7 @@ import Utils.Frontend.Notification as Import
import Utils.Lens as Import import Utils.Lens as Import
import Utils.Failover as Import import Utils.Failover as Import
import Utils.Room as Import import Utils.Room as Import
import Utils.Approot as Import
import Settings as Import import Settings as Import
import Settings.StaticFiles as Import import Settings.StaticFiles as Import

3
src/Jobs/Handler/ChangeUserDisplayEmail.hs
View File

@ -6,13 +6,14 @@ import Import
import Handler.Utils.Mail import Handler.Utils.Mail
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import qualified Data.CaseInsensitive as CI import qualified Data.CaseInsensitive as CI
import Text.Hamlet import Text.Hamlet
dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> JobHandler UniWorX dispatchJobChangeUserDisplayEmail :: UserId -> UserEmail -> JobHandler UniWorX
dispatchJobChangeUserDisplayEmail jUser jDisplayEmail = JobHandlerException $ do 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 jwt <- encodeBearer bearer
let let
setDisplayEmailUrl :: SomeRoute UniWorX setDisplayEmailUrl :: SomeRoute UniWorX

3
src/Jobs/Handler/SendNotification/Utils.hs
View File

@ -8,6 +8,7 @@ import Import
import Text.Hamlet import Text.Hamlet
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
ihamletSomeMessage :: HtmlUrlI18n UniWorXMessage (Route UniWorX) -> HtmlUrlI18n (SomeMessage UniWorX) (Route UniWorX) 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 :: (MonadHandler m, HandlerSite m ~ UniWorX) => UserId -> m (HtmlUrlI18n UniWorXMessage (Route UniWorX))
mkEditNotifications uid = liftHandler $ do mkEditNotifications uid = liftHandler $ do
cID <- encrypt uid 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 let
editNotificationsUrl :: SomeRoute UniWorX editNotificationsUrl :: SomeRoute UniWorX
editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)]) editNotificationsUrl = SomeRoute (UserNotificationR cID, [(toPathPiece GetBearer, toPathPiece jwt)])

3
src/Jobs/Handler/SendPasswordReset.hs
View File

@ -10,6 +10,7 @@ import Handler.Utils.Users
import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Base64 as Base64
import qualified Data.ByteArray as BA import qualified Data.ByteArray as BA
import qualified Data.HashSet as HashSet import qualified Data.HashSet as HashSet
import qualified Data.HashMap.Strict as HashMap
import Text.Hamlet import Text.Hamlet
@ -29,7 +30,7 @@ dispatchJobSendPasswordReset jRecipient = JobHandlerException . userMailT jRecip
LTUUnique utc' _ -> utc' LTUUnique utc' _ -> utc'
_other -> UTCTime (addDays 2 $ utctDay now) 0 _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' let resetBearer = resetBearer'
& bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication) & bearerRestrict (UserPasswordR cID) (decodeUtf8 . Base64.encode . BA.convert $ computeUserAuthenticationDigest userAuthentication)
encodedBearer <- encodeBearer resetBearer encodedBearer <- encodeBearer resetBearer

2
src/Jobs/HealthReport.hs
View File

@ -82,7 +82,7 @@ dispatchHealthCheckMatchingClusterConfig
dispatchHealthCheckHTTPReachable :: Handler HealthReport dispatchHealthCheckHTTPReachable :: Handler HealthReport
dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _appHealthCheckHTTPReachableTimeout) (Just False) $ do dispatchHealthCheckHTTPReachable = fmap HealthHTTPReachable . yesodTimeout (^. _appHealthCheckHTTPReachableTimeout) (Just False) $ do
staticAppRoot <- getsYesod $ view _appRoot staticAppRoot <- getsYesod $ views _appRoot ($ ApprootDefault)
doHTTP <- getsYesod $ view _appHealthCheckHTTP doHTTP <- getsYesod $ view _appHealthCheckHTTP
for (staticAppRoot <* guard doHTTP) $ \_ -> do for (staticAppRoot <* guard doHTTP) $ \_ -> do
url <- getUrlRender <*> pure InstanceR url <- getUrlRender <*> pure InstanceR

29
src/Model/Tokens/Bearer.hs
View File

@ -2,7 +2,7 @@
{-# LANGUAGE UndecidableInstances #-} {-# LANGUAGE UndecidableInstances #-}
module Model.Tokens.Bearer module Model.Tokens.Bearer
( BearerToken(..) ( BearerToken(..), BearerTokenRouteMode(..)
, _bearerIdentifier, _bearerAuthority, _bearerRoutes, _bearerAddAuth, _bearerRestrictions, _bearerRestrictionIx, _bearerRestrictionAt, _bearerIssuedAt, _bearerIssuedBy, _bearerExpiresAt, _bearerStartsAt , _bearerIdentifier, _bearerAuthority, _bearerRoutes, _bearerAddAuth, _bearerRestrictions, _bearerRestrictionIx, _bearerRestrictionAt, _bearerIssuedAt, _bearerIssuedBy, _bearerExpiresAt, _bearerStartsAt
, bearerRestrict , bearerRestrict
, bearerToJSON, bearerParseJSON , bearerToJSON, bearerParseJSON
@ -16,6 +16,9 @@ import Model.Tokens.Lens
import Utils (assertM', foldMapM) import Utils (assertM', foldMapM)
import Utils.Lens hiding ((.=)) import Utils.Lens hiding ((.=))
import Data.Aeson.Lens (AsJSON(..)) import Data.Aeson.Lens (AsJSON(..))
import Utils.PathPiece
import Data.Universe
import Yesod.Auth (AuthId) 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 -- | Presenting a `BearerToken` transfers some authorisation from `tokenAuthority` to /whoever/ presents the token
data BearerToken site = BearerToken data BearerToken site = BearerToken
{ bearerIdentifier :: TokenId { bearerIdentifier :: TokenId
-- ^ Unique identifier for each token; maybe useful for tracing usage of tokens -- ^ Unique identifier for each token; maybe useful for tracing usage of tokens
, bearerAuthority :: HashSet (Either Value (AuthId site)) , 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`) -- ^ 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 -- ^ Tokens can optionally be restricted to only be usable on a subset of routes
, bearerAddAuth :: Maybe AuthDNF , 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. -- ^ 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 authorityToJSON auths | [auth] <- otoList auths = either toJSON toJSON auth
| otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths | otherwise = toJSON $ HashSet.map (either toJSON toJSON) auths
iCID <- traverse I.encrypt bearerImpersonate :: m (Maybe (CryptoUUID (AuthId (HandlerSite m))))
return . JSON.object $ return . JSON.object $
catMaybes [ Just $ "authority" .= authorityToJSON cID catMaybes [ Just $ "authority" .= authorityToJSON cID
, ("routes" .=) <$> bearerRoutes , ("impersonate" .=) <$> iCID
, ("routes" .=) <$> assertM' (not . HashMap.null) bearerRoutes
, ("add-auth" .=) <$> bearerAddAuth , ("add-auth" .=) <$> bearerAddAuth
, ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions , ("restrictions" .=) <$> assertM' (not . HashMap.null) bearerRestrictions
] ]
@ -154,7 +173,9 @@ bearerParseJSON v@(Object o) = do
] :: ReaderT CryptoIDKey Parser (HashSet (Either Value (CryptoUUID (AuthId site)))) ] :: ReaderT CryptoIDKey Parser (HashSet (Either Value (CryptoUUID (AuthId site))))
bearerAuthority <- foldMapM (fmap HashSet.singleton . either (return . Left) (fmap Right . I.decrypt)) bearerAuthority' 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" bearerAddAuth <- lift $ o .:? "add-auth"
bearerRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty bearerRestrictions <- lift $ o .:? "restrictions" .!= HashMap.empty
Jose.JwtClaims{..} <- lift $ parseJSON v Jose.JwtClaims{..} <- lift $ parseJSON v

18
src/Settings.hs
View File

@ -94,7 +94,7 @@ data AppSettings = AppSettings
-- ^ Configuration settings for accessing a SMTP Mailserver -- ^ Configuration settings for accessing a SMTP Mailserver
, appWidgetMemcachedConf :: Maybe WidgetMemcachedConf , appWidgetMemcachedConf :: Maybe WidgetMemcachedConf
-- ^ Configuration settings for accessing a Memcached instance for use with `addStaticContent` -- ^ 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 -- ^ Base for all generated URLs. If @Nothing@, determined
-- from the request headers. -- from the request headers.
, appHost :: HostPreference , appHost :: HostPreference
@ -196,10 +196,16 @@ data AppSettings = AppSettings
, appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime , appFallbackPersonalisedSheetFilesKeysExpire :: NominalDiffTime
, appDownloadTokenExpire :: NominalDiffTime
, appInitialInstanceID :: Maybe (Either FilePath UUID) , appInitialInstanceID :: Maybe (Either FilePath UUID)
, appRibbon :: Maybe Text , appRibbon :: Maybe Text
} deriving Show } deriving Show
data ApprootScope = ApprootUserGenerated | ApprootDefault
deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
deriving anyclass (Universe, Finite, Hashable)
newtype ServerSessionSettings newtype ServerSessionSettings
= ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a } = ServerSessionSettings { applyServerSessionSettings :: forall a. ServerSession.State a -> ServerSession.State a }
@ -308,6 +314,12 @@ data VerpMode = VerpNone
| Verp { verpPrefix :: Text, verpSeparator :: Char } | Verp { verpPrefix :: Text, verpSeparator :: Char }
deriving (Eq, Show, Read, Generic) deriving (Eq, Show, Read, Generic)
nullaryPathPiece ''ApprootScope $ camelToPathPiece' 1
pathPieceJSON ''ApprootScope
pathPieceJSONKey ''ApprootScope
pathPieceBinary ''ApprootScope
pathPieceHttpApiData ''ApprootScope
deriveJSON defaultOptions deriveJSON defaultOptions
{ constructorTagModifier = camelToPathPiece' 1 { constructorTagModifier = camelToPathPiece' 1
, fieldLabelModifier = camelToPathPiece' 1 , fieldLabelModifier = camelToPathPiece' 1
@ -456,7 +468,7 @@ instance FromJSON AppSettings where
appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached" appWidgetMemcachedConf <- assertM validWidgetMemcachedConf <$> o .:? "widget-memcached"
appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached" appSessionMemcachedConf <- assertM validMemcachedConf <$> o .:? "session-memcached"
appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached" appMemcachedConf <- assertM validMemcachedConf <$> o .:? "memcached"
appRoot <- o .:? "approot" appRoot <- o .:? "approot" .!= const Nothing
appHost <- fromString <$> o .: "host" appHost <- fromString <$> o .: "host"
appPort <- o .: "port" appPort <- o .: "port"
appIpFromHeader <- o .: "ip-from-header" appIpFromHeader <- o .: "ip-from-header"
@ -564,6 +576,8 @@ instance FromJSON AppSettings where
appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire" appFallbackPersonalisedSheetFilesKeysExpire <- o .: "fallback-personalised-sheet-files-keys-expire"
appDownloadTokenExpire <- o .: "download-token-expire"
return AppSettings{..} return AppSettings{..}
makeClassy_ ''AppSettings makeClassy_ ''AppSettings

18
src/Utils/Approot.hs Normal file
View 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

2
src/Utils/Parameters.hs
View File

@ -21,7 +21,7 @@ import Data.Universe
import Control.Monad.Trans.Maybe (MaybeT(..)) 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 (Eq, Ord, Enum, Bounded, Read, Show, Generic)
deriving anyclass (Universe, Finite) deriving anyclass (Universe, Finite)

20
src/Utils/Route.hs
View File

@ -2,22 +2,40 @@ module Utils.Route where
import Control.Lens import Control.Lens
import ClassyPrelude.Yesod -- hiding (foldlM) import ClassyPrelude.Yesod -- hiding (foldlM)
import Data.Kind (Type)
import qualified Data.Map as Map
class RedirectUrl site url => HasRoute site url where 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 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 instance HasRoute site (Route site) where
urlRoute = id urlRoute = id
-- | for GET-Parameters -- | for GET-Parameters
instance (key ~ Text) => HasRoute site (Route site, Map key Text) where instance (key ~ Text) => HasRoute site (Route site, Map key Text) where
urlRoute = view _1 urlRoute = view _1
urlRouteParams _ = lens (views _2 Map.toList) (\(route, _) params -> (route, params))
-- | for GET-Parameters -- | for GET-Parameters
instance (key ~ Text) => HasRoute site (Route site, [(key, Text)]) where instance (key ~ Text) => HasRoute site (Route site, [(key, Text)]) where
urlRoute = view _1 urlRoute = view _1
urlRouteParams _ = _2
-- | for PageAnchors, implemented through Fragments -- | for PageAnchors, implemented through Fragments
instance (HasRoute site a, PathPiece b) => HasRoute site (Fragment a b) where 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 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 data SomeRoute site = forall url. HasRoute site url => SomeRoute url
deriving (Typeable) deriving (Typeable)
@ -25,4 +43,6 @@ data SomeRoute site = forall url. HasRoute site url => SomeRoute url
instance RedirectUrl site (SomeRoute site) where instance RedirectUrl site (SomeRoute site) where
toTextUrl (SomeRoute url) = toTextUrl url toTextUrl (SomeRoute url) = toTextUrl url
instance HasRoute site (SomeRoute site) where instance HasRoute site (SomeRoute site) where
type RouteWithParams site (SomeRoute site) = SomeRoute site
urlRoute (SomeRoute url) = urlRoute url 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))

13
src/Utils/Tokens.hs
View File

@ -53,14 +53,15 @@ bearerToken :: forall m.
, HasClusterID (HandlerSite m) ClusterId , HasClusterID (HandlerSite m) ClusterId
, HasAppSettings (HandlerSite m) , HasAppSettings (HandlerSite m)
) )
=> HashSet (Either Value (AuthId (HandlerSite m))) => HashSet (Either Value (AuthId (HandlerSite m))) -- ^ Authority
-> Maybe (HashSet (Route (HandlerSite m))) -> Maybe (AuthId (HandlerSite m)) -- ^ Impersonate
-> Maybe AuthDNF -> HashMap BearerTokenRouteMode (HashSet (Route (HandlerSite m)))
-> Maybe (Maybe UTCTime) -- ^ @Nothing@ determines default expiry time automatically -> Maybe AuthDNF -- ^ Additional auth
-> Maybe UTCTime -- ^ @Nothing@ means token starts to be valid immediately -> 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)) -> m (BearerToken (HandlerSite m))
-- ^ Smart constructor for `BearerToken`, does not set route restrictions (due to polymorphism), use `tokenRestrict` -- ^ 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 bearerIdentifier <- liftIO getRandom
bearerIssuedAt <- liftIO getCurrentTime bearerIssuedAt <- liftIO getCurrentTime
bearerIssuedBy <- getsYesod $ view instanceID bearerIssuedBy <- getsYesod $ view instanceID

4
templates/allocation/show/course.hamlet
View File

@ -40,9 +40,9 @@ $if hasApplicationTemplate || is _Just courseApplicationsInstructions
$maybe aInst <- courseApplicationsInstructions $maybe aInst <- courseApplicationsInstructions
<p> <p>
#{aInst} #{aInst}
$if hasApplicationTemplate $maybe templateUrl <- mApplicationTemplate
<p> <p>
<a href=@{CourseR courseTerm courseSchool courseShorthand CRegisterTemplateR}> <a href=#{templateUrl}>
#{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication} #{iconRegisterTemplate} _{MsgCourseApplicationTemplateApplication}
$maybe ApplicationFormView{ ..} <- mApplyFormView' $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> <div .allocation-course__application-label .allocation__label :not overrideVisible:uw-interactive-fieldset data-conditional-input=#{maybe "" fvId afvPriority} data-conditional-value="" data-conditional-negated>

2
templates/correction-user.hamlet
View File

@ -44,7 +44,7 @@
<tr .table__row> <tr .table__row>
<th .table__th>_{MsgRatingFiles} <th .table__th>_{MsgRatingFiles}
<td .table__td> <td .table__td>
<a href=@{CSubmissionR courseTerm courseSchool courseShorthand sheetName cid $ SubArchiveR SubmissionCorrected}> <a href=#{urlArchive}>
_{MsgRatingUpdatedFiles} _{MsgRatingUpdatedFiles}
$maybe comment <- ratingComment $maybe comment <- ratingComment

16
templates/course.hamlet
View File

@ -8,7 +8,7 @@ $newline never
<dd .deflist__dd> <dd .deflist__dd>
$if not (null news) $if not (null news)
<ul .course-news .list--iconless> <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}> <li .course-news-item ##{"news-" <> toPathPiece cID}>
$case (courseNewsTitle, courseNewsSummary) $case (courseNewsTitle, courseNewsSummary)
$# $of (Just title, Just summary) $# $of (Just title, Just summary)
@ -39,13 +39,13 @@ $# #{summary}
#{courseNewsContent} #{courseNewsContent}
$if showNewsFiles files $if showNewsFiles files
<ul .course-news-item__files-links .list--inline .list--comma-separated> <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> <li .course-news-item__file-link>
<a href=@{CNewsR tid ssh csh cID (CNFileR fp)}> <a href=#{fileUrl}>
#{fp} #{fp}
$elseif not (null files) $elseif not (null files)
<p .course-news-item__files-link> <p .course-news-item__files-link>
<a href=@{CNewsR tid ssh csh cID CNArchiveR}> <a href=#{archiveUrl}>
#{iconFileZip} #{iconFileZip}
\ _{MsgCourseNewsFiles} \ _{MsgCourseNewsFiles}
<p .course-news-item__last-edit> <p .course-news-item__last-edit>
@ -178,23 +178,23 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
<dd .deflist__dd> <dd .deflist__dd>
<div> <div>
#{aInst} #{aInst}
$if hasApplicationTemplate $maybe templateUrl <- mApplicationTemplate
<p> <p>
<a href=@{CourseR tid ssh csh CRegisterTemplateR}> <a href=#{templateUrl}>
#{iconRegisterTemplate} # #{iconRegisterTemplate} #
$if courseApplicationsRequired course $if courseApplicationsRequired course
_{MsgCourseApplicationTemplateApplication} _{MsgCourseApplicationTemplateApplication}
$else $else
_{MsgCourseApplicationTemplateRegistration} _{MsgCourseApplicationTemplateRegistration}
$nothing $nothing
$if hasApplicationTemplate $maybe templateUrl <- mApplicationTemplate
<dt .deflist__dt> <dt .deflist__dt>
$if courseApplicationsRequired course $if courseApplicationsRequired course
_{MsgCourseApplicationInstructionsApplication} _{MsgCourseApplicationInstructionsApplication}
$else $else
_{MsgCourseApplicationInstructionsRegistration} _{MsgCourseApplicationInstructionsRegistration}
<dd .deflist__dd> <dd .deflist__dd>
<a href=@{CourseR tid ssh csh CRegisterTemplateR}> <a href=#{templateUrl}>
#{iconRegisterTemplate} # #{iconRegisterTemplate} #
$if courseApplicationsRequired course $if courseApplicationsRequired course
_{MsgCourseApplicationTemplateApplication} _{MsgCourseApplicationTemplateApplication}

3
templates/mail/sheetActive.hamlet
View File

@ -15,7 +15,4 @@ $newline never
<p> <p>
<a href=@{CSheetR tid ssh csh shn SShowR}> <a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName} #{sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn (SZipR SheetExercise)}>
_{MsgSheetExercise}
^{editNotifications} ^{editNotifications}

3
templates/mail/sheetHint.hamlet
View File

@ -15,7 +15,4 @@ $newline never
<p> <p>
<a href=@{CSheetR tid ssh csh shn SShowR}> <a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName} #{sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn (SZipR SheetHint)}>
_{MsgSheetHint}
^{editNotifications} ^{editNotifications}

3
templates/mail/sheetSolution.hamlet
View File

@ -15,7 +15,4 @@ $newline never
<p> <p>
<a href=@{CSheetR tid ssh csh shn SShowR}> <a href=@{CSheetR tid ssh csh shn SShowR}>
#{sheetName} #{sheetName}
<p>
<a href=@{CSheetR tid ssh csh shn (SZipR SheetSolution)}>
_{MsgSheetSolution}
^{editNotifications} ^{editNotifications}

11
templates/submission.hamlet
View File

@ -1,5 +1,5 @@
$newline never $newline never
$maybe cID <- mcid $maybe _ <- mcid
$maybe wdgt <- correctionWdgt $maybe wdgt <- correctionWdgt
<section> <section>
<h2>_{MsgRating} <h2>_{MsgRating}
@ -18,12 +18,15 @@ $maybe cID <- mcid
_{MsgSubmissionFiles} _{MsgSubmissionFiles}
<p> <p>
$if showCorrection $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 $else
<a href=@{urlOriginal cID}>_{MsgSubmissionArchive} $maybe url <- urlOriginal
<a href=#{url}>_{MsgSubmissionArchive}
$maybe fileTable <- mFileTable $maybe fileTable <- mFileTable
^{fileTable} ^{fileTable}

2
templates/workflows/workflow.hamlet
View File

@ -33,7 +33,7 @@ $maybe WorkflowCurrentState{..} <- workflowState
<ul .list--iconless> <ul .list--iconless>
$maybe fileRoute <- mFileRoute $maybe fileRoute <- mFileRoute
<li> <li>
<a href=@{fileRoute}> <a href=#{fileRoute}>
_{MsgWorkflowPayloadFiles} _{MsgWorkflowPayloadFiles}
$forall pItem <- newPayload $forall pItem <- newPayload
<li> <li>

2
templates/workflows/workflow/history-item.hamlet
View File

@ -65,7 +65,7 @@ $newline never
<ul .list--iconless> <ul .list--iconless>
$maybe fileRoute <- mFileRoute $maybe fileRoute <- mFileRoute
<li> <li>
<a href=@{fileRoute}> <a href=#{fileRoute}>
_{MsgWorkflowPayloadFiles} _{MsgWorkflowPayloadFiles}
$forall pItem <- newPayload $forall pItem <- newPayload
<li> <li>