BUGFIX: schoolField working after SchoolId refactoring

config/submission-blacklist

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

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

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 Handler x = HandlerT UniWorX IO x
--- type Widget  = WidgetT  UniWorX IO ()
+-- type Widget    = WidgetT  UniWorX IO ()
 mkYesodData "UniWorX" $(parseRoutesFile "routes")
 
 -- | Convenient Type Synonyms:

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

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.where_ $ adright E.^. UserAdminUser E.==. E.val uid
-                E.on $ adright ^. UserAdminSchool E.==. school ^. SchoolId
+                E.on $ adright E.^. UserAdminSchool E.==. school E.^. SchoolId
-                return (school ^. SchoolShorthand)
+                return (school E.^. SchoolShorthand)
             )
             <*>
             (E.select $ E.from $ \(lecright `E.InnerJoin` school) -> do
-                E.where_ $ lecright ^. UserLecturerUser E.==. E.val uid
+                E.where_ $ lecright E.^. UserLecturerUser E.==. E.val uid
-                E.on $ lecright ^. UserLecturerSchool E.==. school ^. SchoolId
+                E.on $ lecright E.^. UserLecturerSchool E.==. school E.^. SchoolId
-                return (school ^. SchoolShorthand)
+                return (school E.^. SchoolShorthand)
             )
             <*>
             (E.select $ E.from $ \(lecturer `E.InnerJoin` course) -> do
-                E.where_ $ lecturer ^. LecturerUser E.==. E.val uid
+                E.where_ $ lecturer E.^. LecturerUser E.==. E.val uid
-                E.on $ lecturer ^. LecturerCourse E.==. course ^. CourseId
+                E.on $ lecturer E.^. LecturerCourse E.==. course E.^. CourseId
-                return (course ^. CourseTerm, course ^.CourseSchool, course ^. CourseShorthand)
+                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 E.^. SheetCourse E.==. course    E.^. CourseId
-                E.on $ sheet ^. SheetId     E.==. corrector ^. SheetCorrectorSheet
+                E.on $ sheet E.^. SheetId     E.==. corrector E.^. SheetCorrectorSheet
-                E.where_ $ corrector ^. SheetCorrectorUser E.==. E.val uid
+                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.where_ $ participant E.^. CourseParticipantUser E.==. E.val uid
-                E.on $ participant ^. CourseParticipantCourse E.==. course ^. CourseId
+                E.on $ participant E.^. CourseParticipantCourse E.==. course E.^. CourseId
-                return (course ^. CourseTerm, course ^. CourseSchool, course ^. CourseShorthand, participant ^. CourseParticipantRegistration)
+                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.where_ $ studyfeat E.^. StudyFeaturesUser E.==. E.val uid
-                E.on $ studyfeat ^. StudyFeaturesField  E.==. studyterms  ^. StudyTermsId
+                E.on $ studyfeat E.^. StudyFeaturesField  E.==. studyterms  E.^. StudyTermsId
-                E.on $ studyfeat ^. StudyFeaturesDegree E.==. studydegree ^. StudyDegreeId
+                E.on $ studyfeat E.^. StudyFeaturesDegree E.==. studydegree E.^. StudyDegreeId
-                return  (studydegree ^. StudyDegreeName
+                return  (studydegree E.^. StudyDegreeName
-                        ,studyterms  ^. StudyTermsName
+                        ,studyterms  E.^. StudyTermsName
-                        ,studyfeat   ^. StudyFeaturesType
+                        ,studyfeat   E.^. StudyFeaturesType
-                        ,studyfeat   ^. StudyFeaturesSemester)
+                        ,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
+  courseTable <- do
-        let courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a)
+        let -- should be inlined
-            courseCol = sortable (Just "course") (i18nCell MsgCourse) $
+            -- courseCol :: IsDBTable m a => Colonnade Sortable (DBRow (Entity Course, Entity CourseParticipant)) (DBCell m a)
-                \DBRow{ dbrOutput = (Entity {entityVal=Course{..}}, _participant) } ->
+            courseCol = sortable (Just "course") (i18nCell MsgCourse) $ do -- (->) a Monad
-                anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
+              Course{..} <- view $ _dbrOutput . _1 . _entityVal -- view == ^.
-                           (citext2widget courseName)
+              -- "preview _left" in order to match Either (result is Maybe)
-            courseData :: (E.InnerJoin (E.SqlExpr (Entity Course)) (E.SqlExpr (Entity CourseParticipant)))
+              return $ anchorCell (CourseR courseTerm courseSchool courseShorthand CShowR)
-                            -> E.SqlQuery (E.SqlExpr (Entity Course), E.SqlExpr (Entity CourseParticipant))
+                                  (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

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)

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

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

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
+  mempty = memptydefault
-  mappend = gmappenddefault
+  mappend = mappenddefault
 
 sheetTypeSum :: (SheetType, Maybe Points) -> SheetTypeSummary
 sheetTypeSum (Bonus{..},  achieved) = mempty { sumBonusPoints = Sum maxPoints, achievedBonus = Sum <$> achieved }

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
 

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