diff --git a/build.sh b/build.sh index 991d2ff3c..13a8b2490 100755 --- a/build.sh +++ b/build.sh @@ -1,3 +1,4 @@ #!/usr/bin/env bash exec -- stack build --fast --flag uniworx:library-only --flag uniworx:dev +echo Build task completed. diff --git a/src/Database/Esqueleto/Utils.hs b/src/Database/Esqueleto/Utils.hs index 158fa5bea..5f904f6f3 100644 --- a/src/Database/Esqueleto/Utils.hs +++ b/src/Database/Esqueleto/Utils.hs @@ -5,9 +5,11 @@ module Database.Esqueleto.Utils , isInfixOf, hasInfix , any, all , SqlIn(..) + , mkInFilter ) where import ClassyPrelude.Yesod hiding (isInfixOf, any, all) +import qualified Data.Set as Set import qualified Data.Foldable as F import qualified Database.Esqueleto as E import Database.Esqueleto.Utils.TH @@ -51,3 +53,22 @@ all :: Foldable f => all test = F.foldr (\needle acc -> acc E.&&. test needle) true $(sqlInTuples [2..16]) + + +-- | generic filter creation for dbTable +-- Given a lens-like function, make filter +-- What I thought: +-- mkFilter :: (Foldable f, E.From query expr backend a) +-- => (a -> E.SqlExpr (E.Value b)) +-- -> a +-- -> f b +-- -> E.SqlExpr (E.Value Bool) +-- What is inferred: +mkInFilter :: (PersistField a) + => (t -> E.SqlExpr (E.Value a)) + -> t + -> Set.Set a + -> E.SqlExpr (E.Value Bool) +mkInFilter lenslike row criterias + | Set.null criterias = true + | otherwise = (lenslike row) `E.in_` E.valList (Set.toList criterias) \ No newline at end of file diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 0da847ef6..c32e6d47d 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -8,10 +8,12 @@ import Utils.Lens import Utils.Form -- import Utils.DB import Handler.Utils -import Handler.Utils.Table.Cells import Handler.Utils.Course import Handler.Utils.Delete import Handler.Utils.Database +import Handler.Utils.Table.Cells +import Handler.Utils.Table.Columns +import Database.Esqueleto.Utils -- import Data.Time -- import qualified Data.Text as T @@ -691,6 +693,32 @@ _userTableNote = _dbrOutput . _3 _userTableFeatures :: Lens' UserTableData (Maybe StudyFeatures, Maybe StudyDegree, Maybe StudyTerms) _userTableFeatures = _dbrOutput . _4 +_rowUserSemester :: Traversal' UserTableData Int +_rowUserSemester = _userTableFeatures . _1 . _Just . _studyFeaturesSemester + + +-- Sql-Getters for this query, used for sorting and filtering (cannot be lenses due to being Esqueleto expressions) +queryUser :: UserTableExpr -> E.SqlExpr (Entity User) +queryUser ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user + +-- queryUserName :: UserTableExpr -> E.SqlExpr (E.Value Text) +-- queryUserName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName + +-- queryUserDisplayName :: UserTableExpr -> E.SqlExpr (E.Value Text) +-- queryUserDisplayName ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserDisplayName + +queryUserFeatures :: UserTableExpr -> (E.SqlExpr (Maybe (Entity StudyFeatures)) `E.InnerJoin` E.SqlExpr (Maybe (Entity StudyDegree)) `E.InnerJoin`E.SqlExpr (Maybe (Entity StudyTerms))) +queryUserFeatures ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` studyFeatures) = studyFeatures + +queryUserSemester :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int)) +queryUserSemester = aux . queryUserFeatures + where aux (features `E.InnerJoin` _degree `E.InnerJoin` _terms) + = features E.?. StudyFeaturesSemester + +-- Deprecated in favour of newer implementation +queryUserSemester' :: UserTableExpr -> E.SqlExpr (E.Value (Maybe Int)) -- (E.Value (Maybe Int)) +queryUserSemester' ((_user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` (features `E.InnerJoin` _degree `E.InnerJoin` _terms) ) + = features E.?. StudyFeaturesSemester colUserComment :: IsDBTable m c => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable UserTableData (DBCell m c) colUserComment tid ssh csh = @@ -703,19 +731,26 @@ colUserComment tid ssh csh = colUserSemester :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserSemester = sortable (Just "course-user-semesternr") (i18nCell MsgStudyFeatureAge) $ - foldMap numCell . preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester) + foldMap numCell . preview _rowUserSemester colUserField :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserField = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $ foldMap htmlCell . view (_userTableFeatures . _3) +colUserFieldShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserFieldShort = sortable (Just "course-user-field") (i18nCell MsgCourseStudyFeature) $ + foldMap (htmlCell . shortStudyTerms) . view (_userTableFeatures . _3) + colUserDegree :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) colUserDegree = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $ foldMap htmlCell . preview (_userTableFeatures . _2 . _Just) +colUserDegreeShort :: IsDBTable m c => Colonnade Sortable UserTableData (DBCell m c) +colUserDegreeShort = sortable (Just "course-user-degree") (i18nCell MsgStudyFeatureDegree) $ + foldMap (htmlCell . shortStudyDegree) . preview (_userTableFeatures . _2 . _Just) + makeCourseUserTable :: CourseId -> _ -> _ -> DB Widget makeCourseUserTable cid colChoices psValidator = - -- return [whamlet|TODO|] -- TODO -- -- psValidator has default sorting and filtering let dbtIdent = "courseUsers" :: Text dbtStyle = def @@ -723,8 +758,18 @@ makeCourseUserTable cid colChoices psValidator = dbtRowKey ((user `E.InnerJoin` _participant) `E.LeftOuterJoin` _note `E.LeftOuterJoin` _studyFeatures) = user E.^. UserId dbtProj = traverse $ \(user, E.Value registrationTime , E.Value userNoteId, (feature,degree,terms)) -> return (user, registrationTime, userNoteId, (entityVal <$> feature, entityVal <$> degree, entityVal <$> terms)) dbtColonnade = colChoices - dbtSorting = Map.fromList [] -- TODO - dbtFilter = Map.fromList [] -- TODO + dbtSorting = Map.fromList + [ sortUserName queryUser + , sortUserDisplayName queryUser + , sortUserMatriclenr queryUser + , ( "course-user-semesternr", SortColumn queryUserSemester) -- $ -- preview (_userTableFeatures . _1 . _Just . _studyFeaturesSemester)) + -- TODO + ] + dbtFilter = Map.fromList + [ filterUserName queryUser + , ( "course-user-semesternr", FilterColumn $ mkInFilter queryUserSemester) + -- TODO + ] dbtFilterUI = mempty -- TODO dbtParams = def in dbTableWidget' psValidator DBTable{..} @@ -735,20 +780,20 @@ getCUsersR tid ssh csh = do Entity cid course <- runDB $ getBy404 $ TermSchoolCourseShort tid ssh csh let heading = [whamlet|_{MsgMenuCourseMembers} #{courseName course} #{display tid}|] colChoices = mconcat - [ colUserParticipantLink tid ssh csh + [ colUserNameLink (CourseR tid ssh csh . CUserR) , colUserEmail , colUserMatriclenr - , colUserDegree - , colUserField + , colUserDegreeShort + , colUserFieldShort , colUserSemester , sortable (Just "registration") (i18nCell MsgRegisteredHeader) (dateCell . view _userTableRegistration) , colUserComment tid ssh csh ] - psValidator = def + psValidator = def & defaultSortingByName tableWidget <- runDB $ makeCourseUserTable cid colChoices psValidator siteLayout heading $ do setTitle [shamlet| #{toPathPiece tid} - #{csh}|] - -- TODO: creat hamlet wrapper + -- TODO: create hamlet wrapper tableWidget diff --git a/src/Handler/Utils/Table/Cells.hs b/src/Handler/Utils/Table/Cells.hs index 47f4f6e8b..05d2463f3 100644 --- a/src/Handler/Utils/Table/Cells.hs +++ b/src/Handler/Utils/Table/Cells.hs @@ -173,30 +173,3 @@ correctorLoadCell :: IsDBTable m a => SheetCorrector -> DBCell m a correctorLoadCell sc = i18nCell $ sheetCorrectorLoad sc - --------------------------------- --- Generic Columns --- reuse encourages consistency --- --- if it works out, turn into its own module --- together with filters and sorters - - --- | Does not work, since we have now show Instance for RenderMesage UniWorX msg -colUser :: (IsDBTable m c, HasUser a, RenderMessage UniWorX msg, Show msg) => msg -> Colonnade Sortable a (DBCell m c) -colUser msg = sortable (Just $ fromString $ show msg) (i18nCell msg) cellHasUser - -colUserParticipant :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserParticipant = sortable (Just "participant") (i18nCell MsgCourseMembers) cellHasUser - -colUserParticipantLink :: (IsDBTable m c, HasEntity a User) => TermId -> SchoolId -> CourseShorthand -> Colonnade Sortable a (DBCell m c) -colUserParticipantLink tid ssh csh = sortable (Just "participant") (i18nCell MsgCourseMembers) (cellHasUserLink courseLink) - where - -- courseLink :: CryptoUUIDUser -> Route UniWorX - courseLink = CourseR tid ssh csh . CUserR - -colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserMatriclenr = sortable (Just "matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer - -colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) -colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail diff --git a/src/Handler/Utils/Table/Columns.hs b/src/Handler/Utils/Table/Columns.hs new file mode 100644 index 000000000..6ff916033 --- /dev/null +++ b/src/Handler/Utils/Table/Columns.hs @@ -0,0 +1,87 @@ +module Handler.Utils.Table.Columns where + +import Import + +-- import Data.CaseInsensitive (CI) +-- import qualified Data.CaseInsensitive as CI + +-- import Data.Monoid (Any(..)) +-- import Control.Monad.Writer.Class (MonadWriter(..)) +-- import Control.Monad.Trans.Writer (WriterT) + +-- import Text.Blaze (ToMarkup(..)) + +import qualified Database.Esqueleto as E +import Database.Esqueleto.Utils + +import Utils.Lens +import Handler.Utils +import Handler.Utils.Table.Cells + + +-------------------------------- +-- Generic Columns +-- reuse encourages consistency +-- +-- The constant string for sort/filter keys +-- should never be mentioned outside of this module +-- to ensure consistency! +-- +-- Each section should have the following parts: +-- * colXYZ : column definitions plus variants +-- * sortXYZ : sorting definitions for these columns +-- * fltrXYZ : filter definitions for these columns +-- * additional helper, such as default sorting + + +--------------- +-- 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 + +colUserName :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) +colUserName = sortable (Just "user-surname") (i18nCell MsgCourseMembers) cellHasUser + +colUserNameLink :: (IsDBTable m c, HasEntity a User) => (CryptoUUIDUser -> Route UniWorX) -> Colonnade Sortable a (DBCell m c) +colUserNameLink userLink = sortable (Just "user-surname") (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 = sortUserSurname + +sortUserSurname :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) +sortUserSurname queryUser = ( "user-surname", SortColumn $ compose queryUser (E.^. UserSurname)) + +sortUserDisplayName :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) +sortUserDisplayName queryUser = ( "user-display-name", SortColumn $ compose queryUser (E.^. UserDisplayName)) + +defaultSortingByName :: PSValidator m x -> PSValidator m x +defaultSortingByName = defaultSorting [SortAscBy "user-surname", SortAscBy "user-display-name"] + +filterUserName :: (IsFilterColumn t (a2 -> Set Text -> E.SqlExpr (E.Value Bool)), IsString a1) + => (a2 -> E.SqlExpr (Entity User)) + -> (a1, FilterColumn t) +filterUserName queryUser = ( "user-surname", FilterColumn $ mkInFilter queryName ) + where + queryName = compose queryUser (E.^. UserSurname) + + +------------------- +-- Matriclenumber +colUserMatriclenr :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) +colUserMatriclenr = sortable (Just "user-matriclenumber") (i18nCell MsgMatrikelNr) cellHasMatrikelnummer + +sortUserMatriclenr :: IsString a => (t -> E.SqlExpr (Entity User)) -> (a, SortColumn t) +sortUserMatriclenr queryUser = ( "user-matriclenumber", SortColumn $ compose queryUser (E.^. UserMatrikelnummer)) + + + +---------------- +-- User E-Mail +colUserEmail :: (IsDBTable m c, HasUser a) => Colonnade Sortable a (DBCell m c) +colUserEmail = sortable (Just "email") (i18nCell MsgEMail) cellHasEMail + diff --git a/src/Utils.hs b/src/Utils.hs index a523c723b..33027639a 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -340,6 +340,14 @@ invertMap :: (Ord k, Ord v) => Map k v -> Map v (Set k) invertMap = groupMap . map swap . Map.toList +--------------- +-- Functions -- +--------------- + +-- | Just @flip (.)@ for convenient formatting in some rare cases +compose :: (a -> b) -> (b -> c) -> (a -> c) +compose = flip (.) + ----------- -- Maybe -- @@ -473,8 +481,6 @@ throwExceptT :: ( Exception e, MonadThrow m ) => ExceptT e m a -> m a throwExceptT = exceptT throwM return - - ------------ -- Monads -- ------------