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

Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX

Browse Source
This commit is contained in:
Gregor Kleen 2018-08-06 11:47:06 +02:00
commit 430ca30c7f
7 changed files with 152 additions and 87 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ChangeLog.md
View File

@ -1,6 +1,7 @@
* Version 01.08.2018
Verbesserter Campus-Login
(Ersatz einer C-Bibliothek mit undokumentierter Abhängigkeit durch selbst entwickelten Haskell-Code erlaubt nun auch Umlaute.)
* Version 31.07.2018

1
messages/uniworx/de.msg
View File

@ -60,6 +60,7 @@ CourseShorthand: Kürzel
CourseShorthandUnique: Muss innerhalb des Semesters eindeutig sein
CourseSemester: Semester
CourseSchool: Institut
CourseSchoolShort: Fach
CourseSecretTip: Anmeldung zum Kurs erfordert Eingabe des Passworts, sofern gesetzt
CourseRegisterFromTip: Ohne Datum ist keine Anmeldung möglich
CourseRegisterToTip: Anmeldung darf auch ohne Begrenzung möglich sein

8
src/Foundation.hs
View File

@ -822,6 +822,14 @@ pageActions (TermCourseListR tid) =
, menuItemAccessCallback' = return True
}
]
pageActions (CourseListR) =
[ PageActionPrime $ MenuItem
{ menuItemLabel = "Neuen Kurs anlegen"
, menuItemIcon = Just "book"
, menuItemRoute = CourseNewR
, menuItemAccessCallback' = return True
}
]
pageActions (CourseR tid csh CShowR) =
[ PageActionPrime $ MenuItem
{ menuItemLabel = "Kurs Editieren"

116
src/Handler/Course.hs
View File

@ -10,6 +10,7 @@
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE FlexibleContexts #-}
module Handler.Course where
@ -33,57 +34,89 @@ import qualified Database.Esqueleto as E
import qualified Data.UUID.Cryptographic as UUID
type CourseTableData = DBRow (Entity Course, Int64, Bool)
type CourseTableData = DBRow (Entity Course, Int64, Bool, Entity School)
colCourse :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourse = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|]
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR)
[whamlet|#{display courseName}|]
colCourseDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCourseDescr = sortable (Just "course") (i18nCell MsgCourse)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseName}|] )
( case courseDescription of
Nothing -> mempty
(Just descr) -> cell [whamlet| <span style="float:right"> ^{modalStatic descr} |]
)
colDescription :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colDescription = sortable Nothing (i18nCell MsgCourseDescription)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
case courseDescription of
Nothing -> mempty
(Just descr) -> cell $ modalStatic descr
colCShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShort = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|]
colCShortDescr :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colCShortDescr = sortable (Just "cshort") (i18nCell MsgCourseShort)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } -> mappend
( anchorCell (CourseR courseTerm courseShorthand CShowR) [whamlet|#{display courseShorthand}|] )
( case courseDescription of
Nothing -> mempty
(Just descr) -> cell
[whamlet|<span style="float:right"> ^{modalStatic descr} |]
)
colTerm :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colTerm = sortable (Just "term") (i18nCell MsgTerm)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
anchorCell (TermCourseListR courseTerm) [whamlet|#{display courseTerm}|]
colSchool :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchool = sortable (Just "school") (i18nCell MsgCourseSchool)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } ->
cell [whamlet|#{display schoolName}|]
colSchoolShort :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colSchoolShort = sortable (Just "schoolshort") (i18nCell MsgCourseSchoolShort)
$ \DBRow{ dbrOutput=(_, _, _, Entity _ School{..}) } ->
cell [whamlet|#{display schoolShorthand}|]
colRegFrom :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegFrom = sortable (Just "register-from") (i18nCell MsgRegisterFrom)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
cell $ traverse (formatTime SelFormatDateTime) courseRegisterFrom >>= maybe mempty toWidget
colRegTo :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegTo = sortable (Just "register-to") (i18nCell MsgRegisterTo)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _) } ->
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, _, _) } ->
cell $ traverse (formatTime SelFormatDateTime) courseRegisterTo >>= maybe mempty toWidget
colParticipants :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colParticipants = sortable (Just "participants") (i18nCell MsgCourseMembers)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _) } -> textCell $ case courseCapacity of
$ \DBRow{ dbrOutput=(Entity cid Course{..}, currentParticipants, _, _) } -> textCell $ case courseCapacity of
Nothing -> MsgCourseMembersCount currentParticipants
Just max -> MsgCourseMembersCountLimited currentParticipants max
colRegistered :: IsDBTable m a => Colonnade _ CourseTableData (DBCell m a)
colRegistered = sortable (Just "registered") (i18nCell MsgRegistered)
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered) } -> tickmarkCell registered
$ \DBRow{ dbrOutput=(Entity cid Course{..}, _, registered, _) } -> tickmarkCell registered
type CourseTableExpr = E.SqlExpr (Entity Course)
type CourseTableExpr = E.SqlExpr (Entity Course) `E.InnerJoin` E.SqlExpr (Entity School)
course2Participants :: CourseTableExpr -> E.SqlExpr (E.Value Int64)
course2Participants course = E.sub_select . E.from $ \courseParticipant -> do
course2Participants (course `E.InnerJoin` _school) = E.sub_select . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
return (E.countRows :: E.SqlExpr (E.Value Int64))
course2School :: CourseTableExpr -> E.SqlExpr _ -- this is a bad hack, change to proper innerjoin
course2School course = E.subList_select . E.from $ \school -> do
E.where_ $ course E.^. CourseSchool E.==. school E.^. SchoolId
return (school E.^. SchoolShorthand)
course2Registered :: Maybe UserId -> CourseTableExpr -> E.SqlExpr (E.Value Bool)
course2Registered muid course = E.exists . E.from $ \courseParticipant -> do
course2Registered muid (course `E.InnerJoin` _school) = E.exists . E.from $ \courseParticipant -> do
E.where_ $ courseParticipant E.^. CourseParticipantCourse E.==. course E.^. CourseId
E.&&. E.just (courseParticipant E.^. CourseParticipantUser) E.==. E.val muid
@ -92,41 +125,50 @@ makeCourseTable :: ( IsDBTable m x, ToSortable h, Functor h )
makeCourseTable whereClause colChoices psValidator = do
muid <- maybeAuthId
let dbtSQLQuery :: CourseTableExpr -> E.SqlQuery _
dbtSQLQuery course = do
let participants = course2Participants course
let registered = course2Registered muid course
dbtSQLQuery qin@(course `E.InnerJoin` school) = do
E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
let participants = course2Participants qin
let registered = course2Registered muid qin
E.where_ $ whereClause (course, participants, registered)
return (course, participants, registered)
return (course, participants, registered, school)
dbtProj :: DBRow _ -> MaybeT (ReaderT SqlBackend (HandlerT UniWorX IO)) CourseTableData
dbtProj = traverse $ \(course, E.Value participants, E.Value registered) -> return (course, participants, registered)
dbtProj = traverse $ \(course, E.Value participants, E.Value registered, school) -> return (course, participants, registered, school)
dbTable psValidator $ DBTable
{ dbtSQLQuery
, dbtColonnade = colChoices
, dbtProj
, dbtSorting = Map.fromList -- OverloadedLists does not work with the templates here
[ ( "course", SortColumn $ \course -> course E.^. CourseName)
, ( "cshort", SortColumn $ \course -> course E.^. CourseShorthand)
, ( "term" , SortColumn $ \course -> course E.^. CourseTerm)
, ( "register-from", SortColumn $ \course -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \course -> course E.^. CourseRegisterTo)
, ( "participants", SortColumn $ course2Participants
)
, ( "registered", SortColumn $ course2Registered muid
)
[ ( "course", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseName)
, ( "cshort", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseShorthand)
, ( "term" , SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseTerm)
, ( "school", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolName)
, ( "schoolshort", SortColumn $ \(_course `E.InnerJoin` school) -> school E.^. SchoolShorthand)
, ( "register-from", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterFrom)
, ( "register-to", SortColumn $ \(course `E.InnerJoin` _school) -> course E.^. CourseRegisterTo)
, ( "participants", SortColumn $ course2Participants )
, ( "registered", SortColumn $ course2Registered muid)
]
, dbtFilter = Map.fromList -- OverloadedLists does not work with the templates here
[ ( "course", FilterColumn $ \(course :: CourseTableExpr) criterias -> if
[ ( "course", FilterColumn $ \(course `E.InnerJoin` _school:: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseName `E.in_` E.valList (Set.toList criterias)
)
, ( "cshort", FilterColumn $ \(course :: CourseTableExpr) criterias -> if
, ( "cshort", FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseShorthand `E.in_` E.valList (Set.toList criterias)
)
, ( "term" , FilterColumn $ \(course :: CourseTableExpr) criterias -> if
, ( "term" , FilterColumn $ \(course `E.InnerJoin` _school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> course E.^. CourseTerm `E.in_` E.valList (Set.toList criterias)
)
, ( "school", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> school E.^. SchoolName `E.in_` E.valList (Set.toList criterias)
)
, ( "schoolshort", FilterColumn $ \(_course `E.InnerJoin` school :: CourseTableExpr) criterias -> if
| Set.null criterias -> E.val True :: E.SqlExpr (E.Value Bool)
| otherwise -> school E.^. SchoolShorthand `E.in_` E.valList (Set.toList criterias)
)
]
, dbtStyle = def
, dbtIdent = "courses" :: Text
@ -136,10 +178,11 @@ getCourseListR :: Handler Html
getCourseListR = do -- TODO: Suchfunktion für Kurse und Kürzel!!!
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ colCourse
[ colCourseDescr
, colCShort
, colTerm
, maybe mempty (const colRegistered) muid
, colSchool
]
whereClause = const $ E.val True
validator = def
@ -164,7 +207,8 @@ getTermCourseListR tid = do
muid <- maybeAuthId
let colonnade = widgetColonnade $ mconcat
[ dbRow
, colCShort
, colCShortDescr
, colSchoolShort
, colRegFrom
, colRegTo
, colParticipants

15
src/Handler/Utils/Templates.hs
View File

@ -1,4 +1,4 @@
{-# LANGUAGE NoImplicitPrelude, TemplateHaskell #-}
{-# LANGUAGE NoImplicitPrelude, TemplateHaskell, QuasiQuotes #-}
module Handler.Utils.Templates where
@ -7,8 +7,17 @@ import Import.NoFoundation
lipsum :: WidgetT site IO ()
lipsum = $(widgetFile "widgets/lipsum")
modal :: [Char] -> Maybe [Char] -> WidgetT site IO ()
modal modalTrigger (Just modalContent) = do
modalStatic :: Html -> WidgetT site IO ()
modalStatic modalContent = do
uniqueId <- newIdent
let modalTrigger = cons '#' uniqueId -- SJ: I am confused why this is needed here?
modalId :: Int32
modalId = 13
$(widgetFile "widgets/modalStatic")
[whamlet|<div .tooltip__handle ##{uniqueId}>?|] -- SJ: confused why ## is needed here either?
modal :: Text -> Maybe [Char] -> WidgetT site IO ()
modal modalTrigger (Just modalContent) = do -- WARNING: ModalContent should not have length 11. SJ: This is possibly bad. See Template!
let
modalId :: Int32
modalId = 13

96
templates/standalone/tooltip.lucius
View File

@ -2,59 +2,59 @@
position: relative;
display: inline-block;
.tooltip__handle {
background-color: var(--color-dark);
border-radius: 50%;
height: 1.5rem;
width: 1.5rem;
line-height: 1.5rem;
font-size: 1.2rem;
color: white;
display: inline-block;
text-align: center;
cursor: default;
margin: 0 10px;
}
.tooltip__content {
position: absolute;
top: -10px;
transform: translateY(-100%);
left: 3px;
width: 275px;
z-index: 10;
background-color: #fafafa;
border-radius: 4px;
padding: 13px 17px;
box-shadow: 0 0 20px 4px rgba(0, 0, 0, 0.1);
&.to-left {
left: auto;
right: 3px;
&::after {
left: auto;
right: 10px;
}
}
&::after {
content: '';
width: 16px;
height: 16px;
background-color: #fafafa;
transform: rotate(45deg);
position: absolute;
left: 10px;
bottom: -8px;
}
}
.hidden {
display: none;
}
}
.tooltip__handle {
background-color: var(--color-dark);
border-radius: 50%;
height: 1.5rem;
width: 1.5rem;
line-height: 1.5rem;
font-size: 1.2rem;
color: white;
display: inline-block;
text-align: center;
cursor: default;
margin: 0 10px;
}
.tooltip__content {
position: absolute;
top: -10px;
transform: translateY(-100%);
left: 3px;
width: 275px;
z-index: 10;
background-color: #fafafa;
border-radius: 4px;
padding: 13px 17px;
box-shadow: 0 0 20px 4px rgba(0, 0, 0, 0.1);
&.to-left {
left: auto;
right: 3px;
&::after {
left: auto;
right: 10px;
}
}
&::after {
content: '';
width: 16px;
height: 16px;
background-color: #fafafa;
transform: rotate(45deg);
position: absolute;
left: 10px;
bottom: -8px;
}
}
@media (max-width: 768px) {
.js-tooltip {

2
templates/widgets/modalStatic.hamlet Normal file
View File

@ -0,0 +1,2 @@
<div .modal.js-modal #modal-#{modalId} data-trigger=#{modalTrigger} data-closeable=true>
#{modalContent}