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 UniWorX|] 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) <* submitButton 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) ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid 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 isModal <- hasCustomHeader HeaderIsModal $(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 <$> (submitButton -- for convenience, avoids frequent scrolling *> funcForm taForm (fslI MsgActiveAuthTags) True) <* submitButton mReferer <- runMaybeT $ do param <- MaybeT (lookupGetParam $ toPathPiece GetReferer) <|> MaybeT (lookupPostParam $ toPathPiece GetReferer) MaybeT . return $ fromPathPiece param 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")