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

Merge branch 'master' into 284-massinput

Browse Source
This commit is contained in:
Gregor Kleen 2019-01-31 11:13:27 +01:00
commit 7acba967d1
18 changed files with 252 additions and 242 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
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
@ -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
@ -570,13 +571,14 @@ MenuSheetNew: Neues Übungsblatt anlegen
MenuSheetCurrent: Aktuelles Ü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

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 SheetOldUnassigned 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

104
src/Foundation.hs
View File

@ -276,13 +276,28 @@ menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menu
$(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
@ -463,12 +478,22 @@ 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
CourseR tid ssh csh CRegisterR -> do
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
cTime <- (NTop . Just) <$> liftIO getCurrentTime
guard $ NTop courseRegisterFrom <= cTime
&& NTop courseRegisterTo >= cTime
return Authorized
case mbc of
(Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
| not registered
, courseRegisterFrom <= nBot cTime
, NTop courseRegisterTo >= cTime -> return Authorized
(Just (Entity _ Course{courseDeregisterUntil}))
| registered
, NTop courseDeregisterUntil >= cTime -> return Authorized
_other -> unauthorizedI MsgUnauthorizedCourseTime
MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
smId <- decrypt cID
@ -1265,8 +1290,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
@ -1274,7 +1299,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
@ -1287,21 +1312,9 @@ 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
@ -1310,7 +1323,6 @@ pageActions (CourseR tid ssh csh SheetListR) =
, menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned
, menuItemModal = False
, menuItemAccessCallback' = runDB . maybeT (return False) $ do
guardM $ (== Authorized) <$> evalAccessCorrector tid ssh csh
void . MaybeT $ sheetOldUnassigned tid ssh csh
return True
}
@ -1367,18 +1379,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
@ -1391,6 +1391,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
@ -1415,10 +1427,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

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"

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")

34
src/Handler/Sheet.hs
View File

@ -143,25 +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
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
shn' <- sheetOldUnassigned tid ssh csh
maybe notFound (\shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR) shn'
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
@ -287,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
@ -435,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

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}
|])

2
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

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 --

26
src/Utils/Sheet.hs
View File

@ -3,6 +3,28 @@ 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
@ -12,10 +34,10 @@ sheetOldUnassigned tid ssh csh = do
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 -> do
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.desc $ sheet E.^. SheetActiveTo]
E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
E.limit 1
return $ sheet E.^. SheetName
return $ case sheets of

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>

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}

1
templates/widgets/registerForm.hamlet
View File

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