Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
SJost
commit
e5d62abbaf
@ -22,6 +22,8 @@ InvalidInput: Eingaben bitte korrigieren.
|
||||
Term: Semester
|
||||
TermPlaceholder: W/S + vierstellige Jahreszahl
|
||||
|
||||
LectureStart: Beginn Vorlesungen
|
||||
|
||||
Course: Kurs
|
||||
CourseSecret: Zugangspasswort
|
||||
CourseNewOk tid@TermId courseShortHand@Text: Kurs #{display tid}-#{courseShortHand} wurde erfolgreich erstellt.
|
||||
@ -70,6 +72,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
|
||||
UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
|
||||
UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
|
||||
|
||||
Submission: Abgabenummer
|
||||
|
||||
SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
|
||||
SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
|
||||
@ -79,11 +82,27 @@ SubmissionArchive: Zip-Archiv der Abgabedatei(en)
|
||||
SubmissionFile: Datei zur Abgabe
|
||||
SubmissionAlreadyExistsFor user@Text: #{user} hat bereits eine Abgabe zu diesem bÜbungsblatt.
|
||||
|
||||
CorrectionsTitle: Zugewiesene Korrekturen
|
||||
CourseCorrectionsTitle: Korrekturen für diesen Kurs
|
||||
|
||||
EMail: E-Mail
|
||||
EMailUnknown email@Text: E-Mail #{email} gehört zu keinem bekannten Benutzer.
|
||||
NotAParticipant user@Text tid@TermId csh@Text: #{user} ist nicht im Kurs #{display tid}-#{csh} angemeldet.
|
||||
|
||||
AddCorrector: Zusätzlicher Korrektor
|
||||
CorrectorExists user@Text: #{user} ist bereits als Korrektor eingetragen
|
||||
SheetCorrectorsTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: Korrektoren für #{termToText tid}-#{courseShortHand} #{sheetName}
|
||||
CountTutProp: Tutorien zählen gegen Proportion
|
||||
Corrector: Korrektor
|
||||
Correctors: Korrektoren
|
||||
CorByTut: Nach Tutorium
|
||||
CorProportion: Anteil
|
||||
DeleteRow: Zeile entfernen
|
||||
ProportionNegative: Anteile dürfen nicht negativ sein
|
||||
CorrectorsUpdated: Korrektoren erfolgreich aktualisiert
|
||||
CorrectorsPlaceholder: Korrektoren...
|
||||
CorrectorsDefaulted: Korrektoren-Liste wurde aus bisherigen Übungsblättern diesen Kurses generiert. Es sind keine Daten gespeichert.
|
||||
|
||||
Users: Benutzer
|
||||
HomeHeading: Aktuelle Termine
|
||||
ProfileHeading: Benutzerprofil und Einstellungen
|
||||
@ -107,4 +126,20 @@ SheetSolution: Lösung
|
||||
SheetMarking: Korrekturhinweise
|
||||
|
||||
MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
|
||||
|
||||
NrColumn: Nr
|
||||
SelectColumn: Auswahl
|
||||
|
||||
CorrDownload: Herunterladen
|
||||
CorrUploadField: Korrekturen
|
||||
CorrUpload: Korrekturen hochladen
|
||||
CorrSetCorrector: Korrektor zuweisen
|
||||
CorrAutoSetCorrector: Korrekturen verteilen
|
||||
NatField xyz@Text: #{xyz} muss eine natürliche Zahl sein!
|
||||
|
||||
SubmissionsAlreadyAssigned num@Int64: #{display num} Abgaben waren bereits einem Korrektor zugeteilt und wurden nicht verändert:
|
||||
UpdatedAssignedCorrectorSingle num@Int64: #{display num} Abgaben wurden dem neuen Korrektor zugeteilt.
|
||||
NoCorrector: Kein Korrektor
|
||||
RemovedCorrections num@Int64: Korrektur-Daten wurden von #{display num} Abgaben entfernt.
|
||||
UpdatedAssignedCorrectorsAuto num@Int64: #{display num} Abgaben wurden unter den Korrektoren aufgeteilt.
|
||||
CouldNotAssignCorrectorsAuto num@Int64: #{display num} Abgaben konnten nicht automatisch zugewiesen werden:
|
||||
1
models
1
models
@ -119,6 +119,7 @@ SheetCorrector
|
||||
sheet SheetId
|
||||
load Load
|
||||
UniqueSheetCorrector user sheet
|
||||
deriving Show Eq Ord
|
||||
SheetFile
|
||||
sheet SheetId
|
||||
file FileId
|
||||
|
||||
@ -81,6 +81,7 @@ dependencies:
|
||||
- exceptions
|
||||
- lens
|
||||
- MonadRandom
|
||||
- email-validate
|
||||
|
||||
# The library contains all of our application code. The executable
|
||||
# defined below is just a thin wrapper.
|
||||
|
||||
22
routes
22
routes
@ -51,26 +51,24 @@
|
||||
/show CShowR GET !free
|
||||
/register CRegisterR POST !time
|
||||
/edit CEditR GET POST
|
||||
/subs CourseCorrectionsR GET POST
|
||||
/ex SheetListR GET !registered !materials
|
||||
!/ex/new SheetNewR GET POST
|
||||
/ex/#Text SheetR:
|
||||
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
/edit SEditR GET POST
|
||||
/delete SDelR GET POST
|
||||
!/sub/new SubmissionNewR GET POST !timeANDregistered
|
||||
!/sub/own SubmissionOwnR GET !free
|
||||
/sub/new SubmissionNewR GET POST !timeANDregistered
|
||||
/sub/own SubmissionOwnR GET !free
|
||||
!/sub/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !owner !corrector
|
||||
!/sub/#CryptoFileNameSubmission SubmissionR GET POST !owner !corrector
|
||||
!/sub/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !owner !corrector
|
||||
/correctors SCorrR GET POST
|
||||
/subs SSubsR GET POST
|
||||
!/#SheetFileType/*FilePath SFileR GET !timeANDregistered !timeANDmaterials !corrector
|
||||
|
||||
/corrections CorrectionsR GET POST !free
|
||||
|
||||
-- TODO below
|
||||
!/#{ZIPArchiveName SubmissionId} SubmissionDownloadArchiveR GET !deprecated
|
||||
!/#CryptoFileNameSubmission/*FilePath SubmissionDownloadSingleR GET !deprecated
|
||||
|
||||
/submission SubmissionListR GET !deprecated
|
||||
/submission/#CryptoUUIDSubmission SubmissionDemoR GET POST !deprecated
|
||||
/submissions.zip SubmissionDownloadMultiArchiveR POST !deprecated
|
||||
-- TODO above
|
||||
|
||||
!/#UUID CryptoUUIDDispatchR GET !free -- just redirect
|
||||
!/*{CI FilePath} CryptoFileNameDispatchR GET !free
|
||||
-- !/*{CI FilePath} CryptoFileNameDispatchR GET !free -- Disabled until preliminary check for valid cID exists
|
||||
|
||||
@ -48,6 +48,7 @@ import Handler.Term
|
||||
import Handler.Course
|
||||
import Handler.Sheet
|
||||
import Handler.Submission
|
||||
import Handler.Corrections
|
||||
import Handler.CryptoIDDispatch
|
||||
|
||||
|
||||
|
||||
@ -39,6 +39,8 @@ import Data.ByteArray (convert)
|
||||
import Crypto.Hash (Digest, SHAKE256)
|
||||
import Crypto.Hash.Conduit (sinkHash)
|
||||
|
||||
import qualified Data.CryptoID (CryptoID) -- for DisplayAble instance only
|
||||
|
||||
import qualified Data.ByteString.Base64.URL as Base64 (encode)
|
||||
|
||||
import Data.ByteString (ByteString)
|
||||
@ -72,13 +74,19 @@ import Handler.Utils.DateTime
|
||||
import Control.Lens
|
||||
import Utils.Lens
|
||||
|
||||
-- -- TODO: Move me to appropriate Place
|
||||
|
||||
-- -- TODO: Move the following to the appropriate place, if DisplayAble is kept
|
||||
instance DisplayAble TermId where
|
||||
display = termToText . unTermKey
|
||||
|
||||
instance DisplayAble UTCTime where
|
||||
display = pack . formatTimeGerDT2 -- default Time Format to be used: 00.00.00 00:00
|
||||
|
||||
instance (PathPiece b) => DisplayAble (Data.CryptoID.CryptoID a b) where
|
||||
display = toPathPiece -- requires import of Data.CryptoID here
|
||||
-- -- MOVE ABOVE
|
||||
|
||||
|
||||
-- infixl 9 :$:
|
||||
-- pattern a :$: b = a b
|
||||
|
||||
@ -153,6 +161,9 @@ instance RenderMessage UniWorX TermIdentifier where
|
||||
Winter -> renderMessage' $ MsgWinterTerm year
|
||||
where renderMessage' = renderMessage foundation ls
|
||||
|
||||
instance RenderMessage UniWorX String where
|
||||
renderMessage f ls str = renderMessage f ls $ Text.pack str
|
||||
|
||||
instance RenderMessage UniWorX SheetFileType where
|
||||
renderMessage foundation ls = \case
|
||||
SheetExercise -> renderMessage' MsgSheetExercise
|
||||
@ -565,7 +576,6 @@ instance Yesod UniWorX where
|
||||
makeLogger = return . appLogger
|
||||
|
||||
|
||||
|
||||
-- Define breadcrumbs.
|
||||
instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (AuthR _) = return ("Login" , Just HomeR)
|
||||
@ -595,14 +605,27 @@ instance YesodBreadcrumbs UniWorX where
|
||||
-- (CSheetR tid csh shn SFileR) -- just for Downloads
|
||||
breadcrumb (CSheetR tid csh shn SEditR) = return ("Edit", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SDelR ) = return ("DELETE", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SCorrR) = return ("Korrektoren", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SSubsR) = return ("Abgaben", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SubmissionNewR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn SubmissionOwnR) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
breadcrumb (CSheetR tid csh shn (SubmissionR _)) = return ("Abgabe", Just $ CSheetR tid csh shn SShowR)
|
||||
-- Deprecated below
|
||||
breadcrumb SubmissionListR = return ("Abgaben", Just HomeR)
|
||||
-- Others
|
||||
breadcrumb _ = return ("Uni2work", Nothing) -- Default is no breadcrumb at all
|
||||
|
||||
submissionList :: TermId -> Text -> Text -> UserId -> DB [E.Value SubmissionId]
|
||||
submissionList tid csh shn uid = E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` submission `E.InnerJoin` submissionUser) -> do
|
||||
E.on $ submissionUser E.^. SubmissionUserSubmission E.==. submission E.^. SubmissionId
|
||||
E.on $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
|
||||
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
|
||||
|
||||
E.where_ $ submissionUser E.^. SubmissionUserUser E.==. E.val uid
|
||||
E.&&. sheet E.^. SheetName E.==. E.val shn
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
E.&&. course E.^. CourseTerm E.==. E.val tid
|
||||
|
||||
return $ submission E.^. SubmissionId
|
||||
|
||||
pageActions :: Route UniWorX -> [MenuTypes]
|
||||
pageActions (CourseR tid csh CShowR) =
|
||||
[ PageActionPrime $ MenuItem
|
||||
@ -627,6 +650,12 @@ pageActions (CourseR tid csh CShowR) =
|
||||
return (sheets,lecturer)
|
||||
or2M (return lecturer) $ anyM sheets sheetRouteAccess
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CourseR tid csh CourseCorrectionsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionSecondary $ MenuItem
|
||||
{ menuItemLabel = "Neues Übungsblatt anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
@ -647,13 +676,33 @@ pageActions (CSheetR tid csh shn SShowR) =
|
||||
{ menuItemLabel = "Abgabe anlegen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SubmissionNewR
|
||||
, menuItemAccessCallback' = return True -- TODO: check that no submission already exists
|
||||
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
||||
uid <- MaybeT $ liftHandlerT maybeAuthId
|
||||
submissions <- lift $ submissionList tid csh shn uid
|
||||
guard $ null submissions
|
||||
return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgabe ansehen"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SubmissionOwnR
|
||||
, menuItemAccessCallback' = return True -- TODO: check that a submission already exists
|
||||
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
|
||||
uid <- MaybeT $ liftHandlerT maybeAuthId
|
||||
submissions <- lift $ submissionList tid csh shn uid
|
||||
guard . not $ null submissions
|
||||
return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Korrektoren"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SCorrR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, PageActionPrime $ MenuItem
|
||||
{ menuItemLabel = "Abgaben"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = CSheetR tid csh shn SSubsR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions TermShowR =
|
||||
@ -697,7 +746,7 @@ pageActions (HomeR) =
|
||||
-- ,
|
||||
NavbarAside $ MenuItem
|
||||
{ menuItemLabel = "AdminDemo"
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemIcon = Just "book"
|
||||
, menuItemRoute = AdminTestR
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
@ -741,6 +790,8 @@ pageHeading (CourseR tid csh CShowR)
|
||||
= Just $ do
|
||||
Entity _ Course{..} <- handlerToWidget . runDB . getBy404 $ CourseTermShort tid csh
|
||||
toWidget courseName
|
||||
pageHeading CorrectionsR
|
||||
= Just $ i18nHeading MsgCorrectionsTitle
|
||||
-- (CourseR tid csh CRegisterR) -- just for POST
|
||||
pageHeading (CourseR tid csh CEditR)
|
||||
= Just $ i18nHeading $ MsgCourseEditHeading tid csh
|
||||
|
||||
342
src/Handler/Corrections.hs
Normal file
342
src/Handler/Corrections.hs
Normal file
@ -0,0 +1,342 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE MultiWayIf, LambdaCase #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE OverloadedLists #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE RecordWildCards, NamedFieldPuns, TupleSections #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE ScopedTypeVariables #-}
|
||||
|
||||
module Handler.Corrections where
|
||||
|
||||
import Import
|
||||
-- import System.FilePath (takeFileName)
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Submission
|
||||
-- import Handler.Utils.Zip
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
-- import Data.Time
|
||||
-- import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Yesod.Colonnade
|
||||
--
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
-- import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
-- import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
import Control.Lens
|
||||
-- import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
|
||||
-- import Network.Mime
|
||||
|
||||
import Web.PathPieces
|
||||
|
||||
import Text.Hamlet (ihamletFile)
|
||||
import Text.Blaze.Html (preEscapedToHtml)
|
||||
|
||||
import Database.Persist.Sql (updateWhereCount)
|
||||
|
||||
import Data.List (genericLength)
|
||||
|
||||
|
||||
|
||||
type CorrectionsWhere = forall query expr backend . (E.Esqueleto query expr backend) =>
|
||||
(expr (Entity Course), expr (Entity Sheet), expr (Entity Submission))
|
||||
-> expr (E.Value Bool)
|
||||
|
||||
ratedBy :: Key User -> CorrectionsWhere
|
||||
ratedBy uid (_course,_sheet,submission) = submission E.^. SubmissionRatingBy E.==. E.just (E.val uid)
|
||||
|
||||
courseIs :: Key Course -> CorrectionsWhere
|
||||
courseIs cid (course,_sheet,_submission) = course E.^. CourseId E.==. E.val cid
|
||||
|
||||
sheetIs :: Key Sheet -> CorrectionsWhere
|
||||
sheetIs shid (_course,sheet,_submission) = sheet E.^. SheetId E.==. E.val shid
|
||||
|
||||
|
||||
type CorrectionTableData = DBRow (Entity Submission, Entity Sheet, (E.Value Text, E.Value Text, E.Value (Key Term), E.Value (Key School)), Maybe (Entity User))
|
||||
|
||||
colTerm :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colTerm = sortable (Just "term") (i18nCell MsgTerm)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _) } ->
|
||||
-- cell [whamlet| _{untermKey $ course ^. _3}|] -- lange, internationale Semester
|
||||
textCell $ termToText $ unTermKey $ E.unValue $ course ^. _3 -- kurze Semsterkürzel
|
||||
|
||||
colCourse :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCourse = sortable (Just "course") (i18nCell MsgCourse)
|
||||
$ \DBRow{ dbrOutput=(_, _, course, _) } -> cell $
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
in [whamlet|<a href=@{CourseR tid csh CShowR}>#{display csh}|]
|
||||
|
||||
colSheet :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSheet = sortable (Just "sheet") (i18nCell MsgSheet)
|
||||
$ \DBRow{ dbrOutput=(_, sheet, course, _) } -> cell $
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
in [whamlet|<a href=@{CSheetR tid csh shn SShowR}>#{display shn}|]
|
||||
-- textCell $ sheetName $ entityVal sheet
|
||||
|
||||
colCorrector :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colCorrector = sortable (Just "corrector") (i18nCell MsgCorrector) $ \case
|
||||
DBRow{ dbrOutput = (_, _, _, Nothing) } -> cell mempty
|
||||
DBRow{ dbrOutput = (_, _, _, Just corr) } -> textCell . display . userDisplayName $ entityVal corr
|
||||
|
||||
colSubmissionLink :: IsDBTable m a => Colonnade _ CorrectionTableData (DBCell m a)
|
||||
colSubmissionLink = sortable Nothing (i18nCell MsgSubmission)
|
||||
$ \DBRow{ dbrOutput=(submission, sheet, course, _) } -> cell $ do
|
||||
let tid = E.unValue $ course ^. _3
|
||||
csh = E.unValue $ course ^. _2
|
||||
shn = sheetName $ entityVal sheet
|
||||
cid <- encrypt (entityKey submission :: SubmissionId)
|
||||
[whamlet|<a href=@{CSheetR tid csh shn (SubmissionR cid)}>#{display cid}|]
|
||||
|
||||
colSelect :: Colonnade _ CorrectionTableData (DBCell _ (FormResult (DBFormResult CorrectionTableData CryptoFileNameSubmission Bool)))
|
||||
colSelect = dbSelect id $ \DBRow{ dbrOutput=(Entity subId _, _, _, _) } -> encrypt subId
|
||||
|
||||
type CorrectionTableExpr = (E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity Sheet) `E.InnerJoin` E.SqlExpr (Entity Submission)) `E.LeftOuterJoin` E.SqlExpr (Maybe (Entity User))
|
||||
|
||||
makeCorrectionsTable :: ( IsDBTable m x, DBOutput CorrectionTableData r', ToSortable h, Functor h )
|
||||
=> _ -> Colonnade h r' (DBCell m x) -> PSValidator m x -> Handler (DBResult m x)
|
||||
makeCorrectionsTable whereClause colChoices psValidator = do
|
||||
let tableData :: CorrectionTableExpr -> E.SqlQuery _
|
||||
tableData ((course `E.InnerJoin` sheet `E.InnerJoin` submission) `E.LeftOuterJoin` corrector) = do
|
||||
E.on $ corrector E.?. UserId E.==. submission E.^. SubmissionRatingBy
|
||||
E.on $ sheet E.^. SheetId E.==. submission E.^. SubmissionSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.where_ $ whereClause (course,sheet,submission)
|
||||
let crse = ( course E.^. CourseName :: E.SqlExpr (E.Value Text)
|
||||
, course E.^. CourseShorthand
|
||||
, course E.^. CourseTerm
|
||||
, course E.^. CourseSchool :: E.SqlExpr (E.Value SchoolId)
|
||||
)
|
||||
return (submission, sheet, crse, corrector)
|
||||
dbTable psValidator $ DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
, dbtColonnade = colChoices
|
||||
, dbtSorting = [ ( "term"
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseTerm
|
||||
)
|
||||
, ( "course"
|
||||
, SortColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _) -> course E.^. CourseShorthand
|
||||
)
|
||||
, ( "sheet"
|
||||
, SortColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _) -> sheet E.^. SheetName
|
||||
)
|
||||
, ( "corrector"
|
||||
, SortColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector) -> corrector E.?. UserDisplayName
|
||||
)
|
||||
]
|
||||
, dbtFilter = [ ( "term"
|
||||
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) tids -> if
|
||||
| Set.null tids -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList tids)
|
||||
)
|
||||
, ( "course"
|
||||
, FilterColumn $ \((course `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) cshs -> if
|
||||
| Set.null cshs -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList cshs)
|
||||
)
|
||||
, ( "sheet"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` sheet `E.InnerJoin` _) `E.LeftOuterJoin` _ :: CorrectionTableExpr) shns -> if
|
||||
| Set.null shns -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> sheet E.^. SheetName `E.in_` E.valList (Set.toList shns)
|
||||
)
|
||||
, ( "corrector"
|
||||
, FilterColumn $ \((_ `E.InnerJoin` _ `E.InnerJoin` _) `E.LeftOuterJoin` corrector :: CorrectionTableExpr) emails -> if
|
||||
| Set.null emails -> E.val True :: E.SqlExpr (E.Value Bool)
|
||||
| otherwise -> corrector E.?. UserEmail `E.in_` E.justList (E.valList . catMaybes $ Set.toList emails)
|
||||
E.||. (if Nothing `Set.member` emails then E.isNothing (corrector E.?. UserEmail) else E.val False)
|
||||
)
|
||||
]
|
||||
, dbtAttrs = tableDefault
|
||||
, dbtIdent = "corrections" :: Text
|
||||
}
|
||||
|
||||
data ActionCorrections = CorrDownload
|
||||
| CorrSetCorrector
|
||||
| CorrAutoSetCorrector
|
||||
deriving (Eq, Ord, Read, Show, Enum, Bounded)
|
||||
instance PathPiece ActionCorrections where
|
||||
fromPathPiece = readFromPathPiece
|
||||
toPathPiece = showToPathPiece
|
||||
|
||||
instance RenderMessage UniWorX ActionCorrections where
|
||||
renderMessage m ls CorrDownload = renderMessage m ls MsgCorrDownload
|
||||
renderMessage m ls CorrSetCorrector = renderMessage m ls MsgCorrSetCorrector
|
||||
renderMessage m ls CorrAutoSetCorrector = renderMessage m ls MsgCorrAutoSetCorrector
|
||||
|
||||
data ActionCorrectionsData = CorrDownloadData
|
||||
| CorrSetCorrectorData (Maybe UserId)
|
||||
| CorrAutoSetCorrectorData SheetId
|
||||
|
||||
correctionsR :: _ -> _ -> _ -> Map ActionCorrections (MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget)) -> Handler TypedContent
|
||||
correctionsR whereClause (formColonnade -> displayColumns) psValidator actions = do
|
||||
tableForm <- makeCorrectionsTable whereClause displayColumns psValidator
|
||||
((actionRes, table), tableEncoding) <- runFormPost . identForm FIDcorrectorTable $ \csrf -> do
|
||||
((fmap (Map.keysSet . Map.filter id . getDBFormResult (const False)) -> selectionRes), table) <- tableForm csrf
|
||||
(actionRes, action) <- multiAction actions
|
||||
return ((,) <$> actionRes <*> selectionRes, table <> action)
|
||||
|
||||
Just currentRoute <- getCurrentRoute -- This should never be called from a 404 handler
|
||||
case actionRes of
|
||||
FormFailure errs -> mapM_ (addMessage "danger" . toHtml) errs
|
||||
FormMissing -> return ()
|
||||
FormSuccess (CorrDownloadData, subs) -> do
|
||||
ids <- Set.fromList <$> forM (Set.toList subs) decrypt -- Set is not traversable
|
||||
addHeader "Content-Disposition" "attachment; filename=\"corrections.zip\""
|
||||
sendResponse =<< submissionMultiArchive ids
|
||||
FormSuccess (CorrSetCorrectorData (Just uid), subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
||||
when (not $ null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
when (not $ null unassigned) $ do
|
||||
num <- updateWhereCount [SubmissionId <-. Set.toList unassigned] [SubmissionRatingBy =. Just uid]
|
||||
addMessageI "success" $ MsgUpdatedAssignedCorrectorSingle num
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrSetCorrectorData Nothing, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
num <- updateWhereCount [SubmissionId <-. subs] [ SubmissionRatingPoints =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingTime =. Nothing
|
||||
]
|
||||
addMessageI "success" $ MsgRemovedCorrections num
|
||||
redirect currentRoute
|
||||
FormSuccess (CorrAutoSetCorrectorData shid, subs') -> do
|
||||
subs <- mapM decrypt $ Set.toList subs'
|
||||
runDB $ do
|
||||
alreadyAssigned <- selectList [SubmissionId <-. subs, SubmissionRatingBy !=. Nothing] []
|
||||
when (not $ null alreadyAssigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
alreadyAssigned' <- forM alreadyAssigned $ \Entity{..} -> (, entityVal) <$> (encrypt entityKey :: DB CryptoFileNameSubmission)
|
||||
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsAlreadyAssigned.hamlet") mr)
|
||||
let unassigned = Set.fromList subs `Set.difference` Set.fromList (entityKey <$> alreadyAssigned)
|
||||
when (not $ null unassigned) $ do
|
||||
(assigned, unassigned) <- assignSubmissions shid (Just unassigned)
|
||||
when (not $ null assigned) $
|
||||
addMessageI "success" $ MsgUpdatedAssignedCorrectorsAuto (fromIntegral $ Set.size assigned)
|
||||
when (not $ null unassigned) $ do
|
||||
mr <- (toHtml . ) <$> getMessageRender
|
||||
unassigned' <- forM (Set.toList unassigned) $ \sid -> (encrypt sid :: DB CryptoFileNameSubmission)
|
||||
addMessage "warn" =<< withUrlRenderer ($(ihamletFile "templates/messages/submissionsNotAssignedAuto.hamlet") mr)
|
||||
redirect currentRoute
|
||||
|
||||
fmap toTypedContent . defaultLayout $ do
|
||||
setTitleI MsgCourseCorrectionsTitle
|
||||
$(widgetFile "corrections")
|
||||
|
||||
|
||||
type ActionCorrections' = (ActionCorrections, MForm (HandlerT UniWorX IO) (FormResult ActionCorrectionsData, Maybe Widget))
|
||||
|
||||
downloadAction :: ActionCorrections'
|
||||
downloadAction = ( CorrDownload
|
||||
, return (pure CorrDownloadData, Nothing)
|
||||
)
|
||||
|
||||
assignAction :: Either CourseId SheetId -> ActionCorrections'
|
||||
assignAction selId = ( CorrSetCorrector
|
||||
, over (mapped._2) Just $ do
|
||||
correctors <- liftHandlerT . runDB . E.select . E.from $ \(course `E.InnerJoin` sheet `E.InnerJoin` sheetCorrector `E.InnerJoin` user) -> do
|
||||
E.on $ user E.^. UserId E.==. sheetCorrector E.^. SheetCorrectorUser
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
|
||||
E.where_ $ either (\cId -> course E.^. CourseId E.==. E.val cId) (\shId -> sheet E.^. SheetId E.==. E.val shId) selId
|
||||
|
||||
return user
|
||||
|
||||
mr <- getMessageRender
|
||||
|
||||
correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
|
||||
|
||||
($ mempty) . renderAForm FormStandard . wFormToAForm $ do
|
||||
cId <- wreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
|
||||
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
|
||||
)
|
||||
|
||||
autoAssignAction :: SheetId -> ActionCorrections'
|
||||
autoAssignAction shid = ( CorrAutoSetCorrector
|
||||
, return (pure $ CorrAutoSetCorrectorData shid, Nothing)
|
||||
)
|
||||
|
||||
getCorrectionsR, postCorrectionsR :: Handler TypedContent
|
||||
getCorrectionsR = postCorrectionsR
|
||||
postCorrectionsR = do
|
||||
uid <- requireAuthId
|
||||
let whereClause = ratedBy uid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, colTerm
|
||||
, colCourse
|
||||
, colSheet
|
||||
, colSubmissionLink
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
& restrictFilter (\name _ -> name /= "corrector") -- We need to be careful to restrict allowed sorting/filter to not expose sensitive information
|
||||
& restrictSorting (\name _ -> name /= "corrector")
|
||||
correctionsR whereClause colonnade psValidator $ Map.fromList
|
||||
[ downloadAction
|
||||
]
|
||||
|
||||
getCourseCorrectionsR, postCourseCorrectionsR :: TermId -> Text -> Handler TypedContent
|
||||
getCourseCorrectionsR = postCourseCorrectionsR
|
||||
postCourseCorrectionsR tid csh = do
|
||||
Entity cid _ <- runDB $ getBy404 $ CourseTermShort tid csh
|
||||
let whereClause = courseIs cid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, colSheet
|
||||
, colCorrector
|
||||
, colSubmissionLink
|
||||
] -- Continue here
|
||||
psValidator = def
|
||||
correctionsR whereClause colonnade psValidator $ Map.fromList
|
||||
[ downloadAction
|
||||
, assignAction (Left cid)
|
||||
]
|
||||
|
||||
getSSubsR, postSSubsR :: TermId -> Text -> Text -> Handler TypedContent
|
||||
getSSubsR = postSSubsR
|
||||
postSSubsR tid csh shn = do
|
||||
shid <- runDB $ fetchSheetId tid csh shn
|
||||
let whereClause = sheetIs shid
|
||||
colonnade = mconcat
|
||||
[ colSelect
|
||||
, dbRow
|
||||
, colCorrector
|
||||
, colSubmissionLink
|
||||
]
|
||||
psValidator = def
|
||||
correctionsR whereClause colonnade psValidator $ Map.fromList
|
||||
[ downloadAction
|
||||
, assignAction (Right shid)
|
||||
, autoAssignAction shid
|
||||
]
|
||||
@ -24,7 +24,7 @@ import Data.Time
|
||||
|
||||
-- import Control.Lens
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
import Yesod.Colonnade
|
||||
-- import Yesod.Colonnade
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
-- import qualified Data.UUID.Cryptographic as UUID
|
||||
@ -68,10 +68,10 @@ homeAnonymous = do
|
||||
E.limit nrSheetDeadlines
|
||||
return course
|
||||
|
||||
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (Cell UniWorX)
|
||||
colonnade :: Colonnade Sortable (DBRow (Entity Course)) (DBCell (WidgetT UniWorX IO) ())
|
||||
colonnade = mconcat
|
||||
[ -- dbRow
|
||||
sortable (Just "course") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(Entity {entityVal = course}) } -> do
|
||||
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}|]
|
||||
@ -134,17 +134,17 @@ homeUser uid = do
|
||||
, sheet E.^. SheetActiveTo
|
||||
)
|
||||
|
||||
colonnade :: Colonnade Sortable (DBRow (E.Value (Key Term), E.Value Text, E.Value Text, E.Value UTCTime)) (Cell UniWorX)
|
||||
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") (i18nCell MsgCourse) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, _, _) } ->
|
||||
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") (i18nCell MsgSheet) $ \DBRow{ dbrOutput=(E.Value tid, E.Value csh, E.Value shn, _) } ->
|
||||
, 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") (i18nCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } ->
|
||||
, sortable (Just "deadline") (textCell MsgDeadline) $ \DBRow{ dbrOutput=(_, _, _, E.Value deadline) } ->
|
||||
textCell $ display deadline
|
||||
, sortable (Just "done") (i18nCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } ->
|
||||
textCell $ "?"
|
||||
, sortable (Just "done") (textCell MsgDone) $ \DBRow{ dbrOutput=(_, _, _, _) } ->
|
||||
textCell ("?" :: Text)
|
||||
]
|
||||
sheetTable <- dbTable def $ DBTable
|
||||
{ dbtSQLQuery = tableData
|
||||
|
||||
@ -31,7 +31,7 @@ makeSettingForm template = identForm FIDsettings $ \html -> do
|
||||
<$> areq (natFieldI $ MsgNatField "Favoriten") -- TODO: natFieldI not working here
|
||||
(fslpI MsgFavoriten "Anzahl Favoriten") (stgMaxFavourties <$> template)
|
||||
<*> areq (selectFieldList themeList)
|
||||
(fslI MsgTheme ) (stgTheme <$> template)
|
||||
(fslpI MsgTheme "theme-select" ) (stgTheme <$> template) -- TODO: pass theme-select as id-attribute or similar.
|
||||
<* submitButton
|
||||
return (result, widget) -- no validation required here
|
||||
|
||||
@ -70,7 +70,7 @@ getProfileR = do
|
||||
E.where_ $ adright ^. UserAdminUser E.==. E.val uid
|
||||
E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId
|
||||
return (school ^. SchoolShorthand)
|
||||
)
|
||||
)
|
||||
<*>
|
||||
(E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
|
||||
E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid
|
||||
|
||||
@ -8,7 +8,12 @@
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
{-# LANGUAGE FlexibleContexts #-}
|
||||
{-# LANGUAGE FlexibleInstances #-}
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE RankNTypes #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
{-# LANGUAGE MultiWayIf, LambdaCase #-}
|
||||
{-# LANGUAGE TupleSections #-}
|
||||
|
||||
module Handler.Sheet where
|
||||
|
||||
@ -22,9 +27,10 @@ import Handler.Utils.Zip
|
||||
import qualified Data.Text as T
|
||||
-- import Data.Function ((&))
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton)
|
||||
import Yesod.Colonnade
|
||||
--
|
||||
import Colonnade hiding (fromMaybe, singleton, bool)
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import Text.Blaze (text)
|
||||
--
|
||||
import qualified Data.UUID.Cryptographic as UUID
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
@ -32,12 +38,24 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT)
|
||||
import Control.Monad.Trans.RWS.Lazy (RWST, local)
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import qualified Data.List as List
|
||||
|
||||
import Network.Mime
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.Map (Map, (!), (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Control.Lens
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
instance Eq (Unique Sheet) where
|
||||
(CourseSheet cid1 name1) == (CourseSheet cid2 name2) =
|
||||
@ -64,7 +82,6 @@ data SheetForm = SheetForm
|
||||
, sfSolutionFrom :: Maybe UTCTime
|
||||
, sfSolutionF :: Maybe FileInfo
|
||||
-- Keine SheetId im Formular!
|
||||
, sfCorrectors :: [(UserId,Load)]
|
||||
}
|
||||
|
||||
|
||||
@ -92,7 +109,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
<*> fileAFormOpt (fsb "Hinweis")
|
||||
<*> aopt utcTimeField (fsb "Lösung ab") (sfSolutionFrom <$> template)
|
||||
<*> fileAFormOpt (fsb "Lösung")
|
||||
<*> formToAForm (correctorForm msId (maybe [] sfCorrectors template))
|
||||
<* submitButton
|
||||
return $ case result of
|
||||
FormSuccess sheetResult
|
||||
@ -123,16 +139,6 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
|
||||
-- TODO: continue validation here!!!
|
||||
] ]
|
||||
|
||||
correctorForm :: Maybe SheetId -> [(UserId,Load)] -> MForm Handler (FormResult [(UserId,Load)], [FieldView UniWorX])
|
||||
correctorForm _msid templates = return mempty -- TODO deprecated
|
||||
-- Datenbank UserId -> UserName
|
||||
-- Eingabelist für Colonnade
|
||||
-- enthält die benötigten Felder
|
||||
-- FormResult konstruieren
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
|
||||
-- List Sheets
|
||||
getSheetListCID :: CourseId -> Handler Html
|
||||
getSheetListCID cid = getSheetList =<<
|
||||
@ -180,7 +186,7 @@ getSheetList courseEnt = do
|
||||
setTitle $ toHtml $ csh <> " Übungsblätter"
|
||||
if null sheets
|
||||
then [whamlet|Es wurden noch keine Übungsblätter angelegt.|]
|
||||
else encodeWidgetTable tableDefault colSheets sheets
|
||||
else Yesod.encodeWidgetTable tableDefault colSheets sheets
|
||||
|
||||
|
||||
-- Show single sheet
|
||||
@ -211,8 +217,8 @@ getSShowR tid csh shn = do
|
||||
E.&&. E.not_ (E.isNothing $ file E.^. FileContent)
|
||||
-- return desired columns
|
||||
return $ (file E.^. FileTitle, file E.^. FileModified, sheetFile E.^. SheetFileType)
|
||||
let colonnadeFiles = mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> cell $ [whamlet| _{ftype}|]
|
||||
let colonnadeFiles = widgetColonnade $ mconcat
|
||||
[ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> stringCell ftype
|
||||
, sortable (Just "path") "Dateiname" $ anchorCell (\(E.Value fName,_,E.Value fType) -> CSheetR tid csh shn (SFileR fType fName))
|
||||
(\(E.Value fName,_,_) -> str2widget fName)
|
||||
, sortable (Just "time") "Modifikation" $ \(_,E.Value modified,_) -> stringCell $ formatTimeGerWDT (modified :: UTCTime)
|
||||
@ -303,7 +309,6 @@ getSEditR tid csh shn = do
|
||||
, sfHintF = Nothing -- TODO
|
||||
, sfSolutionFrom = sheetSolutionFrom
|
||||
, sfSolutionF = Nothing -- TODO
|
||||
, sfCorrectors = [] -- TODO read correctors from list
|
||||
}
|
||||
let action newSheet = do
|
||||
replaceRes <- myReplaceUnique sid $ newSheet
|
||||
@ -410,3 +415,201 @@ insertSheetFile' sid ftype fs = do
|
||||
finsert (Right file) = lift $ do
|
||||
fid <- insert file
|
||||
void . insert $ SheetFile sid fid ftype -- cannot fail due to uniqueness, since we generated a fresh FileId in the previous step
|
||||
|
||||
|
||||
data CorrectorForm = CorrectorForm
|
||||
{ cfUserId :: UserId
|
||||
, cfUserName :: Text
|
||||
, cfResult :: FormResult Load
|
||||
, cfViewByTut, cfViewProp, cfViewDel :: FieldView UniWorX
|
||||
}
|
||||
|
||||
type Loads = Map UserId Load
|
||||
|
||||
defaultLoads :: SheetId -> DB Loads
|
||||
-- ^ Generate `Loads` in such a way that minimal editing is required
|
||||
--
|
||||
-- For every user, that ever was a corrector for this course, return their last `Load`.
|
||||
-- "Last `Load`" is taken to mean their `Load` on the `Sheet` with the most recent creation time (first edit).
|
||||
defaultLoads shid = do
|
||||
cId <- sheetCourse <$> getJust shid
|
||||
fmap toMap . E.select . E.from $ \(sheet `E.InnerJoin` sheetCorrector) -> E.distinctOnOrderBy [E.asc (sheetCorrector E.^. SheetCorrectorUser)] $ do
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
|
||||
let creationTime = E.sub_select . E.from $ \sheetEdit -> do
|
||||
E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
|
||||
return . E.min_ $ sheetEdit E.^. SheetEditTime
|
||||
|
||||
E.where_ $ sheet E.^. SheetCourse E.==. E.val cId
|
||||
|
||||
E.orderBy [E.desc creationTime]
|
||||
|
||||
return (sheetCorrector E.^. SheetCorrectorUser, sheetCorrector E.^. SheetCorrectorLoad)
|
||||
where
|
||||
toMap :: [(E.Value UserId, E.Value Load)] -> Loads
|
||||
toMap = foldMap $ \(E.Value uid, E.Value load) -> Map.singleton uid load
|
||||
|
||||
|
||||
correctorForm :: SheetId -> MForm Handler (FormResult (Set SheetCorrector), [FieldView UniWorX])
|
||||
correctorForm shid = do
|
||||
cListIdent <- newFormIdent
|
||||
let
|
||||
guardNonDeleted :: UserId -> Handler (Maybe UserId)
|
||||
guardNonDeleted uid = do
|
||||
cID@CryptoID{..} <- encrypt uid :: Handler CryptoUUIDUser
|
||||
deleted <- lookupPostParam $ tshow ciphertext <> "-" <> "del"
|
||||
return $ bool Just (const Nothing) (isJust deleted) uid
|
||||
formCIDs <- mapM decrypt =<< catMaybes <$> liftHandlerT (map fromPathPiece <$> lookupPostParams cListIdent :: Handler [Maybe CryptoUUIDUser])
|
||||
let
|
||||
currentLoads :: DB Loads
|
||||
currentLoads = Map.fromList . map (\(Entity _ SheetCorrector{..}) -> (sheetCorrectorUser, sheetCorrectorLoad)) <$> selectList [ SheetCorrectorSheet ==. shid ] []
|
||||
(defaultLoads', currentLoads') <- lift . runDB $ (,) <$> defaultLoads shid <*> currentLoads
|
||||
loads' <- fmap (Map.fromList [(uid, mempty) | uid <- formCIDs] `Map.union`) $ if
|
||||
| Map.null currentLoads'
|
||||
, null formCIDs -> defaultLoads' <$ when (not $ Map.null defaultLoads') (addMessageI "warn" MsgCorrectorsDefaulted)
|
||||
| otherwise -> return $ Map.fromList (map (, mempty) formCIDs) `Map.union` currentLoads'
|
||||
|
||||
deletions <- lift $ foldM (\dels uid -> maybe (Set.insert uid dels) (const dels) <$> guardNonDeleted uid) Set.empty (Map.keys loads')
|
||||
|
||||
let loads'' = Map.restrictKeys loads' (Map.keysSet loads' `Set.difference` deletions)
|
||||
didDelete = any (flip Set.member deletions) formCIDs
|
||||
|
||||
(countTutRes, countTutView) <- mreq checkBoxField (fsm MsgCountTutProp) . Just $ any (\Load{..} -> fromMaybe False byTutorial) $ Map.elems loads'
|
||||
let
|
||||
tutorField :: Field Handler [Text]
|
||||
tutorField = multiEmailField
|
||||
{ fieldView = \theId name attrs val isReq -> asWidgetT $ do
|
||||
listIdent <- newIdent
|
||||
userId <- handlerToWidget requireAuthId
|
||||
previousCorrectors <- handlerToWidget . runDB . E.select . E.from $ \(user `E.InnerJoin` sheetCorrector `E.InnerJoin` sheet `E.InnerJoin` course `E.InnerJoin` lecturer) -> E.distinctOnOrderBy [E.asc $ user E.^. UserEmail ] $ do
|
||||
E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.on $ sheet E.^. SheetId E.==. sheetCorrector E.^. SheetCorrectorSheet
|
||||
E.on $ sheetCorrector E.^. SheetCorrectorUser E.==. user E.^. UserId
|
||||
E.where_ $ lecturer E.^. LecturerUser E.==. E.val userId
|
||||
return $ user E.^. UserEmail
|
||||
[whamlet|
|
||||
$newline never
|
||||
<input id=#{theId} name=#{name} list=#{listIdent} *{attrs} type=email multiple :isReq:required value="" placeholder=_{MsgCorrectorsPlaceholder}>
|
||||
<datalist id=#{listIdent}>
|
||||
$forall E.Value prev <- previousCorrectors
|
||||
<option value=#{prev}>
|
||||
|]
|
||||
}
|
||||
(addTutRes, addTutView) <- mopt tutorField (fsm MsgAddCorrector) (Just Nothing)
|
||||
|
||||
loads <- case addTutRes of
|
||||
FormSuccess (Just emails) -> fmap Map.unions . forM emails $ \email -> do
|
||||
mUid <- fmap (fmap entityKey) . lift . runDB $ getBy (UniqueEmail email)
|
||||
case mUid of
|
||||
Nothing -> loads'' <$ addMessageI "error" (MsgEMailUnknown email)
|
||||
Just uid
|
||||
| not (Map.member uid loads') -> return $ Map.insert uid mempty loads''
|
||||
| otherwise -> loads'' <$ addMessageI "warning" (MsgCorrectorExists email)
|
||||
FormFailure errs -> loads'' <$ mapM_ (addMessage "error" . toHtml) errs
|
||||
_ -> return loads''
|
||||
|
||||
let deletions' = deletions `Set.difference` Map.keysSet loads
|
||||
|
||||
names <- fmap (Map.fromList . map (\(E.Value a, E.Value b) -> (a, b))) . lift . runDB . E.select . E.from $ \user -> do
|
||||
E.where_ $ user E.^. UserId `E.in_` E.valList (Map.keys loads)
|
||||
return $ (user E.^. UserId, user E.^. UserDisplayName)
|
||||
|
||||
let
|
||||
constructFields :: (UserId, Text, Load) -> MForm Handler CorrectorForm
|
||||
constructFields (uid, uname, Load{..}) = do
|
||||
cID@CryptoID{..} <- encrypt uid :: MForm Handler CryptoUUIDUser
|
||||
let
|
||||
fs name = ""
|
||||
{ fsName = Just $ tshow ciphertext <> "-" <> name
|
||||
}
|
||||
rationalField = convertField toRational fromRational doubleField
|
||||
|
||||
(byTutRes, cfViewByTut) <- mreq checkBoxField (fs "bytut") (Just $ isJust byTutorial)
|
||||
(propRes, cfViewProp) <- mreq (checkBool (>= 0) MsgProportionNegative $ rationalField) (fs "prop") (Just byProportion)
|
||||
(_, cfViewDel) <- mreq checkBoxField (fs "del") (Just False)
|
||||
let
|
||||
cfResult :: FormResult Load
|
||||
cfResult = Load <$> tutRes' <*> propRes
|
||||
tutRes'
|
||||
| FormSuccess True <- byTutRes = Just <$> countTutRes
|
||||
| otherwise = Nothing <$ byTutRes
|
||||
cfUserId = uid
|
||||
cfUserName = uname
|
||||
return CorrectorForm{..}
|
||||
|
||||
corrData <- sequence . catMaybes . (flip map) (Map.keys loads) $ \uid -> fmap constructFields $ (,,) <$> pure uid <*> names !? uid <*> loads !? uid
|
||||
|
||||
mr <- getMessageRender
|
||||
|
||||
$logDebugS "SCorrR" $ tshow (didDelete, addTutRes)
|
||||
|
||||
let
|
||||
corrColonnade = mconcat
|
||||
[ headed (Yesod.textCell $ mr MsgCorrector) $ \CorrectorForm{..} -> Yesod.textCell cfUserName
|
||||
, headed (Yesod.textCell $ mr MsgCorByTut) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewByTut
|
||||
, headed (Yesod.textCell $ mr MsgCorProportion) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewProp
|
||||
, headed (Yesod.textCell $ mr MsgDeleteRow) $ \CorrectorForm{..} -> Yesod.cell $ fvInput cfViewDel
|
||||
]
|
||||
corrResults
|
||||
| FormSuccess (Just es) <- addTutRes
|
||||
, not $ null es = FormMissing
|
||||
| didDelete = FormMissing
|
||||
| otherwise = fmap Set.fromList $ sequenceA [ SheetCorrector <$> pure cfUserId <*> pure shid <*> cfResult
|
||||
| CorrectorForm{..} <- corrData
|
||||
]
|
||||
idField CorrectorForm{..} = do
|
||||
cID <- encrypt cfUserId :: WidgetT UniWorX IO CryptoUUIDUser
|
||||
toWidget [hamlet|<input name=#{cListIdent} type=hidden value=#{toPathPiece cID}>|]
|
||||
|
||||
delField uid = do
|
||||
cID <- encrypt uid :: WidgetT UniWorX IO CryptoUUIDUser
|
||||
toWidget [hamlet|<input name="#{toPathPiece cID}-del" type=hidden value=yes>|]
|
||||
|
||||
return (corrResults, [ countTutView
|
||||
, FieldView
|
||||
{ fvLabel = text $ mr MsgCorrectors
|
||||
, fvTooltip = Nothing
|
||||
, fvId = ""
|
||||
, fvInput = Yesod.encodeCellTable tableDefault corrColonnade corrData >> mapM_ idField corrData >> mapM_ delField deletions
|
||||
, fvErrors = Nothing
|
||||
, fvRequired = True
|
||||
}
|
||||
, addTutView
|
||||
{ fvInput = [whamlet|
|
||||
<div>
|
||||
^{fvInput addTutView}
|
||||
<button type=submit formnovalidate data-formnorequired>Hinzufügen
|
||||
|]
|
||||
}
|
||||
])
|
||||
|
||||
-- Eingabebox für Korrektor hinzufügen
|
||||
-- Eingabe für Korrekt ausgefüllt: FormMissing zurückschicken um dann Feld hinzuzufügen
|
||||
|
||||
getSCorrR, postSCorrR :: TermId
|
||||
-> Text -- ^ Course shorthand
|
||||
-> Text -- ^ Sheet name
|
||||
-> Handler Html
|
||||
postSCorrR = getSCorrR
|
||||
getSCorrR tid@(unTermKey -> tident) csh shn = do
|
||||
Entity shid Sheet{..} <- runDB $ fetchSheet tid csh shn
|
||||
|
||||
((res,formWidget), formEnctype) <- runFormPost . identForm FIDcorrectors . renderAForm FormStandard $ formToAForm (correctorForm shid) <* submitButton
|
||||
|
||||
case res of
|
||||
FormFailure errs -> mapM_ (addMessage "error" . toHtml) errs
|
||||
FormSuccess res -> runDB $ do
|
||||
deleteWhere [SheetCorrectorSheet ==. shid]
|
||||
insertMany_ $ Set.toList res
|
||||
addMessageI "success" MsgCorrectorsUpdated
|
||||
FormMissing -> return ()
|
||||
|
||||
let
|
||||
formTitle = MsgSheetCorrectorsTitle tident csh shn
|
||||
formText = Nothing :: Maybe (SomeMessage UniWorX)
|
||||
actionUrl = CSheetR tid csh shn SCorrR
|
||||
-- actionUrl = CSheetR tid csh shn SShowR
|
||||
defaultLayout $ do
|
||||
setTitleI $ MsgSheetCorrectorsTitle tident csh shn
|
||||
$(widgetFile "formPageI18n")
|
||||
|
||||
@ -13,6 +13,7 @@
|
||||
{-# LANGUAGE ViewPatterns #-}
|
||||
{-# LANGUAGE PatternGuards #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
|
||||
module Handler.Submission where
|
||||
|
||||
@ -49,7 +50,7 @@ import Data.Bifunctor
|
||||
import System.FilePath
|
||||
|
||||
import Colonnade hiding (bool)
|
||||
import Yesod.Colonnade
|
||||
import qualified Yesod.Colonnade as Yesod
|
||||
import qualified Text.Blaze.Html5.Attributes as HA
|
||||
|
||||
|
||||
@ -204,7 +205,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
(Nothing, Just smid) -- no new files, existing submission partners updated
|
||||
-> return smid
|
||||
(Just files, _) -- new files
|
||||
-> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission shid uid ((,False) <$> msmid)
|
||||
-> runConduit $ transPipe lift files .| extractRatings .| sinkSubmission uid (maybe (Left shid) Right msmid) False
|
||||
_ -> error "Impossible, because of definition of `makeSubmissionForm`"
|
||||
-- Determine members of pre-registered group
|
||||
groupUids <- fmap (setFromList . map E.unValue) . E.select . E.from $ \(submissionGroupUser `E.InnerJoin` submissionGroup `E.InnerJoin` submissionGroupUser') -> do
|
||||
@ -236,9 +237,10 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
let formText = Nothing :: Maybe UniWorXMessage
|
||||
actionUrl <- Data.Maybe.fromJust <$> getCurrentRoute
|
||||
-- Maybe construct a table to display uploaded archive files
|
||||
let colonnadeFiles cid = mconcat
|
||||
let colonnadeFiles :: _ -> Colonnade Sortable _ (DBCell (WidgetT UniWorX IO) ())
|
||||
colonnadeFiles cid = mconcat
|
||||
-- [ sortable (Just "type") "Typ" $ \(_,_, E.Value ftype) -> textCell $ toPathPiece ftype
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> SubmissionDownloadSingleR cid fileTitle)
|
||||
[ sortable (Just "path") "Dateiname" $ anchorCell (\(Entity _ File{..}) -> CSheetR tid csh shn $ SubmissionDownloadSingleR cid fileTitle)
|
||||
(\(Entity _ File{..}) -> str2widget fileTitle)
|
||||
, sortable (Just "time") "Modifikation" $ \(Entity _ File{..}) -> stringCell $ formatTimeGerWDT fileModified
|
||||
]
|
||||
@ -265,7 +267,7 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
$maybe arCid <- mArCid
|
||||
<hr>
|
||||
<h2>
|
||||
<a href=@{SubmissionDownloadArchiveR arCid}>Archiv
|
||||
<a href=@{CSheetR tid csh shn (SubmissionDownloadArchiveR arCid)}>Archiv
|
||||
$forall (name,time) <- lastEdits
|
||||
<div>last edited by #{name} at #{formatTimeGerDTlong time}
|
||||
$maybe fileTable <- mFileTable
|
||||
@ -274,26 +276,15 @@ submissionHelper tid csh shn (SubmissionMode mcid) = do
|
||||
|]
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
||||
submissionFileSource = E.selectSource . E.from . submissionFileQuery
|
||||
|
||||
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity File))
|
||||
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
return f
|
||||
|
||||
getSubmissionDownloadSingleR :: CryptoFileNameSubmission -> FilePath -> Handler TypedContent
|
||||
getSubmissionDownloadSingleR cID path = do
|
||||
getSubmissionDownloadSingleR :: TermId -> Text -> Text -> CryptoFileNameSubmission -> FilePath -> Handler TypedContent
|
||||
getSubmissionDownloadSingleR tid csh shn cID path = do
|
||||
submissionID <- decrypt cID
|
||||
|
||||
runDB $ do
|
||||
shid <- fetchSheetId tid csh shn
|
||||
Submission{..} <- get404 submissionID
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
|
||||
isRating <- maybe False (== submissionID) <$> isRatingFile path
|
||||
case isRating of
|
||||
True -> do
|
||||
@ -311,202 +302,24 @@ getSubmissionDownloadSingleR cID path = do
|
||||
|
||||
let fileName = Text.pack $ takeFileName path
|
||||
case results of
|
||||
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName) (toContent c)
|
||||
[Entity _ File{ fileContent = Just c }] -> return $ TypedContent (defaultMimeLookup fileName <> "; charset=utf-8") (toContent c)
|
||||
_ -> notFound
|
||||
|
||||
getSubmissionDownloadArchiveR :: ZIPArchiveName SubmissionId -> Handler TypedContent
|
||||
getSubmissionDownloadArchiveR (ZIPArchiveName cID) = do
|
||||
getSubmissionDownloadArchiveR :: TermId -> Text -> Text -> ZIPArchiveName SubmissionId -> Handler TypedContent
|
||||
getSubmissionDownloadArchiveR tid csh shn (ZIPArchiveName cID) = do
|
||||
submissionID <- decrypt cID
|
||||
cUUID <- encrypt submissionID
|
||||
respondSourceDB "application/zip" $ do
|
||||
lift $ do
|
||||
shid <- fetchSheetId tid csh shn
|
||||
Submission{..} <- get404 submissionID
|
||||
when (shid /= submissionSheet) $ invalidArgsI [MsgSubmissionWrongSheet]
|
||||
|
||||
rating <- lift $ getRating submissionID
|
||||
case rating of
|
||||
Nothing -> lift notFound
|
||||
Just rating' -> do
|
||||
let fileEntitySource' :: Source (YesodDB UniWorX) File
|
||||
fileEntitySource' = submissionFileSource submissionID =$= Conduit.map entityVal >> yieldM (ratingFile cID rating')
|
||||
info = ZipInfo { zipComment = Text.encodeUtf8 . tshow $ ciphertext (cUUID :: CryptoUUIDSubmission) }
|
||||
info = ZipInfo { zipComment = Text.encodeUtf8 . pack . CI.foldedCase $ ciphertext (cUUID :: CryptoFileNameSubmission) }
|
||||
fileEntitySource' =$= produceZip info =$= Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
-----------------------------------------------------------------------------------------------
|
||||
------------------------- DEMO BELOW
|
||||
|
||||
|
||||
submissionTable :: MForm Handler (FormResult [SubmissionId], Widget)
|
||||
submissionTable = do
|
||||
subs <- lift . runDB $ E.select . E.from $ \(sub `E.InnerJoin` sheet `E.InnerJoin` course) -> do
|
||||
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
|
||||
E.on $ sheet E.^. SheetId E.==. sub E.^. SubmissionSheet
|
||||
|
||||
return (sub, sheet, course)
|
||||
|
||||
cryptedSubs <- forM subs $ \s@(Entity submissionId _, _, _) ->
|
||||
(,,) <$> encrypt submissionId <*> encrypt submissionId <*> pure s
|
||||
|
||||
let
|
||||
anchorCourse (_, _, (_, _, Entity _ Course{..})) = CourseR courseTerm courseShorthand CShowR
|
||||
courseText (_, _, (_, _, Entity _ Course{..})) = toWidget courseName
|
||||
anchorSubmission (_, cUUID, _) = SubmissionDemoR cUUID
|
||||
submissionText (cID, _, _) = toWidget . toPathPiece . CI.foldedCase $ ciphertext cID
|
||||
colonnade = mconcat
|
||||
[ headed "Abgabe-ID" $ anchorCell anchorSubmission submissionText
|
||||
, headed "Kurs" $ anchorCell anchorCourse courseText
|
||||
, headed "Blatt" $ \(_, _, (_, Entity _ Sheet{..}, _)) -> textCell $ sheetName
|
||||
]
|
||||
toExternal :: (CryptoFileNameSubmission, CryptoUUIDSubmission, a) -> Handler CryptoUUIDSubmission
|
||||
toExternal (_, cID, _) = return cID
|
||||
fromExternal :: CryptoUUIDSubmission -> Handler SubmissionId
|
||||
fromExternal = decrypt
|
||||
headedRowSelector toExternal fromExternal (HA.class_ "table table-striped table-hover") colonnade cryptedSubs
|
||||
|
||||
|
||||
getSubmissionListR, postSubmissionListR :: Handler Html
|
||||
getSubmissionListR = postSubmissionListR
|
||||
postSubmissionListR = do
|
||||
((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
|
||||
<$> areq checkBoxField "Dies sind Korrekturen" (Just False)
|
||||
<*> fileAFormReq "Archiv"
|
||||
<* submitButton
|
||||
|
||||
runDB $ do
|
||||
case uploadResult of
|
||||
FormMissing -> return ()
|
||||
FormFailure _ -> addMessage "warning" "Bitte Eingabe korrigieren."
|
||||
FormSuccess (isUpdate, fInfo) -> do
|
||||
userId <- lift requireAuthId
|
||||
let feed :: SubmissionId -> SubmissionContent -> StateT (Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId)) (YesodDB UniWorX) ()
|
||||
feed sId val = do
|
||||
mSink <- gets $ Map.lookup sId
|
||||
sink <- case mSink of
|
||||
Just sink -> return sink
|
||||
Nothing -> do
|
||||
Submission{..} <- lift $ get404 sId
|
||||
return . newResumableSink $ sinkSubmission submissionSheet userId (Just (sId, isUpdate))
|
||||
sink' <- lift $ yield val ++$$ sink
|
||||
case sink' of
|
||||
Left _ -> error "sinkSubmission returned prematurely"
|
||||
Right nSink -> modify $ Map.insert sId nSink
|
||||
sinkSubmissions :: Sink SubmissionContent (YesodDB UniWorX) ()
|
||||
sinkSubmissions = do
|
||||
sinks <- execStateC Map.empty . awaitForever $ \case
|
||||
v@(Right (sId, _)) -> lift $ feed sId v
|
||||
(Left f@File{..}) -> case splitDirectories fileTitle of
|
||||
(cID:rest)
|
||||
| not (null rest) -> do
|
||||
sId <- decrypt (CryptoID $ CI.mk cID :: CryptoFileNameSubmission)
|
||||
lift . feed sId $ Left f{ fileTitle = joinPath rest }
|
||||
| otherwise -> return ()
|
||||
[] -> invalidArgs ["Encountered file/directory with empty name"]
|
||||
lift $ mapM_ (void . closeResumableSink) sinks
|
||||
|
||||
runConduit $ fileSource fInfo =$= void consumeZip =$= extractRatings =$= void sinkSubmissions
|
||||
|
||||
(subTable, selectEncoding) <- generateFormPost . identifyForm "selection" . withFragment $ submissionTable
|
||||
|
||||
defaultLayout $(widgetFile "submission-list")
|
||||
|
||||
|
||||
|
||||
postSubmissionDownloadMultiArchiveR :: Handler TypedContent
|
||||
postSubmissionDownloadMultiArchiveR = do
|
||||
((selectResult, _), _) <- runFormPost . withFragment $ submissionTable
|
||||
|
||||
case selectResult of
|
||||
FormMissing -> invalidArgs ["Missing submission numbers"]
|
||||
FormFailure errs -> invalidArgs errs
|
||||
FormSuccess ids -> do
|
||||
(dbrunner, cleanup) <- getDBRunner
|
||||
|
||||
ratedSubmissions <- runDBRunner dbrunner $ do
|
||||
submissions <- selectList [ SubmissionId <-. ids ] []
|
||||
forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
|
||||
|
||||
(<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
|
||||
let
|
||||
fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
|
||||
|
||||
fileEntitySource = do
|
||||
submissionFileSource submissionID =$= Conduit.map entityVal
|
||||
yieldM (ratingFile cID rating)
|
||||
|
||||
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
|
||||
|
||||
lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
|
||||
lastEditTime <- case lastEditMb of
|
||||
[(submissionEditTime.entityVal -> time)] -> return time
|
||||
_other -> liftIO getCurrentTime
|
||||
yield $ File
|
||||
{ fileModified = lastEditTime
|
||||
, fileTitle = directoryName
|
||||
, fileContent = Nothing
|
||||
}
|
||||
|
||||
fileEntitySource =$= mapC withinDirectory
|
||||
|
||||
mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
getSubmissionDemoR, postSubmissionDemoR :: CryptoUUIDSubmission -> Handler Html
|
||||
getSubmissionDemoR = postSubmissionDemoR
|
||||
postSubmissionDemoR cID = do
|
||||
submissionId <- decrypt cID
|
||||
|
||||
((uploadResult, uploadWidget), uploadEnctype) <- runFormPost . renderAForm FormStandard $ (,)
|
||||
<$> areq checkBoxField "Dies ist eine Korrektur" (Just False)
|
||||
<*> fileAFormReq "Datei"
|
||||
<* submitButton
|
||||
|
||||
(submission, files) <- runDB $ do
|
||||
submission <- do
|
||||
submission@Submission{..} <- get404 submissionId
|
||||
case uploadResult of
|
||||
FormMissing -> return submission
|
||||
FormFailure _ -> submission <$ addMessage "warning" "Bitte Eingabe korrigieren."
|
||||
FormSuccess (isUpdate, fInfo) -> do
|
||||
userId <- lift requireAuthId
|
||||
let mimeType = defaultMimeLookup (fileName fInfo)
|
||||
source
|
||||
| mimeType == "application/zip" = fileSource fInfo =$= void consumeZip
|
||||
| otherwise = do
|
||||
let fileTitle = Text.unpack $ fileName fInfo
|
||||
fileModified <- liftIO getCurrentTime
|
||||
yieldM $ do
|
||||
fileContent <- Just <$> runConduit (fileSource fInfo =$= foldC)
|
||||
return File{..}
|
||||
submissionId' <- runConduit $ source =$= extractRatings =$= sinkSubmission submissionSheet userId (Just (submissionId, isUpdate))
|
||||
get404 submissionId'
|
||||
|
||||
files <- E.select . E.from $ \(sf `E.InnerJoin` f) -> E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ (sf E.^. SubmissionFileSubmission E.==. E.val submissionId)
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate]
|
||||
return (f, sf)
|
||||
return (submission, files)
|
||||
|
||||
let
|
||||
Rating'{..} = Rating'
|
||||
{ ratingPoints = submissionRatingPoints submission
|
||||
, ratingComment = submissionRatingComment submission
|
||||
, ratingTime = submissionRatingTime submission
|
||||
}
|
||||
|
||||
cID' <- encrypt submissionId
|
||||
let
|
||||
archiveBaseName = CI.foldedCase $ ciphertext (cID' :: CryptoFileNameSubmission)
|
||||
archiveName = archiveBaseName <.> "zip"
|
||||
|
||||
defaultLayout $(widgetFile "submission")
|
||||
|
||||
@ -7,6 +7,7 @@
|
||||
, MultiParamTypeClasses
|
||||
, TypeFamilies
|
||||
, FlexibleContexts
|
||||
, PartialTypeSignatures
|
||||
#-}
|
||||
|
||||
module Handler.Term where
|
||||
@ -18,7 +19,6 @@ import Handler.Utils
|
||||
import Yesod.Form.Bootstrap3
|
||||
|
||||
import Colonnade hiding (bool)
|
||||
import Yesod.Colonnade
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
@ -41,7 +41,7 @@ getTermShowR = do
|
||||
selectRep $ do
|
||||
provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
|
||||
provideRep $ do
|
||||
let colonnadeTerms = mconcat
|
||||
let colonnadeTerms = widgetColonnade $ mconcat
|
||||
[ sortable Nothing "Kürzel" $ \(Entity tid Term{..},_) -> cell $ do
|
||||
-- Scrap this if to slow, create term edit page instead
|
||||
adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
|
||||
@ -52,21 +52,21 @@ getTermShowR = do
|
||||
$else
|
||||
#{termToText termName}
|
||||
|]
|
||||
, sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
, sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureStart
|
||||
, sortable (Just "lecture-end") "Ende Vorlesungen" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termLectureEnd
|
||||
, sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
|
||||
textCell $ bool "" tickmark termActive
|
||||
textCell $ (bool "" tickmark termActive :: Text)
|
||||
, sortable Nothing "Kursliste" $ anchorCell
|
||||
(\(Entity tid _, _) -> TermCourseListR tid)
|
||||
(\(_, E.Value numCourses) -> [whamlet|_{MsgNumCourses numCourses}|])
|
||||
, sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termStart
|
||||
stringCell $ formatTimeGerWD termStart
|
||||
, sortable (Just "end") "Semesterende" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ formatTimeGerWD termEnd
|
||||
stringCell $ formatTimeGerWD termEnd
|
||||
, sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
|
||||
stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
|
||||
stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
|
||||
]
|
||||
table <- dbTable def $ DBTable
|
||||
{ dbtSQLQuery = termData
|
||||
|
||||
@ -40,15 +40,19 @@ import qualified Data.Conduit.List as C
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Data.Map (Map)
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Control.Monad.Writer.Class
|
||||
|
||||
------------------------------------------------
|
||||
-- Unique Form Identifiers to avoid accidents --
|
||||
------------------------------------------------
|
||||
|
||||
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings
|
||||
data FormIdentifier = FIDcourse | FIDsheet | FIDsubmission | FIDsettings | FIDcorrectors | FIDcorrectorTable | FIDcorrectionsUpload
|
||||
deriving (Enum, Eq, Ord, Bounded, Read, Show)
|
||||
|
||||
|
||||
@ -530,3 +534,16 @@ mforced Field{..} FieldSettings{..} val = do
|
||||
aforced :: (RenderMessage site FormMessage, HandlerSite m ~ site, MonadHandler m)
|
||||
=> Field m a -> FieldSettings site -> a -> AForm m a
|
||||
aforced field settings val = formToAForm $ second pure <$> mforced field settings val
|
||||
|
||||
multiAction :: (RenderMessage UniWorX action, PathPiece action, Ord action, Eq action)
|
||||
=> Map action (MForm (HandlerT UniWorX IO) (FormResult a, Maybe Widget))
|
||||
-> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
||||
multiAction acts = do
|
||||
mr <- getMessageRender
|
||||
let
|
||||
options = OptionList [ Option (mr a) a (toPathPiece a) | a <- Map.keys acts ] fromPathPiece
|
||||
(actionRes, actionView) <- mreq (selectField $ return options) "" Nothing
|
||||
results <- sequence acts
|
||||
let actionWidgets = Map.foldrWithKey (\act -> \case (_, Just w) -> ($(widgetFile "widgets/multiAction") :); (_, Nothing) -> id) [] results
|
||||
actionResults = Map.map fst results
|
||||
return ((actionResults Map.!) =<< actionRes, $(widgetFile "widgets/multiActionCollect"))
|
||||
|
||||
@ -8,20 +8,26 @@
|
||||
{-# LANGUAGE LambdaCase #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE DeriveGeneric, DeriveDataTypeable #-}
|
||||
{-# LANGUAGE TypeOperators #-}
|
||||
{-# LANGUAGE PartialTypeSignatures #-}
|
||||
|
||||
|
||||
module Handler.Utils.Submission
|
||||
( SubmissionSinkException(..)
|
||||
( AssignSubmissionException(..)
|
||||
, assignSubmissions
|
||||
, submissionFileSource, submissionFileQuery
|
||||
, submissionMultiArchive
|
||||
, SubmissionSinkException(..)
|
||||
, sinkSubmission
|
||||
) where
|
||||
|
||||
import Import hiding ((.=))
|
||||
import Import hiding ((.=), joinPath)
|
||||
|
||||
import Control.Lens
|
||||
import Control.Lens.Extras (is)
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.State hiding (forM_)
|
||||
import Control.Monad.State hiding (forM_, mapM_,foldM)
|
||||
import qualified Control.Monad.Random as Rand
|
||||
|
||||
import Data.Maybe
|
||||
@ -32,15 +38,21 @@ import qualified Data.Set as Set
|
||||
import Data.Map (Map, (!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Data.Monoid (Monoid, Any(..))
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
import Handler.Utils.Rating
|
||||
import Handler.Utils.Zip
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
import Data.Conduit.ResumableSink
|
||||
|
||||
import System.FilePath
|
||||
|
||||
|
||||
data AssignSubmissionException = NoCorrectorsByProportion
|
||||
@ -49,12 +61,12 @@ data AssignSubmissionException = NoCorrectorsByProportion
|
||||
instance Exception AssignSubmissionException
|
||||
|
||||
-- | Assigns all submissions according to sheet corrector loads
|
||||
assignSubmissions ::
|
||||
SheetId -- ^ Sheet do distribute to correction
|
||||
-> YesodDB UniWorX (Set SubmissionId -- ^ assigned submissions
|
||||
,Set SubmissionId -- ^ unassigend submissions (no tutors by load)
|
||||
)
|
||||
assignSubmissions sid = do
|
||||
assignSubmissions :: SheetId -- ^ Sheet do distribute to correction
|
||||
-> Maybe (Set SubmissionId) -- ^ Optionally restrict submission to consider
|
||||
-> YesodDB UniWorX ( Set SubmissionId -- ^ assigned submissions
|
||||
, Set SubmissionId -- ^ unassigend submissions (no tutors by load)
|
||||
)
|
||||
assignSubmissions sid restriction = do
|
||||
correctors <- selectList [SheetCorrectorSheet ==. sid] []
|
||||
let corrsGroup = filter hasTutorialLoad correctors -- needed as List within Esqueleto
|
||||
let corrsProp = filter hasPositiveLoad correctors
|
||||
@ -74,7 +86,8 @@ assignSubmissions sid = do
|
||||
E.where_ (tutorial E.^. TutorialTutor `E.in_` E.valList (map (sheetCorrectorUser . entityVal) corrsGroup))
|
||||
return $ tutorial E.^. TutorialTutor
|
||||
E.on $ user E.?. UserId `E.in_` E.justList tutors
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
|
||||
E.where_ $ submission E.^. SubmissionSheet E.==. E.val sid
|
||||
E.&&. maybe (E.val True) (submission E.^. SubmissionId `E.in_`) (E.valList . Set.toList <$> restriction)
|
||||
E.orderBy [E.rand] -- randomize for fair tutor distribution
|
||||
return (submission E.^. SubmissionId, user) -- , listToMaybe tutors)
|
||||
|
||||
@ -105,6 +118,57 @@ assignSubmissions sid = do
|
||||
hasTutorialLoad = isJust . byTutorial . sheetCorrectorLoad . entityVal
|
||||
|
||||
|
||||
submissionFileSource :: SubmissionId -> Source (YesodDB UniWorX) (Entity File)
|
||||
submissionFileSource = E.selectSource . E.from . submissionFileQuery
|
||||
|
||||
submissionFileQuery :: SubmissionId -> E.SqlExpr (Entity SubmissionFile) `E.InnerJoin` E.SqlExpr (Entity File)
|
||||
-> E.SqlQuery (E.SqlExpr (Entity File))
|
||||
submissionFileQuery submissionID (sf `E.InnerJoin` f) = E.distinctOnOrderBy [E.asc $ f E.^. FileTitle] $ do
|
||||
E.on (f E.^. FileId E.==. sf E.^. SubmissionFileFile)
|
||||
E.where_ $ sf E.^. SubmissionFileSubmission E.==. E.val submissionID
|
||||
E.where_ . E.not_ $ sf E.^. SubmissionFileIsDeletion -- TODO@gk: won't work as intended! Fix with refactor
|
||||
E.orderBy [E.desc $ sf E.^. SubmissionFileIsUpdate] -- E.desc returns corrector updated data first
|
||||
return f
|
||||
|
||||
submissionMultiArchive :: Set SubmissionId -> Handler TypedContent
|
||||
submissionMultiArchive (Set.toList -> ids) = do
|
||||
(dbrunner, cleanup) <- getDBRunner
|
||||
|
||||
ratedSubmissions <- runDBRunner dbrunner $ do
|
||||
submissions <- selectList [ SubmissionId <-. ids ] []
|
||||
forM submissions $ \s@(Entity submissionId _) -> maybe (invalidArgs ["Invalid submission numbers"]) (return . (, s)) =<< getRating submissionId
|
||||
|
||||
(<* cleanup) . respondSource "application/zip" . transPipe (runDBRunner dbrunner) $ do
|
||||
let
|
||||
fileEntitySource' :: (Rating, Entity Submission) -> Source (YesodDB UniWorX) File
|
||||
fileEntitySource' (rating, Entity submissionID Submission{..}) = do
|
||||
cID <- encrypt submissionID
|
||||
|
||||
let
|
||||
directoryName = CI.foldedCase $ ciphertext (cID :: CryptoFileNameSubmission)
|
||||
|
||||
fileEntitySource = do
|
||||
submissionFileSource submissionID =$= Conduit.map entityVal
|
||||
yieldM (ratingFile cID rating)
|
||||
|
||||
withinDirectory f@File{..} = f { fileTitle = directoryName </> fileTitle }
|
||||
|
||||
lastEditMb <- lift $ selectList [SubmissionEditSubmission ==. submissionID] [Desc SubmissionEditTime, LimitTo 1]
|
||||
lastEditTime <- case lastEditMb of
|
||||
[(submissionEditTime.entityVal -> time)] -> return time
|
||||
_other -> liftIO getCurrentTime
|
||||
yield $ File
|
||||
{ fileModified = lastEditTime
|
||||
, fileTitle = directoryName
|
||||
, fileContent = Nothing
|
||||
}
|
||||
|
||||
fileEntitySource =$= mapC withinDirectory
|
||||
|
||||
mapM_ fileEntitySource' ratedSubmissions =$= produceZip def =$= Conduit.map toFlushBuilder
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
data SubmissionSinkState = SubmissionSinkState
|
||||
@ -125,9 +189,9 @@ data SubmissionSinkException = DuplicateFileTitle FilePath
|
||||
|
||||
instance Exception SubmissionSinkException
|
||||
|
||||
sinkSubmission :: SheetId
|
||||
-> UserId
|
||||
-> Maybe (SubmissionId, Bool {-^ Is this a correction -})
|
||||
sinkSubmission :: UserId
|
||||
-> Either SheetId SubmissionId
|
||||
-> Bool -- ^ Is this a correction
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) SubmissionId
|
||||
-- ^ Replace the currently saved files for the given submission (either
|
||||
-- corrected files or original ones, depending on arguments) with the supplied
|
||||
@ -137,25 +201,28 @@ sinkSubmission :: SheetId
|
||||
-- are deleted (or marked as deleted in the case of this being a correction).
|
||||
--
|
||||
-- A 'Submission' is created if no 'SubmissionId' is supplied
|
||||
sinkSubmission sheetId userId mExists = do
|
||||
now <- liftIO getCurrentTime
|
||||
let
|
||||
submissionSheet = sheetId
|
||||
submissionRatingPoints = Nothing
|
||||
submissionRatingComment = Nothing
|
||||
submissionRatingBy = Nothing
|
||||
submissionRatingTime = Nothing
|
||||
|
||||
(sId, isUpdate) <- lift $ maybe ((, False) <$> (insert Submission{..} >>= (\sid -> sid <$ insert (SubmissionEdit userId now sid)))) return mExists
|
||||
|
||||
sinkSubmission userId mExists isUpdate = do
|
||||
sId <- lift $ case mExists of
|
||||
Left sheetId -> do
|
||||
let
|
||||
submissionSheet = sheetId
|
||||
submissionRatingPoints = Nothing
|
||||
submissionRatingComment = Nothing
|
||||
submissionRatingBy = Nothing
|
||||
submissionRatingTime = Nothing
|
||||
sId <- insert Submission{..}
|
||||
-- now <- liftIO getCurrentTime
|
||||
-- insert $ SubmissionEdit userId now sId -- This is done automatically during 'sinkSubmission'' iff the given submission is nonempty
|
||||
return sId
|
||||
Right sId -> return sId
|
||||
|
||||
sId <$ sinkSubmission' sId isUpdate
|
||||
where
|
||||
tell = modify . mappend
|
||||
|
||||
sinkSubmission' :: SubmissionId
|
||||
-> Bool -- ^ Is this a correction
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) ()
|
||||
-> Bool -- ^ Is this a correction
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) ()
|
||||
sinkSubmission' submissionId isUpdate = lift . finalize <=< execStateLC mempty . Conduit.mapM_ $ \case
|
||||
Left file@(File{..}) -> do
|
||||
$logDebugS "sinkSubmission" . tshow $ (submissionId, fileTitle)
|
||||
@ -303,3 +370,43 @@ sinkSubmission sheetId userId mExists = do
|
||||
, SubmissionRatingBy =. Nothing
|
||||
, SubmissionRatingComment =. Nothing
|
||||
]
|
||||
|
||||
sinkMultiSubmission :: UserId
|
||||
-> Bool {-^ Are these corrections -}
|
||||
-> Sink SubmissionContent (YesodDB UniWorX) (Set SubmissionId)
|
||||
|
||||
-- ^ Expects all supplied 'SubmissionContent' to contain an encrypted 'SubmissionId' and replaces the currently saved files for the respective submissions (either corrected files or original ones, depending on arguments) with the supplied 'SubmissionContent'.
|
||||
--
|
||||
-- Files that don't occur in the 'SubmissionContent' but are in the database are deleted (or marked as deleted in the case of this being a correction).
|
||||
sinkMultiSubmission userId isUpdate = do
|
||||
let
|
||||
feed :: SubmissionId
|
||||
-> SubmissionContent
|
||||
-> StateT
|
||||
(Map SubmissionId (ResumableSink SubmissionContent (YesodDB UniWorX) SubmissionId))
|
||||
(YesodDB UniWorX)
|
||||
()
|
||||
feed sId val = do
|
||||
mSink <- gets $ Map.lookup sId
|
||||
sink <- case mSink of
|
||||
Just sink -> return sink
|
||||
Nothing -> do
|
||||
-- Submission{..} <- lift $ get404 sId
|
||||
return . newResumableSink $ sinkSubmission userId (Right sId) isUpdate
|
||||
sink' <- lift $ yield val ++$$ sink
|
||||
case sink' of
|
||||
Left _ -> error "sinkSubmission returned prematurely"
|
||||
Right nSink -> modify $ Map.insert sId nSink
|
||||
sinks <- execStateLC Map.empty . awaitForever $ \case
|
||||
v@(Right (sId, _)) -> lift $ feed sId v
|
||||
(Left f@File{..}) -> do
|
||||
let
|
||||
tryDecrypt :: FilePath -> _ (Either CryptoIDError SubmissionId)
|
||||
tryDecrypt (CI.mk -> ciphertext) = try $ decrypt (CryptoID{..} :: CryptoFileNameSubmission)
|
||||
acc (Just cID, fp) segment = return (Just cID, fp ++ [segment])
|
||||
acc (Nothing , fp) segment = do
|
||||
msId <- tryDecrypt segment
|
||||
return . either (const id) (set _1 . Just) msId $ (Nothing, fp)
|
||||
(msId, (joinPath -> fileTitle')) <- foldM acc (Nothing, []) $ splitDirectories fileTitle
|
||||
lift . maybe (const $ return ()) feed msId $ Left f{ fileTitle = fileTitle' }
|
||||
fmap Map.keysSet . lift $ mapM (void . closeResumableSink) sinks
|
||||
|
||||
@ -35,9 +35,6 @@ numberColonnade = headed "Nr" (fromString.show)
|
||||
pairColonnade :: (Functor h) => Colonnade h a c -> Colonnade h b c -> Colonnade h (a,b) c
|
||||
pairColonnade a b = mconcat [ lmap fst a, lmap snd b]
|
||||
|
||||
i18nCell :: RenderMessage site a => a -> Cell site
|
||||
i18nCell msg = cell [whamlet|_{msg}|]
|
||||
|
||||
|
||||
-- Table Modification
|
||||
encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site IO ()) -> [a] -> WidgetT site IO ()
|
||||
@ -94,3 +91,5 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
||||
return ( catMaybes <$> collectResult selectionResults
|
||||
, encodeCellTable attrs (pairColonnade selColonnade colonnade) (zip [0..] tdata)
|
||||
)
|
||||
|
||||
|
||||
|
||||
@ -1,6 +1,7 @@
|
||||
{-# LANGUAGE NoImplicitPrelude
|
||||
, ExistentialQuantification
|
||||
, RecordWildCards
|
||||
, NamedFieldPuns
|
||||
, OverloadedStrings
|
||||
, TemplateHaskell
|
||||
, QuasiQuotes
|
||||
@ -10,29 +11,37 @@
|
||||
, FlexibleInstances
|
||||
, MultiParamTypeClasses
|
||||
, TypeFamilies
|
||||
, ScopedTypeVariables
|
||||
, TupleSections
|
||||
, RankNTypes
|
||||
#-}
|
||||
|
||||
module Handler.Utils.Table.Pagination
|
||||
( SortColumn(..), SortDirection(..)
|
||||
, FilterColumn(..), IsFilterColumn
|
||||
, DBRow(..), DBOutput
|
||||
, DBTable(..)
|
||||
, DBTable(..), IsDBTable(..)
|
||||
, PaginationSettings(..)
|
||||
, PSValidator(..)
|
||||
, Sortable(..), sortable
|
||||
, defaultFilter, defaultSorting
|
||||
, restrictFilter, restrictSorting
|
||||
, ToSortable(..), Sortable(..), sortable
|
||||
, dbTable
|
||||
, widgetColonnade, formColonnade
|
||||
, textCell, stringCell, i18nCell, anchorCell
|
||||
, formCell, DBFormResult, getDBFormResult
|
||||
, dbRow, dbSelect
|
||||
) where
|
||||
|
||||
import Handler.Utils.Table.Pagination.Types
|
||||
|
||||
import Import
|
||||
import Import hiding (Proxy(..))
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E (SqlSelect,unsafeSqlValue)
|
||||
import qualified Database.Esqueleto.Internal.Language as E (From)
|
||||
import Text.Blaze (Attribute)
|
||||
import qualified Text.Blaze.Html5.Attributes as Html5
|
||||
import qualified Text.Blaze.Html5 as Html5
|
||||
import Yesod.Core.Types (Body(..),GWData(..),WidgetT(..))
|
||||
|
||||
import qualified Data.Binary.Builder as Builder
|
||||
|
||||
@ -42,6 +51,7 @@ import Data.CaseInsensitive (CI)
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Monad.RWS hiding ((<>), Foldable(..), mapM_, forM_)
|
||||
import Control.Monad.Writer hiding ((<>), Foldable(..), mapM_, forM_)
|
||||
|
||||
import Data.Map (Map, (!))
|
||||
import qualified Data.Map as Map
|
||||
@ -49,13 +59,17 @@ import qualified Data.Map as Map
|
||||
import Data.Profunctor (lmap)
|
||||
|
||||
import Colonnade hiding (bool, fromMaybe, singleton)
|
||||
import qualified Colonnade (singleton)
|
||||
import Colonnade.Encode
|
||||
import Yesod.Colonnade
|
||||
|
||||
import Text.Hamlet (hamletFile)
|
||||
|
||||
import Data.Ratio ((%))
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
|
||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
|
||||
@ -99,38 +113,38 @@ instance {-# OVERLAPPABLE #-} (PathPiece (Element l), IsFilterColumn t cont, Mon
|
||||
|
||||
|
||||
data DBRow r = DBRow
|
||||
{ dbrIndex, dbrCount :: Int64
|
||||
, dbrOutput :: r
|
||||
}
|
||||
{ dbrOutput :: r
|
||||
, dbrIndex, dbrCount :: Int64
|
||||
} deriving (Show, Read, Eq, Ord)
|
||||
|
||||
class DBOutput r r' where
|
||||
dbProj :: r -> r'
|
||||
|
||||
instance DBOutput r r where
|
||||
instance DBOutput (DBRow r) (DBRow r) where
|
||||
dbProj = id
|
||||
instance DBOutput (DBRow r) r where
|
||||
dbProj = dbrOutput
|
||||
instance DBOutput (DBRow r) (Int64, r) where
|
||||
dbProj = (,) <$> dbrIndex <*> dbrOutput
|
||||
|
||||
|
||||
data DBTable = forall a r r' h i t.
|
||||
data DBTable m x = forall a r r' h i t.
|
||||
( ToSortable h, Functor h
|
||||
, E.SqlSelect a r, DBOutput (DBRow r) r'
|
||||
, PathPiece i
|
||||
, E.From E.SqlQuery E.SqlExpr E.SqlBackend t
|
||||
) => DBTable
|
||||
{ dbtSQLQuery :: t -> E.SqlQuery a
|
||||
, dbtColonnade :: Colonnade h r' (Cell UniWorX)
|
||||
, dbtSorting :: Map Text (SortColumn t)
|
||||
, dbtFilter :: Map Text (FilterColumn t)
|
||||
, dbtAttrs :: Attribute
|
||||
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
||||
, dbtSorting :: Map (CI Text) (SortColumn t)
|
||||
, dbtFilter :: Map (CI Text) (FilterColumn t)
|
||||
, dbtAttrs :: Attribute -- FIXME: currently unused
|
||||
, dbtIdent :: i
|
||||
}
|
||||
|
||||
|
||||
data PaginationSettings = PaginationSettings
|
||||
{ psSorting :: [(Text, SortDirection)]
|
||||
, psFilter :: Map Text [Text]
|
||||
{ psSorting :: [(CI Text, SortDirection)]
|
||||
, psFilter :: Map (CI Text) [Text]
|
||||
, psLimit :: Int64
|
||||
, psPage :: Int64
|
||||
, psShortcircuit :: Bool
|
||||
@ -145,9 +159,9 @@ instance Default PaginationSettings where
|
||||
, psShortcircuit = False
|
||||
}
|
||||
|
||||
newtype PSValidator = PSValidator { runPSValidator :: DBTable -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationSettings -> ([SomeMessage UniWorX], PaginationSettings) }
|
||||
|
||||
instance Default PSValidator where
|
||||
instance Default (PSValidator m x) where
|
||||
def = PSValidator $ \DBTable{..} -> \case
|
||||
Nothing -> def
|
||||
Just ps -> swap . (\act -> execRWS act () ps) $ do
|
||||
@ -156,15 +170,94 @@ instance Default PSValidator where
|
||||
modify $ \ps -> ps { psLimit = psLimit def }
|
||||
tell . pure $ SomeMessage MsgPSLimitNonPositive
|
||||
|
||||
defaultFilter :: Map (CI Text) [Text] -> PSValidator m x -> PSValidator m x
|
||||
defaultFilter psFilter (runPSValidator -> f) = PSValidator g
|
||||
where
|
||||
g dbTable Nothing = over _2 (\s -> s { psFilter }) $ f dbTable Nothing
|
||||
g dbTable x = f dbTable x
|
||||
|
||||
dbTable :: PSValidator -> DBTable -> Handler Widget
|
||||
defaultSorting :: [(CI Text, SortDirection)] -> PSValidator m x -> PSValidator m x
|
||||
defaultSorting psSorting (runPSValidator -> f) = PSValidator g
|
||||
where
|
||||
g dbTable Nothing = over _2 (\s -> s { psSorting }) $ f dbTable Nothing
|
||||
g dbTable x = f dbTable x
|
||||
|
||||
restrictFilter :: (CI Text -> [Text] -> Bool) -> PSValidator m x -> PSValidator m x
|
||||
restrictFilter restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
|
||||
where
|
||||
restrict' p = p { psFilter = Map.filterWithKey restrict $ psFilter p }
|
||||
|
||||
restrictSorting :: (CI Text -> SortDirection -> Bool) -> PSValidator m x -> PSValidator m x
|
||||
restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> over _2 restrict' $ f dbTable ps
|
||||
where
|
||||
restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p }
|
||||
|
||||
class (MonadHandler m, Monoid x) => IsDBTable (m :: * -> *) (x :: *) where
|
||||
type DBResult m x :: *
|
||||
-- type DBResult' m x :: *
|
||||
|
||||
data DBCell m x :: *
|
||||
cellAttrs :: Lens' (DBCell m x) [(Text, Text)]
|
||||
cellContents :: DBCell m x -> WriterT x m Widget
|
||||
|
||||
cell :: Widget -> DBCell m x
|
||||
|
||||
|
||||
-- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x)
|
||||
dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => Proxy m -> Proxy x -> DBResult m x -> m' Widget
|
||||
runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> m' (DBResult m x)
|
||||
|
||||
instance IsDBTable (WidgetT UniWorX IO) () where
|
||||
type DBResult (WidgetT UniWorX IO) () = Widget
|
||||
-- type DBResult' (WidgetT UniWorX IO) () = ()
|
||||
|
||||
data DBCell (WidgetT UniWorX IO) () = WidgetCell
|
||||
{ dbCellAttrs :: [(Text, Text)]
|
||||
, dbCellContents :: Widget
|
||||
}
|
||||
cellAttrs = lens dbCellAttrs $ \w as -> w { dbCellAttrs = as }
|
||||
cellContents = return . dbCellContents
|
||||
|
||||
cell = WidgetCell []
|
||||
|
||||
-- dbWidget Proxy Proxy = iso (, ()) $ view _1
|
||||
dbWidget Proxy Proxy = return
|
||||
runDBTable = return . join . fmap (view _2)
|
||||
|
||||
instance Monoid a => IsDBTable (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) where
|
||||
-- type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = ((FormResult a, Widget), Enctype)
|
||||
type DBResult (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = Form a
|
||||
-- type DBResult' (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = (FormResult a, Enctype)
|
||||
|
||||
data DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a) = FormCell
|
||||
{ formCellAttrs :: [(Text, Text)]
|
||||
, formCellContents :: MForm (HandlerT UniWorX IO) (FormResult a, Widget)
|
||||
}
|
||||
cellAttrs = lens formCellAttrs $ \w as -> w { formCellAttrs = as }
|
||||
cellContents = WriterT . fmap swap . formCellContents
|
||||
|
||||
cell widget = FormCell [] $ return (mempty, widget)
|
||||
|
||||
-- dbWidget Proxy Proxy = iso ((,) <$> view (_1._2) <*> ((,) <$> view (_1._1) <*> view _2))
|
||||
-- ((,) <$> ((,) <$> view (_2._1) <*> view _1) <*> view (_2._2))
|
||||
dbWidget Proxy Proxy = liftHandlerT . fmap (view $ _1 . _2) . runFormPost
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m ((FormResult a, Widget), Enctype)
|
||||
-- runDBTable form = liftHandlerT . runFormPost $ \html -> over _2 (<> toWidget html) <$> form
|
||||
-- runDBTable :: MForm (HandlerT UniWorX IO) (FormResult a, Widget) -> m (Html -> MForm (HandleT UniWorX IO) (FormResult a, Widget))
|
||||
runDBTable = return . withFragment
|
||||
|
||||
instance IsDBTable m a => IsString (DBCell m a) where
|
||||
fromString = cell . fromString
|
||||
|
||||
|
||||
dbTable :: forall m x. IsDBTable m x => PSValidator m x -> DBTable m x -> Handler (DBResult m x)
|
||||
dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), dbtColonnade = (lmap dbProj -> dbtColonnade), .. }) = do
|
||||
let
|
||||
sortingOptions = mkOptionList
|
||||
[ Option t' (t, d) t'
|
||||
| (t, _) <- mapToList dbtSorting
|
||||
, d <- [SortAsc, SortDesc]
|
||||
, let t' = t <> "-" <> toPathPiece d
|
||||
, let t' = CI.foldedCase t <> "-" <> toPathPiece d
|
||||
]
|
||||
(_, defPS) = runPSValidator dbtable Nothing
|
||||
wIdent n
|
||||
@ -181,7 +274,7 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
|
||||
psResult <- runInputGetResult $ PaginationSettings
|
||||
<$> (fromMaybe [] <$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting"))
|
||||
<*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ wIdent k) dbtFilter)
|
||||
<*> (Map.mapMaybe ((\args -> args <$ guard (not $ null args)) =<<) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ CI.foldedCase k) dbtFilter)
|
||||
<*> (fromMaybe (psLimit defPS) <$> iopt intField (wIdent "pagesize"))
|
||||
<*> (fromMaybe (psPage defPS) <$> iopt intField (wIdent "page"))
|
||||
<*> ireq checkBoxField (wIdent "table-only")
|
||||
@ -212,25 +305,44 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
rowCount
|
||||
| ((_, E.Value n), _):_ <- rows' = n
|
||||
| otherwise = 0
|
||||
rows = map (\((E.Value i, E.Value n), r) -> DBRow i n r) rows'
|
||||
rows = map (\((E.Value dbrIndex, E.Value dbrCount), dbrOutput) -> DBRow{..}) rows'
|
||||
|
||||
bool return (sendResponse <=< tblLayout) psShortcircuit $ do
|
||||
getParams <- handlerToWidget $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
let table = $(widgetFile "table/colonnade")
|
||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
||||
pageNumbers = [0..pred pageCount]
|
||||
table' :: WriterT x m Widget
|
||||
table' = do
|
||||
getParams <- liftHandlerT $ queryToQueryText . Wai.queryString . reqWaiRequest <$> getRequest
|
||||
|
||||
let
|
||||
tblLink f = decodeUtf8 . Builder.toLazyByteString . renderQueryText True $ f getParams
|
||||
|
||||
withSortLinks Sortable{ sortableContent = Cell{..}, .. } = Cell
|
||||
{ cellContents = $(widgetFile "table/sortable-header")
|
||||
, cellAttrs = maybe mempty (const sortableAttr) sortableKey <> cellAttrs
|
||||
}
|
||||
where
|
||||
genHeaders SortableP{..} = forM (toSortable . oneColonnadeHead <$> getColonnade dbtColonnade) $ \Sortable{..} -> do
|
||||
widget <- cellContents sortableContent
|
||||
let
|
||||
directions = [dir | (k, dir) <- psSorting, Just k == sortableKey ]
|
||||
sortableAttr = Html5.class_ . fromString . unwords $ "sortable" : foldMap toAttr directions
|
||||
toAttr SortAsc = ["sorted-asc"]
|
||||
toAttr SortDesc = ["sorted-desc"]
|
||||
$(widgetFile "table/layout")
|
||||
isSortable = isJust sortableKey
|
||||
isSorted = (`elem` directions)
|
||||
attrs = sortableContent ^. cellAttrs
|
||||
return $(widgetFile "table/cell/header")
|
||||
|
||||
columnCount :: Int64
|
||||
columnCount = olength64 $ getColonnade dbtColonnade
|
||||
|
||||
wHeaders <- maybe (return Nothing) (fmap Just . genHeaders) pSortable
|
||||
|
||||
wRows <- forM rows $ \row -> forM (oneColonnadeEncode <$> getColonnade dbtColonnade) $ \(($ row) -> cell) -> do
|
||||
widget <- cellContents cell
|
||||
let attrs = cell ^. cellAttrs
|
||||
return $(widgetFile "table/cell/body")
|
||||
|
||||
let table = $(widgetFile "table/colonnade")
|
||||
pageCount = max 1 . ceiling $ rowCount % psLimit
|
||||
pageNumbers = [0..pred pageCount]
|
||||
|
||||
return $(widgetFile "table/layout")
|
||||
|
||||
dbWidget' :: DBResult m x -> Handler Widget
|
||||
dbWidget' = dbWidget (Proxy :: Proxy m) (Proxy :: Proxy x)
|
||||
|
||||
bool return (sendResponse <=< tblLayout <=< dbWidget') psShortcircuit <=< runDBTable . fmap swap $ runWriterT table'
|
||||
where
|
||||
tblLayout :: Widget -> Handler Html
|
||||
tblLayout tbl' = do
|
||||
@ -240,22 +352,62 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent),
|
||||
setParam :: Text -> Maybe Text -> QueryText -> QueryText
|
||||
setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ]
|
||||
|
||||
widgetFromCell ::
|
||||
(Attribute -> WidgetT site IO () -> WidgetT site IO ())
|
||||
-> Cell site
|
||||
-> WidgetT site IO ()
|
||||
widgetFromCell f (Cell attrs contents) =
|
||||
f attrs contents
|
||||
td,th ::
|
||||
Attribute -> WidgetT site IO () -> WidgetT site IO ()
|
||||
--- DBCell utility functions
|
||||
|
||||
td = liftParent Html5.td
|
||||
th = liftParent Html5.th
|
||||
widgetColonnade :: Headedness h
|
||||
=> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
|
||||
-> Colonnade h r (DBCell (WidgetT UniWorX IO) ())
|
||||
widgetColonnade = id
|
||||
|
||||
liftParent :: (Html -> Html) -> Attribute -> WidgetT site IO a -> WidgetT site IO a
|
||||
liftParent el attrs (WidgetT f) = WidgetT $ \hdata -> do
|
||||
(a,gwd) <- f hdata
|
||||
let Body bodyFunc = gwdBody gwd
|
||||
newBodyFunc render =
|
||||
el Html5.! attrs $ (bodyFunc render)
|
||||
return (a,gwd { gwdBody = Body newBodyFunc })
|
||||
formColonnade :: (Headedness h, Monoid a)
|
||||
=> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
|
||||
-> Colonnade h r (DBCell (RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO)) (FormResult a))
|
||||
formColonnade = id
|
||||
|
||||
textCell, stringCell, i18nCell :: (RenderMessage UniWorX msg, IsDBTable m a) => msg -> DBCell m a
|
||||
stringCell = textCell
|
||||
i18nCell = textCell
|
||||
textCell msg = cell [whamlet|_{msg}|]
|
||||
|
||||
anchorCell :: IsDBTable m a
|
||||
=> (r -> Route UniWorX)
|
||||
-> (r -> Widget)
|
||||
-> (r -> DBCell m a)
|
||||
anchorCell mkRoute mkWidget val = cell $(widgetFile "table/cell/link")
|
||||
where
|
||||
route = mkRoute val
|
||||
widget = mkWidget val
|
||||
|
||||
newtype DBFormResult r i a = DBFormResult (Map i (r, a -> a))
|
||||
|
||||
instance Ord i => Monoid (DBFormResult r i a) where
|
||||
mempty = DBFormResult Map.empty
|
||||
(DBFormResult m1) `mappend` (DBFormResult m2) = DBFormResult $ Map.unionWith (\(r, f1) (_, f2) -> (r, f2 . f1)) m1 m2
|
||||
|
||||
getDBFormResult :: forall r i a. Ord i => (r -> a) -> DBFormResult r i a -> Map i a
|
||||
getDBFormResult initial (DBFormResult m) = Map.map (\(r, f) -> f $ initial r) m
|
||||
|
||||
formCell :: forall r i a. Ord i
|
||||
=> (r -> MForm (HandlerT UniWorX IO) i)
|
||||
-> (r -> i -> MForm (HandlerT UniWorX IO) (FormResult (a -> a), Widget))
|
||||
-> (r -> DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
|
||||
formCell genIndex genForm input = FormCell
|
||||
{ formCellAttrs = []
|
||||
, formCellContents = do -- MForm (HandlerT UniWorX IO) (FormResult (Map i (Endo a)), Widget)
|
||||
i <- genIndex input
|
||||
(edit, w) <- genForm input i
|
||||
return (DBFormResult . Map.singleton i . (input,) <$> edit, w)
|
||||
}
|
||||
|
||||
-- Predefined colonnades
|
||||
|
||||
dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a)
|
||||
dbRow = Colonnade.singleton (headednessPure $ textCell MsgNrColumn) $ \DBRow{ dbrIndex } -> textCell $ tshow dbrIndex
|
||||
|
||||
dbSelect :: forall h r i a. (Headedness h, Ord i, PathPiece i)
|
||||
=> Setter' a Bool
|
||||
-> (r -> MForm (HandlerT UniWorX IO) i)
|
||||
-> Colonnade h r (DBCell ((RWST (Maybe (Env, FileEnv), UniWorX, [Lang]) Enctype Ints (HandlerT UniWorX IO))) (FormResult (DBFormResult r i a)))
|
||||
dbSelect resLens genIndex = Colonnade.singleton (headednessPure $ textCell MsgSelectColumn) $ \r -> flip (formCell genIndex) r $ \_ i -> do
|
||||
(selResult, selWidget) <- mreq checkBoxField ("" { fsName = Just $ "select-" <> toPathPiece i }) (Just False)
|
||||
return (set resLens <$> selResult, [whamlet|^{fvInput selWidget}|])
|
||||
|
||||
@ -11,12 +11,14 @@ import Import hiding (singleton)
|
||||
import Colonnade
|
||||
import Colonnade.Encode
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
|
||||
data Sortable a = Sortable
|
||||
{ sortableKey :: Maybe Text
|
||||
{ sortableKey :: Maybe (CI Text)
|
||||
, sortableContent :: a
|
||||
}
|
||||
|
||||
sortable :: Maybe Text -> c -> (a -> c) -> Colonnade Sortable a c
|
||||
sortable :: Maybe (CI Text) -> c -> (a -> c) -> Colonnade Sortable a c
|
||||
sortable k h = singleton (Sortable k h)
|
||||
|
||||
instance Headedness Sortable where
|
||||
@ -40,4 +42,3 @@ instance ToSortable Headed where
|
||||
|
||||
instance ToSortable Headless where
|
||||
pSortable = Nothing
|
||||
|
||||
|
||||
@ -109,7 +109,7 @@ data Load -- = ByTutorial { countsToLoad :: Bool } | ByProportion { load :: Rati
|
||||
= Load { byTutorial :: Maybe Bool -- ^ Just all from Tutorial, True if counting towards overall workload
|
||||
, byProportion :: Rational -- ^ workload proportion of all submission not assigned to tutorial leaders
|
||||
}
|
||||
deriving (Show, Read, Eq)
|
||||
deriving (Show, Read, Eq, Ord)
|
||||
derivePersistField "Load"
|
||||
|
||||
instance Semigroup Load where
|
||||
@ -169,14 +169,30 @@ termFromText t
|
||||
, Right season <- seasonFromChar s
|
||||
= Right TermIdentifier{..}
|
||||
| otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
|
||||
|
||||
|
||||
termToRational :: TermIdentifier -> Rational
|
||||
termToRational TermIdentifier{..} = fromInteger year + seasonOffset
|
||||
where
|
||||
seasonOffset
|
||||
| Summer <- season = 0
|
||||
| Winter <- season = 0.5
|
||||
|
||||
termFromRational :: Rational -> TermIdentifier
|
||||
termFromRational n = TermIdentifier{..}
|
||||
where
|
||||
year = floor n
|
||||
remainder = n - (fromInteger $ floor n)
|
||||
season
|
||||
| remainder == 0 = Summer
|
||||
| otherwise = Winter
|
||||
|
||||
instance PersistField TermIdentifier where
|
||||
toPersistValue = PersistText . termToText
|
||||
fromPersistValue (PersistText t) = termFromText t
|
||||
toPersistValue = PersistRational . termToRational
|
||||
fromPersistValue (PersistRational t) = Right $ termFromRational t
|
||||
fromPersistValue x = Left $ "Expected TermIdentifier, received: " <> tshow x
|
||||
|
||||
instance PersistFieldSql TermIdentifier where
|
||||
sqlType _ = SqlString
|
||||
sqlType _ = SqlNumeric 5 1
|
||||
|
||||
instance ToHttpApiData TermIdentifier where
|
||||
toUrlPiece = termToText
|
||||
@ -193,20 +209,20 @@ instance ToJSON TermIdentifier where
|
||||
|
||||
instance FromJSON TermIdentifier where
|
||||
parseJSON = withText "Term" $ either (fail . Text.unpack) return . termFromText
|
||||
|
||||
|
||||
{- Must be defined in a later module:
|
||||
termField :: Field (HandlerT UniWorX IO) TermIdentifier
|
||||
termField = checkMMap (return . termFromText) termToText textField
|
||||
-- TODO: this is too simple and inconvenient, use selector and year picker
|
||||
-}
|
||||
-- TODO: this is too simple and inconvenient, use selector and year picker
|
||||
-}
|
||||
|
||||
|
||||
withinTerm :: Day -> TermIdentifier -> Bool
|
||||
time `withinTerm` term = timeYear `mod` 100 == termYear `mod` 100
|
||||
where
|
||||
timeYear = fst3 $ toGregorian time
|
||||
termYear = year term
|
||||
|
||||
where
|
||||
timeYear = fst3 $ toGregorian time
|
||||
termYear = year term
|
||||
|
||||
|
||||
data StudyFieldType = FieldPrimary | FieldSecondary
|
||||
deriving (Eq, Ord, Enum, Show, Read, Bounded)
|
||||
@ -216,9 +232,10 @@ derivePersistField "StudyFieldType"
|
||||
-- Skins / Themes
|
||||
data Theme --Simply add Themes to this type only. CamelCase will be converted to "-lower"
|
||||
= Default
|
||||
| Lavender
|
||||
| NeutralBlue
|
||||
| AberdeenReds
|
||||
| MintGreen
|
||||
| MossGreen
|
||||
| SkyLove
|
||||
deriving (Eq,Ord,Bounded,Enum)
|
||||
|
||||
@ -242,5 +259,3 @@ instance Default Theme where
|
||||
-}
|
||||
|
||||
derivePersistField "Theme"
|
||||
|
||||
|
||||
|
||||
@ -43,6 +43,10 @@ getMsgRenderer = do
|
||||
mr <- getMessageRender
|
||||
return $ MsgRenderer (mr . SomeMessage :: forall msg. RenderMessage site msg => msg -> Text)
|
||||
|
||||
instance Monad FormResult where
|
||||
FormMissing >>= _ = FormMissing
|
||||
(FormFailure errs) >>= _ = FormFailure errs
|
||||
(FormSuccess a) >>= f = f a
|
||||
|
||||
---------------------
|
||||
-- Text and String --
|
||||
|
||||
@ -16,7 +16,7 @@ import Language.Haskell.TH
|
||||
-- Tuples --
|
||||
------------
|
||||
|
||||
|
||||
-- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens
|
||||
projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth
|
||||
-- $(projN n m) :: (t1,..,tn) -> tm (for m<=n)
|
||||
projNI n i = lamE [pat] rhs
|
||||
|
||||
@ -36,10 +36,7 @@
|
||||
<a href=@{TermEditR}>Neues Semester anlegen
|
||||
|
||||
<li .list-group-item>
|
||||
<a href=@{CourseNewR}>Kurse anlegen
|
||||
|
||||
<li .list-group-item>
|
||||
<a href=@{SubmissionListR}>Dateien hochladen und abrufen
|
||||
<a href=@{CourseNewR}>Kurse anlegen
|
||||
|
||||
<hr>
|
||||
<div .container>
|
||||
|
||||
5
templates/corrections.hamlet
Normal file
5
templates/corrections.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
<div .container>
|
||||
<form method=POST enctype=#{tableEncoding}>
|
||||
^{table}
|
||||
<button type=submit>
|
||||
_{MsgBtnSubmit}
|
||||
@ -1,4 +1,4 @@
|
||||
0<div .container>
|
||||
<div .container>
|
||||
<div .scrolltable>
|
||||
<table .table.table--striped.table--hover.table--vertical>
|
||||
$maybe school <- schoolMB
|
||||
@ -22,18 +22,17 @@
|
||||
#{participants}
|
||||
$maybe capacity <- courseCapacity course
|
||||
\ von #{capacity}
|
||||
<tr .table__row>
|
||||
<th #registration>Anmeldezeitraum
|
||||
<td>
|
||||
$maybe regFrom <- courseRegisterFrom course
|
||||
#{formatTimeGerWD regFrom}
|
||||
$maybe regTo <- courseRegisterTo course
|
||||
\ bis #{formatTimeGerWD regTo}
|
||||
|
||||
<tr .table__row>
|
||||
<th>
|
||||
<td>
|
||||
$if registrationOpen
|
||||
$maybe regFrom <- courseRegisterFrom course
|
||||
<tr .table__row>
|
||||
<th #registration>Anmeldezeitraum
|
||||
<td>
|
||||
Ab #{formatTimeGerWD regFrom}
|
||||
$maybe regTo <- courseRegisterTo course
|
||||
\ bis #{formatTimeGerWD regTo}
|
||||
$if registrationOpen
|
||||
<tr .table__row>
|
||||
<th>
|
||||
<td>
|
||||
<div .course__registration.container>
|
||||
<form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
|
||||
$# regWidget is defined through templates/widgets/registerForm
|
||||
|
||||
@ -16,7 +16,7 @@
|
||||
--font-logo: "Roboto", var(--font-base);
|
||||
|
||||
/* DIMENSIONS */
|
||||
--header-height: 80px;
|
||||
--header-height: 100px;
|
||||
--header-height-collapsed: 50px;
|
||||
}
|
||||
|
||||
@ -38,15 +38,25 @@ body {
|
||||
/* THEMES */
|
||||
|
||||
body {
|
||||
/* DEFAULT THEME */
|
||||
--color-primary: #4C7A9C;
|
||||
--color-light: #598EB5;
|
||||
--color-lighter: #5F98C2;
|
||||
--color-dark: #425d79;
|
||||
--color-darker: #274a65;
|
||||
--color-link: var(--color-dark);
|
||||
--color-link-hover: var(--color-darker);
|
||||
/* DEFAULT LMU THEME */
|
||||
--color-primary: #0a9342;
|
||||
--color-light: #31cc72;
|
||||
--color-lighter: #35db7a;
|
||||
--color-dark: #087536;
|
||||
--color-darker: #075728;
|
||||
--color-link: var(--color-font);
|
||||
--color-link-hover: var(--color-font);
|
||||
--color-lmu-box-border: var(--color-lightwhite);
|
||||
|
||||
&.theme--lavender {
|
||||
--color-primary: #4C7A9C;
|
||||
--color-light: #598EB5;
|
||||
--color-lighter: #5F98C2;
|
||||
--color-dark: #425d79;
|
||||
--color-darker: #274a65;
|
||||
--color-link: var(--color-dark);
|
||||
--color-link-hover: var(--color-darker);
|
||||
}
|
||||
|
||||
&.theme--neutral-blue {
|
||||
--color-primary: #3E606F;
|
||||
@ -64,7 +74,7 @@ body {
|
||||
--color-darker: #2E112D;
|
||||
}
|
||||
|
||||
&.theme--mint-green {
|
||||
&.theme--moss-green {
|
||||
--color-primary: #5C996B;
|
||||
--color-light: #7ACC8F;
|
||||
--color-lighter: #99FFB2;
|
||||
@ -159,7 +169,6 @@ h4 {
|
||||
.main__content {
|
||||
position: relative;
|
||||
background-color: white;
|
||||
z-index: 0;
|
||||
overflow: hidden;
|
||||
|
||||
> .container {
|
||||
@ -281,38 +290,31 @@ a.btn.btn-info:hover,
|
||||
}
|
||||
|
||||
/* TABLE DESIGN */
|
||||
.table__row {
|
||||
.table__td, .table__th {
|
||||
padding-top: 14px;
|
||||
padding-bottom: 10px;
|
||||
padding-left: 10px;
|
||||
padding-right: 10px;
|
||||
max-width: 300px;
|
||||
}
|
||||
|
||||
/* TODO: move outside of table__row as soon as tds and ths get their own class */
|
||||
/* .table__td, .table__th { */
|
||||
td, th {
|
||||
padding-top: 14px;
|
||||
padding-bottom: 10px;
|
||||
padding-left: 10px;
|
||||
padding-right: 10px;
|
||||
max-width: 300px;
|
||||
}
|
||||
.table__td {
|
||||
font-size: 16px;
|
||||
color: var(--color-font);
|
||||
line-height: 1.4;
|
||||
vertical-align: top;
|
||||
}
|
||||
|
||||
/* .table__td { */
|
||||
td {
|
||||
font-size: 16px;
|
||||
color: #808080;
|
||||
line-height: 1.4;
|
||||
vertical-align: top;
|
||||
}
|
||||
|
||||
/* .table__th { */
|
||||
th {
|
||||
background-color: var(--color-dark);
|
||||
position: relative;
|
||||
font-size: 16px;
|
||||
color: #fff;
|
||||
line-height: 1.4;
|
||||
padding-top: 10px;
|
||||
padding-bottom: 10px;
|
||||
font-weight: bold;
|
||||
text-align: left;
|
||||
}
|
||||
.table__th {
|
||||
background-color: var(--color-dark);
|
||||
position: relative;
|
||||
font-size: 16px;
|
||||
color: #fff;
|
||||
line-height: 1.4;
|
||||
padding-top: 10px;
|
||||
padding-bottom: 10px;
|
||||
font-weight: bold;
|
||||
text-align: left;
|
||||
}
|
||||
|
||||
@media (max-width: 1200px) {
|
||||
@ -323,7 +325,7 @@ a.btn.btn-info:hover,
|
||||
}
|
||||
|
||||
.table__td-content {
|
||||
max-height: 100px;
|
||||
max-height: 200px;
|
||||
overflow-y: auto;
|
||||
}
|
||||
|
||||
|
||||
5
templates/messages/submissionsAlreadyAssigned.hamlet
Normal file
5
templates/messages/submissionsAlreadyAssigned.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
_{MsgSubmissionsAlreadyAssigned (genericLength alreadyAssigned')}
|
||||
|
||||
<ul>
|
||||
$forall (cID, _) <- alreadyAssigned'
|
||||
<li><pre>#{toPathPiece cID}
|
||||
5
templates/messages/submissionsNotAssignedAuto.hamlet
Normal file
5
templates/messages/submissionsNotAssignedAuto.hamlet
Normal file
@ -0,0 +1,5 @@
|
||||
_{MsgCouldNotAssignCorrectorsAuto (genericLength unassigned')}
|
||||
|
||||
<ul>
|
||||
$forall cID <- unassigned'
|
||||
<li><pre>#{toPathPiece cID}
|
||||
@ -3,71 +3,71 @@
|
||||
<div .scrolltable>
|
||||
<table .table.table--striped.table--hover.table--vertical>
|
||||
<tr.table__row>
|
||||
<th> _{MsgName}
|
||||
<td> #{display userDisplayName}
|
||||
<th .table__th> _{MsgName}
|
||||
<td .table__td> #{display userDisplayName}
|
||||
<tr.table__row>
|
||||
<th> _{MsgMatrikelNr}
|
||||
<td> #{display userMatrikelnummer}
|
||||
<th .table__th> _{MsgMatrikelNr}
|
||||
<td .table__td> #{display userMatrikelnummer}
|
||||
<tr.table__row>
|
||||
<th> _{MsgEMail}
|
||||
<td> #{display userEmail}
|
||||
<th .table__th> _{MsgEMail}
|
||||
<td .table__td> #{display userEmail}
|
||||
<tr.table__row>
|
||||
<th> _{MsgIdent}
|
||||
<td> #{display userIdent}
|
||||
<th .table__th> _{MsgIdent}
|
||||
<td .table__td> #{display userIdent}
|
||||
<tr.table__row>
|
||||
<th> _{MsgPlugin}
|
||||
<td> #{display userPlugin}
|
||||
<th .table__th> _{MsgPlugin}
|
||||
<td .table__td> #{display userPlugin}
|
||||
$if not $ null admin_rights
|
||||
<tr.table__row>
|
||||
<th> Administrator
|
||||
<td>
|
||||
<th .table__th> Administrator
|
||||
<td .table__td>
|
||||
<ul>
|
||||
$forall institute <- admin_rights
|
||||
<li>#{display institute}
|
||||
$if not $ null lecturer_rights
|
||||
<tr.table__row>
|
||||
<th> Lehrberechtigt
|
||||
<td>
|
||||
<th .table__th> Lehrberechtigt
|
||||
<td .table__td>
|
||||
<ul>
|
||||
$forall institute <- lecturer_rights
|
||||
<li>#{display institute}
|
||||
$if not $ null lecture_owner
|
||||
<tr.table__row>
|
||||
<th> Eigene Kurse
|
||||
<td>
|
||||
<th .table__th> Eigene Kurse
|
||||
<td .table__td>
|
||||
<ul>
|
||||
$forall (E.Value csh, E.Value tid) <- lecture_owner
|
||||
<li>
|
||||
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
|
||||
$if not $ null lecture_corrector
|
||||
<tr.table__row>
|
||||
<th> Korrektor
|
||||
<td>
|
||||
<th .table__th> Korrektor
|
||||
<td .table__td>
|
||||
<ul>
|
||||
$forall (E.Value csh, E.Value tid) <- lecture_corrector
|
||||
<li>
|
||||
<a href=@{CourseR tid csh CShowR}>#{display tid} - #{csh}
|
||||
$if not $ null studies
|
||||
<tr.table__row>
|
||||
<th> Studiengänge
|
||||
<td>
|
||||
<th .table__th> Studiengänge
|
||||
<td .table__td>
|
||||
<table .table .table-striped .table-hover>
|
||||
<tr.table__row>
|
||||
<th> Abschluss
|
||||
<th> Studiengang
|
||||
<th> Studienart
|
||||
<th> Semester
|
||||
<th .table__th> Abschluss
|
||||
<th .table__th> Studiengang
|
||||
<th .table__th> Studienart
|
||||
<th .table__th> Semester
|
||||
|
||||
$forall (degree,field,fieldtype,semester) <- studies
|
||||
<tr.table__row>
|
||||
<td> #{display degree}
|
||||
<td> #{display field}
|
||||
<td> #{display fieldtype}
|
||||
<td> #{display semester}
|
||||
<td .table__td> #{display degree}
|
||||
<td .table__td> #{display field}
|
||||
<td .table__td> #{display fieldtype}
|
||||
<td .table__td> #{display semester}
|
||||
$if not $ null participant
|
||||
<tr.table__row>
|
||||
<th> Teilnehmer
|
||||
<td>
|
||||
<th .table__th> Teilnehmer
|
||||
<td .table__td>
|
||||
<ul>
|
||||
$forall (E.Value csh, E.Value tid, regSince) <- participant
|
||||
<li>
|
||||
|
||||
17
templates/profile.julius
Normal file
17
templates/profile.julius
Normal file
@ -0,0 +1,17 @@
|
||||
document.addEventListener('DOMContentLoaded', function () {
|
||||
|
||||
var themeSelector = document.querySelector('[placeholder="theme-select"]');
|
||||
themeSelector.addEventListener('change', function() {
|
||||
// get rid of old themes on body
|
||||
var options = Array.from(themeSelector.options)
|
||||
.forEach(function (option) {
|
||||
document.body.classList.remove(optionToTheme(option));
|
||||
});
|
||||
// add newly selected theme
|
||||
document.body.classList.add(optionToTheme(themeSelector.options[themeSelector.value - 1]));
|
||||
});
|
||||
|
||||
function optionToTheme(option) {
|
||||
return optionValue = 'theme--' + option.innerText.toLowerCase().trim().replace(/\s/g, '-');
|
||||
}
|
||||
});
|
||||
@ -11,6 +11,13 @@
|
||||
alertEl.classList.add('alert--invisible');
|
||||
});
|
||||
alertEl.insertBefore(closeEl, alertEl.children[0]);
|
||||
|
||||
// auto-hide info and success-alerts after 3 seconds
|
||||
if (!alertEl.matches('.alert-danger, .alert-warning')) {
|
||||
window.setTimeout(function() {
|
||||
alertEl.classList.add('alert--invisible');
|
||||
}, 3000);
|
||||
}
|
||||
}
|
||||
|
||||
})();
|
||||
|
||||
@ -8,6 +8,15 @@
|
||||
display: flex;
|
||||
flex-direction: column;
|
||||
}
|
||||
|
||||
@media (min-width: 768px) {
|
||||
|
||||
.alerts {
|
||||
top: 150px;
|
||||
bottom: auto;
|
||||
}
|
||||
}
|
||||
|
||||
.alert {
|
||||
position: relative;
|
||||
display: inline-block;
|
||||
@ -23,6 +32,7 @@
|
||||
margin-left: 20px;
|
||||
margin-right: 60px;
|
||||
box-shadow: 0 0 7px var(--color-dark);
|
||||
animation: slide-in-alert .2s ease-out forwards;
|
||||
|
||||
+ .alert:not(.alert--invisible) {
|
||||
margin-top: 20px;
|
||||
@ -39,6 +49,15 @@
|
||||
}
|
||||
}
|
||||
|
||||
@keyframes slide-in-alert {
|
||||
from {
|
||||
left: 120%;
|
||||
}
|
||||
to {
|
||||
left: 0;
|
||||
}
|
||||
}
|
||||
|
||||
@media (min-width: 425px) {
|
||||
|
||||
.alert {
|
||||
@ -91,6 +110,7 @@
|
||||
align-items: center;
|
||||
font-size: 40px;
|
||||
color: var(--color-dark);
|
||||
box-shadow: 0 0 2px var(--color-dark);
|
||||
}
|
||||
}
|
||||
|
||||
@ -146,6 +166,7 @@
|
||||
&::after {
|
||||
content: '\f05a';
|
||||
color: var(--color-success);
|
||||
box-shadow: 0 0 2px var(--color-success);
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -173,6 +194,7 @@
|
||||
&::after {
|
||||
content: '\f071';
|
||||
color: var(--color-warning);
|
||||
box-shadow: 0 0 2px var(--color-warning);
|
||||
}
|
||||
}
|
||||
}
|
||||
@ -189,7 +211,7 @@
|
||||
/* TODO: remove me as soon as messagerenderer-error in julius gets resolved */
|
||||
&::before {
|
||||
color: var(--color-lightwhite);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
.alert__content {
|
||||
@ -201,6 +223,7 @@
|
||||
&::after {
|
||||
content: '\f071';
|
||||
color: var(--color-error);
|
||||
box-shadow: 0 0 2px var(--color-error);
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
3
templates/table/cell/body.hamlet
Normal file
3
templates/table/cell/body.hamlet
Normal file
@ -0,0 +1,3 @@
|
||||
<td .table__td *{attrs}>
|
||||
<div .table__td-content>
|
||||
^{widget}
|
||||
11
templates/table/cell/header.hamlet
Normal file
11
templates/table/cell/header.hamlet
Normal file
@ -0,0 +1,11 @@
|
||||
<th .table__th *{attrs} :isSortable:.sortable :isSorted SortAsc:.sorted-asc :isSorted SortDesc:.sorted-desc>
|
||||
$maybe flag <- sortableKey
|
||||
$case directions
|
||||
$of [SortAsc]
|
||||
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-desc")}>
|
||||
^{widget}
|
||||
$of _
|
||||
<a .table__th-link href=#{tblLink $ setParam (wIdent "sorting") (Just $ CI.foldedCase flag <> "-asc")}>
|
||||
^{widget}
|
||||
$nothing
|
||||
^{widget}
|
||||
2
templates/table/cell/link.hamlet
Normal file
2
templates/table/cell/link.hamlet
Normal file
@ -0,0 +1,2 @@
|
||||
<a href=@{route}>
|
||||
^{widget}
|
||||
@ -1,18 +1,20 @@
|
||||
$newline never
|
||||
<table id="#{dbtIdent}" .table.table--striped.table--hover>
|
||||
$maybe sortableP <- pSortable
|
||||
$with toSortable <- toSortable sortableP
|
||||
<thead>
|
||||
<tr .table__row>
|
||||
$forall OneColonnade{..} <- getColonnade dbtColonnade
|
||||
<!-- TODO: give ths a class 'table__th' -->
|
||||
<!-- TODO: wrap content of th in 'div.table__th-content' -->
|
||||
^{widgetFromCell th $ withSortLinks $ toSortable oneColonnadeHead}
|
||||
$maybe wHeaders' <- wHeaders
|
||||
<thead>
|
||||
<tr .table__row.table__row--head>
|
||||
$forall widget <- wHeaders'
|
||||
$# cell/header.hamlet
|
||||
^{widget}
|
||||
$nothing
|
||||
<tbody>
|
||||
$forall row <- rows
|
||||
<tr .table__row>
|
||||
$forall OneColonnade{..} <- getColonnade dbtColonnade
|
||||
<!-- TODO: give tds a class 'table__td' -->
|
||||
<!-- TODO: wrap content of td in 'div.table__td-content' -->
|
||||
^{widgetFromCell td $ oneColonnadeEncode row}
|
||||
$if null wRows
|
||||
<tr>
|
||||
<td colspan=#{show columnCount}>
|
||||
Kein Inhalt.
|
||||
$else
|
||||
$forall row <- wRows
|
||||
<tr .table__row>
|
||||
$forall widget <- row
|
||||
$# cell/body.hamlet
|
||||
^{widget}
|
||||
|
||||
@ -1,44 +1,40 @@
|
||||
/* SORTABLE TABLE */
|
||||
.table {
|
||||
|
||||
/* TODO: move outside of table as soon as tds and ths get their own class */
|
||||
th.sortable {
|
||||
position: relative;
|
||||
padding-right: 24px;
|
||||
cursor: pointer;
|
||||
}
|
||||
|
||||
th.sortable::after,
|
||||
th.sortable::before {
|
||||
content: '';
|
||||
position: absolute;
|
||||
top: 50%;
|
||||
right: 4px;
|
||||
width: 0;
|
||||
height: 0;
|
||||
border-left: 8px solid transparent;
|
||||
border-right: 8px solid transparent;
|
||||
border-bottom: 8px solid rgba(255, 255, 255, 0.4);
|
||||
}
|
||||
|
||||
th.sortable::before {
|
||||
/* magic numbers to move arrow back in the right position after flipping it.
|
||||
this allows us to use the same border for the up and the down arrow */
|
||||
transform: translateY(150%) scale(1, -1);
|
||||
transform-origin: top;
|
||||
}
|
||||
|
||||
th.sortable::after {
|
||||
transform: translateY(-150%);
|
||||
}
|
||||
|
||||
th.sortable:hover::before,
|
||||
th.sortable:hover::after {
|
||||
border-bottom-color: rgba(255, 255, 255, 0.7);
|
||||
}
|
||||
|
||||
th.sorted-asc::before,
|
||||
th.sorted-desc::after {
|
||||
border-bottom-color: white !important;
|
||||
}
|
||||
/* SORTABLE TABLE-HEADERS*/
|
||||
.table__th.sortable {
|
||||
position: relative;
|
||||
padding-right: 24px;
|
||||
cursor: pointer;
|
||||
}
|
||||
|
||||
.table__th.sortable::after,
|
||||
.table__th.sortable::before {
|
||||
content: '';
|
||||
position: absolute;
|
||||
top: 50%;
|
||||
right: 4px;
|
||||
width: 0;
|
||||
height: 0;
|
||||
border-left: 8px solid transparent;
|
||||
border-right: 8px solid transparent;
|
||||
border-bottom: 8px solid rgba(255, 255, 255, 0.4);
|
||||
}
|
||||
|
||||
.table__th.sortable::before {
|
||||
/* magic numbers to move arrow back in the right position after flipping it.
|
||||
this allows us to use the same border for the up and the down arrow */
|
||||
transform: translateY(150%) scale(1, -1);
|
||||
transform-origin: top;
|
||||
}
|
||||
|
||||
.table__th.sortable::after {
|
||||
transform: translateY(-150%);
|
||||
}
|
||||
|
||||
.table__th.sortable:hover::before,
|
||||
.table__th.sortable:hover::after {
|
||||
border-bottom-color: rgba(255, 255, 255, 0.7);
|
||||
}
|
||||
|
||||
.table__th.sorted-asc::before,
|
||||
.table__th.sorted-desc::after {
|
||||
border-bottom-color: white !important;
|
||||
}
|
||||
|
||||
@ -48,9 +48,15 @@
|
||||
justify-content: flex-start;
|
||||
align-items: center;
|
||||
|
||||
&:not(.asidenav__list-item--active):hover {
|
||||
background-color: var(--color-darker);
|
||||
|
||||
> .asidenav__link-wrapper {
|
||||
color: var(--color-lightwhite);
|
||||
}
|
||||
}
|
||||
|
||||
&:hover {
|
||||
color: var(--color-link);
|
||||
background-color: var(--color-lightwhite);
|
||||
|
||||
.asidenav__link-shorthand {
|
||||
transform: scale(1.05, 1.0);
|
||||
@ -58,10 +64,6 @@
|
||||
text-shadow: none;
|
||||
}
|
||||
|
||||
> .asidenav__link-wrapper {
|
||||
color: var(--color-link);
|
||||
}
|
||||
|
||||
.asidenav__nested-list {
|
||||
transform: translateX(100%);
|
||||
opacity: 1;
|
||||
@ -109,7 +111,6 @@
|
||||
width: 50px;
|
||||
}
|
||||
|
||||
|
||||
.glyphicon + .asidenav__link-label {
|
||||
padding-left: 0;
|
||||
}
|
||||
@ -143,15 +144,10 @@
|
||||
background-color: var(--color-dark);
|
||||
|
||||
&:hover {
|
||||
color: var(--color-link);
|
||||
background-color: var(--color-lightwhite);
|
||||
|
||||
.asidenav__link-wrapper {
|
||||
background-color: white;
|
||||
color: var(--color-link);
|
||||
}
|
||||
background-color: var(--color-darker);
|
||||
}
|
||||
.asidenav__link-wrapper {
|
||||
|
||||
.asidenav__link-wrapper {
|
||||
padding-left: 13px;
|
||||
padding-right: 13px;
|
||||
border-left: 20px solid white;
|
||||
|
||||
@ -7,5 +7,4 @@ $case formLayout
|
||||
$if not (Blaze.null $ fvLabel view)
|
||||
<label .form-group__label for=#{fvId view}>#{fvLabel view}
|
||||
<div .form-group__input>
|
||||
$# FIXME: file-input does not have `required` attribute, although set on form-group
|
||||
^{fvInput view}
|
||||
|
||||
@ -10,6 +10,12 @@
|
||||
if (requireds.length == 0) {
|
||||
return false;
|
||||
}
|
||||
if (typeof button.dataset.formnorequired !== 'undefined' && button.dataset.formnorequired !== null) {
|
||||
button.addEventListener('click', function() {
|
||||
form.submit();
|
||||
});
|
||||
return false;
|
||||
}
|
||||
updateButtonState();
|
||||
|
||||
requireds.forEach(function(el) {
|
||||
@ -28,17 +34,52 @@
|
||||
}
|
||||
}
|
||||
};
|
||||
|
||||
window.utils.interactiveFieldset = function(form, fieldSets) {
|
||||
|
||||
var fields = fieldSets.map(function(fs) {
|
||||
return {
|
||||
fieldSet: fs,
|
||||
condId: fs.dataset.conditionalId,
|
||||
condValue: fs.dataset.conditionalValue,
|
||||
condEl: form.querySelector('#' + fs.dataset.conditionalId),
|
||||
};
|
||||
}).filter(function(field) {
|
||||
return !!field.condEl;
|
||||
});
|
||||
|
||||
function updateFields() {
|
||||
fields.forEach(function(field) {
|
||||
field.fieldSet.classList.toggle('hidden', field.condEl.value !== field.condValue);
|
||||
});
|
||||
}
|
||||
|
||||
function addEventListeners() {
|
||||
fields.forEach(function(field) {
|
||||
field.condEl.addEventListener('input', updateFields)
|
||||
});
|
||||
}
|
||||
|
||||
if (fieldSets.length) {
|
||||
addEventListeners();
|
||||
updateFields();
|
||||
}
|
||||
};
|
||||
})();
|
||||
|
||||
document.addEventListener('DOMContentLoaded', function() {
|
||||
|
||||
// auto reactiveButton submit-buttons with required fields
|
||||
var forms = document.querySelectorAll('form');
|
||||
Array.from(forms).forEach(function(form) {
|
||||
var submitBtn = form.querySelector('[type=submit]');
|
||||
if (submitBtn) {
|
||||
// auto reactiveButton submit-buttons with required fields
|
||||
var submitBtns = Array.from(form.querySelectorAll('[type=submit]'));
|
||||
submitBtns.forEach(function(submitBtn) {
|
||||
window.utils.reactiveButton(form, submitBtn, validateForm);
|
||||
}
|
||||
});
|
||||
|
||||
// auto conditonal fieldsets
|
||||
var fieldSets = Array.from(form.querySelectorAll('fieldset[data-conditional-id][data-conditional-value]'));
|
||||
window.utils.interactiveFieldset(form, fieldSets);
|
||||
});
|
||||
|
||||
function validateForm(inputs) {
|
||||
|
||||
@ -0,0 +1,15 @@
|
||||
.hidden {
|
||||
visibility: hidden;
|
||||
height: 0;
|
||||
opacity: 0;
|
||||
}
|
||||
|
||||
|
||||
fieldset {
|
||||
border: 0;
|
||||
margin: 20px 0 30px;
|
||||
|
||||
legend {
|
||||
display: none;
|
||||
}
|
||||
}
|
||||
4
templates/widgets/multiAction.hamlet
Normal file
4
templates/widgets/multiAction.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
<fieldset data-conditional-id="#{fvId actionView}" data-conditional-value="#{toPathPiece act}">
|
||||
<legend>
|
||||
_{act}
|
||||
^{w}
|
||||
4
templates/widgets/multiActionCollect.hamlet
Normal file
4
templates/widgets/multiActionCollect.hamlet
Normal file
@ -0,0 +1,4 @@
|
||||
^{fvInput actionView}
|
||||
|
||||
$forall w <- actionWidgets
|
||||
^{w}
|
||||
@ -4,7 +4,7 @@ $newline never
|
||||
|
||||
<a href="/" .navbar__logo>
|
||||
|
||||
<ul .navbar__list.list--inline>
|
||||
<ul .navbar__list.list--inline.navbar__list-left>
|
||||
$forall menuType <- menuTypes
|
||||
$case menuType
|
||||
$of NavbarAside (MenuItem label mIcon route _)
|
||||
|
||||
@ -3,11 +3,10 @@
|
||||
display: flex;
|
||||
flex-direction: row;
|
||||
align-items: center;
|
||||
justify-content: space-between;
|
||||
justify-content: flex-start;
|
||||
width: 100%;
|
||||
height: var(--header-height);
|
||||
padding-right: 2vw;
|
||||
padding-left: calc(24% + 40px);
|
||||
background: var(--color-darker); /* Old browsers */
|
||||
background: -moz-linear-gradient(bottom, var(--color-dark) 0%, var(--color-darker) 100%); /* FF3.6-15 */
|
||||
background: -webkit-linear-gradient(bottom, var(--color-dark) 0%,var(--color-darker) 100%); /* Chrome10-25,Safari5.1-6 */
|
||||
@ -21,13 +20,6 @@
|
||||
transition: all .2s cubic-bezier(0.03, 0.43, 0.58, 1);
|
||||
}
|
||||
|
||||
@media (min-width: 1200px) {
|
||||
|
||||
.navbar {
|
||||
padding-left: 340px;
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-width: 768px) {
|
||||
|
||||
.navbar {
|
||||
@ -36,31 +28,67 @@
|
||||
}
|
||||
|
||||
.navbar__logo {
|
||||
position: absolute;
|
||||
top: 15px;
|
||||
top: 10px;
|
||||
left: 20px;
|
||||
transition: all .2s ease;
|
||||
transform-origin: left;
|
||||
width: 0px;
|
||||
height: 80px;
|
||||
padding: 0 20px;
|
||||
display: flex;
|
||||
flex-basis: 300px;
|
||||
font-size: 16px;
|
||||
align-items: center;
|
||||
color: var(--color-lightwhite);
|
||||
transform-origin: left;
|
||||
transition: all .2s ease;
|
||||
|
||||
&:hover {
|
||||
color: var(--color-lightwhite);
|
||||
}
|
||||
|
||||
&::before {
|
||||
content: 'Uni2work';
|
||||
content: 'LMU';
|
||||
font-family: var(--font-logo);
|
||||
font-size: 42px;
|
||||
font-weight: bold;
|
||||
letter-spacing: 2px;
|
||||
display: flex;
|
||||
align-items: flex-end;
|
||||
font-size: 30px;
|
||||
min-width: 70px;
|
||||
height: calc(100% - 4px);
|
||||
padding: 0 6px 4px;
|
||||
box-shadow: 0 0 0 1px inset var(--color-lmu-box-border);
|
||||
}
|
||||
|
||||
&::after {
|
||||
content: 'Uni2work';
|
||||
margin-left: 12px;
|
||||
font-weight: normal;
|
||||
letter-spacing: 2px;
|
||||
display: flex;
|
||||
align-items: flex-end;
|
||||
text-transform: uppercase;
|
||||
width: 100%;
|
||||
height: calc(100% - 4px);
|
||||
padding: 0 6px 4px;
|
||||
box-shadow: 0 0 0 1px inset var(--color-lmu-box-border);
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-width: 1200px) {
|
||||
|
||||
.navbar__logo {
|
||||
flex-basis: 24%;
|
||||
font-size: 16px;
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-width: 1024px) {
|
||||
|
||||
.navbar__logo {
|
||||
transform: scale(0.7);
|
||||
font-size: 14px;
|
||||
|
||||
&::before {
|
||||
content: none;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -75,21 +103,30 @@
|
||||
.navbar__link-wrapper {
|
||||
display: flex;
|
||||
flex-direction: column;
|
||||
justify-content: center;
|
||||
align-items: center;
|
||||
height: var(--header-height);
|
||||
justify-content: flex-end;
|
||||
align-items: flex-start;
|
||||
height: 80px;
|
||||
min-width: 90px;
|
||||
color: var(--color-lightwhite);
|
||||
transition: height .2s cubic-bezier(0.03, 0.43, 0.58, 1);
|
||||
box-shadow: 0 0 0 1px inset var(--color-lmu-box-border);
|
||||
}
|
||||
|
||||
.navbar__link-label {
|
||||
transition: opacity .2s ease;
|
||||
padding: 0 13px;
|
||||
padding: 4px 6px;
|
||||
text-transform: uppercase;
|
||||
}
|
||||
|
||||
@media (max-width: 768px) {
|
||||
|
||||
.navbar__link-wrapper {
|
||||
box-shadow: none;
|
||||
min-width: 0;
|
||||
align-items: center;
|
||||
justify-content: center;
|
||||
}
|
||||
|
||||
.navbar__link-label {
|
||||
padding: 0 7px;
|
||||
}
|
||||
@ -105,6 +142,10 @@
|
||||
/* navbar list */
|
||||
.navbar__list {
|
||||
white-space: nowrap;
|
||||
|
||||
+ .navbar__list {
|
||||
margin-left: 12px;
|
||||
}
|
||||
}
|
||||
|
||||
/* list item */
|
||||
@ -112,6 +153,10 @@
|
||||
position: relative;
|
||||
transition: background-color .1s ease;
|
||||
|
||||
+ .navbar__list-item {
|
||||
margin-left: 12px;
|
||||
}
|
||||
|
||||
.glyphicon {
|
||||
position: relative;
|
||||
width: 20px;
|
||||
@ -120,10 +165,22 @@
|
||||
|
||||
.glyphicon::before {
|
||||
height: 20px;
|
||||
margin-left: 6px;
|
||||
}
|
||||
|
||||
.fas {
|
||||
height: 20px;
|
||||
margin-left: 8px;
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-width: 768px) {
|
||||
|
||||
.navbar__list-item {
|
||||
|
||||
.fas {
|
||||
margin-left: 0;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -134,15 +191,36 @@
|
||||
}
|
||||
}
|
||||
|
||||
.navbar__list-left {
|
||||
flex: 5;
|
||||
padding-left: 40px;
|
||||
}
|
||||
|
||||
@media (max-width: 768px) {
|
||||
|
||||
.navbar__list-left {
|
||||
padding-left: 0;
|
||||
}
|
||||
}
|
||||
|
||||
.navbar__list-item--secondary {
|
||||
margin-left: 20px;
|
||||
color: var(--color-grey);
|
||||
|
||||
.navbar__link-wrapper {
|
||||
color: var(--color-grey);
|
||||
box-shadow: 0 0 0 1px inset var(--color-grey);
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-width: 768px) {
|
||||
|
||||
.navbar__list-item--secondary {
|
||||
margin-left: 0;
|
||||
|
||||
.navbar__link-wrapper {
|
||||
box-shadow: none;
|
||||
}
|
||||
}
|
||||
}
|
||||
|
||||
@ -169,10 +247,6 @@
|
||||
color: var(--color-lightwhite);
|
||||
}
|
||||
|
||||
.navbar__list-item--secondary .navbar__link-wrapper {
|
||||
color: var(--color-grey);
|
||||
}
|
||||
|
||||
/* sticky state */
|
||||
.navbar--sticky {
|
||||
height: var(--header-height-collapsed);
|
||||
@ -209,7 +283,7 @@
|
||||
}
|
||||
}
|
||||
|
||||
@media (max-height: 768px) {
|
||||
@media (max-height: 500px) {
|
||||
|
||||
.navbar,
|
||||
.navbar__pushdown {
|
||||
@ -222,5 +296,6 @@
|
||||
|
||||
.navbar__logo {
|
||||
top: 5px;
|
||||
height: var(--header-height-collapsed);
|
||||
}
|
||||
}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user