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

Merge branch 'master' into pageactions

Browse Source
This commit is contained in:
Felix Hamann 2019-02-04 22:06:22 +01:00
commit 8110405534
36 changed files with 547 additions and 432 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
ChangeLog.md
View File

@ -1,3 +1,7 @@
* Version 30.01.2019
Designänderungen
* Version 16.01.2019
Links für Bequemlichkeiten hinzugefügt (z.B. aktuelles Übungsblatt)

15
messages/uniworx/de.msg
View File

@ -7,6 +7,7 @@ BtnHijack: Sitzung übernehmen
Aborted: Abgebrochen
Registered: Angemeldet
RegisteredSince date@Text: Angemeldet seit #{date}
RegisterFrom: Anmeldungen von
RegisterTo: Anmeldungen bis
DeRegUntil: Abmeldungen bis
@ -69,7 +70,7 @@ CourseSemester: Semester
CourseSchool: Institut
CourseSchoolShort: Fach
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
CourseRegisterFromTip: Ohne Datum ist keine eigenständige Anmeldung von Studierenden möglich
CourseRegisterFromTip: Ohne Datum ist KEINE eigenständige Anmeldung von Studierenden möglich
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein
CourseDeregisterUntilTip: Abmeldung darf auch ohne Begrenzung möglich sein
CourseFilterSearch: Volltext-Suche
@ -108,7 +109,7 @@ SheetSolutionFrom: Lösung ab
SheetMarking: Hinweise für Korrektoren
SheetType: Wertung
SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}!
SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
SheetName: Name
SheetDescription: Hinweise für Teilnehmer
SheetGroup: Gruppenabgabe
@ -207,6 +208,7 @@ CorByProportionOnly proportion@Rational: #{display proportion} Anteile
CorByProportionIncludingTutorial proportion@Rational: #{display proportion} Anteile - Tutorium
CorByProportionExcludingTutorial proportion@Rational: #{display proportion} Anteile + Tutorium
RowCount count@Int64: #{display count} #{pluralDE count "Eintrag" "Einträge"} insgesamt
DeleteRow: Zeile entfernen
ProportionNegative: Anteile dürfen nicht negativ sein
CorrectorUpdated: Korrektor erfolgreich aktualisiert
@ -240,7 +242,7 @@ MultiFileUploadInfo: (Mehrere Dateien mit Shift oder Strg auswählen)
NrColumn: Nr
SelectColumn: Auswahl
DBTablePagesize: Einträge
DBTablePagesize: Einträge pro Seite
DBTablePagesizeAll: Alle
CorrDownload: Herunterladen
@ -568,15 +570,16 @@ MenuSubmissions: Abgaben
MenuSheetList: Übungsblätter
MenuSheetNew: Neues Übungsblatt anlegen
MenuSheetCurrent: Aktuelles Übungsblatt
MenuSheetLastInactive: Zuletzt abgegebenes Übungsblatt
MenuSheetOldUnassigned: Abgaben ohne Korrektor
MenuCourseEdit: Kurs editieren
MenuCourseNewTemplate: Als neuen Kurs klonen
MenuCourseClone: Als neuen Kurs klonen
MenuCourseDelete: Kurs löschen
MenuSubmissionNew: Abgabe anlegen
MenuSubmissionOwn: Abgabe
MenuCorrectors: Korrektoren
MenuSheetEdit: Übungsblatt editieren
MenuSheetDelete: Übungsblatt löschen
MenuSheetClone: Als neues Übungsblatt klonen
MenuCorrectionsUpload: Korrekturen hochladen
MenuCorrectionsCreate: Abgaben registrieren
MenuCorrectionsGrade: Abgaben bewerten
@ -608,4 +611,4 @@ DeleteCopyStringIfSure n@Int: Wenn Sie sich sicher sind, dass Sie #{pluralDE n "
DeleteConfirmation: Bestätigung
DeleteConfirmationWrong: Bestätigung muss genau dem angezeigten Text entsprechen.
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde
DBTIRowsMissing n@Int: #{pluralDE n "Eine Zeile ist" "Einige Zeile sind"} aus der Datenbank verschwunden, seit das Formular für Sie generiert wurde

6
routes
View File

@ -72,9 +72,9 @@
/notes CNotesR GET POST !corrector
/subs CCorrectionsR GET POST
/ex SheetListR GET !registered !materials !corrector
!/ex/new SheetNewR GET POST
!/ex/current SheetCurrentR GET !free -- just a redirect
!/ex/lastinactive SheetLastInactiveR GET !free -- just a redirect
/ex/new SheetNewR GET POST
/ex/current SheetCurrentR GET !registered !materials !corrector
/ex/unassigned SheetOldUnassigned GET
/ex/#SheetName SheetR:
/show SShowR GET !timeANDregistered !timeANDmaterials !corrector
/edit SEditR GET POST

9
src/Auth/Dummy.hs
View File

@ -14,15 +14,14 @@ import qualified Data.CaseInsensitive as CI
data DummyMessage = MsgDummyIdent
| MsgDummyNoFormData
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
dummyForm :: ( RenderMessage site FormMessage
, RenderMessage site DummyMessage
, RenderMessage site ButtonMessage
, YesodPersist site
, SqlBackendCanRead (YesodPersistBackend site)
, Button site SubmitButton
, Show (ButtonCssClass site)
, Button site ButtonSubmit
) => AForm (HandlerT site IO) (CI Text)
dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
<* submitButton
@ -35,9 +34,7 @@ dummyLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site DummyMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
, Button site ButtonSubmit
) => AuthPlugin site
dummyLogin = AuthPlugin{..}
where

13
src/Auth/LDAP.hs
View File

@ -28,13 +28,14 @@ import qualified Yesod.Auth.Message as Msg
data CampusLogin = CampusLogin
{ campusIdent :: CI Text
, campusPassword :: Text
}
} deriving (Generic, Typeable)
data CampusMessage = MsgCampusIdentNote
| MsgCampusIdent
| MsgCampusPassword
| MsgCampusSubmit
| MsgCampusInvalidCredentials
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
@ -53,9 +54,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName"
campusForm :: ( RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
, Button site ButtonSubmit
) => AForm (HandlerT site IO) CampusLogin
campusForm = CampusLogin
<$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
@ -66,9 +65,7 @@ campusLogin :: forall site.
( YesodAuth site
, RenderMessage site FormMessage
, RenderMessage site CampusMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
, Button site ButtonSubmit
) => LdapConf -> LdapPool -> AuthPlugin site
campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
where
@ -116,7 +113,7 @@ data CampusUserException = CampusUserLdapError LdapPoolError
| CampusUserHostCannotConnect String [IOException]
| CampusUserNoResult
| CampusUserAmbiguous
deriving (Show, Eq, Typeable)
deriving (Show, Eq, Generic, Typeable)
instance Exception CampusUserException

