227 lines
11 KiB
Haskell
227 lines
11 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE TemplateHaskell #-}
|
|
{-# 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 Data.Time hiding (formatTime)
|
|
-- 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 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.InnerJoin (E.InnerJoin (E.SqlExpr (Entity CourseParticipant))
|
|
-- (E.SqlExpr (Entity Course )))
|
|
-- (E.SqlExpr (Entity Sheet ))
|
|
_ -> 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)
|