diff --git a/config/submission-blacklist b/config/submission-blacklist index 1027b869b..ad2a62ccf 100644 --- a/config/submission-blacklist +++ b/config/submission-blacklist @@ -8,5 +8,5 @@ $# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt **/__MACOSX/* **/__MACOSX/**/* -$# Ignoriere rekursiv alle Dateien .DS_Store -**/.DS_Store \ No newline at end of file +$# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS) +**/.DS_Store diff --git a/messages/uniworx/de.msg b/messages/uniworx/de.msg index 35914e8ca..f68710517 100644 --- a/messages/uniworx/de.msg +++ b/messages/uniworx/de.msg @@ -114,7 +114,7 @@ Done: Eingereicht Submission: Abgabenummer SubmissionsCourse tid@TermId ssh@SchoolId courseShortHand@CourseShorthand: Alle Abgaben Kurs #{display tid}-#{display ssh}-#{courseShortHand} -SubmissionsSheet sheetName@SheetName: Abgaben für Blatt #{sheetName} +SubmissionsSheet sheetName@SheetName: Abgaben für #{sheetName} SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt. SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt. SubmissionEditHead tid@TermId ssh@SchoolId courseShortHand@CourseShorthand sheetName@SheetName: #{display tid}-#{display ssh}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen diff --git a/src/Foundation.hs b/src/Foundation.hs index 839a5f4e5..90371f955 100644 --- a/src/Foundation.hs +++ b/src/Foundation.hs @@ -126,8 +126,8 @@ data UniWorX = UniWorX -- http://www.yesodweb.com/book/scaffolding-and-the-site-template#scaffolding-and-the-site-template_foundation_and_application_modules -- -- This function also generates the following type synonyms: --- type Handler = HandlerT UniWorX IO --- type Widget = WidgetT UniWorX IO () +-- type Handler x = HandlerT UniWorX IO x +-- type Widget = WidgetT UniWorX IO () mkYesodData "UniWorX" $(parseRoutesFile "routes") -- | Convenient Type Synonyms: diff --git a/src/Handler/Course.hs b/src/Handler/Course.hs index 465c8f73f..f8bddf741 100644 --- a/src/Handler/Course.hs +++ b/src/Handler/Course.hs @@ -335,6 +335,7 @@ courseDeleteHandler = undefined courseEditHandler :: Bool -> Maybe (Entity Course) -> Handler Html courseEditHandler isGet course = do + $logDebug "€€€€€€ courseEditHandler started" aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!! ((result, formWidget), formEnctype) <- runFormPost . newCourseForm =<< for course courseToForm case result of diff --git a/src/Handler/Profile.hs b/src/Handler/Profile.hs index f5e448563..4bb62d344 100644 --- a/src/Handler/Profile.hs +++ b/src/Handler/Profile.hs @@ -14,12 +14,12 @@ module Handler.Profile where import Import import Handler.Utils - +import Utils.Lens -- import Colonnade hiding (fromMaybe, singleton) -- import Yesod.Colonnade import qualified Data.Map as Map import qualified Database.Esqueleto as E -import Database.Esqueleto ((^.)) +-- import Database.Esqueleto ((^.)) @@ -89,45 +89,45 @@ getProfileR = do (admin_rights,lecturer_rights,lecture_owner,lecture_corrector,participant,studies) <- runDB $ (,,,,,) <$> (E.select $ E.from $ \(adright `E.InnerJoin` school) -> do - E.where_ $ adright ^. UserAdminUser E.==. E.val uid - E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId - return (school ^. SchoolShorthand) + E.where_ $ adright E.^. UserAdminUser E.==. E.val uid + E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId + return (school E.^. SchoolShorthand) ) <*> (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do - E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid - E.on $ lecright ^. UserLecturerSchool E.==. school ^. SchoolId - return (school ^. SchoolShorthand) + E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid + E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId + return (school E.^. SchoolShorthand) ) <*> (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do - E.where_ $ lecturer ^. LecturerUser E.==. E.val uid - E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId - return (course ^. CourseTerm, course ^.CourseSchool, course ^. CourseShorthand) + E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid + E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId + return (course E.^. CourseTerm, course E.^.CourseSchool, course E.^. CourseShorthand) ) <*> (E.select $ E.from $ \(sheet `E.InnerJoin` corrector `E.InnerJoin` course) -> do - E.on $ sheet ^. SheetCourse E.==. course ^. CourseId - E.on $ sheet ^. SheetId E.==. corrector ^. SheetCorrectorSheet - E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid + E.on $ sheet E.^. SheetCourse E.==. course E.^. CourseId + E.on $ sheet E.^. SheetId E.==. corrector E.^. SheetCorrectorSheet + E.where_ $ corrector E.^. SheetCorrectorUser E.==. E.val uid - return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand) + return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand) ) <*> (E.select $ E.from $ \(participant `E.InnerJoin` course) -> do - E.where_ $ participant ^. CourseParticipantUser E.==. E.val uid - E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId - return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand, participant ^. CourseParticipantRegistration) + E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid + E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId + return (course E.^. CourseTerm, course E.^. CourseSchool, course E.^. CourseShorthand, participant E.^. CourseParticipantRegistration) ) <*> (E.select $ E.from $ \(studydegree `E.InnerJoin` studyfeat `E.InnerJoin` studyterms) -> do - E.where_ $ studyfeat ^. StudyFeaturesUser E.==. E.val uid - E.on $ studyfeat ^. StudyFeaturesField E.==. studyterms ^. StudyTermsId - E.on $ studyfeat ^. StudyFeaturesDegree E.==. studydegree ^. StudyDegreeId - return (studydegree ^. StudyDegreeName - ,studyterms ^. StudyTermsName - ,studyfeat ^. StudyFeaturesType - ,studyfeat ^. StudyFeaturesSemester) + E.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid + E.on $ studyfeat E.^. StudyFeaturesField E.==. studyterms E.^. StudyTermsId + E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId + return (studydegree E.^. StudyDegreeName + ,studyterms E.^. StudyTermsName + ,studyfeat E.^. StudyFeaturesType + ,studyfeat E.^. StudyFeaturesSemester) ) let formText = Just MsgSettings actionUrl = ProfileR @@ -149,20 +149,23 @@ getProfileDataR = do (uid, User{..}) <- requireAuthPair -- mr <- getMessageRender + -- Tabelle mit eigenen Kursen -- Tabelle mit allen Teilnehmer: Kurs (link), Datum - ((), courseTable :: Widget) <- do - let courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a) - courseCol = sortable (Just "course") (i18nCell MsgCourse) $ - \DBRow{ dbrOutput = (Entity {entityVal=Course{..}}, _participant) } -> - anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) - (citext2widget courseName) - courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) - -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant)) + courseTable <- do + let -- should be inlined + -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a) + courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad + Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^. + -- "preview _left" in order to match Either (result is Maybe) + return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR) + (citext2widget courseName) + --courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant))) + -- -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant)) courseData = \(course `E.InnerJoin` participant) -> do E.on $ course E.^. CourseId E.==. participant E.^. CourseParticipantCourse E.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid return (course, participant) - dbTable def $ DBTable + dbTableWidget' def $ DBTable { dbtIdent = "courseMembership" :: Text , dbtSQLQuery = courseData , dbtColonnade = mconcat diff --git a/src/Handler/Utils/Form.hs b/src/Handler/Utils/Form.hs index fbb5ed22c..d15febb46 100644 --- a/src/Handler/Utils/Form.hs +++ b/src/Handler/Utils/Form.hs @@ -227,7 +227,7 @@ schoolFieldEnt :: Field Handler (Entity School) schoolFieldEnt = selectField $ optionsPersist [] [Asc SchoolName] schoolName schoolFieldFor :: [SchoolId] -> Field Handler SchoolId -schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolId <-. userSchools] [Asc SchoolName] schoolName +schoolFieldFor userSchools = selectField $ optionsPersistKey [SchoolShorthand <-. map unSchoolKey userSchools] [Asc SchoolName] schoolName zipFileField :: Bool -- ^ Unpack zips? -> Field Handler (Source Handler File) diff --git a/src/Handler/Utils/Table/Pagination.hs b/src/Handler/Utils/Table/Pagination.hs index 515427664..c550356d1 100644 --- a/src/Handler/Utils/Table/Pagination.hs +++ b/src/Handler/Utils/Table/Pagination.hs @@ -21,7 +21,7 @@ module Handler.Utils.Table.Pagination ( SortColumn(..), SortDirection(..) , FilterColumn(..), IsFilterColumn - , DBRow(..) + , DBRow(..), HasDBRow(..) , DBStyle(..), DBEmptyStyle(..) , DBTable(..), IsDBTable(..), DBCell(..) , cellAttrs, cellContents @@ -31,6 +31,7 @@ module Handler.Utils.Table.Pagination , restrictFilter, restrictSorting , ToSortable(..), Sortable(..), sortable , dbTable + , dbTableWidget, dbTableWidget' , widgetColonnade, formColonnade, dbColonnade , cell, textCell, stringCell, i18nCell , anchorCell, anchorCell', anchorCellM @@ -163,6 +164,22 @@ piIsUnset PaginationInput{..} = and , not piShortcircuit ] +data DBRow r = DBRow + { dbrOutput :: r + , dbrIndex, dbrCount :: Int64 + } deriving (Show, Read, Eq, Ord) + +makeClassy_ ''DBRow + +instance Functor DBRow where + fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } + +instance Foldable DBRow where + foldMap f DBRow{..} = f dbrOutput + +instance Traversable DBRow where + traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount + newtype PSValidator m x = PSValidator { runPSValidator :: DBTable m x -> Maybe PaginationInput -> ([SomeMessage UniWorX], PaginationSettings) } instance Default (PSValidator m x) where @@ -206,19 +223,6 @@ restrictSorting restrict (runPSValidator -> f) = PSValidator $ \dbTable ps -> ov where restrict' p = p { psSorting = filter (uncurry restrict) $ psSorting p } -data DBRow r = DBRow - { dbrOutput :: r - , dbrIndex, dbrCount :: Int64 - } deriving (Show, Read, Eq, Ord) - -instance Functor DBRow where - fmap f DBRow{..} = DBRow{ dbrOutput = f dbrOutput, .. } - -instance Foldable DBRow where - foldMap f DBRow{..} = f dbrOutput - -instance Traversable DBRow where - traverse f DBRow{..} = DBRow <$> f dbrOutput <*> pure dbrIndex <*> pure dbrCount data DBEmptyStyle = DBESNoHeading | DBESHeading deriving (Enum, Bounded, Ord, Eq, Show, Read) @@ -262,8 +266,8 @@ class (MonadHandler m, Monoid x, Monoid (DBCell m x)) => IsDBTable (m :: * -> *) dbCell :: Iso' (DBCell m x) ([(Text, Text)], WriterT x m Widget) -- dbWidget :: Proxy m -> Proxy x -> Iso' (DBResult m x) (Widget, DBResult' m x) - dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget - dbHandler :: forall m'. (MonadHandler m' , HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) + dbWidget :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> DBResult m x -> m' Widget + dbHandler :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => DBTable m x -> (Widget -> Widget) -> DBResult m x -> m' (DBResult m x) runDBTable :: forall m'. (MonadHandler m', HandlerSite m' ~ UniWorX) => m (x, Widget) -> ReaderT SqlBackend m' (DBResult m x) cellAttrs :: IsDBTable m x => Lens' (DBCell m x) [(Text, Text)] @@ -453,7 +457,12 @@ dbTable PSValidator{..} dbtable@(DBTable{ dbtIdent = (toPathPiece -> dbtIdent), setParam :: Text -> Maybe Text -> QueryText -> QueryText setParam key v qt = (key, v) : [ i | i@(key', _) <- qt, key' /= key ] ---- DBCell utility functions +dbTableWidget :: Monoid x => PSValidator (HandlerT UniWorX IO) x -> DBTable (HandlerT UniWorX IO) x + -> Handler (DBResult (HandlerT UniWorX IO) x) +dbTableWidget = dbTable + +dbTableWidget' :: PSValidator (HandlerT UniWorX IO) () -> DBTable (HandlerT UniWorX IO) () -> Handler Widget +dbTableWidget' = fmap (fmap snd) . dbTable widgetColonnade :: (Headedness h, Monoid x) => Colonnade h r (DBCell (HandlerT UniWorX IO) x) @@ -470,6 +479,9 @@ dbColonnade :: (Headedness h, Monoid x) -> Colonnade h r (DBCell (ReaderT SqlBackend (HandlerT UniWorX IO)) x) dbColonnade = id + +--- DBCell utility functions + cell :: IsDBTable m a => Widget -> DBCell m a cell wgt = dbCell # ([], return wgt) @@ -528,6 +540,7 @@ formCell genIndex genForm input = FormCell return (DBFormResult . Map.singleton i . (input,) <$> edit, w) } + -- Predefined colonnades dbRow :: forall h r m a. (Headedness h, IsDBTable m a) => Colonnade h (DBRow r) (DBCell m a) diff --git a/src/Model.hs b/src/Model.hs index 10fc4733e..f57f39a7c 100644 --- a/src/Model.hs +++ b/src/Model.hs @@ -24,6 +24,7 @@ import Model.Types import Data.Aeson.TH import Data.CaseInsensitive (CI) +import Data.CaseInsensitive.Instances () -- You can define all of your database entities in the entities file. -- You can find more information on persistent and how to declare entities diff --git a/src/Model/Types.hs b/src/Model/Types.hs index 959432f68..a84f6ba7a 100644 --- a/src/Model/Types.hs +++ b/src/Model/Types.hs @@ -49,7 +49,7 @@ import Data.Aeson (FromJSON(..), ToJSON(..), withText, Value(..)) import Data.Aeson.TH (deriveJSON, defaultOptions, Options(..)) import GHC.Generics (Generic) -import Generics.Deriving.Monoid (gmemptydefault, gmappenddefault) +import Generics.Deriving.Monoid (memptydefault, mappenddefault) import Data.Typeable (Typeable) @@ -115,8 +115,8 @@ data SheetTypeSummary = SheetTypeSummary } deriving (Generic) instance Monoid SheetTypeSummary where - mempty = gmemptydefault - mappend = gmappenddefault + mempty = memptydefault + mappend = mappenddefault sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary sheetTypeSum (Bonus{..}, achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved } diff --git a/src/Utils.hs b/src/Utils.hs index 5dae9d28a..e472e72ca 100644 --- a/src/Utils.hs +++ b/src/Utils.hs @@ -21,7 +21,7 @@ import Data.CaseInsensitive (CI) import qualified Data.CaseInsensitive as CI import Utils.DB as Utils -import Utils.Common as Utils +import Utils.TH as Utils import Utils.DateTime as Utils import Utils.PathPiece as Utils diff --git a/src/Utils/Common.hs b/src/Utils/TH.hs similarity index 98% rename from src/Utils/Common.hs rename to src/Utils/TH.hs index 0bb828291..04eebdfa2 100644 --- a/src/Utils/Common.hs +++ b/src/Utils/TH.hs @@ -1,7 +1,7 @@ {-# LANGUAGE TemplateHaskell #-} {-# LANGUAGE QuasiQuotes #-} -module Utils.Common where +module Utils.TH where -- Common Utility Functions that require TemplateHaskell -- import Data.Char @@ -17,13 +17,14 @@ import Language.Haskell.TH ------------ -- Alternatively uses lenses: "^. _3" projects the 3rd component of an n-tuple for any n >=3, requires import Control.Lens +{- projNI :: Int -> Int -> ExpQ -- generic projection gives I-th element of N-tuple, i.e. snd3 = $(projNI 3 2) --ghci -fth -- $(projN n m) :: (t1,..,tn) -> tm (for m<=n) projNI n i = lamE [pat] rhs where pat = tupP (map varP xs) rhs = varE (xs !! (i - 1)) xs = [ mkName $ "x" ++ show j | j <- [1..n] ] - +-} --------------- -- Functions --