feat(schools): implement cru

messages/uniworx/de.msg

@@ -1031,6 +1031,8 @@ MenuExamAddMembers: Prüfungsteilnehmer hinzufügen
 MenuLecturerInvite: Dozenten hinzufügen
 MenuAllocationInfo: Hinweise zum Ablauf einer Zentralanmeldung
 MenuCourseApplicationsFiles: Dateien aller Bewerbungen
+MenuSchoolList: Institute
+MenuSchoolNew: Neues Institut anlegen
 
 AuthPredsInfo: Um eigene Veranstaltungen aus Sicht der Teilnehmer anzusehen, können Veranstalter und Korrektoren hier die Prüfung ihrer erweiterten Berechtigungen temporär deaktivieren. Abgewählte Prädikate schlagen immer fehl. Abgewählte Prädikate werden also nicht geprüft um Zugriffe zu gewähren, welche andernfalls nicht erlaubt wären. Diese Einstellungen gelten nur temporär bis Ihre Sitzung abgelaufen ist, d.h. bis ihr Browser-Cookie abgelaufen ist. Durch Abwahl von Prädikaten kann man sich höchstens temporär aussperren.
 AuthPredsActive: Aktive Authorisierungsprädikate
@@ -1562,4 +1564,13 @@ CourseApplicationNoRatingPoints: Keine Bewertung
 CourseApplicationNoRatingComment: Kein Kommentar
 
 UserDisplayName: Voller Name
-UserMatriculation: Matrikelnummer
+UserMatriculation: Matrikelnummer
+
+SchoolShort: Kürzel
+SchoolName: Name
+
+SchoolUpdated ssh@SchoolId: #{ssh} erfolgreich angepasst
+SchoolTitle ssh@SchoolId: Institut „#{ssh}“
+TitleSchoolNew: Neues Institut anlegen
+SchoolCreated ssh@SchoolId: #{ssh} erfolgreich angelegt
+SchoolExists ssh@SchoolId: Institut „#{ssh}“ existiert bereits

routes

@@ -78,8 +78,9 @@
 !/term/#TermId             TermCourseListR     GET             !free
 !/term/#TermId/#SchoolId   TermSchoolCourseListR  GET          !free
 
-/school                    SchoolListR         GET             !development
-/school/#SchoolId          SchoolShowR         GET             !development
+/school                    SchoolListR         GET
+!/school/new               SchoolNewR          GET POST
+/school/#SchoolId          SchoolShowR         GET POST
 
 /allocation/               AllocationListR     GET             !free
 /allocation/#TermId/#SchoolId/#AllocationShorthand AllocationR:

src/Foundation.hs

@@ -1723,6 +1723,10 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb AdminFeaturesR   = return ("Test"         , Just AdminR)
   breadcrumb AdminTestR       = return ("Test"         , Just AdminR)
   breadcrumb AdminErrMsgR     = return ("Test"         , Just AdminR)
+  
+  breadcrumb SchoolListR      = return ("Institute"    , Just AdminR)
+  breadcrumb (SchoolShowR ssh) = return (original (unSchoolKey ssh), Just SchoolListR)
+  breadcrumb SchoolNewR       = return ("Neu"          , Just SchoolListR)
 
   breadcrumb InfoR            = return ("Information"  , Nothing)
   breadcrumb InfoLecturerR    = return ("Veranstalter" , Just InfoR)
@@ -1996,6 +2000,14 @@ pageActions (HomeR) =
   ]
 pageActions (AdminR) =
   [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuSchoolList
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute SchoolListR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  , MenuItem
       { menuItemType  = PageActionPrime
       , menuItemLabel = MsgAdminFeaturesHeading
       , menuItemIcon  = Nothing
@@ -2028,6 +2040,16 @@ pageActions (AdminR) =
       , menuItemAccessCallback' = return True
       }
   ]
