172 lines
6.9 KiB
Haskell
172 lines
6.9 KiB
Haskell
{-# LANGUAGE RecordWildCards #-}
|
|
{-# LANGUAGE NoImplicitPrelude #-}
|
|
{-# LANGUAGE OverloadedStrings #-}
|
|
{-# LANGUAGE OverloadedLists #-}
|
|
{-# 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 Data.Time
|
|
-- 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 qualified Data.UUID.Cryptographic as UUID
|
|
|
|
|
|
-- Some constants:
|
|
nrSheetDeadlines :: Int64
|
|
nrSheetDeadlines = 10
|
|
offSheetDeadlines :: NominalDiffTime
|
|
offSheetDeadlines = 15
|
|
--nrExamDeadlines = 10
|
|
--offExamDeadlines = 15
|
|
--nrCourseDeadlines = 10
|
|
--offCourseDeadlines = 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 fTime = addUTCTime (offSheetDeadlines * nominalDay) cTime
|
|
let tableData :: E.SqlExpr (Entity Course)
|
|
-> E.SqlQuery (E.SqlExpr (Entity Course))
|
|
tableData course = do
|
|
E.where_ $ course E.^. CourseHasRegistration E.==. E.val True
|
|
E.&&. course E.^. CourseRegisterFrom E.<=. E.val (Just cTime)
|
|
E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
|
|
E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
|
|
E.limit nrSheetDeadlines
|
|
E.orderBy [ E.asc $ course E.^. CourseRegisterTo
|
|
, E.desc $ course E.^. CourseShorthand
|
|
]
|
|
E.limit nrSheetDeadlines
|
|
return course
|
|
|
|
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ())
|
|
colonnade = mconcat
|
|
[ -- dbRow
|
|
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
|
|
let tid = courseTerm course
|
|
csh = courseShorthand course
|
|
cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
|
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } ->
|
|
textCell $ display $ courseRegisterTo course
|
|
]
|
|
courseTable <- dbTable def $ DBTable
|
|
{ dbtSQLQuery = tableData
|
|
, dbtColonnade = colonnade
|
|
, dbtSorting = [ ( "term"
|
|
, SortColumn $ \(course) -> course E.^. CourseTerm
|
|
)
|
|
, ( "course"
|
|
, SortColumn $ \(course) -> course E.^. CourseShorthand
|
|
)
|
|
-- TODO
|
|
]
|
|
, 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)
|
|
)
|
|
] -}
|
|
, dbtAttrs = tableDefault
|
|
, dbtIdent = "upcomingdeadlines" :: Text
|
|
}
|
|
|
|
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 Text)
|
|
, E.SqlExpr (E.Value Text)
|
|
, E.SqlExpr (E.Value UTCTime))
|
|
tableData (participant `E.InnerJoin` course `E.InnerJoin` sheet) = do
|
|
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 fTime
|
|
E.&&. sheet E.^. SheetActiveTo E.>=. E.val cTime
|
|
E.orderBy [ E.asc $ sheet E.^. SheetActiveTo
|
|
, E.desc $ sheet E.^. SheetName
|
|
, E.desc $ course E.^. CourseShorthand
|
|
]
|
|
E.limit nrSheetDeadlines
|
|
return
|
|
( course E.^. CourseTerm
|
|
, course E.^. CourseShorthand
|
|
, sheet E.^. SheetName
|
|
, sheet E.^. SheetActiveTo
|
|
)
|
|
|
|
colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (DBCell (WidgetT UniWorX IO) ())
|
|
colonnade = mconcat
|
|
[ -- dbRow
|
|
sortable (Just "course") (textCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } ->
|
|
cell [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
|
, sortable (Just "sheet") (textCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } ->
|
|
cell [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
|
|
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } ->
|
|
textCell $ display deadline
|
|
, sortable (Just "done") (textCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } ->
|
|
textCell ("?" :: Text)
|
|
]
|
|
sheetTable <- dbTable def $ DBTable
|
|
{ dbtSQLQuery = tableData
|
|
, dbtColonnade = colonnade
|
|
, dbtSorting = [ ( "term"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseTerm
|
|
)
|
|
, ( "course"
|
|
, SortColumn $ \(_ `E.InnerJoin` course `E.InnerJoin` _ ) -> course E.^. CourseShorthand
|
|
)
|
|
-- TODO
|
|
]
|
|
, 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)
|
|
)
|
|
] -}
|
|
, dbtAttrs = tableDefault
|
|
, dbtIdent = "upcomingdeadlines" :: Text
|
|
}
|
|
|
|
defaultLayout $ do
|
|
-- setTitle "Willkommen zum Uniworky Test!"
|
|
$(widgetFile "homeUser")
|
|
$(widgetFile "dsgvDisclaimer")
|