177 lines
9.5 KiB
Haskell
177 lines
9.5 KiB
Haskell
module Handler.Home where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
|
|
import qualified Data.Map as Map
|
|
import qualified Database.Esqueleto as E
|
|
|
|
|
|
getHomeR :: Handler Html
|
|
getHomeR = do
|
|
muid <- maybeAuthId
|
|
defaultLayout $ do
|
|
setTitleI MsgHomeHeading
|
|
maybe mempty homeUpcomingSheets muid
|
|
homeOpenCourses
|
|
|
|
|
|
homeOpenCourses :: Widget
|
|
homeOpenCourses = 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 <- liftHandlerT . 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 = "open-courses" :: Text
|
|
}
|
|
$(widgetFile "home/openCourses")
|
|
|
|
homeUpcomingSheets :: UserId -> Widget
|
|
homeUpcomingSheets 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 -> cell $ do
|
|
let submitRoute = CSheetR tid ssh csh shn SubmissionNewR
|
|
whenM (hasWriteAccessTo submitRoute) $
|
|
modal [whamlet|_{MsgMenuSubmissionNew}|] . Left $ SomeRoute submitRoute
|
|
(Just sid) -> anchorCellM (CSubmissionR tid ssh csh shn <$> encrypt sid <*> pure SubShowR)
|
|
(toWidget $ hasTickmark True)
|
|
]
|
|
let validator = def & defaultSorting [SortDescBy "done", SortAscBy "deadline"]
|
|
sheetTable <- liftHandlerT . 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 = "upcoming-sheets" :: Text
|
|
}
|
|
$(widgetFile "home/upcomingSheets")
|