330 lines
15 KiB
Haskell
330 lines
15 KiB
Haskell
module Handler.Home where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Data.Set as Set
|
|
import qualified Database.Esqueleto as E
|
|
|
|
import Jobs
|
|
import Development.GitRev
|
|
|
|
|
|
getHomeR :: Handler Html
|
|
getHomeR = do
|
|
muid <- maybeAuthId
|
|
case muid of
|
|
Nothing -> homeAnonymous
|
|
Just uid -> homeUser uid
|
|
|
|
|
|
homeAnonymous :: Handler Html
|
|
homeAnonymous = do
|
|
cTime <- liftIO getCurrentTime
|
|
let tableData :: E.SqlExpr (Entity Course)
|
|
-> E.SqlQuery (E.SqlExpr (Entity Course))
|
|
tableData course = do
|
|
E.where_ $ E.not_ (E.isNothing $ course E.^. CourseRegisterFrom) -- DO: do this with isAuthorized in dbtProj
|
|
E.&&. (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
|
|
E.&&. ( E.isNothing (course E.^. CourseRegisterTo)
|
|
E.||. course E.^. CourseRegisterTo E.>=. E.val (Just cTime)
|
|
)
|
|
return course
|
|
|
|
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (HandlerT UniWorX IO) ())
|
|
colonnade = mconcat
|
|
[ -- dbRow
|
|
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
|
textCell $ display $ courseTerm course
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
|
textCell $ display $ courseSchool course
|
|
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=Entity{entityVal = course} } -> do
|
|
let tid = courseTerm course
|
|
ssh = courseSchool course
|
|
csh = courseShorthand course
|
|
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
|
|
, sortable (Just "deadline") (i18nCell MsgRegisterTo) $ \DBRow{ dbrOutput=Entity{entityVal = course} } ->
|
|
cell $ traverse (formatTime SelFormatDateTime) (courseRegisterTo course) >>= maybe mempty toWidget
|
|
]
|
|
courseTable <- runDB $ dbTableWidget' def DBTable
|
|
{ dbtSQLQuery = tableData
|
|
, dbtRowKey = (E.^. CourseId)
|
|
, dbtColonnade = colonnade
|
|
, dbtProj = return
|
|
, dbtSorting = Map.fromList
|
|
[ ( "term"
|
|
, SortColumn $ \course -> course E.^. CourseTerm
|
|
)
|
|
, ( "school"
|
|
, SortColumn $ \course -> course E.^. CourseSchool
|
|
)
|
|
, ( "course"
|
|
, SortColumn $ \course -> course E.^. CourseShorthand
|
|
)
|
|
, ( "deadline"
|
|
, SortColumn $ \course -> course E.^. CourseRegisterTo
|
|
)
|
|
]
|
|
, dbtFilter = mempty {- [ ( "term"
|
|
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
|
|
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
|
)
|
|
] -}
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def
|
|
, dbtParams = def
|
|
, dbtIdent = "upcomingdeadlines" :: Text
|
|
}
|
|
-- let features = $(widgetFile "featureList")
|
|
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!"
|
|
defaultLayout
|
|
-- (widgetFile "dsgvDisclaimer")
|
|
$(widgetFile "home")
|
|
|
|
homeUser :: Key User -> Handler Html
|
|
homeUser uid = do
|
|
cTime <- liftIO getCurrentTime
|
|
let tableData :: E.LeftOuterJoin
|
|
(E.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant)) (E.SqlExpr (Entity Course))) (E.SqlExpr (Entity Sheet)))
|
|
(E.InnerJoin (E.SqlExpr (Maybe (Entity Submission))) (E.SqlExpr (Maybe (Entity SubmissionUser))))
|
|
-> E.SqlQuery ( E.SqlExpr (E.Value (Key Term))
|
|
, E.SqlExpr (E.Value SchoolId)
|
|
, E.SqlExpr (E.Value CourseShorthand)
|
|
, E.SqlExpr (E.Value SheetName)
|
|
, E.SqlExpr (E.Value UTCTime)
|
|
, E.SqlExpr (E.Value (Maybe SubmissionId)))
|
|
tableData ((participant `E.InnerJoin` course `E.InnerJoin` sheet) `E.LeftOuterJoin` (submission `E.InnerJoin` subuser)) = do
|
|
E.on $ submission E.?. SubmissionId E.==. subuser E.?. SubmissionUserSubmission
|
|
E.&&. E.just (E.val uid) E.==. subuser E.?. SubmissionUserUser
|
|
E.on $ submission E.?. SubmissionSheet E.==. E.just(sheet E.^. SheetId)
|
|
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
|
E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse
|
|
E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
|
|
E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
|
|
return
|
|
( course E.^. CourseTerm
|
|
, course E.^. CourseSchool
|
|
, course E.^. CourseShorthand
|
|
, sheet E.^. SheetName
|
|
, sheet E.^. SheetActiveTo
|
|
, submission E.?. SubmissionId
|
|
)
|
|
|
|
colonnade :: Colonnade Sortable (DBRow ( E.Value (Key Term)
|
|
, E.Value SchoolId
|
|
, E.Value CourseShorthand
|
|
, E.Value SheetName
|
|
, E.Value UTCTime
|
|
, E.Value (Maybe SubmissionId)
|
|
))
|
|
(DBCell (HandlerT UniWorX IO) ())
|
|
colonnade = mconcat
|
|
[ -- dbRow
|
|
-- TOOD: sortable (Just "term") (textCell MsgTerm) $ \DBRow{ dbrOutput=(view _1 -> E.Value tid) } ->
|
|
sortable (Just "term") (i18nCell MsgTerm) $ \DBRow{ dbrOutput=(E.Value tid,_,_,_,_,_) } ->
|
|
textCell $ display tid
|
|
, sortable (Just "school") (i18nCell MsgCourseSchool) $ \DBRow{ dbrOutput=(_,E.Value ssh,_,_,_,_) } ->
|
|
textCell $ display ssh
|
|
, sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, _, _, _) } ->
|
|
anchorCell (CourseR tid ssh csh CShowR) (toWidget $ display csh)
|
|
, sortable (Just "sheet") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) } ->
|
|
anchorCell (CSheetR tid ssh csh shn SShowR) (toWidget $ display shn)
|
|
, sortable (Just "deadline") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, _, E.Value deadline, _) } ->
|
|
cell $ formatTime SelFormatDateTime deadline >>= toWidget
|
|
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, E.Value mbsid) } ->
|
|
case mbsid of
|
|
Nothing -> mempty
|
|
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
|
(toWidget $ hasTickmark True)
|
|
]
|
|
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
|
|
sheetTable <- runDB $ dbTableWidget' validator DBTable
|
|
{ dbtSQLQuery = tableData
|
|
, dbtRowKey = \((_ `E.InnerJoin` _ `E.InnerJoin` sheet) `E.LeftOuterJoin` _) -> sheet E.^. SheetId
|
|
, dbtColonnade = colonnade
|
|
, dbtProj = \row@DBRow{ dbrOutput = (E.Value tid, E.Value ssh, E.Value csh, E.Value shn, _, _) }
|
|
-> row <$ guardM (lift $ (== Authorized) <$> evalAccessDB (CSheetR tid ssh csh shn SShowR) False)
|
|
, dbtSorting = Map.fromList
|
|
[ ( "term"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
|
)
|
|
, ( "school"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseSchool
|
|
)
|
|
, ( "course"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
|
)
|
|
, ( "sheet"
|
|
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
|
)
|
|
, ( "deadline"
|
|
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveTo
|
|
)
|
|
, ( "done"
|
|
, SortColumn $ \(_ `E.InnerJoin` _ `E.InnerJoin` _ `E.LeftOuterJoin` (subm `E.InnerJoin` _)) -> E.isNothing $ subm E.?. SubmissionId
|
|
)
|
|
]
|
|
, dbtFilter = mempty {- [ ( "term"
|
|
, FilterColumn $ \(course `E.InnerJoin` _ `E.InnerJoin` _ ) tids -> if
|
|
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
|
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
|
)
|
|
] -}
|
|
, dbtFilterUI = mempty
|
|
, dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines }
|
|
, dbtParams = def
|
|
, dbtIdent = "upcomingdeadlines" :: Text
|
|
}
|
|
-- addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen."
|
|
defaultLayout $
|
|
-- setTitle "Willkommen zum Uni2work Test!"
|
|
$(widgetFile "homeUser")
|
|
-- (widgetFile "dsgvDisclaimer")
|
|
|
|
-- | Versionsgeschichte
|
|
getVersionR :: Handler TypedContent
|
|
getVersionR = getInfoR -- TODO
|
|
|
|
-- | Impressum
|
|
getImpressumR :: Handler Html
|
|
getImpressumR = -- do
|
|
siteLayoutMsg' MsgMenuImpressum $ do
|
|
setTitleI MsgImpressumHeading
|
|
$(i18nWidgetFile "imprint")
|
|
|
|
|
|
-- | Hinweise zu Datenschutz und Aufbewahrungspflichten
|
|
getDataProtR :: Handler Html
|
|
getDataProtR = -- do
|
|
siteLayoutMsg' MsgMenuDataProt $ do
|
|
setTitleI MsgDataProtHeading
|
|
$(i18nWidgetFile "data-protection")
|
|
|
|
|
|
-- | Allgemeine Informationen
|
|
getInfoR :: Handler TypedContent
|
|
getInfoR = selectRep $ do
|
|
let infoHeading = [whamlet|Re-Implementierung von <a href="https://uniworx.ifi.lmu.de/">UniWorX</a>|]
|
|
provideRep . siteLayout infoHeading $ do
|
|
let features = $(widgetFile "featureList")
|
|
gitInfo :: Text
|
|
gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")"
|
|
changeLog <- withUrlRenderer $(textFile "ChangeLog.md")
|
|
$(widgetFile "versionHistory")
|
|
provideRep $
|
|
return ($gitDescribe :: Text)
|
|
|
|
|
|
|
|
|
|
data HelpIdentOptions = HIUser | HIEmail | HIAnonymous
|
|
deriving (Eq, Ord, Bounded, Enum, Show, Read)
|
|
|
|
instance Universe HelpIdentOptions
|
|
instance Finite HelpIdentOptions
|
|
|
|
nullaryPathPiece ''HelpIdentOptions (camelToPathPiece' 1)
|
|
embedRenderMessage ''UniWorX ''HelpIdentOptions (("Help" <>) . dropPrefix "HI")
|
|
|
|
data HelpForm = HelpForm
|
|
{ hfReferer:: Maybe (Route UniWorX)
|
|
, hfUserId :: Either (Maybe Address) UserId
|
|
, hfRequest:: Text
|
|
}
|
|
|
|
helpForm :: Maybe (Route UniWorX) -> Maybe UserId -> AForm _ HelpForm
|
|
helpForm mReferer mUid = HelpForm
|
|
<$> aopt routeField (fslI MsgHelpProblemPage & inputReadonly) (Just <$> mReferer)
|
|
<*> multiActionA (fslI MsgHelpAnswer) identActions (HIUser <$ mUid)
|
|
<*> (unTextarea <$> areq textareaField (fslI MsgHelpRequest) Nothing)
|
|
where
|
|
identActions :: Map _ (AForm _ (Either (Maybe Address) UserId))
|
|
identActions = Map.fromList $ case mUid of
|
|
(Just uid) -> (HIUser, pure $ Right uid):defaultActions
|
|
Nothing -> defaultActions
|
|
|
|
defaultActions =
|
|
[ (HIEmail, Left . Just <$> (Address <$> aopt textField (fslI MsgName) Nothing <*> apreq emailField (fslI MsgEMail) Nothing))
|
|
, (HIAnonymous, pure $ Left Nothing)
|
|
]
|
|
|
|
getHelpR, postHelpR :: Handler Html
|
|
getHelpR = postHelpR
|
|
postHelpR = do
|
|
mUid <- maybeAuthId
|
|
mReferer <- flip formResultMaybe return <=< runInputGetResult $ iopt routeField (toPathPiece GetReferer)
|
|
isModal <- hasCustomHeader HeaderIsModal
|
|
|
|
((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid
|
|
let form = wrapForm formWidget def
|
|
{ formAction = Just $ SomeRoute HelpR
|
|
, formEncoding = formEnctype
|
|
, formAttrs = [ ("uw-async-form", "") | isModal ]
|
|
}
|
|
|
|
formResultModal res HelpR $ \HelpForm{..} -> do
|
|
now <- liftIO getCurrentTime
|
|
hfReferer' <- traverse toTextUrl hfReferer
|
|
queueJob' JobHelpRequest
|
|
{ jSender = hfUserId
|
|
, jHelpRequest = hfRequest
|
|
, jRequestTime = now
|
|
, jReferer = hfReferer'
|
|
}
|
|
tell . pure =<< messageI Success MsgHelpSent
|
|
|
|
defaultLayout $ do
|
|
setTitleI MsgHelpTitle
|
|
$(widgetFile "help")
|
|
|
|
|
|
getInfoLecturerR :: Handler Html
|
|
getInfoLecturerR =
|
|
siteLayoutMsg' MsgInfoLecturerTitle $ do
|
|
setTitleI MsgInfoLecturerTitle
|
|
$(i18nWidgetFile "info-lecturer")
|
|
|
|
|
|
getAuthPredsR, postAuthPredsR :: Handler Html
|
|
getAuthPredsR = postAuthPredsR
|
|
postAuthPredsR = do
|
|
(AuthTagActive authTagCurrentActive) <- fromMaybe def <$> lookupSessionJson SessionActiveAuthTags
|
|
|
|
let
|
|
blacklist = Set.fromList [ AuthFree, AuthDevelopment, AuthDeprecated ]
|
|
taForm authTag
|
|
| authTag `Set.member` blacklist = aforced checkBoxField (fslI authTag) (authTagIsActive def authTag)
|
|
| otherwise = fromMaybe False <$> aopt checkBoxField (fslI authTag) (Just . Just $ authTagCurrentActive authTag)
|
|
|
|
((authActiveRes, authActiveWidget), authActiveEnctype) <- runFormPost . renderAForm FormStandard
|
|
$ AuthTagActive <$> funcForm taForm (fslI MsgActiveAuthTags) True
|
|
|
|
mReferer <- runMaybeT $ do
|
|
param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer)
|
|
MaybeT . return $ fromPathPiece param
|
|
|
|
let authActiveForm = wrapForm authActiveWidget' def
|
|
{ formAction = Just $ SomeRoute AuthPredsR
|
|
, formEncoding = authActiveEnctype
|
|
, formSubmit = FormDualSubmit
|
|
}
|
|
authActiveWidget'
|
|
= [whamlet|
|
|
$newline never
|
|
$maybe referer <- mReferer
|
|
<input type=hidden name=#{toPathPiece GetReferer} value=#{toPathPiece referer}>
|
|
^{authActiveWidget}
|
|
|]
|
|
|
|
formResult authActiveRes $ \authTagActive -> do
|
|
setSessionJson SessionActiveAuthTags authTagActive
|
|
modifySessionJson SessionInactiveAuthTags . fmap $ Set.filter (not . authTagIsActive authTagActive)
|
|
addMessageI Success MsgAuthPredsActiveChanged
|
|
redirect $ fromMaybe AuthPredsR mReferer
|
|
|
|
siteLayoutMsg MsgAuthPredsActive $ do
|
|
setTitleI MsgAuthPredsActive
|
|
$(widgetFile "authpreds")
|