fraport/fradrive
3
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Fixes #183

Browse Source
This commit is contained in:
SJost 2018-09-19 19:40:05 +02:00
parent 0e6596889a
commit f914963eb5
5 changed files with 34 additions and 36 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

22
src/Handler/Sheet.hs
View File

@ -22,6 +22,7 @@ import System.FilePath (takeFileName)
import Handler.Utils import Handler.Utils
-- import Handler.Utils.Zip -- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
-- import Data.Time -- import Data.Time
-- import qualified Data.Text as T -- import qualified Data.Text as T
@ -150,27 +151,25 @@ getSheetListR tid ssh csh = do
muid <- maybeAuthId muid <- maybeAuthId
Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh Entity cid _ <- runDB . getBy404 $ TermSchoolCourseShort tid ssh csh
let let
lastSheetEdit sheet = E.sub_select . E.from $ \sheetEdit -> do
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit E.^. SheetEditTime
sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission))) sheetData :: E.SqlExpr (Entity Sheet) `E.LeftOuterJoin` (E.SqlExpr (Maybe (Entity Submission)) `E.InnerJoin` (E.SqlExpr (Maybe (Entity SubmissionUser)))) -> E.SqlQuery (E.SqlExpr (Entity Sheet), E.SqlExpr (E.Value (Maybe UTCTime)),E.SqlExpr (Maybe (Entity Submission)))
sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do sheetData (sheet `E.LeftOuterJoin` (submission `E.InnerJoin` submissionUser)) = do
E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission E.on $ submission E.?. SubmissionId E.==. submissionUser E.?. SubmissionUserSubmission
E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet E.on $ (E.just $ sheet E.^. SheetId) E.==. submission E.?. SubmissionSheet
E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid E.&&. submissionUser E.?. SubmissionUserUser E.==. E.val muid
let sheetEdit = E.sub_select . E.from $ \sheetEdit' -> do
E.where_ $ sheetEdit' E.^. SheetEditSheet E.==. sheet E.^. SheetId
return . E.max_ $ sheetEdit' E.^. SheetEditTime
E.where_ $ sheet E.^. SheetCourse E.==. E.val cid E.where_ $ sheet E.^. SheetCourse E.==. E.val cid
return (sheet, sheetEdit, submission) return (sheet, lastSheetEdit sheet, submission)
sheetCol = widgetColonnade . mconcat $ sheetCol = widgetColonnade . mconcat $
[ sortable (Just "name") (i18nCell MsgSheet) [ sortable (Just "name") (i18nCell MsgSheet)
$ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName) $ \(Entity _ Sheet{..}, _, _) -> anchorCell (CSheetR tid ssh csh sheetName SShowR) (toWidget sheetName)
, sortable (Just "last-edit") (i18nCell MsgLastEdit) , sortable (Just "last-edit") (i18nCell MsgLastEdit)
$ \(_, E.Value mEditTime, _) -> case mEditTime of $ \(_, E.Value mEditTime, _) -> maybe mempty timeCell mEditTime
Just editTime -> cell $ formatTime SelFormatDateTime (editTime :: UTCTime) >>= toWidget
Nothing -> mempty
, sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom) , sortable (Just "submission-since") (i18nCell MsgSheetActiveFrom)
$ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveFrom >>= toWidget $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveFrom
, sortable (Just "submission-until") (i18nCell MsgSheetActiveTo) , sortable (Just "submission-until") (i18nCell MsgSheetActiveTo)
$ \(Entity _ Sheet{..}, _, _) -> cell $ formatTime SelFormatDateTime sheetActiveTo >>= toWidget $ \(Entity _ Sheet{..}, _, _) -> timeCell sheetActiveTo
, sortable Nothing (i18nCell MsgSheetType) , sortable Nothing (i18nCell MsgSheetType)
$ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType $ \(Entity _ Sheet{..}, _, _) -> textCell $ display sheetType
, sortable Nothing (i18nCell MsgSubmission) , sortable Nothing (i18nCell MsgSubmission)
@ -203,7 +202,7 @@ getSheetListR tid ssh csh = do
in textCell $ textPercent $ realToFrac percent in textCell $ textPercent $ realToFrac percent
_other -> mempty _other -> mempty
_other -> mempty _other -> mempty
] ]
psValidator = def psValidator = def
& defaultSorting [("submission-since", SortAsc)] & defaultSorting [("submission-since", SortAsc)]
(SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable (SheetTypeSummary{..}, table) <- dbTable psValidator $ DBTable
@ -216,8 +215,7 @@ getSheetListR tid ssh csh = do
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetName
) )
, ( "last-edit" , ( "last-edit"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> E.sub_select . E.from $ \sheetEdit -> E.distinctOnOrderBy [E.desc $ sheetEdit E.?. SheetEditTime] $ do , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> lastSheetEdit sheet
return $ sheetEdit E.?. SheetEditTime
) )
, ( "submission-since" , ( "submission-since"
, SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom , SortColumn $ \(sheet `E.LeftOuterJoin` _) -> sheet E.^. SheetActiveFrom

38
src/Handler/Submission.hs
View File

@ -27,36 +27,36 @@ import Handler.Utils.Table.Cells
import Network.Mime import Network.Mime
import Control.Monad.Trans.Maybe -- import Control.Monad.Trans.Maybe
import Control.Monad.State.Class -- import Control.Monad.State.Class
import Control.Monad.Trans.State.Strict (StateT) -- import Control.Monad.Trans.State.Strict (StateT)
import Data.Monoid (Any(..)) import Data.Monoid (Any(..))
import Data.Maybe (fromJust) import Data.Maybe (fromJust)
import qualified Data.Maybe -- import qualified Data.Maybe
import qualified Data.Text as Text import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text import qualified Data.Text.Encoding as Text
import Data.CaseInsensitive (CI) import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI -- import qualified Data.CaseInsensitive as CI
import qualified Database.Esqueleto as E import qualified Database.Esqueleto as E
import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction) import qualified Database.Esqueleto.Internal.Sql as E (unsafeSqlFunction)
import qualified Data.Conduit.List as Conduit import qualified Data.Conduit.List as Conduit
import Data.Conduit.ResumableSink -- import Data.Conduit.ResumableSink
import Data.Set (Set) -- import Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Data.Map (Map) import Data.Map (Map)
import qualified Data.Map as Map import qualified Data.Map as Map
import Data.Bifunctor -- import Data.Bifunctor
import System.FilePath import System.FilePath
import Colonnade hiding (bool, fromMaybe) -- import Colonnade hiding (bool, fromMaybe)
import qualified Yesod.Colonnade as Yesod -- import qualified Yesod.Colonnade as Yesod
import qualified Text.Blaze.Html5.Attributes as HA -- import qualified Text.Blaze.Html5.Attributes as HA
-- DEPRECATED: We always show all edits! -- DEPRECATED: We always show all edits!
-- numberOfSubmissionEditDates :: Int64 -- numberOfSubmissionEditDates :: Int64
@ -113,7 +113,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc. maySubmit <- (== Authorized) <$> isAuthorized actionUrl True -- affects visibility of Edit-Dates, Submission-Button, etc.
(Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do (Entity shid Sheet{..}, buddies, lastEdits) <- runDB $ do
sheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn csheet@(Entity shid Sheet{..}) <- fetchSheet tid ssh csh shn
case msmid of case msmid of
Nothing -> do Nothing -> do
submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do submissions <- E.select . E.from $ \(submission `E.InnerJoin` submissionUser) -> do
@ -127,12 +127,12 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
-- fetch buddies from previous submission in this course -- fetch buddies from previous submission in this course
buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do buddies <- E.select . E.from $ \(submissionUser `E.InnerJoin` user) -> do
E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId) E.on (submissionUser E.^. SubmissionUserUser E.==. user E.^. UserId)
let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser `E.InnerJoin` submissionEdit) -> do let oldids = E.subList_select . E.from $ \(sheet `E.InnerJoin` submission `E.InnerJoin` subUser `E.InnerJoin` submissionEdit) -> do
E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId) E.on (submissionEdit E.^. SubmissionEditSubmission E.==. submission E.^. SubmissionId)
E.on (submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId) E.on (subUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId)
E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet) E.on (sheet E.^. SheetId E.==. submission E.^. SubmissionSheet)
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid E.where_ $ subUser E.^. SubmissionUserUser E.==. E.val uid
E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse E.&&. sheet E.^. SheetCourse E.==. E.val sheetCourse
E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime] E.orderBy [E.desc $ submissionEdit E.^. SubmissionEditTime]
E.limit 1 E.limit 1
return $ submission E.^. SubmissionId return $ submission E.^. SubmissionId
@ -140,7 +140,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid E.&&. submissionUser E.^. SubmissionUserUser E.!=. E.val uid
E.orderBy [E.asc $ user E.^. UserEmail] E.orderBy [E.asc $ user E.^. UserEmail]
return $ user E.^. UserEmail return $ user E.^. UserEmail
return (sheet, map E.unValue buddies, []) return (csheet, map E.unValue buddies, [])
(E.Value smid:_) -> do (E.Value smid:_) -> do
cID <- encrypt smid cID <- encrypt smid
addMessageI "info" $ MsgSubmissionAlreadyExists addMessageI "info" $ MsgSubmissionAlreadyExists
@ -172,7 +172,7 @@ submissionHelper tid ssh csh shn (SubmissionMode mcid) = do
else E.nothing else E.nothing
return $ (userName, submissionEdit E.^. SubmissionEditTime) return $ (userName, submissionEdit E.^. SubmissionEditTime)
forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time forM raw $ \(E.Value name, E.Value time) -> (name, ) <$> formatTime SelFormatDateTime time
return (sheet,buddies,lastEdits) return (csheet,buddies,lastEdits)
let unpackZips = True -- undefined -- TODO let unpackZips = True -- undefined -- TODO
((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies ((res,formWidget), formEnctype) <- runFormPost $ makeSubmissionForm msmid unpackZips sheetGrouping buddies
mCID <- runDB $ do mCID <- runDB $ do

4
src/Handler/Term.hs
View File

@ -180,9 +180,9 @@ termEditHandler term = do
newTermForm :: Maybe Term -> Form Term newTermForm :: Maybe Term -> Form Term
newTermForm template html = do newTermForm template html = do
renderMessage <- getMessageRender mr <- getMessageRender
(result, widget) <- flip (renderAForm FormStandard) html $ Term (result, widget) <- flip (renderAForm FormStandard) html $ Term
<$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName <$> template) <$> areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (termName <$> template)
<*> areq dayField (fsl ("Erster Tag" :: Text)) (termStart <$> template) <*> areq dayField (fsl ("Erster Tag" :: Text)) (termStart <$> template)
<*> areq dayField (fsl ("Letzer Tag" :: Text)) (termEnd <$> template) <*> areq dayField (fsl ("Letzer Tag" :: Text)) (termEnd <$> template)
<*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined

4
src/Handler/Utils.hs
View File

@ -12,7 +12,7 @@ module Handler.Utils
import Import import Import
import qualified Data.Text as T import qualified Data.Text as T
import qualified Data.Set (Set) -- import qualified Data.Set (Set)
import qualified Data.Set as Set import qualified Data.Set as Set
import Handler.Utils.DateTime as Handler.Utils import Handler.Utils.DateTime as Handler.Utils
@ -62,7 +62,7 @@ warnTermDays tid times = do
warnholidays = Set.intersection alldays $ Set.fromList termHolidays warnholidays = Set.intersection alldays $ Set.fromList termHolidays
outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays outoftermdays = Set.filter (\d -> d < termStart || d > termEnd ) alldays
outoflecture = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays outoflecture = Set.filter (\d -> d < termLectureStart || d > termLectureEnd) alldays
`Set.difference` outoftermdays `Set.difference` outoftermdays -- out of term implies out of lecture-time
warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt warnI msg d = formatTime SelFormatDate d >>= \dt -> addMessageI "warning" $ msg tid dt
forM_ warnholidays $ warnI MsgDayIsAHoliday forM_ warnholidays $ warnI MsgDayIsAHoliday
forM_ outoflecture $ warnI MsgDayIsOutOfLecture forM_ outoflecture $ warnI MsgDayIsOutOfLecture

2
src/Utils.hs
View File

@ -130,7 +130,7 @@ withFragment form html = (flip fmap) form $ \(x, widget) -> (x, toWidget html >>
-- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production) -- Types that can be converted to Text for direct displayed to User! (Show for debugging, Display for Production)
{-# DEPRECATED display "Create RenderMessage Instances instead!" #-} {- (not so sure we really want to get rid of display?!) DEPRECATED display "Create RenderMessage Instances instead!" -}
class DisplayAble a where class DisplayAble a where
display :: a -> Text display :: a -> Text
-- Default definitions for types belonging to Show (allows empty instance declarations) -- Default definitions for types belonging to Show (allows empty instance declarations)