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

BUGFIX: schoolField working after SchoolId refactoring

Browse Source
This commit is contained in:
SJost 2018-09-06 13:29:25 +02:00
parent 0c10e7e0d9
commit 5feb6ff0f6
11 changed files with 82 additions and 63 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

4
config/submission-blacklist
View File

@ -8,5 +8,5 @@ $# Ignoriere rekursiv alle Ordner __MACOSX und ihren Inhalt
**/__MACOSX/*
**/__MACOSX/**/*
$# Ignoriere rekursiv alle Dateien .DS_Store
**/.DS_Store
$# Ignoriere rekursiv alle Dateien .DS_Store (Mac OS)
**/.DS_Store

2
messages/uniworx/de.msg
View File

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

4
src/Foundation.hs
View File

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

1
src/Handler/Course.hs
View File

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

71
src/Handler/Profile.hs
View File

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

2
src/Handler/Utils/Form.hs
View File

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

47
src/Handler/Utils/Table/Pagination.hs
View File

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

1
src/Model.hs
View File

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

6
src/Model/Types.hs
View File

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

2
src/Utils.hs
View File

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

5
src/Utils/Common.hs → src/Utils/TH.hs
View File

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