+pageActions (SchoolListR) =
+  [ MenuItem
+      { menuItemType  = PageActionPrime
+      , menuItemLabel = MsgMenuSchoolNew
+      , menuItemIcon  = Nothing
+      , menuItemRoute = SomeRoute SchoolNewR
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
+  ]
 pageActions (UsersR) =
   [ MenuItem
       { menuItemType  = PageActionPrime

src/Handler/Course/Application/List.hs

@@ -525,6 +525,7 @@ postCApplicationsR tid ssh csh = do
 
       psValidator :: PSValidator _ _
       psValidator = def
+        & defaultSorting [SortAscBy "user-name"]
 
     dbTableWidget' psValidator DBTable{..}
 

src/Handler/School.hs

@@ -1,10 +1,133 @@
 module Handler.School where
 
 import Import
+import Handler.Utils
+import Handler.Utils.Table.Columns
+
+import qualified Database.Esqueleto as E
 
 getSchoolListR :: Handler Html
-getSchoolListR = error "getSchoolListR: Not implemented"
+getSchoolListR = do
+  let
+    schoolLink :: SchoolId -> SomeRoute UniWorX
+    schoolLink ssh = SomeRoute $ SchoolShowR ssh
+    
+    dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
+    dbtSQLQuery = return
 
-getSchoolShowR :: SchoolId -> Handler Html
-getSchoolShowR = error "getSchoolShowR: Not implemented"
+    dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School))
+    dbtProj = return
 
+    dbtRowKey = (E.^. SchoolId)
+
+    dbtColonnade :: Colonnade Sortable _ _
+    dbtColonnade = mconcat
+      [ colSchoolShort $ _dbrOutput . _entityKey
+      , anchorColonnade (views (_dbrOutput . _entityKey) schoolLink) $ colSchoolName (_dbrOutput . _entityVal . _schoolName)
+      ]
+
+    dbtSorting = mconcat
+      [ sortSchoolShort $ to (E.^. SchoolId)
+      , sortSchoolName $ to (E.^. SchoolName)
+      ]
+
+    dbtFilter = mempty
+    dbtFilterUI = mempty
+
+    dbtStyle = def
+    dbtParams = def
+
+    dbtCsvEncode = noCsvEncode
+    dbtCsvDecode = Nothing
+
+    dbtIdent :: Text
+    dbtIdent = "schools"
+
+    psValidator = def
+      & defaultSorting [SortAscBy "school-name"]
+    
+
+  table <- runDB $ dbTableWidget' psValidator DBTable{..}
+
+  let title = MsgMenuSchoolList
+  siteLayoutMsg title $ do
+    setTitleI title
+    table
+
+data SchoolForm = SchoolForm
+  { sfShorthand :: CI Text
+  , sfName :: CI Text
+  }
+
+mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
+mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
+  <$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
+  <*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
+
+schoolToForm :: SchoolId -> DB (Form SchoolForm)
+schoolToForm ssh = do
+  School{..} <- get404 ssh
+  return . mkSchoolForm (Just ssh) $ Just SchoolForm
+    { sfShorthand = schoolShorthand
+    , sfName = schoolName
+    }
+
+
+getSchoolShowR, postSchoolShowR :: SchoolId -> Handler Html
+getSchoolShowR = postSchoolShowR
+postSchoolShowR ssh = do
+  sForm <- runDB $ schoolToForm ssh
+  
+  ((sfResult, sfView), sfEnctype) <- runFormPost sForm
+
+  formResult sfResult $ \SchoolForm{..} -> do
+    runDB $ do
+      update ssh [ SchoolName =. sfName ]
+      addMessageI Success $ MsgSchoolUpdated ssh
+    redirect $ SchoolShowR ssh
+
+  let sfView' = wrapForm sfView FormSettings
+        { formMethod = POST
+        , formAction = Just . SomeRoute $ SchoolShowR ssh
+        , formEncoding = sfEnctype
+        , formAttrs = []
+        , formSubmit = FormSubmit
+        , formAnchor = Nothing :: Maybe Text
+        }
+
+  siteLayoutMsg (MsgSchoolTitle ssh) $ do
+    setTitleI $ MsgSchoolTitle ssh
+    sfView'
+
+getSchoolNewR, postSchoolNewR :: Handler Html
+getSchoolNewR = postSchoolNewR
+postSchoolNewR = do
+  ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing
+
+  formResult sfResult $ \SchoolForm{..} -> do
+    let ssh = SchoolKey sfShorthand
+    insertOkay <- runDB $ do
+      fmap (is _Just) $ insertUnique School
+        { schoolShorthand = sfShorthand
+        , schoolName = sfName
+        }
+
+    if
+      | insertOkay -> do
+          addMessageI Success $ MsgSchoolCreated ssh
+          redirect $ SchoolShowR ssh
+      | otherwise
+        -> addMessageI Error $ MsgSchoolExists ssh
+
+  let sfView' = wrapForm sfView FormSettings
+        { formMethod = POST
+        , formAction = Just $ SomeRoute SchoolNewR
+        , formEncoding = sfEnctype
+        , formAttrs = []
+        , formSubmit = FormSubmit
+        , formAnchor = Nothing :: Maybe Text
+        }
+
+  siteLayoutMsg MsgTitleSchoolNew $ do
+    setTitleI MsgTitleSchoolNew
+    sfView'

src/Handler/Utils/Table/Columns.hs

@@ -102,8 +102,8 @@ fltrTermUI mPrev = prismAForm (singletonFilter "term" . maybePrism _PathPiece) m
 -- Schools --
 -------------
 
-colSchoolShort :: OpticColonnade SchoolId
-colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
+colSchool :: OpticColonnade SchoolId
+colSchool resultSsh = Colonnade.singleton (fromSortable header) body
   where
     header = Sortable (Just "school") (i18nCell MsgSchool)
     body = i18nCell . unSchoolKey . view resultSsh
@@ -111,6 +111,24 @@ colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
 sortSchool :: OpticSortColumn SchoolId
 sortSchool querySsh = singletonMap "school" . SortColumn $ view querySsh
 
+colSchoolShort :: OpticColonnade SchoolId
+colSchoolShort resultSsh = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "school-short") (i18nCell MsgSchoolShort)
+    body = i18nCell . unSchoolKey . view resultSsh
+
+sortSchoolShort :: OpticSortColumn SchoolId
+sortSchoolShort querySsh = singletonMap "school-short" . SortColumn $ view querySsh
+  
+colSchoolName :: OpticColonnade SchoolName
+colSchoolName resultSn = Colonnade.singleton (fromSortable header) body
+  where
+    header = Sortable (Just "school-name") (i18nCell MsgSchoolName)
+    body = i18nCell . view resultSn
+
+sortSchoolName :: OpticSortColumn SchoolName
+sortSchoolName querySn = singletonMap "school-name" . SortColumn $ view querySn
+  
 fltrSchool :: OpticFilterColumn t SchoolId
 fltrSchool querySsh = singletonMap "school" . FilterColumn $ mkExactFilter (view querySsh)
 

src/Utils/Lens.hs

@@ -167,6 +167,8 @@ makeLenses_ ''Allocation
 
 makeLenses_ ''File
 
+makeLenses_ ''School
+
 
 -- makeClassy_ ''Load