{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE NoImplicitPrelude #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE TupleSections #-} {-# LANGUAGE QuasiQuotes #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE IncoherentInstances #-} -- why is this needed? Instance for "display deadline" ought to be clear {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE PartialTypeSignatures #-} module Handler.Home where import Import import Handler.Utils import qualified Data.Map as Map import qualified Data.Text as Text import Data.Text.Encoding (decodeUtf8') import Data.Time hiding (formatTime) import Data.Universe import Data.Universe.Helpers import Network.Wai (requestHeaderReferer) -- import qualified Data.Text as T -- import Yesod.Form.Bootstrap3 -- import Web.PathPieces (showToPathPiece, readFromPathPiece) -- import Control.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import qualified Database.Esqueleto as E import Jobs -- import Text.Shakespeare.Text import Development.GitRev -- import qualified Data.UUID.Cryptographic as UUID -- CONSTANTS: TODO: make configurable elsewhere offSheetDeadlines :: NominalDiffTime offSheetDeadlines = 15 offCourseDeadlines :: NominalDiffTime offCourseDeadlines = 15 --offExamDeadlines :: NominalDiffTime --offExamDeadlines = 15 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}) } -> do 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) <- dbTable def $ DBTable { dbtSQLQuery = tableData , 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) ) ] -} , dbtStyle = def , dbtIdent = "upcomingdeadlines" :: Text } let features = $(widgetFile "featureList") addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen!" defaultLayout $ do $(widgetFile "dsgvDisclaimer") $(widgetFile "home") homeUser :: Key User -> Handler Html homeUser uid = do cTime <- liftIO getCurrentTime let fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime 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 E.&&. sheet E.^. SheetActiveTo E.<=. E.val fTime -- E.limit nrSheetDeadlines -- arbitrary limits are not intuitive 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) tickmark ] let validator = def & defaultSorting [("done",SortDesc), ("deadline",SortDesc)] ((), sheetTable) <- dbTable validator $ DBTable { dbtSQLQuery = tableData , 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) ) ] -} , dbtStyle = def { dbsEmptyStyle = DBESNoHeading, dbsEmptyMessage = MsgNoUpcomingSheetDeadlines } , dbtIdent = "upcomingdeadlines" :: Text } addMessage Warning "Vorabversion! Die Implementierung von Uni2work ist noch nicht abgeschlossen." defaultLayout $ do -- setTitle "Willkommen zum Uni2work Test!" $(widgetFile "homeUser") $(widgetFile "dsgvDisclaimer") getVersionR :: Handler TypedContent getVersionR = selectRep $ do provideRep . defaultLayout $ do let features = $(widgetFile "featureList") gitInfo :: Text gitInfo = $gitDescribe <> " (" <> $gitCommitDate <> ")" changeLog <- withUrlRenderer $(textFile "ChangeLog.md") $(widgetFile "versionHistory") provideRep $ return ($gitDescribe :: Text) data HelpIdentOptions = HIAnonymous | HIUser | HIEmail deriving (Eq, Ord, Bounded, Enum, Show, Read) $( return [] ) -- forces order of splices, error otherwise, see https://ghc.haskell.org/trac/ghc/ticket/9813 instance Universe HelpIdentOptions where universe = universeDef instance Finite HelpIdentOptions instance PathPiece HelpIdentOptions where toPathPiece = $(nullaryToPathPiece ''HelpIdentOptions [Text.intercalate "-" . map Text.toLower . unsafeTail . splitCamel]) fromPathPiece = finiteFromPathPiece instance RenderMessage UniWorX HelpIdentOptions where renderMessage _ _ opt = tshow opt -- TODO data HelpForm = HelpForm { hfReferer:: Maybe Text , hfUserId :: Either (Maybe Email) UserId , hfRequest:: Text } helpForm :: Maybe Text -> Maybe UserId -> AForm _ HelpForm helpForm mReferer mUid = HelpForm <$> maybe (pure Nothing) (fmap Just . aforced textField (fslI MsgDummy)) mReferer <*> multiActionA (fslI MsgDummy) identActions (HIUser <$ mUid) <*> (unTextarea <$> areq textareaField (fslI MsgDummy) Nothing) <* submitButton where identActions :: Map _ (AForm _ (Either (Maybe Email) UserId)) identActions = Map.fromList . catMaybes $ [ ( HIUser,) . pure . Right <$> mUid , Just (HIAnonymous, pure (Left Nothing)) , Just (HIEmail, Left . Just <$> apreq emailField (fslI MsgDummy) Nothing) ] getHelpR :: Handler Html getHelpR = postHelpR postHelpR :: Handler Html postHelpR = do mUid <- maybeAuthId mRefererBS <- requestHeaderReferer <$> waiRequest let mReferer = maybeRight . decodeUtf8' =<< mRefererBS ((res,formWidget),formEnctype) <- runFormPost $ renderAForm FormStandard $ helpForm mReferer mUid case res of FormSuccess (HelpForm{..}) -> do now <- liftIO getCurrentTime queueJob' $ JobHelpRequest { jSender = hfUserId , jHelpRequest = hfRequest , jRequestTime = now , jReferer = hfReferer } redirect $ HelpR {-selectRep $ do provideJson () provideRep (redirect $ HelpR :: Handler Html) -} FormMissing -> return () FormFailure errs -> mapM_ (addMessage Error . toHtml) errs defaultLayout $ do setTitle "Hilfe" -- TODO: International $(widgetFile "help")