Merge branch 'master' of gitlab.cip.ifi.lmu.de:jost/UniWorX
This commit is contained in:
Steffen Jost
commit
b7eab7f103
@ -227,6 +227,8 @@ CourseAllocationCapacityMayNotBeChanged: Kapazität eines Kurses, der an einer Z
|
||||
|
||||
CourseLecturerRightsIdentical: Alle Sorten von Kursverwalter haben identische Rechte.
|
||||
|
||||
School: Institut
|
||||
|
||||
NoSuchTerm tid@TermId: Semester #{tid} gibt es nicht.
|
||||
NoSuchSchool ssh@SchoolId: Institut #{ssh} gibt es nicht.
|
||||
NoSuchCourseShorthand csh@CourseShorthand: Kein Kurs mit Kürzel #{csh} bekannt.
|
||||
@ -963,10 +965,12 @@ MenuHelp: Hilfe
|
||||
MenuProfile: Anpassen
|
||||
MenuLogin: Login
|
||||
MenuLogout: Logout
|
||||
MenuAllocationList: Zentralanmeldungen
|
||||
MenuCourseList: Kurse
|
||||
MenuCourseMembers: Kursteilnehmer
|
||||
MenuCourseAddMembers: Kursteilnehmer hinzufügen
|
||||
MenuCourseCommunication: Kursmitteilung
|
||||
MenuCourseApplications: Bewerbungen
|
||||
MenuTermShow: Semester
|
||||
MenuSubmissionDelete: Abgabe löschen
|
||||
MenuUsers: Benutzer
|
||||
@ -1469,6 +1473,7 @@ MailSchoolLecturerInviteHeading school@SchoolName: Einladung zum Dozent für „
|
||||
SchoolLecturerInviteExplanation: Sie wurden eingeladen, Dozent für ein Institut zu sein. Sie können, nachdem Sie die Einladung annehmen, eigenständig neue Kurse anlegen.
|
||||
SchoolLecturerInvitationAccepted school@SchoolName: Einladung zum Dozent für „#{school}“ angenommen
|
||||
|
||||
AllocationName: Name
|
||||
AllocationTitle termText@Text ssh'@SchoolShorthand allocation@AllocationName: #{termText} - #{ssh'}: #{allocation}
|
||||
AllocationShortTitle termText@Text ssh'@SchoolShorthand ash@AllocationShorthand: #{termText} - #{ssh'} - #{ash}
|
||||
AllocationDescription: Beschreibung
|
||||
@ -1513,4 +1518,14 @@ ApplicationRatingCommentInvisibleTip: Dient zunächst nur als Notiz für Kursver
|
||||
|
||||
AllocationSchoolShort: Institut
|
||||
Allocation: Zentralanmeldung
|
||||
AllocationRegisterTo: Anmeldungen bis
|
||||
AllocationRegisterTo: Anmeldungen bis
|
||||
|
||||
AllocationListTitle: Zentralanmeldungen
|
||||
|
||||
CourseApplicationsListTitle: Bewerbungen
|
||||
CourseApplicationId: Bewerbungsnummer
|
||||
CourseApplicationRatingPoints: Bewertung
|
||||
CourseApplicationVeto: Veto
|
||||
|
||||
UserDisplayName: Voller Name
|
||||
UserMatriculation: Matrikelnummer
|
||||
@ -12,10 +12,10 @@ User json -- Each Uni2work user has a corresponding row in this table; create
|
||||
authentication AuthenticationMode -- 'AuthLDAP' or ('AuthPWHash'+password-hash)
|
||||
lastAuthentication UTCTime Maybe -- last login date
|
||||
tokensIssuedAfter UTCTime Maybe -- do not accept bearer tokens issued before this time (accept all tokens if null)
|
||||
matrikelnummer Text Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
matrikelnummer UserMatriculation Maybe -- optional immatriculation-string; usually a number, but not always (e.g. lecturers, pupils, guests,...)
|
||||
email (CI Text) -- Case-insensitive eMail address
|
||||
displayName Text -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
surname Text -- Display user names always through 'nameWidget displayName surname'
|
||||
displayName UserDisplayName -- we only show LDAP-DisplayName, and highlight LDAP-Surname within (appended if not contained)
|
||||
surname UserSurname -- Display user names always through 'nameWidget displayName surname'
|
||||
firstName Text -- For export in tables, pre-split firstName from displayName
|
||||
title Text Maybe -- For upcoming name customisation
|
||||
maxFavourites Int default=12 -- max number of rows with this userId in table "CourseFavourite"; for convenience links; user-defined
|
||||
|
||||
1
routes
1
routes
@ -81,6 +81,7 @@
|
||||
/school SchoolListR GET !development
|
||||
/school/#SchoolId SchoolShowR GET !development
|
||||
|
||||
/allocation/ AllocationListR GET !free
|
||||
/allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:
|
||||
/ AShowR GET !free
|
||||
/register ARegisterR POST !time
|
||||
|
||||
@ -64,10 +64,6 @@ import qualified Yesod.Core.Types as Yesod (Logger(..))
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Data.Aeson as Aeson
|
||||
|
||||
import System.Exit
|
||||
|
||||
@ -10,7 +10,6 @@ module Auth.LDAP
|
||||
) where
|
||||
|
||||
import Import.NoFoundation hiding (userEmail, userDisplayName)
|
||||
import Control.Lens
|
||||
import Network.Connection
|
||||
|
||||
import Data.CaseInsensitive (CI)
|
||||
|
||||
19
src/Colonnade/Instances.hs
Normal file
19
src/Colonnade/Instances.hs
Normal file
@ -0,0 +1,19 @@
|
||||
{-# OPTIONS_GHC -fno-warn-orphans #-}
|
||||
|
||||
module Colonnade.Instances
|
||||
(
|
||||
) where
|
||||
|
||||
import ClassyPrelude
|
||||
|
||||
import Control.Lens.Indexed (FunctorWithIndex(imap))
|
||||
|
||||
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
||||
|
||||
instance Functor h => FunctorWithIndex (Maybe a) (Colonnade h a) where
|
||||
imap f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones
|
||||
where
|
||||
dimapColonnade' OneColonnade{..} = OneColonnade
|
||||
{ oneColonnadeEncode = \x -> f (Just x) $ oneColonnadeEncode x
|
||||
, oneColonnadeHead = f Nothing <$> oneColonnadeHead
|
||||
}
|
||||
@ -18,6 +18,7 @@ module Database.Esqueleto.Utils
|
||||
, SqlHashable
|
||||
, sha256
|
||||
, maybe
|
||||
, SqlProject(..)
|
||||
) where
|
||||
|
||||
|
||||
@ -232,3 +233,16 @@ maybe onNothing onJust val = E.case_
|
||||
(onJust $ E.veryUnsafeCoerceSqlExprValue val)
|
||||
]
|
||||
(E.else_ onNothing)
|
||||
|
||||
|
||||
class (PersistEntity entity, PersistField value) => SqlProject entity value entity' value' | entity value entity' -> value', entity value value' -> entity' where
|
||||
sqlProject :: E.SqlExpr entity' -> EntityField entity value -> E.SqlExpr (E.Value value')
|
||||
unSqlProject :: forall p1 p2. p1 entity -> p2 entity' -> value -> value'
|
||||
|
||||
instance (PersistEntity val, PersistField typ) => SqlProject val typ (E.Entity val) typ where
|
||||
sqlProject = (E.^.)
|
||||
unSqlProject _ _ = id
|
||||
|
||||
instance (PersistEntity val, PersistField typ) => SqlProject val typ (Maybe (E.Entity val)) (Maybe typ) where
|
||||
sqlProject = (E.?.)
|
||||
unSqlProject _ _ = Just
|
||||
|
||||
@ -65,7 +65,6 @@ import Control.Monad.Memo.Class (MonadMemo(..), for4)
|
||||
import qualified Control.Monad.Catch as C
|
||||
|
||||
import Handler.Utils.StudyFeatures
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Utils.Sheet
|
||||
import Utils.SystemMessage
|
||||
@ -1047,6 +1046,7 @@ tagAccessPredicate AuthAllocationRegistered = APDB $ \mAuthId route _ -> case ro
|
||||
r -> $unsupportedAuthPredicate AuthAllocationRegistered r
|
||||
tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
CourseR tid ssh csh (CUserR cID) -> exceptT return return $ do
|
||||
cTime <- liftIO getCurrentTime
|
||||
let authorizedIfExists f = do
|
||||
[E.Value ok] <- lift . E.select . return . E.exists $ E.from f
|
||||
whenExceptT ok Authorized
|
||||
@ -1107,12 +1107,16 @@ tagAccessPredicate AuthParticipant = APDB $ \_ route _ -> case route of
|
||||
E.&&. course E.^. CourseSchool E.==. E.val ssh
|
||||
E.&&. course E.^. CourseShorthand E.==. E.val csh
|
||||
-- participant is applicant for this course
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
$cachedHereBinary (participant, tid, ssh, csh) . authorizedIfExists $ \((course `E.InnerJoin` courseApplication) `E.LeftOuterJoin` allocation) -> do
|
||||
E.on $ allocation E.?. AllocationId E.==. courseApplication E.^. CourseApplicationAllocation
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
E.where_ $ courseApplication E.^. CourseApplicationUser E.==. E.val participant
|
||||
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.maybe E.true (E.maybe E.false $ \f -> f E.<=. E.val cTime) (allocation E.?. AllocationStaffAllocationFrom)
|
||||
E.&&. E.maybe E.true (E.maybe E.true $ \t -> t E.>=. E.val cTime) (allocation E.?. AllocationStaffAllocationTo)
|
||||
|
||||
unauthorizedI MsgUnauthorizedParticipant
|
||||
r -> $unsupportedAuthPredicate AuthParticipant r
|
||||
tagAccessPredicate AuthCapacity = APDB $ \_ route _ -> case route of
|
||||
@ -1748,10 +1752,11 @@ instance YesodBreadcrumbs UniWorX where
|
||||
|
||||
breadcrumb (TermSchoolCourseListR tid ssh) = return (original $ unSchoolKey ssh, Just $ TermCourseListR tid)
|
||||
|
||||
breadcrumb AllocationListR = return ("Zentralanmeldungen", Just HomeR)
|
||||
breadcrumb (AllocationR tid ssh ash AShowR) = do
|
||||
mr <- getMessageRender
|
||||
Entity _ Allocation{allocationName} <- runDB . getBy404 $ TermSchoolAllocationShort tid ssh ash
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ HomeR)
|
||||
return ([st|#{allocationName} (#{mr (ShortTermIdentifier (unTermKey tid))}, #{original (unSchoolKey ssh)})|], Just $ AllocationListR)
|
||||
breadcrumb (AllocationR tid ssh ash (AApplicationR _)) = return ("Bewerbung", Just $ AllocationR tid ssh ash AShowR)
|
||||
|
||||
breadcrumb CourseListR = return ("Kurse" , Nothing)
|
||||
@ -1776,6 +1781,8 @@ instance YesodBreadcrumbs UniWorX where
|
||||
breadcrumb (CourseR tid ssh csh CExamListR) = return ("Prüfungen", Just $ CourseR tid ssh csh CShowR)
|
||||
breadcrumb (CourseR tid ssh csh CExamNewR) = return ("Anlegen", Just $ CourseR tid ssh csh CExamListR)
|
||||
|
||||
breadcrumb (CourseR tid ssh csh CApplicationsR) = return ("Bewerbungen", Just $ CourseR tid ssh csh CShowR)
|
||||
|
||||
breadcrumb (CExamR tid ssh csh examn EShowR) = return (original examn, Just $ CourseR tid ssh csh CExamListR)
|
||||
breadcrumb (CExamR tid ssh csh examn EEditR) = return ("Bearbeiten", Just $ CExamR tid ssh csh examn EShowR)
|
||||
breadcrumb (CExamR tid ssh csh examn EUsersR) = return ("Teilnehmer", Just $ CExamR tid ssh csh examn EShowR)
|
||||
@ -1970,35 +1977,11 @@ pageActions (HomeR) =
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgAdminHeading
|
||||
, menuItemIcon = Just "screwdriver"
|
||||
, menuItemRoute = SomeRoute AdminR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgAdminFeaturesHeading
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute AdminFeaturesR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuMessageList
|
||||
, menuItemLabel = MsgMenuAllocationList
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute MessageListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuAdminErrMsg
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute AdminErrMsgR
|
||||
, menuItemRoute = SomeRoute AllocationListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
@ -2022,20 +2005,12 @@ pageActions (AdminR) =
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgErrMsgHeading
|
||||
, menuItemLabel = MsgMenuAdminErrMsg
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute AdminErrMsgR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuUsers
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute UsersR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuAdminTest
|
||||
@ -2201,6 +2176,14 @@ pageActions (CourseListR) =
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionPrime
|
||||
, menuItemLabel = MsgMenuAllocationList
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute AllocationListR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' = return True
|
||||
}
|
||||
]
|
||||
pageActions (CourseNewR) = [
|
||||
MenuItem
|
||||
@ -2279,6 +2262,28 @@ pageActions (CourseR tid ssh csh CShowR) =
|
||||
anyM examNames $ examAccess . E.unValue
|
||||
in runDB $ lecturerAccess `or2M` existsVisible
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuCourseApplications
|
||||
, menuItemIcon = Nothing
|
||||
, menuItemRoute = SomeRoute $ CourseR tid ssh csh CApplicationsR
|
||||
, menuItemModal = False
|
||||
, menuItemAccessCallback' =
|
||||
let courseWhere course = course <$ do
|
||||
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
|
||||
existsApplications = E.selectExists . E.from $ \(course `E.InnerJoin` courseApplication) -> do
|
||||
E.on $ course E.^. CourseId E.==. courseApplication E.^. CourseApplicationCourse
|
||||
void $ courseWhere course
|
||||
courseApplications = fmap (any E.unValue) . E.select . E.from $ \course -> do
|
||||
void $ courseWhere course
|
||||
return $ course E.^. CourseApplicationsRequired
|
||||
courseAllocation = E.selectExists . E.from $ \(course `E.InnerJoin` allocationCourse) -> do
|
||||
E.on $ course E.^. CourseId E.==. allocationCourse E.^. AllocationCourseCourse
|
||||
void $ courseWhere course
|
||||
in runDB $ courseAllocation `or2M` courseApplications `or2M` existsApplications
|
||||
}
|
||||
, MenuItem
|
||||
{ menuItemType = PageActionSecondary
|
||||
, menuItemLabel = MsgMenuCourseMembers
|
||||
|
||||
@ -8,8 +8,6 @@ import Data.Aeson.Encode.Pretty (encodePrettyToTextBuilder)
|
||||
import Control.Monad.Trans.Except
|
||||
import Control.Monad.Trans.Writer (mapWriterT)
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
-- import Data.Time
|
||||
import Data.Char (isDigit)
|
||||
import qualified Data.Text as Text
|
||||
|
||||
@ -6,3 +6,4 @@ import Handler.Allocation.Info as Handler.Allocation
|
||||
import Handler.Allocation.Show as Handler.Allocation
|
||||
import Handler.Allocation.Application as Handler.Allocation
|
||||
import Handler.Allocation.Register as Handler.Allocation
|
||||
import Handler.Allocation.List as Handler.Allocation
|
||||
|
||||
@ -12,8 +12,6 @@ module Handler.Allocation.Application
|
||||
import Import hiding (hash)
|
||||
|
||||
import Handler.Utils
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
86
src/Handler/Allocation/List.hs
Normal file
86
src/Handler/Allocation/List.hs
Normal file
@ -0,0 +1,86 @@
|
||||
module Handler.Allocation.List
|
||||
( getAllocationListR
|
||||
) where
|
||||
|
||||
import Import
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Handler.Utils.Table.Columns
|
||||
import Handler.Utils.Table.Pagination
|
||||
|
||||
|
||||
type AllocationTableExpr = E.SqlExpr (Entity Allocation)
|
||||
type AllocationTableData = DBRow (Entity Allocation)
|
||||
|
||||
allocationListIdent :: Text
|
||||
allocationListIdent = "allocations"
|
||||
|
||||
queryAllocation :: Getter AllocationTableExpr (E.SqlExpr (Entity Allocation))
|
||||
queryAllocation = id
|
||||
|
||||
resultAllocation :: Lens' AllocationTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput
|
||||
|
||||
allocationTermLink :: TermId -> SomeRoute UniWorX
|
||||
allocationTermLink tid = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "term", toPathPiece tid)])
|
||||
|
||||
allocationSchoolLink :: SchoolId -> SomeRoute UniWorX
|
||||
allocationSchoolLink ssh = SomeRoute (AllocationListR, [(dbFilterKey allocationListIdent "school", toPathPiece ssh)])
|
||||
|
||||
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||
|
||||
getAllocationListR :: Handler Html
|
||||
getAllocationListR = do
|
||||
let
|
||||
dbtSQLQuery :: AllocationTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = return
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) AllocationTableData
|
||||
dbtProj = return
|
||||
|
||||
dbtRowKey = view $ queryAllocation . to (E.^. AllocationId)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ anchorColonnade (views (resultAllocation . _entityVal . _allocationTerm) allocationTermLink) $ colTermShort (resultAllocation . _entityVal . _allocationTerm)
|
||||
, anchorColonnade (views (resultAllocation . _entityVal . _allocationSchool) allocationSchoolLink) $ colSchoolShort (resultAllocation . _entityVal . _allocationSchool)
|
||||
, anchorColonnade (views (resultAllocation . _entityVal) allocationLink) $ colAllocationName (resultAllocation . _entityVal . _allocationName)
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ sortTerm $ queryAllocation . to (E.^. AllocationTerm)
|
||||
, sortSchool $ queryAllocation . to (E.^. AllocationSchool)
|
||||
, sortAllocationName $ queryAllocation . to (E.^. AllocationName)
|
||||
]
|
||||
|
||||
dbtFilter = mconcat
|
||||
[ fltrTerm $ queryAllocation . to (E.^. AllocationTerm)
|
||||
, fltrSchool $ queryAllocation . to (E.^. AllocationSchool)
|
||||
, fltrAllocation queryAllocation
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrTermUI
|
||||
, fltrSchoolUI
|
||||
, fltrAllocationUI
|
||||
]
|
||||
|
||||
dbtStyle = def
|
||||
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||
}
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
dbtIdent = allocationListIdent
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
psValidator = def
|
||||
& defaultSorting [SortAscBy "term", SortAscBy "school", SortAscBy "allocation"]
|
||||
|
||||
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
siteLayoutMsg MsgAllocationListTitle $ do
|
||||
setTitleI MsgAllocationListTitle
|
||||
table
|
||||
@ -8,8 +8,6 @@ module Handler.Allocation.Register
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Handler.Utils.Form
|
||||
|
||||
{-# ANN module ("HLint: ignore Use newtype instead of data"::String) #-}
|
||||
|
||||
@ -4,8 +4,7 @@ module Handler.Allocation.Show
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
import Handler.Allocation.Register
|
||||
import Handler.Allocation.Application
|
||||
|
||||
|
||||
@ -12,8 +12,6 @@ import Handler.Utils.SheetType
|
||||
import Handler.Utils.Delete
|
||||
-- import Handler.Utils.Zip
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.List as List (nub, foldl, foldr)
|
||||
import Data.Set (Set)
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -6,8 +6,10 @@ module Handler.Course.Application
|
||||
import Import
|
||||
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import System.FilePath (addExtension)
|
||||
|
||||
@ -37,6 +39,192 @@ getCAFilesR tid ssh csh cID = do
|
||||
|
||||
serveSomeFiles archiveName $ fsSource .| C.map entityVal
|
||||
|
||||
|
||||
type CourseApplicationsTableExpr = ( E.SqlExpr (Entity CourseApplication)
|
||||
`E.InnerJoin` E.SqlExpr (Entity User)
|
||||
)
|
||||
`E.LeftOuterJoin` E.SqlExpr (Maybe (Entity Allocation))
|
||||
`E.LeftOuterJoin` ( E.SqlExpr (Maybe (Entity StudyFeatures))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyTerms))
|
||||
`E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree))
|
||||
)
|
||||
type CourseApplicationsTableData = DBRow ( Entity CourseApplication
|
||||
, Entity User
|
||||
, E.Value Bool -- hasFiles
|
||||
, Maybe (Entity Allocation)
|
||||
, Maybe (Entity StudyFeatures)
|
||||
, Maybe (Entity StudyTerms)
|
||||
, Maybe (Entity StudyDegree)
|
||||
)
|
||||
|
||||
courseApplicationsIdent :: Text
|
||||
courseApplicationsIdent = "applications"
|
||||
|
||||
queryCourseApplication :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity CourseApplication))
|
||||
queryCourseApplication = to $ $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryUser :: Getter CourseApplicationsTableExpr (E.SqlExpr (Entity User))
|
||||
queryUser = to $ $(sqlIJproj 2 2) . $(sqlLOJproj 3 1)
|
||||
|
||||
queryHasFiles :: Getter CourseApplicationsTableExpr (E.SqlExpr (E.Value Bool))
|
||||
queryHasFiles = to $ hasFiles . $(sqlIJproj 2 1) . $(sqlLOJproj 3 1)
|
||||
where
|
||||
hasFiles appl = E.exists . E.from $ \courseApplicationFile ->
|
||||
E.where_ $ courseApplicationFile E.^. CourseApplicationFileApplication E.==. appl E.^. CourseApplicationId
|
||||
|
||||
queryAllocation :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity Allocation)))
|
||||
queryAllocation = to $(sqlLOJproj 3 2)
|
||||
|
||||
queryStudyFeatures :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyFeatures)))
|
||||
queryStudyFeatures = to $ $(sqlIJproj 3 1) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyTerms :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyTerms)))
|
||||
queryStudyTerms = to $ $(sqlIJproj 3 2) . $(sqlLOJproj 3 3)
|
||||
|
||||
queryStudyDegree :: Getter CourseApplicationsTableExpr (E.SqlExpr (Maybe (Entity StudyDegree)))
|
||||
queryStudyDegree = to $ $(sqlIJproj 3 3) . $(sqlLOJproj 3 3)
|
||||
|
||||
resultCourseApplication :: Lens' CourseApplicationsTableData (Entity CourseApplication)
|
||||
resultCourseApplication = _dbrOutput . _1
|
||||
|
||||
resultUser :: Lens' CourseApplicationsTableData (Entity User)
|
||||
resultUser = _dbrOutput . _2
|
||||
|
||||
resultHasFiles :: Lens' CourseApplicationsTableData Bool
|
||||
resultHasFiles = _dbrOutput . _3 . _Value
|
||||
|
||||
resultAllocation :: Traversal' CourseApplicationsTableData (Entity Allocation)
|
||||
resultAllocation = _dbrOutput . _4 . _Just
|
||||
|
||||
resultStudyFeatures :: Traversal' CourseApplicationsTableData (Entity StudyFeatures)
|
||||
resultStudyFeatures = _dbrOutput . _5 . _Just
|
||||
|
||||
resultStudyTerms :: Traversal' CourseApplicationsTableData (Entity StudyTerms)
|
||||
resultStudyTerms = _dbrOutput . _6 . _Just
|
||||
|
||||
resultStudyDegree :: Traversal' CourseApplicationsTableData (Entity StudyDegree)
|
||||
resultStudyDegree = _dbrOutput . _7 . _Just
|
||||
|
||||
getCApplicationsR, postCApplicationsR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
|
||||
getCApplicationsR = postCApplicationsR
|
||||
postCApplicationsR = fail "not implemented" -- dbtable of _all_ course applications
|
||||
postCApplicationsR tid ssh csh = do
|
||||
table <- runDB $ do
|
||||
cid <- getKeyBy404 $ TermSchoolCourseShort tid ssh csh
|
||||
|
||||
let
|
||||
allocationLink :: Allocation -> SomeRoute UniWorX
|
||||
allocationLink Allocation{..} = SomeRoute $ AllocationR allocationTerm allocationSchool allocationShorthand AShowR
|
||||
|
||||
participantLink :: MonadCrypto m => UserId -> m (SomeRoute UniWorX)
|
||||
participantLink uid = do
|
||||
cID <- encrypt uid
|
||||
return . SomeRoute . CourseR tid ssh csh $ CUserR cID
|
||||
|
||||
dbtSQLQuery :: CourseApplicationsTableExpr -> E.SqlQuery _
|
||||
dbtSQLQuery = runReaderT $ do
|
||||
courseApplication <- view queryCourseApplication
|
||||
hasFiles <- view queryHasFiles
|
||||
user <- view queryUser
|
||||
allocation <- view queryAllocation
|
||||
studyFeatures <- view queryStudyFeatures
|
||||
studyTerms <- view queryStudyTerms
|
||||
studyDegree <- view queryStudyDegree
|
||||
|
||||
lift $ do
|
||||
E.on $ studyDegree E.?. StudyDegreeId E.==. studyFeatures E.?. StudyFeaturesDegree
|
||||
E.on $ studyTerms E.?. StudyTermsId E.==. studyFeatures E.?. StudyFeaturesField
|
||||
E.on $ studyFeatures E.?. StudyFeaturesId E.==. courseApplication E.^. CourseApplicationField
|
||||
E.on $ courseApplication E.^. CourseApplicationAllocation E.==. allocation E.?. AllocationId
|
||||
E.on $ user E.^. UserId E.==. courseApplication E.^. CourseApplicationUser
|
||||
E.where_ $ courseApplication E.^. CourseApplicationCourse E.==. E.val cid
|
||||
|
||||
return (courseApplication, user, hasFiles, allocation, studyFeatures, studyTerms, studyDegree)
|
||||
|
||||
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) CourseApplicationsTableData
|
||||
dbtProj = runReaderT $ do
|
||||
appId <- view $ resultCourseApplication . _entityKey
|
||||
cID <- encrypt appId
|
||||
|
||||
guardM . hasReadAccessTo $ CApplicationR tid ssh csh cID CAFilesR -- TODO: replace with CAShowR
|
||||
|
||||
view id
|
||||
|
||||
dbtRowKey = view $ queryCourseApplication . to (E.^. CourseApplicationId)
|
||||
|
||||
dbtColonnade :: Colonnade Sortable _ _
|
||||
dbtColonnade = mconcat
|
||||
[ emptyOpticColonnade (resultAllocation . _entityVal) $ \l -> anchorColonnade (views l allocationLink) $ colAllocationShorthand (l . _allocationShorthand)
|
||||
, colApplicationId (resultCourseApplication . _entityKey)
|
||||
, anchorColonnadeM (views (resultUser . _entityKey) participantLink) $ colUserDisplayName (resultUser . _entityVal . $(multifocusL 2) _userDisplayName _userSurname)
|
||||
, colUserMatriculation (resultUser . _entityVal . _userMatrikelnummer)
|
||||
, emptyOpticColonnade (resultStudyTerms . _entityVal) colStudyTerms
|
||||
, emptyOpticColonnade (resultStudyDegree . _entityVal) colStudyDegree
|
||||
, emptyOpticColonnade (resultStudyFeatures . _entityVal . _studyFeaturesSemester) colStudyFeaturesSemester
|
||||
, colApplicationText (resultCourseApplication . _entityVal . _courseApplicationText)
|
||||
, lmap ((tid, ssh, csh), ) $ colApplicationFiles ($(multifocusL 5) (_1 . _1) (_1 . _2) (_1 . _3) (_2 . resultCourseApplication . _entityKey) (_2 . resultHasFiles))
|
||||
, colApplicationVeto (resultCourseApplication . _entityVal . _courseApplicationRatingVeto)
|
||||
, colApplicationRatingPoints (resultCourseApplication . _entityVal . _courseApplicationRatingPoints)
|
||||
, colApplicationRatingComment (resultCourseApplication . _entityVal . _courseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtSorting = mconcat
|
||||
[ sortAllocationShorthand $ queryAllocation . to (E.?. AllocationShorthand)
|
||||
, sortUserName' $ $(multifocusG 2) (queryUser . to (E.^. UserDisplayName)) (queryUser . to (E.^. UserSurname))
|
||||
, sortUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, sortStudyTerms queryStudyTerms
|
||||
, sortStudyDegree queryStudyDegree
|
||||
, sortStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, sortApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, sortApplicationFiles queryHasFiles
|
||||
, sortApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, sortApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, sortApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
|
||||
dbtFilter = mconcat
|
||||
[ fltrAllocation queryAllocation
|
||||
, fltrUserName' $ queryUser . to (E.^. UserDisplayName)
|
||||
, fltrUserMatriculation $ queryUser . to (E.^. UserMatrikelnummer)
|
||||
, fltrStudyTerms queryStudyTerms
|
||||
, fltrStudyDegree queryStudyDegree
|
||||
, fltrStudyFeaturesSemester $ queryStudyFeatures . to (E.?. StudyFeaturesSemester)
|
||||
, fltrApplicationText $ queryCourseApplication . to (E.^. CourseApplicationText)
|
||||
, fltrApplicationFiles queryHasFiles
|
||||
, fltrApplicationVeto $ queryCourseApplication . to (E.^. CourseApplicationRatingVeto)
|
||||
, fltrApplicationRatingPoints $ queryCourseApplication . to (E.^. CourseApplicationRatingPoints)
|
||||
, fltrApplicationRatingComment $ queryCourseApplication . to (E.^. CourseApplicationRatingComment)
|
||||
]
|
||||
dbtFilterUI = mconcat
|
||||
[ fltrAllocationUI
|
||||
, fltrUserNameUI'
|
||||
, fltrUserMatriculationUI
|
||||
, fltrStudyTermsUI
|
||||
, fltrStudyDegreeUI
|
||||
, fltrStudyFeaturesSemesterUI
|
||||
, fltrApplicationTextUI
|
||||
, fltrApplicationFilesUI
|
||||
, fltrApplicationVetoUI
|
||||
, fltrApplicationRatingPointsUI
|
||||
, fltrApplicationRatingCommentUI
|
||||
]
|
||||
|
||||
dbtStyle = def
|
||||
{ dbsFilterLayout = defaultDBSFilterLayout
|
||||
}
|
||||
dbtParams = def
|
||||
|
||||
dbtCsvEncode = noCsvEncode
|
||||
dbtCsvDecode = Nothing
|
||||
|
||||
dbtIdent = courseApplicationsIdent
|
||||
|
||||
psValidator :: PSValidator _ _
|
||||
psValidator = def
|
||||
|
||||
dbTableWidget' psValidator DBTable{..}
|
||||
|
||||
let title = prependCourseTitle tid ssh csh MsgCourseApplicationsListTitle
|
||||
|
||||
siteLayoutMsg title $ do
|
||||
setTitleI title
|
||||
table
|
||||
|
||||
@ -5,7 +5,6 @@ module Handler.Course.Edit
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
@ -8,7 +8,6 @@ module Handler.Course.LecturerInvite
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
|
||||
@ -10,7 +10,6 @@ import Import
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
|
||||
@ -8,7 +8,6 @@ module Handler.Course.ParticipantInvite
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
@ -7,7 +7,6 @@ module Handler.Course.Register
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
|
||||
import Data.Function ((&))
|
||||
|
||||
@ -12,7 +12,6 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
|
||||
@ -4,7 +4,6 @@ module Handler.Course.User
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
@ -9,7 +9,6 @@ module Handler.Course.Users
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Database
|
||||
|
||||
@ -5,8 +5,6 @@ module Handler.CryptoIDDispatch
|
||||
|
||||
import Import
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
@ -8,8 +8,6 @@ import Handler.Exam.RegistrationInvite
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Invitations
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
@ -12,8 +12,6 @@ import Import
|
||||
import Handler.Utils.Invitations
|
||||
import Handler.Utils.Exam
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
@ -6,8 +6,6 @@ import Import
|
||||
import Handler.Exam.Form
|
||||
import Handler.Exam.CorrectorInvite
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
@ -8,8 +8,6 @@ module Handler.Exam.Form
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens hiding (parts)
|
||||
|
||||
import Handler.Exam.CorrectorInvite
|
||||
|
||||
import Handler.Utils
|
||||
@ -230,12 +228,12 @@ examPartsForm prev = wFormToAForm $ do
|
||||
|
||||
examFormTemplate :: Entity Exam -> DB ExamForm
|
||||
examFormTemplate (Entity eId Exam{..}) = do
|
||||
parts <- selectList [ ExamPartExam ==. eId ] []
|
||||
examParts <- selectList [ ExamPartExam ==. eId ] []
|
||||
occurrences <- selectList [ ExamOccurrenceExam ==. eId ] []
|
||||
correctors <- selectList [ ExamCorrectorExam ==. eId ] []
|
||||
invitations <- map (\(email, InvDBDataExamCorrector) -> email) <$> sourceInvitationsList eId
|
||||
|
||||
parts' <- forM parts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
|
||||
examParts' <- forM examParts $ \(Entity pid part) -> (,) <$> encrypt pid <*> pure part
|
||||
occurrences' <- forM occurrences $ \(Entity oid occ) -> (,) <$> encrypt oid <*> pure occ
|
||||
|
||||
return ExamForm
|
||||
@ -267,7 +265,7 @@ examFormTemplate (Entity eId Exam{..}) = do
|
||||
, eofDescription = examOccurrenceDescription
|
||||
}
|
||||
, efExamParts = Set.fromList $ do
|
||||
(Just -> epfId, ExamPart{..}) <- parts'
|
||||
(Just -> epfId, ExamPart{..}) <- examParts'
|
||||
return ExamPartForm
|
||||
{ epfId
|
||||
, epfName = examPartName
|
||||
|
||||
@ -16,8 +16,6 @@ import Handler.Utils.Invitations
|
||||
import qualified Data.Set as Set
|
||||
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
|
||||
|
||||
@ -5,8 +5,6 @@ module Handler.Exam.Show
|
||||
import Import
|
||||
import Handler.Exam.Register
|
||||
|
||||
import Utils.Lens hiding (parts)
|
||||
|
||||
import Data.Map ((!?))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@ -24,7 +22,7 @@ getEShowR tid ssh csh examn = do
|
||||
cTime <- liftIO getCurrentTime
|
||||
mUid <- maybeAuthId
|
||||
|
||||
(Entity _ Exam{..}, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
|
||||
(Entity _ Exam{..}, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown) <- runDB $ do
|
||||
exam@(Entity eId Exam{..}) <- fetchExam tid ssh csh examn
|
||||
|
||||
let examVisible = NTop (Just cTime) >= NTop examVisibleFrom
|
||||
@ -35,12 +33,12 @@ getEShowR tid ssh csh examn = do
|
||||
let occurrenceAssignmentsVisible = NTop (Just cTime) >= NTop examPublishOccurrenceAssignments
|
||||
occurrenceAssignmentsShown <- or2M (return occurrenceAssignmentsVisible) . hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
parts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
||||
examParts <- selectList [ ExamPartExam ==. eId ] [ Asc ExamPartName ]
|
||||
|
||||
resultsRaw <- for mUid $ \uid ->
|
||||
E.select . E.from $ \examPartResult -> do
|
||||
E.where_ $ examPartResult E.^. ExamPartResultUser E.==. E.val uid
|
||||
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey parts)
|
||||
E.&&. examPartResult E.^. ExamPartResultExamPart `E.in_` E.valList (map entityKey examParts)
|
||||
return examPartResult
|
||||
let results = maybe Map.empty (\rs -> Map.fromList [ (examPartResultExamPart, res) | res@(Entity _ ExamPartResult{..}) <- rs ]) resultsRaw
|
||||
|
||||
@ -66,7 +64,7 @@ getEShowR tid ssh csh examn = do
|
||||
|
||||
occurrenceNamesShown <- hasReadAccessTo $ CExamR tid ssh csh examn EEditR
|
||||
|
||||
return (exam, parts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
|
||||
return (exam, examParts, examVisible, (gradingVisible, gradingShown), (occurrenceAssignmentsVisible, occurrenceAssignmentsShown), results, result, occurrences, (registered, mayRegister), occurrenceNamesShown)
|
||||
|
||||
let examTimes = all (\(Entity _ ExamOccurrence{..}, _) -> Just examOccurrenceStart == examStart && examOccurrenceEnd == examEnd) occurrences
|
||||
registerWidget
|
||||
|
||||
@ -6,7 +6,6 @@ module Handler.Exam.Users
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Exam
|
||||
import Handler.Utils.Table.Columns
|
||||
|
||||
@ -5,8 +5,6 @@ import Import
|
||||
import qualified Data.Aeson.Encode.Pretty as Aeson
|
||||
import qualified Data.Text.Lazy.Builder as Builder
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.UUID as UUID
|
||||
|
||||
import Data.Semigroup (Min(..), Max(..))
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.Home where
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
|
||||
@ -14,7 +14,6 @@ import qualified Data.Conduit.List as C
|
||||
import qualified Database.Esqueleto as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Delete
|
||||
|
||||
@ -5,7 +5,6 @@ import Import
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import Utils.Lens
|
||||
-- import Colonnade hiding (fromMaybe, singleton)
|
||||
-- import Yesod.Colonnade
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
@ -49,11 +49,6 @@ import Data.Map (Map, (!))
|
||||
|
||||
import Data.Monoid (Any(..))
|
||||
|
||||
-- import Control.Lens
|
||||
import Utils.Lens
|
||||
|
||||
--import qualified Data.Aeson as Aeson
|
||||
|
||||
import Control.Monad.Random.Class (MonadRandom(..))
|
||||
import Utils.Sql
|
||||
|
||||
|
||||
@ -6,8 +6,6 @@ import Import
|
||||
|
||||
import Jobs
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
-- import Yesod.Form.Bootstrap3
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
@ -11,8 +11,6 @@ import qualified Data.List.NonEmpty as NonEmpty
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
-- htmlField' moved to Handler.Utils.Form/Fields
|
||||
|
||||
@ -5,8 +5,6 @@ import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -25,8 +25,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson hiding (Result(..))
|
||||
import Text.Hamlet (ihamlet)
|
||||
|
||||
|
||||
@ -4,7 +4,6 @@ module Handler.Tutorial.Users
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
-- import Utils.DB
|
||||
import Handler.Utils
|
||||
|
||||
@ -13,8 +13,6 @@ import Handler.Utils.Invitations
|
||||
|
||||
import qualified Auth.LDAP as Auth
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -4,8 +4,6 @@ module Handler.Utils
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Text as T
|
||||
import qualified Data.Text.Encoding as T
|
||||
import Data.Map ((!))
|
||||
|
||||
@ -9,7 +9,6 @@ module Handler.Utils.Communication
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import Utils.Lens
|
||||
|
||||
import Jobs.Queue
|
||||
import Control.Monad.Trans.Reader (mapReaderT)
|
||||
|
||||
@ -5,8 +5,6 @@ module Handler.Utils.ContentDisposition
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
-- | Check whether the user's preference for files is inline-viewing or downloading
|
||||
downloadFiles :: (MonadHandler m, HandlerSite m ~ UniWorX) => m Bool
|
||||
downloadFiles = do
|
||||
|
||||
@ -16,8 +16,6 @@ module Handler.Utils.DateTime
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Time.Zones
|
||||
import qualified Data.Time.Zones as TZ
|
||||
|
||||
|
||||
@ -17,8 +17,6 @@ module Handler.Utils.Delete
|
||||
import Import
|
||||
import Handler.Utils.Form
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
@ -12,8 +12,6 @@ import qualified Database.Esqueleto.Utils as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.Conduit.List as C
|
||||
|
||||
import qualified Data.Map as Map
|
||||
|
||||
@ -40,13 +40,9 @@ import Control.Monad.Error.Class (MonadError(..))
|
||||
|
||||
import Data.Either (partitionEithers)
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Aeson (eitherDecodeStrict')
|
||||
import Data.Aeson.Text (encodeToLazyText)
|
||||
|
||||
import Data.Proxy
|
||||
|
||||
import qualified Text.Email.Validate as Email
|
||||
|
||||
import Yesod.Core.Types (FileInfo(..))
|
||||
|
||||
@ -17,7 +17,6 @@ module Handler.Utils.Form.MassInput
|
||||
|
||||
import Import
|
||||
import Utils.Form
|
||||
import Utils.Lens
|
||||
import Handler.Utils.Form.MassInput.Liveliness
|
||||
import Handler.Utils.Form.MassInput.TH
|
||||
|
||||
|
||||
@ -10,8 +10,6 @@ import qualified Data.Set as Set
|
||||
import Data.Map ((!))
|
||||
import qualified Data.Map as Map
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
data OccurrenceScheduleKind = ScheduleKindWeekly
|
||||
deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
|
||||
|
||||
@ -16,7 +16,6 @@ module Handler.Utils.Invitations
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens
|
||||
import Utils.Form
|
||||
import Jobs.Queue
|
||||
|
||||
|
||||
@ -7,8 +7,6 @@ module Handler.Utils.Mail
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Data.ByteString.Lazy as LBS
|
||||
|
||||
@ -39,8 +39,6 @@ import qualified Database.Esqueleto as E
|
||||
|
||||
import qualified Data.Conduit.List as Conduit
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
instance HasResolution prec => Pretty (Fixed prec) where
|
||||
pretty = pretty . show
|
||||
|
||||
@ -5,7 +5,6 @@ module Handler.Utils.SheetType
|
||||
|
||||
import Import
|
||||
import Data.Monoid (Sum(..))
|
||||
import Utils.Lens
|
||||
|
||||
addBonusToPoints :: SheetTypeSummary -> SheetTypeSummary
|
||||
addBonusToPoints sts =
|
||||
|
||||
@ -15,8 +15,6 @@ import Import hiding (joinPath)
|
||||
import Jobs.Queue
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.State as State (StateT)
|
||||
import Control.Monad.State.Class as State
|
||||
import Control.Monad.Writer (MonadWriter(..), execWriterT, execWriter)
|
||||
|
||||
@ -2,7 +2,6 @@ module Handler.Utils.Table where
|
||||
-- General Utilities for Tables
|
||||
|
||||
import Import
|
||||
import Data.Profunctor
|
||||
|
||||
import Control.Monad.Except
|
||||
|
||||
@ -51,10 +50,12 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
||||
externalIds <- mapM (lift . toExternal) tdata
|
||||
|
||||
let
|
||||
checkbox extId = Field parse view UrlEncoded
|
||||
checkbox extId = Field{..}
|
||||
where
|
||||
parse [] _ = return $ Right Nothing
|
||||
parse optlist _ = runExceptT $ do
|
||||
fieldEnctype = UrlEncoded
|
||||
|
||||
fieldParse [] _ = return $ Right Nothing
|
||||
fieldParse optlist _ = runExceptT $ do
|
||||
extIds <- maybe (throwError "Error parsing values") return $ mapM fromPathPiece optlist
|
||||
case () of
|
||||
_ | extId `elem` extIds
|
||||
@ -62,11 +63,11 @@ headedRowSelector toExternal fromExternal attrs colonnade tdata = do
|
||||
| otherwise
|
||||
-> return Nothing
|
||||
|
||||
view _ name attributes val _ =
|
||||
fieldView theId name attributes val _ =
|
||||
-- TODO: move this to a *.hamlet file
|
||||
[whamlet|
|
||||
<label style="display: block">
|
||||
<input type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|
||||
<input ##{theId} type=checkbox name=#{name} value=#{toPathPiece extId} *{attributes} :isRight val:checked>
|
||||
|]
|
||||
|
||||
selectionIdent <- newFormIdent
|
||||
|
||||
@ -13,7 +13,6 @@ import Control.Monad.Trans.Writer (WriterT)
|
||||
|
||||
import Text.Blaze (ToMarkup(..))
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
|
||||
import Utils.Occurrences
|
||||
@ -101,6 +100,9 @@ msgCell = textCell . toMessage
|
||||
---------------------
|
||||
-- Icon cells
|
||||
|
||||
iconCell :: IsDBTable m a => Icon -> DBCell m a
|
||||
iconCell = cell . toWidget . icon
|
||||
|
||||
addIconFixedWidth :: (IsDBTable m a) => DBCell m a -> DBCell m a
|
||||
addIconFixedWidth = over cellAttrs $ insertClass "icon-fixed-width"
|
||||
|
||||
|
||||
@ -12,14 +12,19 @@ import Import
|
||||
-- import Text.Blaze (ToMarkup(..))
|
||||
|
||||
import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Utils as E
|
||||
import Database.Esqueleto.Utils (mkExactFilter, mkExactFilterWith, mkContainsFilter, mkContainsFilterWith, anyFilter)
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Table.Cells
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import qualified Colonnade
|
||||
import Colonnade.Encode (Colonnade(..), OneColonnade(..))
|
||||
|
||||
import Text.Blaze (toMarkup)
|
||||
|
||||
|
||||
--------------------------------
|
||||
-- Generic Columns
|
||||
@ -35,6 +40,36 @@ import qualified Data.CaseInsensitive as CI
|
||||
-- * fltrXYZ : filter definitions for these columns
|
||||
-- * additional helper, such as default sorting
|
||||
|
||||
type OpticColonnade focus
|
||||
= forall m x r' h.
|
||||
( IsDBTable m x
|
||||
, FromSortable h
|
||||
)
|
||||
=> (forall focus'. Getting focus' r' focus)
|
||||
-> Colonnade h r' (DBCell m x)
|
||||
|
||||
type OpticSortColumn' focus
|
||||
= forall t sortingMap.
|
||||
( IsMap sortingMap
|
||||
, ContainerKey sortingMap ~ SortingKey
|
||||
, MapValue sortingMap ~ SortColumn t
|
||||
)
|
||||
=> (forall focus'. Getting focus' t focus)
|
||||
-> sortingMap
|
||||
|
||||
type OpticSortColumn val = OpticSortColumn' (E.SqlExpr (E.Value val))
|
||||
|
||||
type OpticFilterColumn' t inp focus
|
||||
= forall filterMap.
|
||||
( IsMap filterMap
|
||||
, ContainerKey filterMap ~ FilterKey
|
||||
, MapValue filterMap ~ FilterColumn t
|
||||
, IsFilterColumn t (t -> inp -> E.SqlExpr (E.Value Bool))
|
||||
)
|
||||
=> (forall focus'. Getting focus' t focus)
|
||||
-> filterMap
|
||||
|
||||
type OpticFilterColumn t focus = OpticFilterColumn' t (Set focus) (E.SqlExpr (E.Value focus))
|
||||
|
||||
-----------------------
|
||||
-- Numbers and Indices
|
||||
@ -44,6 +79,174 @@ import qualified Data.CaseInsensitive as CI
|
||||
dbRowIndicator :: IsDBTable m Any => Colonnade Sortable (DBRow r) (DBCell m Any)
|
||||
dbRowIndicator = sortable Nothing (i18nCell MsgNrColumn) $ \DBRow{ dbrIndex } -> tellCell (Any True) $ textCell $ tshow dbrIndex
|
||||
|
||||
-----------
|
||||
-- Terms --
|
||||
-----------
|
||||
|
||||
colTermShort :: OpticColonnade TermId
|
||||
colTermShort resultTid = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "term") (i18nCell MsgTerm)
|
||||
body = i18nCell . ShortTermIdentifier . unTermKey . view resultTid
|
||||
|
||||
sortTerm :: OpticSortColumn TermId
|
||||
sortTerm queryTid = singletonMap "term" . SortColumn $ view queryTid
|
||||
|
||||
fltrTerm :: OpticFilterColumn t TermId
|
||||
fltrTerm queryTid = singletonMap "term" . FilterColumn $ mkExactFilter (view queryTid)
|
||||
|
||||
fltrTermUI :: DBFilterUI
|
||||
fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift termField) (fslI MsgTerm)
|
||||
|
||||
-------------
|
||||
-- Schools --
|
||||
-------------
|
||||
|
||||
colSchoolShort :: OpticColonnade SchoolId
|
||||
colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "school") (i18nCell MsgSchool)
|
||||
body = i18nCell . unSchoolKey . view resultSsh
|
||||
|
||||
sortSchool :: OpticSortColumn SchoolId
|
||||
sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh
|
||||
|
||||
fltrSchool :: OpticFilterColumn t SchoolId
|
||||
fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh)
|
||||
|
||||
fltrSchoolUI :: DBFilterUI
|
||||
fltrSchoolUI mPrev = prismAForm (singletonFilter "school" . maybePrism _PathPiece) mPrev $ aopt (hoistField lift schoolField) (fslI MsgSchool)
|
||||
|
||||
-----------------
|
||||
-- Allocations --
|
||||
-----------------
|
||||
|
||||
colAllocationName :: OpticColonnade AllocationName
|
||||
colAllocationName resultName = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "allocation") (i18nCell MsgAllocationName)
|
||||
body = i18nCell . view resultName
|
||||
|
||||
sortAllocationName :: OpticSortColumn AllocationName
|
||||
sortAllocationName queryName = singletonMap "allocation" . SortColumn $ view queryName
|
||||
|
||||
fltrAllocation :: forall allocation t shorthand name.
|
||||
( E.SqlProject Allocation AllocationShorthand allocation shorthand
|
||||
, E.SqlProject Allocation AllocationName allocation name
|
||||
, E.SqlString name, E.SqlString shorthand
|
||||
)
|
||||
=> OpticFilterColumn' t (Set Text) (E.SqlExpr allocation)
|
||||
fltrAllocation query = singletonMap "allocation" . FilterColumn $ anyFilter
|
||||
[ mkContainsFilterWith (unSqlProject' . CI.mk) $ views query (`E.sqlProject` AllocationShorthand)
|
||||
, mkContainsFilterWith (unSqlProject' . CI.mk) $ views query (`E.sqlProject` AllocationName)
|
||||
]
|
||||
where
|
||||
unSqlProject' = E.unSqlProject (Proxy @Allocation) (Proxy @allocation)
|
||||
|
||||
fltrAllocationUI :: DBFilterUI
|
||||
fltrAllocationUI mPrev = prismAForm (singletonFilter "allocation" . maybePrism _PathPiece) mPrev $ aopt (ciField :: Field _ AllocationName) (fslI MsgAllocation)
|
||||
|
||||
|
||||
colAllocationShorthand :: OpticColonnade AllocationShorthand
|
||||
colAllocationShorthand resultShort = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "allocation-short") (i18nCell MsgAllocation)
|
||||
body = i18nCell . view resultShort
|
||||
|
||||
sortAllocationShorthand :: forall shorthand. PersistField shorthand => OpticSortColumn shorthand
|
||||
sortAllocationShorthand queryShorthand = singletonMap "allocation-short" . SortColumn $ view queryShorthand
|
||||
|
||||
-------------------------
|
||||
-- Course Applications --
|
||||
-------------------------
|
||||
|
||||
colApplicationId :: OpticColonnade CourseApplicationId
|
||||
colApplicationId resultId = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable Nothing (i18nCell MsgCourseApplicationId)
|
||||
body = views resultId $ cell . (toWidget . toMarkup =<<) . (encrypt :: CourseApplicationId -> WidgetT UniWorX IO CryptoFileNameCourseApplication)
|
||||
|
||||
colApplicationRatingPoints :: OpticColonnade (Maybe ExamGrade)
|
||||
colApplicationRatingPoints resultPoints = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "points") (i18nCell MsgCourseApplicationRatingPoints)
|
||||
body = views resultPoints $ maybe mempty i18nCell
|
||||
|
||||
sortApplicationRatingPoints :: OpticSortColumn (Maybe ExamGrade)
|
||||
sortApplicationRatingPoints queryPoints = singletonMap "points" . SortColumn $ view queryPoints
|
||||
|
||||
fltrApplicationRatingPoints :: OpticFilterColumn t (Maybe ExamGrade)
|
||||
fltrApplicationRatingPoints queryPoints = singletonMap "points" . FilterColumn . mkExactFilter $ view queryPoints
|
||||
|
||||
fltrApplicationRatingPointsUI :: DBFilterUI
|
||||
fltrApplicationRatingPointsUI mPrev = prismAForm (singletonFilter "points" . maybePrism _PathPiece) mPrev $ aopt examGradeField (fslI MsgCourseApplicationRatingPoints)
|
||||
|
||||
colApplicationVeto :: OpticColonnade Bool
|
||||
colApplicationVeto resultVeto = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "veto") (i18nCell MsgCourseApplicationVeto)
|
||||
body = views resultVeto $ bool mempty (iconCell IconApplicationVeto)
|
||||
|
||||
sortApplicationVeto :: OpticSortColumn Bool
|
||||
sortApplicationVeto queryVeto = singletonMap "veto" . SortColumn $ view queryVeto
|
||||
|
||||
fltrApplicationVeto :: OpticFilterColumn t Bool
|
||||
fltrApplicationVeto queryVeto = singletonMap "veto" . FilterColumn . mkExactFilter $ view queryVeto
|
||||
|
||||
fltrApplicationVetoUI :: DBFilterUI
|
||||
fltrApplicationVetoUI mPrev = prismAForm (singletonFilter "veto" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationVeto)
|
||||
|
||||
colApplicationRatingComment :: OpticColonnade (Maybe Text)
|
||||
colApplicationRatingComment resultComment = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "comment") (i18nCell MsgApplicationRatingComment)
|
||||
body = views resultComment . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget
|
||||
|
||||
sortApplicationRatingComment :: OpticSortColumn (Maybe Text)
|
||||
sortApplicationRatingComment queryComment = singletonMap "comment" . SortColumn $ view queryComment
|
||||
|
||||
fltrApplicationRatingComment :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text)))
|
||||
fltrApplicationRatingComment queryComment = singletonMap "comment" . FilterColumn . mkContainsFilterWith Just $ view queryComment
|
||||
|
||||
fltrApplicationRatingCommentUI :: DBFilterUI
|
||||
fltrApplicationRatingCommentUI mPrev = prismAForm (singletonFilter "comment") mPrev $ aopt textField (fslI MsgApplicationRatingComment)
|
||||
|
||||
colApplicationText :: OpticColonnade (Maybe Text)
|
||||
colApplicationText resultText = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "text") (i18nCell MsgCourseApplicationText)
|
||||
body = views resultText . maybe mempty $ cell . modal (toWidget $ hasComment True) . Right . toWidget
|
||||
|
||||
sortApplicationText :: OpticSortColumn (Maybe Text)
|
||||
sortApplicationText queryText = singletonMap "text" . SortColumn $ view queryText
|
||||
|
||||
fltrApplicationText :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe Text)))
|
||||
fltrApplicationText queryText = singletonMap "text" . FilterColumn . mkContainsFilterWith Just $ view queryText
|
||||
|
||||
fltrApplicationTextUI :: DBFilterUI
|
||||
fltrApplicationTextUI mPrev = prismAForm (singletonFilter "text") mPrev $ aopt textField (fslI MsgCourseApplicationText)
|
||||
|
||||
|
||||
colApplicationFiles :: OpticColonnade (TermId, SchoolId, CourseShorthand, CourseApplicationId, Bool) -- ^ `Bool` controls whether link is shown, use result of determination whether files exist
|
||||
colApplicationFiles resultInfo = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "has-files") (i18nCell MsgCourseApplicationFiles)
|
||||
body = views resultInfo $ \(tid, ssh, csh, appId, showLink) -> if
|
||||
| showLink
|
||||
-> flip anchorCellM (asWidgetT $ toWidget iconApplicationFiles) $ do
|
||||
cID <- encrypt appId
|
||||
return $ CApplicationR tid ssh csh cID CAFilesR
|
||||
| otherwise
|
||||
-> mempty
|
||||
|
||||
sortApplicationFiles :: OpticSortColumn Bool
|
||||
sortApplicationFiles queryFiles = singletonMap "has-files" . SortColumn $ view queryFiles
|
||||
|
||||
fltrApplicationFiles :: OpticFilterColumn t Bool
|
||||
fltrApplicationFiles queryFiles = singletonMap "has-files" . FilterColumn . mkExactFilter $ view queryFiles
|
||||
|
||||
fltrApplicationFilesUI :: DBFilterUI
|
||||
fltrApplicationFilesUI mPrev = prismAForm (singletonFilter "has-files" . maybePrism _PathPiece) mPrev $ aopt boolField (fslI MsgCourseApplicationFiles)
|
||||
|
||||
---------------
|
||||
-- Files
|
||||
@ -92,9 +295,24 @@ defaultSortingByFileModification = defaultSorting [SortAscBy "time"]
|
||||
---------------
|
||||
-- User names
|
||||
|
||||
-- | Generic sort key from msg does not work, since we have no show Instance for RenderMesage UniWorX msg. Dangerous anyway!
|
||||
colUserName' :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c)
|
||||
colUserName' msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser
|
||||
colUserDisplayName :: OpticColonnade (UserDisplayName, UserSurname)
|
||||
colUserDisplayName resultDisplayName = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "user-name") (i18nCell MsgUserDisplayName)
|
||||
body = views resultDisplayName $ cell . uncurry nameWidget
|
||||
|
||||
sortUserName' :: OpticSortColumn' (E.SqlExpr (E.Value UserDisplayName), E.SqlExpr (E.Value UserSurname))
|
||||
sortUserName' queryDisplayName = singletonMap "user-name" . SortColumns $ \(view queryDisplayName -> (dn, sn))
|
||||
-> [ SomeExprValue sn
|
||||
, SomeExprValue dn
|
||||
]
|
||||
|
||||
fltrUserName' :: OpticFilterColumn t UserDisplayName
|
||||
fltrUserName' queryDisplayName = singletonMap "user-name" . FilterColumn . mkContainsFilter $ view queryDisplayName
|
||||
|
||||
fltrUserNameUI' :: DBFilterUI
|
||||
fltrUserNameUI' mPrev = prismAForm (singletonFilter "user-name") mPrev $ aopt textField (fslI MsgUserDisplayName)
|
||||
|
||||
|
||||
colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserName = sortable (Just "user-name") (i18nCell MsgCourseMembers) cellHasUser
|
||||
@ -103,11 +321,12 @@ colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route
|
||||
colUserNameLink userLink = sortable (Just "user-name") (i18nCell MsgCourseMembers) (cellHasUserLink userLink)
|
||||
|
||||
-- | Intended to work with @nameWidget@, showing highlighter Surname within Displayname
|
||||
-- TOOD: We want to sort first by UserSurname and then by UserDisplayName, not supportet by dbTable
|
||||
-- see also @defaultSortingName@
|
||||
sortUserName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||
sortUserName queryUser = ("user-name", SortColumn $ toSortKey . queryUser)
|
||||
where toSortKey user = (user E.^. UserSurname) E.++. (user E.^. UserDisplayName)
|
||||
sortUserName queryUser = ("user-name", SortColumns $ queryUser >>> \user ->
|
||||
[ SomeExprValue $ user E.^. UserSurname
|
||||
, SomeExprValue $ user E.^. UserDisplayName
|
||||
]
|
||||
)
|
||||
|
||||
-- | Alias for sortUserName for consistency, since column comes in two variants
|
||||
sortUserNameLink :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t)
|
||||
@ -175,7 +394,25 @@ fltrUserNameEmailUI mPrev =
|
||||
prismAForm (singletonFilter "user-name-email") mPrev $ aopt textField (fslI MsgCourseMembers)
|
||||
|
||||
-------------------
|
||||
-- Matriclenumber
|
||||
-- Matriculation --
|
||||
-------------------
|
||||
|
||||
colUserMatriculation :: OpticColonnade (Maybe UserMatriculation)
|
||||
colUserMatriculation resultMatriculation = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "user-matriculation") (i18nCell MsgUserMatriculation)
|
||||
body = views resultMatriculation . maybe mempty $ cell . toWidget
|
||||
|
||||
sortUserMatriculation :: OpticSortColumn (Maybe UserMatriculation)
|
||||
sortUserMatriculation queryMatriculation = singletonMap "user-matriculation" . SortColumn $ view queryMatriculation
|
||||
|
||||
fltrUserMatriculation :: OpticFilterColumn' t (Set Text) (E.SqlExpr (E.Value (Maybe UserMatriculation)))
|
||||
fltrUserMatriculation queryMatriculation = singletonMap "user-matriculation" . FilterColumn . mkContainsFilterWith Just $ view queryMatriculation
|
||||
|
||||
fltrUserMatriculationUI :: DBFilterUI
|
||||
fltrUserMatriculationUI mPrev = prismAForm (singletonFilter "user-matriculation") mPrev $ aopt textField (fslI MsgUserMatriculation)
|
||||
|
||||
|
||||
colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c)
|
||||
colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer
|
||||
|
||||
@ -218,6 +455,109 @@ fltrUserEmailUI mPrev =
|
||||
-- Study features --
|
||||
--------------------
|
||||
|
||||
colStudyDegree :: OpticColonnade StudyDegree
|
||||
colStudyDegree resultDegree = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "features-degree") (i18nCell MsgStudyFeatureDegree)
|
||||
body = views resultDegree $ \StudyDegree{..}
|
||||
-> cell . maybe (toWidget $ toMarkup studyDegreeKey) toWidget $ studyDegreeShorthand <|> studyDegreeName
|
||||
|
||||
sortStudyDegree :: forall studyDegree name shorthand key.
|
||||
( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name
|
||||
, E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand
|
||||
, E.SqlProject StudyDegree StudyDegreeKey studyDegree key
|
||||
, PersistField key, PersistField name, PersistField shorthand
|
||||
)
|
||||
=> OpticSortColumn' (E.SqlExpr studyDegree)
|
||||
sortStudyDegree queryDegree = singletonMap "features-degree" . SortColumns $ \(view queryDegree -> degree)
|
||||
-> [ SomeExprValue $ degree `E.sqlProject` StudyDegreeName
|
||||
, SomeExprValue $ degree `E.sqlProject` StudyDegreeShorthand
|
||||
, SomeExprValue $ degree `E.sqlProject` StudyDegreeKey
|
||||
]
|
||||
|
||||
fltrStudyDegree :: forall studyDegree t name shorthand key.
|
||||
( E.SqlProject StudyDegree (Maybe StudyDegreeName) studyDegree name
|
||||
, E.SqlProject StudyDegree (Maybe StudyDegreeShorthand) studyDegree shorthand
|
||||
, E.SqlProject StudyDegree StudyDegreeKey studyDegree key
|
||||
, E.SqlString name, E.SqlString shorthand, PersistField key
|
||||
)
|
||||
=> OpticFilterColumn' t (Set Text) (E.SqlExpr studyDegree)
|
||||
fltrStudyDegree queryDegree = singletonMap "features-degree" . FilterColumn $ anyFilter
|
||||
[ mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeName)
|
||||
, mkContainsFilterWith (unSqlProject' . Just) $ view queryDegree >>> (`E.sqlProject` StudyDegreeShorthand)
|
||||
, mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyDegreeKey)) $ view queryDegree >>> (`E.sqlProject` StudyDegreeKey) >>> E.just
|
||||
]
|
||||
where
|
||||
unSqlProject' :: E.SqlProject StudyDegree value studyDegree value' => value -> value'
|
||||
unSqlProject' = E.unSqlProject (Proxy @StudyDegree) (Proxy @studyDegree)
|
||||
|
||||
fltrStudyDegreeUI :: DBFilterUI
|
||||
fltrStudyDegreeUI mPrev = prismAForm (singletonFilter "features-degree") mPrev $ aopt textField (fslI MsgStudyFeatureDegree)
|
||||
|
||||
|
||||
colStudyTerms :: OpticColonnade StudyTerms
|
||||
colStudyTerms resultTerms = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "features-terms") (i18nCell MsgStudyTerm)
|
||||
body = views resultTerms $ \StudyTerms{..}
|
||||
-> cell . maybe (toWidget $ toMarkup studyTermsKey) toWidget $ studyTermsShorthand <|> studyTermsName
|
||||
|
||||
sortStudyTerms :: forall studyTerms name shorthand key.
|
||||
( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name
|
||||
, E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand
|
||||
, E.SqlProject StudyTerms StudyTermsKey studyTerms key
|
||||
, PersistField key, PersistField name, PersistField shorthand
|
||||
)
|
||||
=> OpticSortColumn' (E.SqlExpr studyTerms)
|
||||
sortStudyTerms queryTerms = singletonMap "features-terms" . SortColumns $ \(view queryTerms -> terms)
|
||||
-> [ SomeExprValue $ terms `E.sqlProject` StudyTermsName
|
||||
, SomeExprValue $ terms `E.sqlProject` StudyTermsShorthand
|
||||
, SomeExprValue $ terms `E.sqlProject` StudyTermsKey
|
||||
]
|
||||
|
||||
fltrStudyTerms :: forall studyTerms t name shorthand key.
|
||||
( E.SqlProject StudyTerms (Maybe StudyTermsName) studyTerms name
|
||||
, E.SqlProject StudyTerms (Maybe StudyTermsShorthand) studyTerms shorthand
|
||||
, E.SqlProject StudyTerms StudyTermsKey studyTerms key
|
||||
, E.SqlString name, E.SqlString shorthand, PersistField key
|
||||
)
|
||||
=> OpticFilterColumn' t (Set Text) (E.SqlExpr studyTerms)
|
||||
fltrStudyTerms queryTerms = singletonMap "features-terms" . FilterColumn $ anyFilter
|
||||
[ mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsName)
|
||||
, mkContainsFilterWith (unSqlProject' . Just) $ view queryTerms >>> (`E.sqlProject` StudyTermsShorthand)
|
||||
, mkExactFilterWith (fmap unSqlProject' . (readMay :: Text -> Maybe StudyTermsKey)) $ view queryTerms >>> (`E.sqlProject` StudyTermsKey) >>> E.just
|
||||
]
|
||||
where
|
||||
unSqlProject' :: E.SqlProject StudyTerms value studyTerms value' => value -> value'
|
||||
unSqlProject' = E.unSqlProject (Proxy @StudyTerms) (Proxy @studyTerms)
|
||||
|
||||
fltrStudyTermsUI :: DBFilterUI
|
||||
fltrStudyTermsUI mPrev = prismAForm (singletonFilter "features-terms") mPrev $ aopt textField (fslI MsgStudyTerm)
|
||||
|
||||
|
||||
colStudyFeaturesSemester :: OpticColonnade Int
|
||||
colStudyFeaturesSemester resultSemester = Colonnade.singleton (fromSortable header) body
|
||||
where
|
||||
header = Sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge)
|
||||
body = views resultSemester $ cell . toWidget . toMarkup
|
||||
|
||||
sortStudyFeaturesSemester :: forall semester. PersistField semester => OpticSortColumn semester
|
||||
sortStudyFeaturesSemester querySemester = singletonMap "features-semester" . SortColumn $ view querySemester
|
||||
|
||||
fltrStudyFeaturesSemester :: forall studyFeatures t semester.
|
||||
( E.SqlProject StudyFeatures Int studyFeatures semester
|
||||
, PersistField semester
|
||||
)
|
||||
=> OpticFilterColumn' t (Set Int) (E.SqlExpr (E.Value semester))
|
||||
fltrStudyFeaturesSemester querySemester = singletonMap "features-semester" . FilterColumn . mkExactFilterWith unSqlProject' $ view querySemester
|
||||
where
|
||||
unSqlProject' :: Int -> semester
|
||||
unSqlProject' = E.unSqlProject (Proxy @StudyFeatures) (Proxy @studyFeatures)
|
||||
|
||||
fltrStudyFeaturesSemesterUI :: DBFilterUI
|
||||
fltrStudyFeaturesSemesterUI mPrev = prismAForm (singletonFilter "features-semester" . maybePrism _PathPiece) mPrev $ aopt (intField :: Field _ Int) (fslI MsgStudyFeatureAge)
|
||||
|
||||
|
||||
colFeaturesSemester :: (IsDBTable m c, HasStudyFeatures x) => Getting (Leftmost x) a x -> Colonnade Sortable a (DBCell m c)
|
||||
colFeaturesSemester feature = sortable (Just "features-semester") (i18nCell MsgStudyFeatureAge) $ maybe mempty cellHasSemester . firstOf feature
|
||||
|
||||
@ -282,3 +622,64 @@ fltrDegree queryFeatures = ( "degree"
|
||||
fltrDegreeUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
fltrDegreeUI mPrev =
|
||||
prismAForm (singletonFilter "degree") mPrev $ aopt textField (fslI MsgDegreeName)
|
||||
|
||||
----------------------------
|
||||
-- Colonnade manipulation --
|
||||
----------------------------
|
||||
|
||||
imapColonnade :: (a -> c -> c)
|
||||
-> Colonnade h a c
|
||||
-> Colonnade h a c
|
||||
-- ^ Not quite `imap`
|
||||
imapColonnade f (Colonnade ones) = Colonnade $ dimapColonnade' <$> ones
|
||||
where
|
||||
dimapColonnade' OneColonnade{..} = OneColonnade
|
||||
{ oneColonnadeEncode = \x -> f x $ oneColonnadeEncode x
|
||||
, oneColonnadeHead
|
||||
}
|
||||
|
||||
anchorColonnade :: forall h r' m a url.
|
||||
( HasRoute UniWorX url
|
||||
, IsDBTable m a
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> (r' -> url)
|
||||
-> Colonnade h r' (DBCell m a)
|
||||
-> Colonnade h r' (DBCell m a)
|
||||
anchorColonnade = anchorColonnadeM . (return .)
|
||||
|
||||
|
||||
anchorColonnadeM :: forall h r' m a url.
|
||||
( HasRoute UniWorX url
|
||||
, IsDBTable m a
|
||||
, HandlerSite m ~ UniWorX
|
||||
)
|
||||
=> (r' -> WidgetT UniWorX IO url)
|
||||
-> Colonnade h r' (DBCell m a)
|
||||
-> Colonnade h r' (DBCell m a)
|
||||
anchorColonnadeM mkUrl = imapColonnade anchorColonnade'
|
||||
where
|
||||
anchorColonnade' :: r' -> DBCell m a -> DBCell m a
|
||||
anchorColonnade' inp (view dbCell -> (attrs, act)) = review dbCell . (attrs,) $
|
||||
view (dbCell . _2) . anchorCellM (mkUrl inp) =<< act
|
||||
|
||||
emptyOpticColonnade :: forall h r' focus c.
|
||||
( Monoid c
|
||||
)
|
||||
=> Fold r' focus -- ^ View on @focus@ within @r'@ that may produce any number of results
|
||||
-> ((forall focus'. Getting focus' r' focus) -> Colonnade h r' c) -- ^ `OpticColonnade focus`
|
||||
-> Colonnade h r' c
|
||||
-- ^ Generalize an `OpticColonnade` from `Getter` to `Fold` by defaulting results of zero or more than one values to `mempty`
|
||||
emptyOpticColonnade l c = Colonnade $ oldColonnade <&> \column -> column { oneColonnadeEncode = \s -> defaultColumn s $ oneColonnadeEncode column }
|
||||
where
|
||||
Colonnade oldColonnade = c $ singular l
|
||||
-- This is safe (as long as we don't evaluate the `oneColonnadeEncode`s)
|
||||
-- because `Getter s a` is of kind @k -> *@ and can thus only be inspected
|
||||
-- by @c@ through application which is precluded by the type of `Getter s a`
|
||||
-- and the definition of `OneColonnade`
|
||||
|
||||
defaultColumn :: r' -> (r' -> c) -> c
|
||||
defaultColumn x f = case x ^.. l of
|
||||
[_] -> f x
|
||||
_ -> mempty
|
||||
|
||||
|
||||
@ -1,5 +1,7 @@
|
||||
module Handler.Utils.Table.Pagination
|
||||
( module Handler.Utils.Table.Pagination.Types
|
||||
, dbFilterKey
|
||||
, SomeExprValue(..)
|
||||
, SortColumn(..), SortDirection(..)
|
||||
, SortingSetting(..)
|
||||
, pattern SortAscBy, pattern SortDescBy
|
||||
@ -10,7 +12,7 @@ module Handler.Utils.Table.Pagination
|
||||
, DBCsvActionMode(..)
|
||||
, DBCsvDiff(..), _DBCsvDiffNew, _DBCsvDiffExisting, _DBCsvDiffMissing, _dbCsvOldKey, _dbCsvOld, _dbCsvNewKey, _dbCsvNew
|
||||
, DBTCsvEncode, DBTCsvDecode(..)
|
||||
, DBTable(..), noCsvEncode, IsDBTable(..), DBCell(..)
|
||||
, DBTable(..), DBFilterUI, noCsvEncode, IsDBTable(..), DBCell(..)
|
||||
, singletonFilter
|
||||
, DBParams(..)
|
||||
, cellAttrs, cellContents
|
||||
@ -81,8 +83,6 @@ import Text.Hamlet (hamletFile)
|
||||
|
||||
import Data.Ratio ((%))
|
||||
|
||||
import Control.Lens.Extras (is)
|
||||
|
||||
import Data.List (elemIndex)
|
||||
|
||||
import Data.Aeson (Options(..), SumEncoding(..), defaultOptions)
|
||||
@ -116,7 +116,26 @@ type Monoid' x = (Sem.Semigroup x, Monoid x)
|
||||
#endif
|
||||
|
||||
|
||||
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
|
||||
|
||||
instance PathPiece x => PathPiece (WithIdent x) where
|
||||
toPathPiece (WithIdent ident x)
|
||||
| not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
|
||||
| otherwise = toPathPiece x
|
||||
fromPathPiece txt = do
|
||||
let sep = "-"
|
||||
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
|
||||
WithIdent <$> pure ident <*> fromPathPiece rest
|
||||
|
||||
|
||||
dbFilterKey :: PathPiece dbtIdent => dbtIdent -> FilterKey -> Text
|
||||
dbFilterKey ident = toPathPiece . WithIdent ident
|
||||
|
||||
|
||||
data SomeExprValue = forall a. PersistField a => SomeExprValue { getSomeExprValue :: E.SqlExpr (E.Value a) }
|
||||
|
||||
data SortColumn t = forall a. PersistField a => SortColumn { getSortColumn :: t -> E.SqlExpr (E.Value a) }
|
||||
| SortColumns { getSortColumns :: t -> [SomeExprValue] }
|
||||
|
||||
data SortDirection = SortAsc | SortDesc
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read, Generic)
|
||||
@ -133,9 +152,11 @@ deriveJSON defaultOptions
|
||||
{ constructorTagModifier = camelToPathPiece' 1
|
||||
} ''SortDirection
|
||||
|
||||
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> E.SqlExpr E.OrderBy
|
||||
sqlSortDirection t (SortColumn e, SortAsc ) = E.asc $ e t
|
||||
sqlSortDirection t (SortColumn e, SortDesc) = E.desc $ e t
|
||||
sqlSortDirection :: t -> (SortColumn t, SortDirection) -> [E.SqlExpr E.OrderBy]
|
||||
sqlSortDirection t (SortColumn e , SortAsc ) = pure . E.asc $ e t
|
||||
sqlSortDirection t (SortColumn e , SortDesc) = pure . E.desc $ e t
|
||||
sqlSortDirection t (SortColumns es, SortAsc ) = es t <&> \(SomeExprValue v) -> E.asc v
|
||||
sqlSortDirection t (SortColumns es, SortDesc) = es t <&> \(SomeExprValue v) -> E.desc v
|
||||
|
||||
|
||||
data SortingSetting = SortingSetting
|
||||
@ -486,17 +507,6 @@ singletonFilter key = prism' fromInner (fmap Just . fromOuter)
|
||||
fromOuter = Map.lookup key >=> listToMaybe
|
||||
|
||||
|
||||
data WithIdent x = forall ident. PathPiece ident => WithIdent { _ident :: ident, _withoutIdent :: x }
|
||||
|
||||
instance PathPiece x => PathPiece (WithIdent x) where
|
||||
toPathPiece (WithIdent ident x)
|
||||
| not . null $ toPathPiece ident = toPathPiece ident <> "-" <> toPathPiece x
|
||||
| otherwise = toPathPiece x
|
||||
fromPathPiece txt = do
|
||||
let sep = "-"
|
||||
(ident, (Text.stripSuffix sep -> Just rest)) <- return $ Text.breakOn sep txt
|
||||
WithIdent <$> pure ident <*> fromPathPiece rest
|
||||
|
||||
type DBTCsvEncode r' csv = DictMaybe (ToNamedRecord csv, DefaultOrdered csv, CsvColumnsExplained csv) (Conduit r' (YesodDB UniWorX) csv)
|
||||
data DBTCsvDecode r' k' csv = forall route csvAction csvActionClass csvException.
|
||||
( FromNamedRecord csv, ToNamedRecord csv, DefaultOrdered csv
|
||||
@ -529,7 +539,7 @@ data DBTable m x = forall a r r' h i t k k' csv.
|
||||
, dbtColonnade :: Colonnade h r' (DBCell m x)
|
||||
, dbtSorting :: Map SortingKey (SortColumn t)
|
||||
, dbtFilter :: Map FilterKey (FilterColumn t)
|
||||
, dbtFilterUI :: Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
, dbtFilterUI :: DBFilterUI
|
||||
, dbtStyle :: DBStyle r'
|
||||
, dbtParams :: DBParams m x
|
||||
, dbtCsvEncode :: DBTCsvEncode r' csv
|
||||
@ -537,6 +547,8 @@ data DBTable m x = forall a r r' h i t k k' csv.
|
||||
, dbtIdent :: i
|
||||
}
|
||||
|
||||
type DBFilterUI = Maybe (Map FilterKey [Text]) -> AForm (YesodDB UniWorX) (Map FilterKey [Text])
|
||||
|
||||
noCsvEncode :: DictMaybe (ToNamedRecord Void, DefaultOrdered Void, CsvColumnsExplained Void) (Conduit r' (YesodDB UniWorX) Void)
|
||||
noCsvEncode = Nothing
|
||||
|
||||
@ -771,7 +783,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
piInput <- lift . runInputGetResult $ PaginationInput
|
||||
<$> iopt (multiSelectField $ return sortingOptions) (wIdent "sorting")
|
||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField . wIdent $ toPathPiece k) dbtFilter)
|
||||
<*> (assertM' (not . Map.null) . Map.mapMaybe (assertM $ not . null) <$> Map.traverseWithKey (\k _ -> iopt multiTextField $ dbFilterKey dbtIdent' k) dbtFilter)
|
||||
<*> iopt pathPieceField (wIdent "pagesize")
|
||||
<*> iopt intField (wIdent "page")
|
||||
|
||||
@ -818,7 +830,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
tblLink f = SomeRoute . (currentRoute, ) . over (mapped . _2) (fromMaybe Text.empty) $ (f . substPi . setParam "_hasdata" Nothing) getParams
|
||||
substPi = foldr (.) id
|
||||
[ setParams (wIdent "sorting") . map toPathPiece $ fromMaybe [] piSorting
|
||||
, foldr (.) id . map (\k -> setParams (wIdent $ toPathPiece k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
|
||||
, foldr (.) id . map (\k -> setParams (dbFilterKey dbtIdent' k) . fromMaybe [] . join $ traverse (Map.lookup k) piFilter) $ Map.keys dbtFilter
|
||||
, setParam (wIdent "pagesize") $ fmap toPathPiece piLimit
|
||||
, setParam (wIdent "page") $ fmap toPathPiece piPage
|
||||
, setParam (wIdent "pagination") Nothing
|
||||
@ -863,7 +875,7 @@ dbTable PSValidator{..} dbtable@DBTable{ dbtIdent = dbtIdent'@(toPathPiece -> db
|
||||
|
||||
rows' <- E.select . E.from $ \t -> do
|
||||
res <- dbtSQLQuery t
|
||||
E.orderBy (map (sqlSortDirection t) psSorting')
|
||||
E.orderBy $ concatMap (sqlSortDirection t) psSorting'
|
||||
case csvMode of
|
||||
FormSuccess DBCsvExport -> return ()
|
||||
FormSuccess DBCsvImport{} -> return ()
|
||||
|
||||
@ -4,7 +4,7 @@ module Handler.Utils.Table.Pagination.Types
|
||||
( FilterKey, SortingKey
|
||||
, Sortable(..)
|
||||
, sortable
|
||||
, ToSortable(..)
|
||||
, ToSortable(..), FromSortable(..)
|
||||
, SortableP(..)
|
||||
, DBTableInvalid(..)
|
||||
) where
|
||||
@ -58,6 +58,19 @@ instance ToSortable Headless where
|
||||
pSortable = Nothing
|
||||
|
||||
|
||||
class FromSortable s where
|
||||
fromSortable :: forall a. Sortable a -> s a
|
||||
|
||||
instance FromSortable Sortable where
|
||||
fromSortable = id
|
||||
|
||||
instance FromSortable Headed where
|
||||
fromSortable Sortable{..} = Headed sortableContent
|
||||
|
||||
instance FromSortable Headless where
|
||||
fromSortable _ = Headless
|
||||
|
||||
|
||||
data DBTableInvalid = DBTIRowsMissing Int
|
||||
deriving (Eq, Ord, Read, Show, Generic, Typeable)
|
||||
|
||||
|
||||
@ -5,8 +5,6 @@ module Handler.Utils.Tokens
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Control.Monad.Trans.Maybe (runMaybeT)
|
||||
|
||||
|
||||
|
||||
@ -10,8 +10,6 @@ import qualified Database.Esqueleto as E
|
||||
import qualified Database.Esqueleto.Internal.Sql as E
|
||||
import Database.Esqueleto.Utils.TH
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
|
||||
fetchTutorialAux :: ( SqlBackendCanRead backend
|
||||
, E.SqlSelect b a
|
||||
|
||||
@ -10,6 +10,7 @@ import Model.Submission as Import
|
||||
import Model.Tokens as Import
|
||||
import Utils.Tokens as Import
|
||||
import Utils.Frontend.Modal as Import
|
||||
import Utils.Lens as Import
|
||||
|
||||
import Settings as Import
|
||||
import Settings.StaticFiles as Import
|
||||
|
||||
@ -3,7 +3,18 @@ module Import.NoModel
|
||||
, MForm
|
||||
) where
|
||||
|
||||
import ClassyPrelude.Yesod as Import hiding (formatTime, derivePersistFieldJSON, getMessages, addMessage, addMessageI, (.=), MForm, Proxy, foldlM, static, boolField, identifyForm, cons, HasHttpManager(..))
|
||||
import ClassyPrelude.Yesod as Import
|
||||
hiding ( formatTime
|
||||
, derivePersistFieldJSON
|
||||
, getMessages, addMessage, addMessageI
|
||||
, (.=)
|
||||
, MForm
|
||||
, Proxy
|
||||
, foldlM
|
||||
, static
|
||||
, boolField, identifyForm
|
||||
, HasHttpManager(..)
|
||||
)
|
||||
|
||||
import Model.Types.TH.JSON as Import
|
||||
import Model.Types.TH.Wordlist as Import
|
||||
@ -80,6 +91,8 @@ import Data.Void as Import (Void)
|
||||
|
||||
import Algebra.Lattice as Import hiding (meet, join)
|
||||
|
||||
import Data.Proxy as Import (Proxy(..))
|
||||
|
||||
import Language.Haskell.TH.Instances as Import ()
|
||||
import Data.List.NonEmpty.Instances as Import ()
|
||||
import Data.NonNull.Instances as Import ()
|
||||
@ -114,6 +127,16 @@ import System.FilePath.Instances as Import ()
|
||||
import Net.IP.Instances as Import ()
|
||||
import Data.Void.Instances as Import ()
|
||||
import Crypto.Hash.Instances as Import ()
|
||||
import Colonnade.Instances as Import ()
|
||||
|
||||
import Control.Lens as Import
|
||||
hiding ( (<.>)
|
||||
, universe
|
||||
, cons, uncons, snoc, unsnoc, (<|)
|
||||
, Index, index, (<.)
|
||||
)
|
||||
import Control.Lens.Extras as Import (is)
|
||||
import Data.Set.Lens as Import
|
||||
|
||||
|
||||
import Control.Monad.Trans.RWS (RWST)
|
||||
|
||||
@ -6,8 +6,6 @@ module Jobs
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens
|
||||
|
||||
import Jobs.Types as Types hiding (JobCtl(JobCtlQueue))
|
||||
import Jobs.Types (JobCtl(JobCtlQueue))
|
||||
import Jobs.Queue
|
||||
|
||||
@ -4,8 +4,6 @@ module Jobs.Crontab
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import qualified Data.HashMap.Strict as HashMap
|
||||
import Jobs.Types
|
||||
|
||||
|
||||
@ -9,8 +9,6 @@ import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Handler.Utils
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Data.Bitraversable
|
||||
|
||||
|
||||
|
||||
@ -3,7 +3,6 @@ module Jobs.Handler.Invitation
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens
|
||||
import Handler.Utils.Mail
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -4,7 +4,6 @@ module Jobs.Handler.SendCourseCommunication
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
|
||||
import qualified Data.Set as Set
|
||||
|
||||
@ -6,7 +6,6 @@ module Jobs.Handler.SendNotification.SubmissionRated
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
|
||||
@ -5,7 +5,6 @@ module Jobs.Handler.SendNotification.UserAuthModeUpdate
|
||||
) where
|
||||
|
||||
import Import
|
||||
import Utils.Lens
|
||||
|
||||
import Handler.Utils.Mail
|
||||
import Jobs.Handler.SendNotification.Utils
|
||||
|
||||
@ -4,7 +4,6 @@ module Jobs.Handler.SendPasswordReset
|
||||
|
||||
import Import
|
||||
|
||||
import Utils.Lens
|
||||
import Handler.Utils
|
||||
import Handler.Utils.Users
|
||||
|
||||
|
||||
@ -8,8 +8,6 @@ import Handler.Utils.DateTime
|
||||
|
||||
import Text.Shakespeare.Text
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
dispatchJobSendTestEmail :: Email -> MailContext -> Handler ()
|
||||
dispatchJobSendTestEmail jEmail jMailContext = mailT jMailContext $ do
|
||||
_mailTo .= [Address Nothing jEmail]
|
||||
|
||||
@ -4,7 +4,6 @@ module Jobs.Handler.TransactionLog
|
||||
) where
|
||||
|
||||
import Import hiding (currentYear)
|
||||
import Utils.Lens hiding ((<.))
|
||||
import Handler.Utils.DateTime
|
||||
|
||||
import Database.Persist.Sql (updateWhereCount, deleteWhereCount)
|
||||
|
||||
@ -14,8 +14,6 @@ import Data.Proxy (Proxy(..))
|
||||
|
||||
import qualified Data.ByteArray as ByteArray
|
||||
|
||||
import Utils.Lens
|
||||
|
||||
import Network.HTTP.Simple (httpJSON, httpLBS)
|
||||
import qualified Network.HTTP.Simple as HTTP
|
||||
|
||||
|
||||
@ -11,7 +11,6 @@ module Jobs.Queue
|
||||
import Import hiding ((<>))
|
||||
|
||||
import Utils.Sql
|
||||
import Utils.Lens
|
||||
import Jobs.Types
|
||||
|
||||
import Control.Monad.Trans.Writer (WriterT, runWriterT)
|
||||
|
||||
@ -18,6 +18,17 @@ type Points = Centi
|
||||
|
||||
type Email = Text
|
||||
|
||||
type UserDisplayName = Text
|
||||
type UserSurname = Text
|
||||
type UserMatriculation = Text
|
||||
|
||||
type StudyDegreeName = Text
|
||||
type StudyDegreeShorthand = Text
|
||||
type StudyDegreeKey = Int
|
||||
type StudyTermsName = Text
|
||||
type StudyTermsShorthand = Text
|
||||
type StudyTermsKey = Int
|
||||
|
||||
type SchoolName = CI Text
|
||||
type SchoolShorthand = CI Text
|
||||
type CourseName = CI Text
|
||||
|
||||
@ -9,7 +9,6 @@ module Model.Types.DateTime
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
@ -14,7 +14,6 @@ import Model.Types.Common
|
||||
|
||||
import qualified Data.Text as Text
|
||||
|
||||
import Control.Lens hiding (universe)
|
||||
import Utils.Lens.TH
|
||||
|
||||
import qualified Data.Csv as Csv
|
||||
|
||||
@ -8,7 +8,6 @@ module Model.Types.Misc
|
||||
) where
|
||||
|
||||
import Import.NoModel
|
||||
import Control.Lens
|
||||
|
||||
import Data.Maybe (fromJust)
|
||||
|
||||
|
||||
@ -11,8 +11,6 @@ import Import.NoModel
|
||||
import Model.Types.Common
|
||||
import Utils.Lens.TH
|
||||
|
||||
import Control.Lens
|
||||
import Control.Lens.Extras (is)
|
||||
import Generics.Deriving.Monoid (memptydefault, mappenddefault)
|
||||
|
||||
import Data.Set (Set)
|
||||
|
||||
@ -20,8 +20,6 @@ import Data.Word.Word24
|
||||
|
||||
import qualified Data.CaseInsensitive as CI
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import qualified Data.Text as Text
|
||||
import qualified Data.Set as Set
|
||||
|
||||
|
||||
@ -44,8 +44,6 @@ import qualified Data.Text.Encoding as Text
|
||||
|
||||
import qualified Ldap.Client as Ldap
|
||||
|
||||
import Control.Lens
|
||||
|
||||
import qualified Network.HaskellNet.Auth as HaskellNet (UserName, Password, AuthType(..))
|
||||
import qualified Network.Socket as HaskellNet (PortNumber(..), HostName)
|
||||
import qualified Network
|
||||
|
||||
@ -59,6 +59,8 @@ data Icon
|
||||
| IconApplyTrue
|
||||
| IconApplyFalse
|
||||
| IconNoCorrectors
|
||||
| IconApplicationVeto
|
||||
| IconApplicationFiles
|
||||
deriving (Eq, Ord, Enum, Bounded, Show, Read)
|
||||
|
||||
iconText :: Icon -> Text
|
||||
@ -92,6 +94,8 @@ iconText = \case
|
||||
IconApplyTrue -> "file-alt"
|
||||
IconApplyFalse -> "trash"
|
||||
IconNoCorrectors -> "user-slash"
|
||||
IconApplicationVeto -> "times"
|
||||
IconApplicationFiles -> "file-alt"
|
||||
|
||||
instance Universe Icon
|
||||
instance Finite Icon
|
||||
|
||||
@ -3,13 +3,18 @@
|
||||
|
||||
module Utils.Lens ( module Utils.Lens ) where
|
||||
|
||||
import ClassyPrelude.Yesod hiding (HasHttpManager(..))
|
||||
import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
|
||||
import Import.NoModel
|
||||
import Model
|
||||
import qualified ClassyPrelude.Yesod as Yesod (HasHttpManager(..))
|
||||
|
||||
import Control.Lens as Utils.Lens hiding ((<.>), universe, snoc)
|
||||
import Control.Lens as Utils.Lens
|
||||
hiding ( (<.>)
|
||||
, universe
|
||||
, cons, uncons, snoc, unsnoc, (<|)
|
||||
, Index, index, (<.)
|
||||
)
|
||||
import Control.Lens.Extras as Utils.Lens (is)
|
||||
import Utils.Lens.TH as Utils.Lens (makeLenses_, makeClassyFor_)
|
||||
import Utils.Lens.TH as Utils.Lens
|
||||
import Data.Set.Lens as Utils.Lens
|
||||
|
||||
import Yesod.Core.Types (HandlerContents(..), ErrorResponse(..))
|
||||
@ -42,6 +47,8 @@ _SchoolId = iso unSchoolKey SchoolKey
|
||||
-----------------------------------
|
||||
-- Lens Definitions for our Types
|
||||
|
||||
makeClassyFor_ ''Term
|
||||
|
||||
|
||||
-- makeLenses_ ''Course
|
||||
makeClassyFor_ ''Course
|
||||
|
||||
@ -1,10 +1,17 @@
|
||||
module Utils.Lens.TH where
|
||||
module Utils.Lens.TH
|
||||
( makeLenses_, makeClassyFor_
|
||||
, multifocusG, multifocusL
|
||||
) where
|
||||
|
||||
import ClassyPrelude (Maybe(..), (<>))
|
||||
import ClassyPrelude
|
||||
import Control.Lens
|
||||
import Control.Lens.Internal.FieldTH
|
||||
import Language.Haskell.TH
|
||||
|
||||
import Numeric.Natural
|
||||
|
||||
import Data.Foldable (Foldable(foldl))
|
||||
|
||||
-- import Control.Lens.Misc
|
||||
{-
|
||||
NOTE: The code for lensRules_ and makeLenses_ was stolen from package lens-misc-0.0.2.0,
|
||||
@ -65,3 +72,47 @@ makeClassyFor_ recName = makeFieldOptics (classyRulesFor_ clNamer) recName
|
||||
clNamer :: ClassyNamer
|
||||
-- clNamer _ = Just (clsName, funName) -- for newer versions >= 4.17
|
||||
clNamer _ = Just (mkName clsName, mkName funName)
|
||||
|
||||
multifocusG :: Natural -> ExpQ
|
||||
multifocusG = multifocusOptic
|
||||
[e|to . view|]
|
||||
(\s a -> [t|Getting $(a) $(s) $(a)|])
|
||||
(\s a -> [t|Getter $(s) $(a)|])
|
||||
(\doGet _doSet -> [e|to $(doGet)|])
|
||||
|
||||
multifocusL :: Natural -> ExpQ
|
||||
multifocusL = multifocusOptic
|
||||
[e|cloneLens|]
|
||||
(\s a -> [t|ALens' $(s) $(a)|])
|
||||
(\s a -> [t|Lens' $(s) $(a)|])
|
||||
(\doGet doSet -> [e|lens $(doGet) $(doSet)|])
|
||||
|
||||
|
||||
multifocusOptic :: _ -> _ -> _ -> _ -> Natural -> ExpQ
|
||||
multifocusOptic _ _ _ _ 0 = [e|united|]
|
||||
multifocusOptic doClone _ _ _ 1 = doClone
|
||||
multifocusOptic doClone alensT lensT lens' (fromIntegral -> n) = do
|
||||
ll <- newName "l"
|
||||
ls <- replicateM n $ newName "l"
|
||||
s <- newName "s"
|
||||
xs <- replicateM n $ newName "x"
|
||||
|
||||
tS <- newName "s"
|
||||
tXs <- replicateM n $ newName "x" :: Q [Name]
|
||||
|
||||
let tup = foldl (\t x -> [t|$(t) $(varT x)|]) (tupleT (length tXs)) tXs
|
||||
mkL x = alensT (varT tS) (varT x)
|
||||
|
||||
letE
|
||||
[ sigD ll $ foldr (\x t -> [t|$(mkL x) -> $(t)|]) (lensT (varT tS) tup) tXs
|
||||
, funD ll
|
||||
[ clause
|
||||
(map (viewP doClone . varP) ls)
|
||||
(normalB $ lens'
|
||||
(lamE [varP s] . tupE . flip map ls $ \l -> [e| $(varE s) ^. $(varE l) |])
|
||||
(lamE [varP s, tupP $ map varP xs] . foldr (\(x, l) x' -> [e|$(x') & $(varE l) .~ $(varE x)|]) (varE s) $ zip xs ls)
|
||||
)
|
||||
[]
|
||||
]
|
||||
]
|
||||
(varE ll)
|
||||
|
||||
@ -23,7 +23,7 @@ setSerializable act = setSerializable' (0 :: Integer)
|
||||
let
|
||||
delay :: NominalDiffTime
|
||||
delay = 1e-3 * 2 ^ logBackoff
|
||||
$logWarnS "Sql" $ tshow (delay, e)
|
||||
$logDebugS "Sql" $ tshow (delay, e)
|
||||
transactionUndo
|
||||
threadDelay . round $ delay * 1e6
|
||||
setSerializable' (succ logBackoff)
|
||||
|
||||
@ -126,7 +126,7 @@ $if not (null occurrences)
|
||||
$maybe desc <- examOccurrenceDescription
|
||||
#{desc}
|
||||
|
||||
$if gradingShown && not (null parts)
|
||||
$if gradingShown && not (null examParts)
|
||||
<section>
|
||||
<h2>
|
||||
_{MsgExamParts}
|
||||
@ -139,7 +139,7 @@ $if gradingShown && not (null parts)
|
||||
<th .table__th>_{MsgExamPartMaxPoints}
|
||||
<th .table__th>_{MsgExamPartResultPoints}
|
||||
<tbody>
|
||||
$forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- parts
|
||||
$forall Entity partId ExamPart{examPartName, examPartWeight, examPartMaxPoints} <- examParts
|
||||
<tr .table__row>
|
||||
<td .table__td>#{examPartName}
|
||||
<td .table__td>
|
||||
|
||||
@ -3,14 +3,16 @@ $if null rows && (dbsEmptyStyle == DBESNoHeading)
|
||||
_{dbsEmptyMessage}
|
||||
$else
|
||||
<div .table-header>
|
||||
<div .table__row-count>
|
||||
_{MsgRowCount rowCount}
|
||||
$if rowCount > 5
|
||||
<div .table__row-count>
|
||||
_{MsgRowCount rowCount}
|
||||
|
||||
^{table}
|
||||
|
||||
<div .table-footer>
|
||||
<div .table__row-count>
|
||||
_{MsgRowCount rowCount}
|
||||
$if rowCount > 5
|
||||
<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)
|
||||
^{pagesizeWdgt'}
|
||||
|
||||
Loading…
Reference in New Issue
Block a user