11
src/Auth/PWHash.hs
View File

@ -19,17 +19,16 @@ import qualified Yesod.Auth.Message as Msg
data HashLogin = HashLogin
{ hashIdent :: CI Text
, hashPassword :: Text
}
} deriving (Generic, Typeable)
data PWHashMessage = MsgPWHashIdent
| MsgPWHashPassword
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
hashForm :: ( RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
, Button site ButtonSubmit
) => AForm (HandlerT site IO) HashLogin
hashForm = HashLogin
<$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
@ -42,9 +41,7 @@ hashLogin :: ( YesodAuth site
, SqlBackendCanRead (YesodPersistBackend site)
, RenderMessage site FormMessage
, RenderMessage site PWHashMessage
, RenderMessage site ButtonMessage
, Button site SubmitButton
, Show (ButtonCssClass site)
, Button site ButtonSubmit
) => PWHashAlgorithm -> AuthPlugin site
hashLogin pwHashAlgo = AuthPlugin{..}
where

121
src/Foundation.hs
View File

@ -63,6 +63,7 @@ import Handler.Utils.StudyFeatures
import Handler.Utils.Templates
import Utils.Lens
import Utils.Form
import Utils.Sheet
import Utils.SystemMessage
import Text.Shakespeare.Text (st)
@ -275,20 +276,35 @@ instance HasRoute UniWorX MenuItem where
urlRoute MenuItem{..} = urlRoute menuItemRoute
menuItemAccessCallback :: MenuItem -> Handler Bool
menuItemAccessCallback MenuItem{..} = (&&) <$> ((==) Authorized <$> authCheck) <*> menuItemAccessCallback'
menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menuItemAccessCallback'
where
authCheck = handleAny (\_ -> return . Unauthorized $ error "authCheck caught exception") $ isAuthorized (urlRoute menuItemRoute) False
$(return [])
data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
deriving (Enum, Eq, Ord, Bounded, Read, Show)
data instance ButtonClass UniWorX
= BCIsButton
| BCDefault
| BCPrimary
| BCSuccess
| BCInfo
| BCWarning
| BCDanger
| BCLink
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe (ButtonClass UniWorX)
instance Finite (ButtonClass UniWorX)
instance Button UniWorX SubmitButton where
label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
instance PathPiece (ButtonClass UniWorX) where
toPathPiece BCIsButton = "btn"
toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
fromPathPiece = finiteFromPathPiece
cssClass BtnSubmit = BCPrimary
embedRenderMessage ''UniWorX ''ButtonSubmit id
instance Button UniWorX ButtonSubmit where
btnClasses BtnSubmit = [BCIsButton, BCPrimary]
getTimeLocale' :: [Lang] -> TimeLocale
@ -469,12 +485,23 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
return Authorized
CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime
return Authorized
CourseR tid ssh csh CRegisterR -> do
now <- liftIO getCurrentTime
mbc <- getBy $ TermSchoolCourseShort tid ssh csh
mAid <- lift maybeAuthId
registered <- case (mbc,mAid) of
(Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
_ -> return False
case mbc of
(Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
| not registered
, Just regFrom <- courseRegisterFrom -- Nothing = no registration
, regFrom <= now
, maybe True (now <=) courseRegisterTo -> return Authorized
(Just (Entity _ Course{courseDeregisterUntil}))
| registered
, maybe True (now <=) courseDeregisterUntil -> return Authorized
_other -> unauthorizedI MsgUnauthorizedCourseTime
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID
@ -1269,8 +1296,8 @@ pageActions (CourseR tid ssh csh CShowR) =
}
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseNewTemplate
, menuItemIcon = Nothing
, menuItemLabel = MsgMenuCourseClone
, menuItemIcon = Just "copy"
, menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
, menuItemModal = False
, menuItemAccessCallback' = return True
@ -1278,7 +1305,7 @@ pageActions (CourseR tid ssh csh CShowR) =
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuCourseDelete
, menuItemIcon = Nothing
, menuItemIcon = Just "trash"
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
, menuItemModal = False
, menuItemAccessCallback' = return True
@ -1291,29 +1318,19 @@ pageActions (CourseR tid ssh csh SheetListR) =
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
, menuItemModal = False
, menuItemAccessCallback' = do
now <- liftIO getCurrentTime
sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now
E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
E.limit 1
return $ sheet E.^. SheetName
case sheets of
(E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
_ -> return False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
void . MaybeT $ sheetCurrent tid ssh csh
return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSheetLastInactive
, menuItemLabel = MsgMenuSheetOldUnassigned
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetLastInactiveR
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned
, menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
void . MaybeT $ sheetOldUnassigned tid ssh csh
return True
}
, MenuItem
{ menuItemType = PageActionPrime
@ -1368,18 +1385,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
guard $ null submissions
return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh)
, ("corrections-course", CI.original csh)
, ("corrections-sheet" , CI.original shn)
])
, menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuSubmissionOwn
@ -1392,6 +1397,18 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
guard . not $ null submissions
return True
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectionsOwn
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term" , termToText $ unTermKey tid)
, ("corrections-school", CI.original $ unSchoolKey ssh)
, ("corrections-course", CI.original csh)
, ("corrections-sheet" , CI.original shn)
])
, menuItemModal = False
, menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
}
, MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrectors
@ -1416,10 +1433,18 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSheetClone
, menuItemIcon = Just "copy"
, menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
, menuItemModal = False
, menuItemAccessCallback' = return True
}
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSheetDelete
, menuItemIcon = Nothing
, menuItemIcon = Just "trash"
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
, menuItemModal = False
, menuItemAccessCallback' = return True
@ -1455,7 +1480,7 @@ pageActions (CSubmissionR tid ssh csh shn cid SubShowR) =
, MenuItem
{ menuItemType = PageActionSecondary
, menuItemLabel = MsgMenuSubmissionDelete
, menuItemIcon = Nothing
, menuItemIcon = Just "trash"
, menuItemRoute = SomeRoute $ CSubmissionR tid ssh csh shn cid SubDelR
, menuItemModal = False
, menuItemAccessCallback' = return True
@ -1474,7 +1499,7 @@ pageActions (CSubmissionR tid ssh csh shn cid CorrectionR) =
pageActions (CSheetR tid ssh csh shn SCorrR) =
[ MenuItem
{ menuItemType = PageActionPrime
, menuItemLabel = MsgMenuCorrections
, menuItemLabel = MsgMenuSubmissions
, menuItemIcon = Nothing
, menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SSubsR
, menuItemModal = False

24
src/Handler/Admin.hs
View File

@ -13,8 +13,6 @@ import Control.Monad.Trans.Except
-- import Data.Function ((&))
-- import Yesod.Form.Bootstrap3
import Web.PathPieces (showToPathPiece, readFromPathPiece)
import Database.Persist.Sql (fromSqlKey)
-- import Colonnade hiding (fromMaybe)
@ -23,19 +21,19 @@ import Database.Persist.Sql (fromSqlKey)
-- import qualified Data.UUID.Cryptographic as UUID
-- BEGIN - Buttons needed only here
data CreateButton = CreateMath | CreateInf -- Dummy for Example
deriving (Enum, Eq, Ord, Bounded, Read, Show)
data ButtonCreate = CreateMath | CreateInf -- Dummy for Example
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonCreate
instance Finite ButtonCreate
instance PathPiece CreateButton where -- for displaying the button only, not really for paths
toPathPiece = showToPathPiece
fromPathPiece = readFromPathPiece
nullaryPathPiece ''ButtonCreate camelToPathPiece
instance Button UniWorX CreateButton where
label CreateMath = [whamlet|Ma<i>thema</i>tik|]
label CreateInf = "Informatik"
instance Button UniWorX ButtonCreate where
btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
btnLabel CreateInf = "Informatik"
cssClass CreateMath = BCInfo
cssClass CreateInf = BCPrimary
btnClasses CreateMath = [BCIsButton, BCInfo]
btnClasses CreateInf = [BCIsButton, BCPrimary]
-- END Button needed here
emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
@ -60,7 +58,7 @@ emailTestForm = (,)
getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
getAdminTestR = postAdminTestR
postAdminTestR = do
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton)
((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
case btnResult of
(FormSuccess CreateInf) -> addMessage Info "Informatik-Knopf gedrückt"
(FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"

6
src/Handler/Corrections.hs
View File

@ -479,11 +479,9 @@ assignAction selId = ( CorrSetCorrector
E.distinct $ return user
mr <- getMessageRender
correctors' <- forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (SomeMessage userDisplayName, ) <$> encrypt entityKey
correctors' <- fmap ((mr MsgNoCorrector, Nothing) :) . forM correctors $ \Entity{ entityKey, entityVal = User{..} } -> (display userDisplayName, ) . Just <$> encrypt entityKey
cId <- wpreq (selectFieldList correctors' :: Field (HandlerT UniWorX IO) (Maybe CryptoUUIDUser)) (fslI MsgCorrector) Nothing
cId <- wopt (selectFieldList correctors' :: Field (HandlerT UniWorX IO) CryptoUUIDUser) (fslI MsgCorrector) Nothing
fmap CorrSetCorrectorData <$> (traverse.traverse) decrypt cId
)

42
src/Handler/Course.hs
View File

@ -259,25 +259,31 @@ getTermCourseListR tid = do
getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCShowR tid ssh csh = do
mbAid <- maybeAuthId
(courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
dependent <- (,,)
<$> get (courseSchool course) -- join -- just fetch full school name here
<*> count [CourseParticipantCourse ==. cid] -- join
<*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
Nothing -> return False
(Just aid) -> do regL <- getBy (UniqueParticipant aid cid)
return $ isJust regL)
lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName
return (courseEnt,dependent,E.unValue <$> lecturers)
let course = entityVal courseEnt
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
(course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do
[(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)]
<- lift . E.select . E.from $
\((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
let numParticipants = E.sub_select . E.from $ \part -> do
E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
return ( E.countRows :: E.SqlExpr (E.Value Int64))
return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration)
lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
return $ user E.^. UserDisplayName
return (course,schoolName,participants,registered,map E.unValue lecturers)
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
mDereg <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
mRegAt <- traverse (formatTime SelFormatDateTime) registered
(regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
mRegTo <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
defaultLayout $ do
setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
$(widgetFile "course")

2
src/Handler/Profile.hs
View File

@ -222,7 +222,7 @@ getProfileDataR = do
let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
-- Delete Button
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
(btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
defaultLayout $ do
let delWdgt = $(widgetFile "widgets/data-delete")
$(widgetFile "profileData")

52
src/Handler/Sheet.hs
View File

@ -3,6 +3,7 @@ module Handler.Sheet where
import Import
import System.FilePath (takeFileName)
import Utils.Sheet
import Handler.Utils
-- import Handler.Utils.Zip
import Handler.Utils.Table.Cells
@ -142,38 +143,15 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetCurrentR tid ssh csh = runDB $ do
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now
E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.orderBy [E.asc $ sheet E.^. SheetActiveFrom]
E.limit 1
return $ sheet E.^. SheetName
case sheets of
(E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
_ -> notFound
getSheetLastInactiveR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetLastInactiveR tid ssh csh = runDB $ do
-- TODO: deliver oldest sheet with unassigned submissions instead!!!
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.orderBy [E.desc $ sheet E.^. SheetActiveTo]
E.limit 1
return $ sheet E.^. SheetName
case sheets of
(E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
_ -> notFound
let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
shn <- sheetCurrent tid ssh csh
maybe notFound redi shn
getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler ()
getSheetOldUnassigned tid ssh csh = runDB $ do
let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
shn <- sheetOldUnassigned tid ssh csh
maybe notFound redi shn
getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetListR tid ssh csh = do
@ -299,15 +277,15 @@ getSheetListR tid ssh csh = do
$(widgetFile "sheetList")
data ButtonGeneratePseudonym = BtnGenerate
deriving (Enum, Eq, Ord, Bounded, Read, Show)
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonGeneratePseudonym
instance Finite ButtonGeneratePseudonym
nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
instance Button UniWorX ButtonGeneratePseudonym where
label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
cssClass BtnGenerate = BCDefault
btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
btnClasses BtnGenerate = [BCIsButton, BCDefault]
-- Show single sheet
getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
@ -447,11 +425,17 @@ getSFileR tid ssh csh shn typ title = do
getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getSheetNewR tid ssh csh = do
parShn <- runInputGetResult $ iopt ciField "shn"
let searchShn sheet = case parShn of
(FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
-- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
_other -> return ()
lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ course E.^. CourseId E.==. sheet E.^. SheetCourse
E.where_ $ course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
searchShn sheet
-- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do
-- E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
-- return . E.max_ $ sheetEdit E.^. SheetEditTime

5
src/Handler/Utils.hs
View File

@ -69,3 +69,8 @@ warnTermDays tid times = do
forM_ warnholidays $ warnI MsgDayIsAHoliday
forM_ outoflecture $ warnI MsgDayIsOutOfLecture
forM_ outoftermdays $ warnI MsgDayIsOutOfTerm
visibleWidget :: Bool -> Widget
-- ^ @visibleWidget False@ is an icon that denotes that something™ is not visible
visibleWidget True = mempty
visibleWidget False = [whamlet|<i .fas .fa-eye-slash>|]

122
src/Handler/Utils/Form.hs
View File

@ -15,8 +15,6 @@ import qualified Data.Char as Char
import qualified Data.CaseInsensitive as CI
import qualified Data.Foldable as Foldable
-- import Yesod.Core
import qualified Data.Text as T
-- import Yesod.Form.Types
@ -51,64 +49,55 @@ import Data.Aeson.Text (encodeToLazyText)
-- Buttons (new version ) --
----------------------------
data BtnDelete = BtnDelete
deriving (Enum, Eq, Ord, Bounded, Read, Show)
data ButtonDelete = BtnDelete
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonDelete
instance Finite ButtonDelete
instance Universe BtnDelete
instance Finite BtnDelete
nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1
nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
embedRenderMessage ''UniWorX ''ButtonDelete id
instance Button UniWorX ButtonDelete where
btnClasses BtnDelete = [BCIsButton, BCDanger]
instance Button UniWorX BtnDelete where
label BtnDelete = [whamlet|_{MsgBtnDelete}|]
data ButtonRegister = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonRegister
instance Finite ButtonRegister
cssClass BtnDelete = BCDanger
nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1
data RegisterButton = BtnRegister | BtnDeregister
deriving (Enum, Eq, Ord, Bounded, Read, Show)
embedRenderMessage ''UniWorX ''ButtonRegister id
instance Button UniWorX ButtonRegister where
btnClasses BtnRegister = [BCIsButton, BCPrimary]
btnClasses BtnDeregister = [BCIsButton, BCDanger]
instance Universe RegisterButton
instance Finite RegisterButton
data ButtonHijack = BtnHijack
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
instance Universe ButtonHijack
instance Finite ButtonHijack
nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1
nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1
instance Button UniWorX RegisterButton where
label BtnRegister = [whamlet|_{MsgBtnRegister}|]
label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
embedRenderMessage ''UniWorX ''ButtonHijack id
instance Button UniWorX ButtonHijack where
btnClasses BtnHijack = [BCIsButton, BCDefault]
cssClass BtnRegister = BCPrimary
cssClass BtnDeregister = BCDanger
data ButtonSubmitDelete = BtnSubmit' | BtnDelete'
deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
data AdminHijackUserButton = BtnHijack
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance Universe ButtonSubmitDelete
instance Finite ButtonSubmitDelete
instance Universe AdminHijackUserButton
instance Finite AdminHijackUserButton
nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1
instance Button UniWorX AdminHijackUserButton where
label BtnHijack = [whamlet|_{MsgBtnHijack}|]
cssClass BtnHijack = BCDefault
data BtnSubmitDelete = BtnSubmit' | BtnDelete'
deriving (Enum, Eq, Ord, Bounded, Read, Show)
instance Universe BtnSubmitDelete
instance Finite BtnSubmitDelete
instance Button UniWorX BtnSubmitDelete where
label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|]
label BtnDelete' = [whamlet|_{MsgBtnDelete}|]
cssClass BtnSubmit' = BCPrimary
cssClass BtnDelete' = BCDanger
embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'"
instance Button UniWorX ButtonSubmitDelete where
btnClasses BtnSubmit' = [BCIsButton, BCPrimary]
btnClasses BtnDelete' = [BCIsButton, BCDanger]
btnValidate _ BtnSubmit' = True
btnValidate _ BtnDelete' = False
nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
-- -- Looks like a button, but is just a link (e.g. for create course, etc.)
@ -118,8 +107,14 @@ nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
-- instance PathPiece LinkButton where
-- LinkButton route = ???
linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
linkButton lbl cls url = do
url' <- toTextUrl url
[whamlet|
$newline never
<a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
^{lbl}
|]
-- [whamlet|
-- <form method=post action=@{url}>
-- <input type="hidden" name="_formid" value="identify-linkButton">
@ -128,31 +123,16 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
-- <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
-- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
buttonForm :: (Button UniWorX a, Show a) => Form a
-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
buttonForm :: (Button UniWorX a, Finite a) => Form a
buttonForm csrf = do
buttonIdent <- newFormIdent
let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
(results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
let widget =
[whamlet|
#{csrf}
$forall bView <- btnViews
^{fvInput bView}
|]
return (accResult results,widget)
where
accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
accResult = Foldable.foldr accResult' FormMissing
accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one.
accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
accResult' (FormSuccess (Just x)) _ = FormSuccess x
accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess
accResult' (FormSuccess Nothing) x = x
accResult' FormMissing _ = FormMissing
accResult' (FormFailure errs) _ = FormFailure errs
(res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
return (res, [whamlet|
$newline never
#{csrf}
$forall bView <- fViews
^{fvInput bView}
|])

4
src/Handler/Utils/Submission.hs
View File

@ -130,7 +130,9 @@ assignSubmissions sid restriction = do
props = getSum $ foldMap (Sum . fst) assignments
toDeficit' (prop, assigned) = let
target = round $ fromInteger assigned' * (prop / props)
target
| props == 0 = 0
| otherwise = round $ fromInteger assigned' * (prop / props)
in target - assigned
$logDebugS "assignSubmissions" $ "Previous submissions: " <> tshow prevSubs'

26
src/Handler/Utils/Table/Pagination.hs
View File

@ -519,7 +519,7 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do
return . (res,) $ do
btnId <- newIdent
act <- traverse toTextUrl dbParamsFormAction
let submitField :: Field Handler SubmitButton
let submitField :: Field Handler ButtonSubmit
submitField = buttonField BtnSubmit
submitView :: Widget
submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False
@ -602,11 +602,11 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
| otherwise
= def
referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
(((filterRes, filterWdgt), filterEnc), ((pagesizeRes, pagesizeWdgt), pagesizeEnc)) <- mdo
(filterRes'@((filterRes, _), _)) <- runFormGet . identForm FIDDBTableFilter . addPIHiddenField dbtable (prevPi & _piFilter .~ Nothing & _piPage .~ Nothing & _piLimit .~ (formResult' pagesizeRes <|> piLimit prevPi)) . renderAForm FormDBTableFilter $ dbtFilterUI (piFilter prevPi)
let referencePagesize = psLimit . snd . runPSValidator dbtable $ Just prevPi
(pagesizeRes'@((pagesizeRes, _), _)) <- lift . runFormGet . identForm FIDDBTablePagesize . addPIHiddenField dbtable (prevPi & _piPage .~ Nothing & _piLimit .~ Nothing & _piFilter .~ (formResult' filterRes <|> piFilter prevPi)) . renderAForm FormDBTablePagesize $
areq (pagesizeField referencePagesize) (fslI MsgDBTablePagesize & addAutosubmit & addName (wIdent "pagesize") & addClass "select--pagesize") (Just referencePagesize)
<* autosubmitButton
@ -760,6 +760,15 @@ dbColonnade :: (Headedness h, Monoid x)
-> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x)
dbColonnade = id
pagesizeOptions :: PagesizeLimit -- ^ Current/previous value
-> NonNull [PagesizeLimit]
pagesizeOptions psLim = impureNonNull . Set.toAscList . Set.fromList $ psLim : PagesizeAll : map PagesizeLimit opts
where
opts :: [Int64]
opts = filter (> 0) $ opts' <> map (`div` 2) opts'
opts' = [ 10^n | n <- [1..3]]
pagesizeField :: PagesizeLimit -> Field Handler PagesizeLimit
pagesizeField psLim = selectField $ do
MsgRenderer mr <- getMsgRenderer
@ -767,16 +776,9 @@ pagesizeField psLim = selectField $ do
optText (PagesizeLimit l) = tshow l
optText PagesizeAll = mr MsgDBTablePagesizeAll
toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o) . Set.toAscList . Set.fromList
return $ toOptionList limOpts
where
limOpts :: [PagesizeLimit]
limOpts = psLim : PagesizeAll : map PagesizeLimit opts
toOptionList = flip OptionList fromPathPiece . map (\o -> Option (optText o) o $ toPathPiece o)
return . toOptionList . toNullable $ pagesizeOptions psLim
opts :: [Int64]
opts = filter (> 0) $ opts' <> map (`div` 2) opts'
opts' = [ 10^n | n <- [1..3]]
--- DBCell utility functions

1
src/Import/NoFoundation.hs
View File

@ -59,6 +59,7 @@ import Ldap.Client.Pool as Import
import Database.Esqueleto.Instances as Import ()
import Database.Persist.Sql.Instances as Import ()
import Database.Persist.Sql as Import (SqlReadT,SqlWriteT)
import Control.Monad.Trans.RWS (RWST)

2
src/Utils.hs
View File

@ -364,7 +364,7 @@ mcons :: Maybe a -> [a] -> [a]
mcons Nothing xs = xs
mcons (Just x) xs = x:xs
newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
instance Eq a => Eq (NTop (Maybe a)) where
(NTop x) == (NTop y) = x == y

52
src/Utils/Form.hs
View File

@ -7,7 +7,6 @@ import Settings
import qualified Text.Blaze.Internal as Blaze (null)
import qualified Data.Text as T
import qualified Data.Char as Char
import Data.CaseInsensitive (CI)
import qualified Data.CaseInsensitive as CI
@ -200,37 +199,36 @@ identForm = identifyForm . toPathPiece
-- Buttons (new version ) --
----------------------------
data family ButtonCssClass site :: *
data family ButtonClass site :: *
bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc))
class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
btnLabel :: a -> WidgetT site IO ()
class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
label :: a -> WidgetT site IO ()
label = toWidget . toPathPiece
default btnLabel :: RenderMessage site a => a -> WidgetT site IO ()
btnLabel = toWidget <=< ap getMessageRender . return
btnValidate :: forall p. p site -> a -> Bool
btnValidate _ _ = True
cssClass :: a -> ButtonCssClass site
btnClasses :: a -> [ButtonClass site]
btnClasses _ = []
data ButtonMessage = MsgAmbiguousButtons
| MsgWrongButtonValue
| MsgMultipleButtonValues
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
data SubmitButton = BtnSubmit
deriving (Enum, Eq, Ord, Bounded, Read, Show)
data ButtonSubmit = BtnSubmit
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
instance Universe SubmitButton
instance Finite SubmitButton
instance Universe ButtonSubmit
instance Finite ButtonSubmit
nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1
buttonField :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, Monad m
, MonadHandler m
) => a -> Field m a
-- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
buttonField btn = Field{..}
@ -239,12 +237,12 @@ buttonField btn = Field{..}
fieldView :: FieldViewFunc m a
fieldView fid name attrs _val _ = let
cssClass' :: ButtonCssClass (HandlerSite m)
cssClass' = cssClass btn
validate = btnValidate (Proxy @(HandlerSite m)) btn
classes :: [ButtonClass (HandlerSite m)]
classes = btnClasses btn
in [whamlet|
$newline never
<button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{label btn}
<button class=#{unwords $ map toPathPiece classes} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{btnLabel btn}
|]
fieldParse [] [] = return $ Right Nothing
@ -255,8 +253,6 @@ buttonField btn = Field{..}
combinedButtonField :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
combinedButtonField bs FieldSettings{..} = formToAForm $ do
@ -280,8 +276,6 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do
combinedButtonFieldF :: forall m a.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, Finite a
, MonadHandler m
) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
@ -298,26 +292,22 @@ disambiguateButtons = traverseAForm $ \case
combinedButtonField_ :: forall a m.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonField_ = (void .) . combinedButtonField
combinedButtonFieldF_ :: forall m a p.
( Button (HandlerSite m) a
, Show (ButtonCssClass (HandlerSite m))
, RenderMessage (HandlerSite m) ButtonMessage
, MonadHandler m
, Finite a
) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a
submitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @SubmitButton) ""
submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""
autosubmitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @SubmitButton) $ "" & addAutosubmit
autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit
-------------------
-- Custom Fields --

46
src/Utils/Sheet.hs Normal file
View File

@ -0,0 +1,46 @@
module Utils.Sheet where
import Import.NoFoundation
import qualified Database.Esqueleto as E
-- DB Queries for Sheets that are used in several places
sheetCurrent :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName)
sheetCurrent tid ssh csh = do
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.>. E.val now
E.&&. sheet E.^. SheetActiveFrom E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
E.limit 1
return $ sheet E.^. SheetName
return $ case sheets of
[] -> Nothing
[E.Value shn] -> Just shn
_ -> error "SQL Query with limit 1 returned more than one result"
sheetOldUnassigned :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName)
sheetOldUnassigned tid ssh csh = do
now <- liftIO getCurrentTime
sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId
E.where_ $ sheet E.^. SheetActiveTo E.<=. E.val now
E.&&. course E.^. CourseTerm E.==. E.val tid
E.&&. course E.^. CourseSchool E.==. E.val ssh
E.&&. course E.^. CourseShorthand E.==. E.val csh
E.where_ . E.exists . E.from $ \submission ->
E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
E.&&. E.isNothing (submission E.^. SubmissionRatingBy)
E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
E.limit 1
return $ sheet E.^. SheetName
return $ case sheets of
[] -> Nothing
[E.Value shn] -> Just shn
_ -> error "SQL Query with limit 1 returned more than one result"

2
templates/adminTest.hamlet
View File

@ -36,3 +36,5 @@
^{modal "Klick mich für Content-Test" (Right "Test Inhalt für Modal")}
<li>
^{modal "Email-Test" (Right emailWidget')}
<li>
^{visibleWidget False}

36
templates/course.hamlet
View File

@ -1,10 +1,9 @@
<div .container>
<dl .deflist>
$maybe school <- schoolMB
<dt .deflist__dt>Fakultät/Institut
<dd .deflist__dd>
<div>
#{schoolName school}
<dt .deflist__dt>Fakultät/Institut
<dd .deflist__dd>
<div>
#{schoolName}
$maybe descr <- courseDescription course
<dt .deflist__dt>_{MsgCourseDescription}
@ -33,20 +32,27 @@ $# $if NTop (Just 0) < NTop (courseCapacity course)
#{participants}
$maybe capacity <- courseCapacity course
\ von #{capacity}
$maybe regFrom <- mRegFrom
<dt .deflist__dt>Anmeldezeitraum
<dd .deflist__dd>
$maybe regFrom <- mRegFrom
<dt .deflist__dt>Anmeldezeitraum
<dd .deflist__dd>
<div>
Ab #{regFrom}
$maybe regTo <- mRegTo
\ bis #{regTo}
$maybe dereg <- mDereg
<div>
Ab #{regFrom}
$maybe regTo <- mRegTo
\ bis #{regTo}
$if registrationOpen
\ <em>Achtung:</em>
\ Abmeldung nur bis #{dereg} erlaubt.
$if registrationOpen || isJust mRegAt
<dt .deflist__dt>
<dd .deflist__dd>
<div .course__registration>
<form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm
^{regWidget}
$if registrationOpen
<form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
$# regWidget is defined through templates/widgets/registerForm
^{regWidget}
$maybe date <- mRegAt
_{MsgRegisteredSince date}
<dt .deflist__dt>
Material
<dd .deflist__dd>

3
templates/courses.hamlet
View File

@ -1,3 +1,2 @@
<div .container>
<div .scrolltable>
^{coursesTable}
^{coursesTable}

2
templates/default-layout.lucius
View File

@ -335,6 +335,8 @@ input[type="button"].btn-info:hover,
/* SCROLLTABLE */
.scrolltable {
overflow: auto;
box-shadow: 0 0 3px 0 var(--color-grey);
margin-bottom: 15px;
}
@media (max-width: 425px) {

2
templates/multiFileField.lucius
View File

@ -6,7 +6,7 @@
.checkbox {
display: inline-block;
margin-left: 5px;
margin-left: 7px;
}
}

37
templates/standalone/inputs.lucius
View File

@ -234,7 +234,8 @@ input[type="checkbox"]:checked::after {
height: 24px;
width: 24px;
background-color: #f3f3f3;
box-shadow: inset 0 1px 2px 1px rgba(50,50,50,.05);
box-shadow: inset 0 1px 2px 1px rgba(50, 50, 50, 0.05);
border: 2px solid var(--color-primary);
border-radius: 4px;
color: white;
cursor: pointer;
@ -242,39 +243,43 @@ input[type="checkbox"]:checked::after {
label::before,
label::after {
content: '';
position: absolute;
top: 11px;
left: 3px;
display: block;
width: 18px;
top: 12px;
left: 8px;
height: 2px;
width: 8px;
background-color: var(--color-font);
transition: all .2s;
transform: scale(0.5, 0.1);
}
:checked + label {
background-color: var(--color-primary);
text-decoration: underline;
}
:checked + label::before,
:checked + label::after {
content: '';
}
:checked + label::before {
background-color: white;
transform: scale(1, 1) rotate(45deg);
transform: rotate(45deg);
left: 4px;
}
:checked + label::after {
background-color: white;
transform: scale(1, 1) rotate(-45deg);
transform: rotate(-45deg);
top: 11px;
width: 13px;
}
}
.radio label::before {
transform: scale(0.01, 0.01) rotate(45deg);
}
.radio label::after {
transform: scale(0.01, 0.01) rotate(-45deg);
[disabled] + label {
pointer-events: none;
border: none;
opacity: 0.6;
filter: grayscale(1);
}
}
.radio::before {

2
templates/table/layout-filter-default.hamlet
View File

@ -3,6 +3,6 @@ $newline never
<form method=GET action=#{filterAction} enctype=#{filterEnctype}>
^{filterWgdt}
<button>
^{label BtnSubmit}
^{btnLabel BtnSubmit}
<section>
^{scrolltable}

11
templates/table/layout.hamlet
View File

@ -3,10 +3,17 @@ $if null rows && (dbsEmptyStyle == DBESNoHeading)
_{dbsEmptyMessage}
$else
^{table}
<div .table-footer>
<div .table__row-count>
_{MsgRowCount rowCount}
$# Since the current pagesize is always a member of pagesizeOptions we don't need to check `pageCount > 1`
$if toEnum (fromIntegral rowCount) > minimum (pagesizeOptions referencePagesize)
<form .pagesize ##{wIdent "pagesize-form"} method=GET enctype=#{pagesizeEnc} action=#{rawAction}>
^{pagesizeWdgt}
$if pageCount > 1
<div .pagination>
<form .pagesize method=GET enctype=#{pagesizeEnc} action=#{rawAction}>
^{pagesizeWdgt}
<ul ##{wIdent "pagination"} .pages>
$forall p <- pageNumbers
<li .page-link :p == psPage:.current>

196
templates/table/layout.julius
View File

@ -1,94 +1,148 @@
(function collonadeClosure() {
'use strict';
document.addEventListener('setup', function DOMContentLoaded(e) {
window.utils = window.utils || {};
console.log('dbtable', e);
window.utils.asyncTable = function(wrapper) {
if (e.detail.module && e.detail.module !== 'dbtable')
return;
var tableIdent = #{String dbtIdent};
var shortCircuitHeader = #{String (toPathPiece HeaderDBTableShortcircuit)};
function setupAsync(wrapper) {
var ths = [];
var pagination;
var pagesizeForm;
var table = wrapper.querySelector('#' + #{String dbtIdent});
if (!table)
function init() {
var table = wrapper.querySelector('#' + tableIdent);
if (!table) {
return;
var ths = Array.from(table.querySelectorAll('th.sortable'));
var pagination = wrapper.querySelector('#' + #{String dbtIdent} + '-pagination');
}
ths = Array.from(table.querySelectorAll('th.sortable'));
pagination = wrapper.querySelector('#' + tableIdent + '-pagination');
pagesizeForm = wrapper.querySelector('#' + tableIdent + '-pagesize-form');
setupListeners();
wrapper.classList.add('js-initialized');
}
function setupListeners() {
ths.forEach(function(th) {
th.addEventListener('click', clickHandler);
});
if (pagination) {
Array.from(pagination.querySelectorAll('.page-link'))
.forEach(function(p) {
p.addEventListener('click', clickHandler);
});
}
function clickHandler(event) {
event.preventDefault();
var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
updateTableFrom(url);
}
function getClickDestination(el) {
console.log(el);
if (!el.querySelector('a')) {
return false;
}
return el.querySelector('a').getAttribute('href');
}
// fetches new sorted table from url with params and replaces contents of current table
function updateTableFrom(url) {
fetch(url, {
credentials: 'same-origin',
headers: {
'Accept': 'text/html',
#{String (toPathPiece HeaderDBTableShortcircuit)}: #{String dbtIdent}
}
}).then(function(response) {
if (!response.ok) {
throw ('Looks like there was a problem fetching ' + url.toString() + '. Status Code: ' + response.status);
}
return response.text();
}).then(function(data) {
// remove listeners
ths.forEach(function(th) {
th.removeEventListener('click', clickHandler);
});
// replace contents of table body
wrapper.innerHTML = data;
// set up async functionality again
wrapper.classList.remove("js-initialized");
document.dispatchEvent(new CustomEvent('setup', {
detail: { scope: wrapper },
bubbles: true,
cancelable: true
}));
// table.querySelector('tbody').innerHTML = data;
}).catch(function(err) {
console.error(err);
var pageLinks = Array.from(pagination.querySelectorAll('.page-link'));
pageLinks.forEach(function(p) {
p.addEventListener('click', clickHandler);
});
}
wrapper.classList.add("js-initialized");
if (pagesizeForm) {
var pagesizeSelect = pagesizeForm.querySelector('[name=' + tableIdent + '-pagesize]')
pagesizeSelect.addEventListener('change', changeHandler);
}
}
var selector = '#' + #{String $ dbtIdent} + '-table-wrapper:not(.js-initialized)';
var wrapperEl = e.detail.scope.querySelector(selector);
if (wrapperEl)
setupAsync(wrapperEl);
else if (e.detail.scope.matches(selector))
setupAsync(e.detail.scope);
});
function removeListeners() {
ths.forEach(function(th) {
th.removeEventListener('click', clickHandler);
});
if (pagination) {
var pageLinks = Array.from(pagination.querySelectorAll('.page-link'));
pageLinks.forEach(function(p) {
p.removeEventListener('click', clickHandler);
});
}
if (pagesizeForm) {
var pagesizeSelect = pagesizeForm.querySelector('[name=' + tableIdent + '-pagesize]')
pagesizeSelect.removeEventListener('change', changeHandler);
}
}
function clickHandler(event) {
event.preventDefault();
var url = new URL(window.location.origin + window.location.pathname + getClickDestination(this));
updateTableFrom(url);
}
function getClickDestination(el) {
if (!el.querySelector('a')) {
return '';
}
return el.querySelector('a').getAttribute('href');
}
function changeHandler(event) {
var currentTableUrl = wrapper.dataset.currentUrl || window.location.href;
var url = getUrlWithUpdatedPagesize(currentTableUrl, event.target.value);
url = getUrlWithResetPagenumber(url);
updateTableFrom(url);
}
function getUrlWithUpdatedPagesize(url, pagesize) {
if (url.indexOf('pagesize') >= 0) {
return url.replace(/pagesize=(\d+)/, 'pagesize=' + pagesize);
} else if (url.indexOf('?') >= 0) {
return url += '&' + tableIdent + '-pagesize=' + pagesize;
}
return url += '?' + tableIdent + '-pagesize=' + pagesize;
}
function getUrlWithResetPagenumber(url) {
return url.replace(/-page=\d+/, '-page=0');
}
function updateWrapperContents(newHtml) {
wrapper.innerHTML = newHtml;
wrapper.classList.remove("js-initialized");
// setup the wrapper and its components to behave async again
window.utils.asyncTable(wrapper);
// make sure to hide any new submit buttons
document.dispatchEvent(new CustomEvent('setup', {
detail: {
scope: wrapper,
module: 'autoSubmit'
}
}));
}
// fetches new sorted table from url with params and replaces contents of current table
function updateTableFrom(url) {
fetch(url, {
credentials: 'same-origin',
headers: {
'Accept': 'text/html',
[shortCircuitHeader]: tableIdent
}
}).then(function(response) {
if (!response.ok) {
throw new Error('Looks like there was a problem fetching ' + url + '. Status Code: ' + response.status);
}
return response.text();
}).then(function(data) {
wrapper.dataset.currentUrl = url;
removeListeners();
updateWrapperContents(data);
}).catch(function(err) {
console.error(err);
});
}
init();
};
})();
document.addEventListener('DOMContentLoaded', function() {
document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'dbtable' }, bubbles: true, cancelable: true }));
var selector = '#' + #{String $ dbtIdent} + '-table-wrapper:not(.js-initialized)';
var wrapper = document.querySelector(selector);
if (wrapper) {
window.utils.asyncTable(wrapper);
}
});

27
templates/table/layout.lucius
View File

@ -1,24 +1,29 @@
/* TABLE FOOTER */
.table-footer {
display: flex;
flex-flow: row-reverse;
justify-content: space-between;
}
/* PAGINATION */
.pagination {
margin-top: 20px;
display: flex;
flex-direction: row;
.pagesize {
float: left;
flex-grow: 0;
}
overflow: auto;
.pages {
text-align: center;
flex-grow: 1;
white-space: nowrap;
margin: 0;
.page-link {
margin: 0 7px;
margin-top: 7px;
display: inline-block;
background-color: var(--color-grey);
+ .page-link {
margin-left: 7px;
}
a {
color: var(--color-lightwhite);
padding: 7px 13px;
@ -42,10 +47,6 @@
pointer-events: none;
}
}
&:last-child {
margin-right: 0;
}
}
}
}

13
templates/widgets/asidenav.julius
View File

@ -17,16 +17,7 @@
};
})();
document.addEventListener('setup', function(e) {
if (e.detail.module && e.detail.module !== 'asidenav')
return;
var asidenavEl = e.detail.scope.querySelector('.main__aside');
window.utils.aside(asidenavEl);
});
document.addEventListener('DOMContentLoaded', function() {
document.dispatchEvent(new CustomEvent('setup', { detail: { scope: document.body, module: 'asidenav' }, bubbles: true, cancelable: true }))
var asidenavEl = document.querySelector('.main__aside');
window.utils.aside(asidenavEl);
});

1
templates/widgets/form.hamlet
View File

@ -3,6 +3,7 @@ $newline never
$case formLayout
$of FormDBTablePagesize
$forall view <- fieldViews
<label .form-group__label.label-pagesize for=#{fvId view}>#{fvLabel view}
^{fvInput view}
$of _
$forall view <- fieldViews

8
templates/widgets/form.julius
View File

@ -55,8 +55,6 @@
function addEventListeners() {
fields.forEach(function(field) {
console.log('interactiveFieldset', 'addEventListeners', field);
field.condEl.addEventListener('input', updateFields)
});
}
@ -72,8 +70,6 @@ document.addEventListener('setup', function(e) {
if (e.detail.module && e.detail.module !== 'showHide')
return;
console.log('form setup', e.detail.scope);
var forms = e.detail.scope.querySelectorAll('form');
Array.from(forms).forEach(function(form) {
// auto reactiveButton submit-buttons with required fields
@ -114,11 +110,9 @@ document.addEventListener('setup', function(e) {
var target = ancestor || elem;
target.classList.add('hidden');
} else if (elem.form) {
elem.addEventListener('change', function () { elem.form.submit() })
}
elem.classList.add('.js-initalized');
elem.classList.add('js-initialized');
});
});

26
templates/widgets/form.lucius
View File

@ -11,14 +11,32 @@ fieldset {
margin-bottom: 0;
}
[data-autosubmit][type="submit"] {
animation: fade-in 500ms ease-in-out backwards;
animation-delay: 500ms;
}
@keyframes fade-in {
from {
opacity: 0;
}
}
.hidden {
visibility: hidden;
height: 0;
opacity: 0;
margin: 0;
visibility: hidden !important;
height: 0 !important;
width: 0 !important;
opacity: 0 !important;
margin: 0 !important;
padding: 0 !important;
min-width: 0 !important;
}
.select--pagesize {
width: 5em;
min-width: 75px;
}
.label-pagesize {
margin-right: 13px;
}

49
templates/widgets/gradingSummary.hamlet
View File

@ -9,34 +9,35 @@ $# rowWdgts :: Liste von Widgets für jede Zeile (Normal,Bonus,KeineWert
$# --
<div>
<h3>_{MsgSummaryTitle} _{title $ getSum $ numSheets $ sumSummaries}
<table .table .table--striped>
<tr .table__row .table__row--head>
<th>
$# empty cell for row headers
$maybe _ <- hasMarkedPasses
<th .table__th colspan=2>_{MsgCorrected}
$maybe _ <- hasPasses
<th .table__th>_{MsgSheetGradingPassing'}
$maybe _ <- hasMarkedPoints
<th .table__th colspan=2>_{MsgCorrected}
$maybe _ <- hasPoints
<th .table__th>_{MsgSheetGradingPoints'}
<th .table__th>_{MsgSheetGradingCount'}
$# Number of Sheet/Submissions used for calculating maximum passes/points
$forall row <- rowWdgts
^{row}
$maybe nrNoGrade <- positiveSum $ numNotGraded
<tr .table__row>
<th .table__th>_{MsgSheetTypeNotGraded}
<div .scrolltable>
<table .table .table--striped>
<tr .table__row .table__row--head>
<th>
$# empty cell for row headers
$maybe _ <- hasMarkedPasses
<td colspan=2>
<th .table__th colspan=2>_{MsgCorrected}
$maybe _ <- hasPasses
<td .table__td>
<th .table__th>_{MsgSheetGradingPassing'}
$maybe _ <- hasMarkedPoints
<td .table__td colspan=2>
<th .table__th colspan=2>_{MsgCorrected}
$maybe _ <- hasPoints
<td .table__td>
<td .table__td>#{nrNoGrade}
<th .table__th>_{MsgSheetGradingPoints'}
<th .table__th>_{MsgSheetGradingCount'}
$# Number of Sheet/Submissions used for calculating maximum passes/points
$forall row <- rowWdgts
^{row}
$maybe nrNoGrade <- positiveSum $ numNotGraded
<tr .table__row>
<th .table__th>_{MsgSheetTypeNotGraded}
$maybe _ <- hasMarkedPasses
<td colspan=2>
$maybe _ <- hasPasses
<td .table__td>
$maybe _ <- hasMarkedPoints
<td .table__td colspan=2>
$maybe _ <- hasPoints
<td .table__td>
<td .table__td>#{nrNoGrade}
$maybe _ <- positiveSum $ bonusSummary ^. _numSheets
<p>_{MsgSheetTypeInfoBonus} #
$maybe _ <- positiveSum $ bonusSummary ^. _achievedPoints

1
templates/widgets/registerForm.hamlet
View File

@ -5,4 +5,3 @@ $maybe secretView <- msecretView
^{fvInput secretView}
$# Always display register/deregister button
^{fvInput btnView}