Merge branch 'master' into 284-massinput

messages/uniworx/de.msg

@@ -7,6 +7,7 @@ BtnHijack: Sitzung übernehmen
 
 Aborted: Abgebrochen
 Registered: Angemeldet
+RegisteredSince date@Text: Angemeldet seit #{date}
 RegisterFrom: Anmeldungen von
 RegisterTo: Anmeldungen bis
 DeRegUntil: Abmeldungen bis
@@ -108,7 +109,7 @@ SheetSolutionFrom: Lösung ab
 SheetMarking: Hinweise für Korrektoren
 SheetType: Wertung
 SheetInvisible: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar!
-SheetInvisibleUntil mFrom@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{mFrom}!
+SheetInvisibleUntil date@Text: Dieses Übungsblatt ist für Teilnehmer momentan unsichtbar bis #{date}!
 SheetName: Name
 SheetDescription: Hinweise für Teilnehmer
 SheetGroup: Gruppenabgabe
@@ -570,13 +571,14 @@ MenuSheetNew: Neues Übungsblatt anlegen
 MenuSheetCurrent: Aktuelles Übungsblatt
 MenuSheetOldUnassigned: Abgaben ohne Korrektor
 MenuCourseEdit: Kurs editieren
-MenuCourseNewTemplate: Als neuen Kurs klonen
+MenuCourseClone: Als neuen Kurs klonen
 MenuCourseDelete: Kurs löschen
 MenuSubmissionNew: Abgabe anlegen
 MenuSubmissionOwn: Abgabe
 MenuCorrectors: Korrektoren
 MenuSheetEdit: Übungsblatt editieren
 MenuSheetDelete: Übungsblatt löschen
+MenuSheetClone:  Als neues Übungsblatt klonen
 MenuCorrectionsUpload: Korrekturen hochladen
 MenuCorrectionsCreate: Abgaben registrieren
 MenuCorrectionsGrade: Abgaben bewerten

routes

@@ -72,9 +72,9 @@
   /notes                      CNotesR         GET POST        !corrector
   /subs                       CCorrectionsR   GET POST
   /ex                         SheetListR      GET             !registered !materials !corrector
-  !/ex/new                    SheetNewR       GET POST
+  /ex/new                     SheetNewR       GET POST
-  !/ex/current                 SheetCurrentR   GET             !free -- just a redirect
+  /ex/current                 SheetCurrentR   GET             !registered !materials !corrector
-  !/ex/lastinactive            SheetOldUnassigned GET          !free -- just a redirect
+  /ex/unassigned              SheetOldUnassigned GET
   /ex/#SheetName SheetR:
     /show                       SShowR        GET             !timeANDregistered !timeANDmaterials !corrector
     /edit                       SEditR        GET POST

src/Auth/Dummy.hs

@@ -14,15 +14,14 @@ import qualified Data.CaseInsensitive as CI
 
 data DummyMessage = MsgDummyIdent
                   | MsgDummyNoFormData
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
 dummyForm :: ( RenderMessage site FormMessage
              , RenderMessage site DummyMessage
-             , RenderMessage site ButtonMessage
              , YesodPersist site
              , SqlBackendCanRead (YesodPersistBackend site)
-             , Button site SubmitButton
+             , Button site ButtonSubmit
-             , Show (ButtonCssClass site)
              ) => AForm (HandlerT site IO) (CI Text)
 dummyForm = areq (selectField userList) (fslI MsgDummyIdent) Nothing
          <* submitButton
@@ -35,9 +34,7 @@ dummyLogin :: ( YesodAuth site
               , SqlBackendCanRead (YesodPersistBackend site)
               , RenderMessage site FormMessage
               , RenderMessage site DummyMessage
-              , RenderMessage site ButtonMessage
+              , Button site ButtonSubmit
-              , Button site SubmitButton
-              , Show (ButtonCssClass site)
               ) => AuthPlugin site
 dummyLogin = AuthPlugin{..}
   where

src/Auth/LDAP.hs

@@ -28,13 +28,14 @@ import qualified Yesod.Auth.Message as Msg
 data CampusLogin = CampusLogin
   { campusIdent :: CI Text
   , campusPassword :: Text
-  }
+  } deriving (Generic, Typeable)
 
 data CampusMessage = MsgCampusIdentNote
                    | MsgCampusIdent
                    | MsgCampusPassword
                    | MsgCampusSubmit
                    | MsgCampusInvalidCredentials
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
   
 
 findUser :: LdapConf -> Ldap -> Text -> [Ldap.Attr] -> IO [Ldap.SearchEntry]
@@ -53,9 +54,7 @@ userPrincipalName = Ldap.Attr "userPrincipalName"
 
 campusForm :: ( RenderMessage site FormMessage
               , RenderMessage site CampusMessage
-              , RenderMessage site ButtonMessage
+              , Button site ButtonSubmit
-              , Button site SubmitButton
-              , Show (ButtonCssClass site)
               ) => AForm (HandlerT site IO) CampusLogin
 campusForm = CampusLogin
   <$> areq ciField (fslpI MsgCampusIdent "user.name@campus.lmu.de" & setTooltip MsgCampusIdentNote) Nothing
@@ -66,9 +65,7 @@ campusLogin :: forall site.
                ( YesodAuth site
                , RenderMessage site FormMessage
                , RenderMessage site CampusMessage
-               , RenderMessage site ButtonMessage
+               , Button site ButtonSubmit
-               , Button site SubmitButton
-               , Show (ButtonCssClass site)
                ) => LdapConf -> LdapPool -> AuthPlugin site
 campusLogin conf@LdapConf{..} pool = AuthPlugin{..}
   where
@@ -116,7 +113,7 @@ data CampusUserException = CampusUserLdapError LdapPoolError
                          | CampusUserHostCannotConnect String [IOException]
                          | CampusUserNoResult
                          | CampusUserAmbiguous
-  deriving (Show, Eq, Typeable)
+  deriving (Show, Eq, Generic, Typeable)
 
 instance Exception CampusUserException
 

src/Auth/PWHash.hs

@@ -19,17 +19,16 @@ import qualified Yesod.Auth.Message as Msg
 data HashLogin = HashLogin
   { hashIdent :: CI Text
   , hashPassword :: Text
-  }
+  } deriving (Generic, Typeable)
 
 data PWHashMessage = MsgPWHashIdent
                    | MsgPWHashPassword
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
 
 hashForm :: ( RenderMessage site FormMessage
             , RenderMessage site PWHashMessage
-            , RenderMessage site ButtonMessage
+            , Button site ButtonSubmit
-            , Button site SubmitButton
-            , Show (ButtonCssClass site)
             ) => AForm (HandlerT site IO) HashLogin
 hashForm = HashLogin
   <$> areq ciField (fslpI MsgPWHashIdent "Identifikation") Nothing
@@ -42,9 +41,7 @@ hashLogin :: ( YesodAuth site
              , SqlBackendCanRead (YesodPersistBackend site)
              , RenderMessage site FormMessage
              , RenderMessage site PWHashMessage
-             , RenderMessage site ButtonMessage
+             , Button site ButtonSubmit
-             , Button site SubmitButton
-             , Show (ButtonCssClass site)
              ) => PWHashAlgorithm -> AuthPlugin site
 hashLogin pwHashAlgo = AuthPlugin{..}
   where

src/Foundation.hs

@@ -276,13 +276,28 @@ menuItemAccessCallback MenuItem{..} = and2M ((==) Authorized <$> authCheck) menu
 $(return [])
 
 
-data instance ButtonCssClass UniWorX = BCDefault | BCPrimary | BCSuccess | BCInfo | BCWarning | BCDanger | BCLink
+data instance ButtonClass UniWorX
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  = BCIsButton
+  | BCDefault
+  | BCPrimary
+  | BCSuccess
+  | BCInfo
+  | BCWarning
+  | BCDanger
+  | BCLink
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe (ButtonClass UniWorX)
+instance Finite (ButtonClass UniWorX)
 
-instance Button UniWorX SubmitButton where
+instance PathPiece (ButtonClass UniWorX) where
-  label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
+  toPathPiece BCIsButton = "btn"
+  toPathPiece bClass = ("btn-" <>) . camelToPathPiece' 1 $ tshow bClass
+  fromPathPiece = finiteFromPathPiece
 
-  cssClass BtnSubmit = BCPrimary
+
+embedRenderMessage ''UniWorX ''ButtonSubmit id
+instance Button UniWorX ButtonSubmit where
+  btnClasses BtnSubmit = [BCIsButton, BCPrimary]
 
 
 getTimeLocale' :: [Lang] -> TimeLocale
@@ -463,12 +478,22 @@ tagAccessPredicate AuthTime = APDB $ \route _ -> case route of
 
     return Authorized
 
-  CourseR tid ssh csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
+  CourseR tid ssh csh CRegisterR -> do
-    Entity _ Course{courseRegisterFrom, courseRegisterTo} <- MaybeT . getBy $ TermSchoolCourseShort tid ssh csh
+    mbc <- getBy $ TermSchoolCourseShort tid ssh csh
+    mAid <- lift maybeAuthId
+    registered <- case (mbc,mAid) of
+      (Just (Entity cid _), Just uid) -> isJust <$> (getBy $ UniqueParticipant uid cid)
+      _ -> return False
     cTime <- (NTop . Just) <$> liftIO getCurrentTime
-    guard $ NTop courseRegisterFrom <= cTime
+    case mbc of
-         && NTop courseRegisterTo   >= cTime
+      (Just (Entity _ Course{courseRegisterFrom, courseRegisterTo}))
-    return Authorized
+        | not registered
+        , courseRegisterFrom <= nBot cTime
+        , NTop courseRegisterTo   >= cTime -> return Authorized
+      (Just (Entity _ Course{courseDeregisterUntil}))
+        | registered
+        , NTop courseDeregisterUntil >= cTime -> return Authorized
+      _other -> unauthorizedI MsgUnauthorizedCourseTime
 
   MessageR cID -> maybeT (unauthorizedI MsgUnauthorizedSystemMessageTime) $ do
     smId <- decrypt cID
@@ -1265,8 +1290,8 @@ pageActions (CourseR tid ssh csh CShowR) =
       }
   , MenuItem
       { menuItemType = PageActionSecondary
-      , menuItemLabel = MsgMenuCourseNewTemplate
+      , menuItemLabel = MsgMenuCourseClone
-      , menuItemIcon  = Nothing
+      , menuItemIcon  = Just "copy"
       , menuItemRoute = SomeRoute (CourseNewR, [("tid", toPathPiece tid), ("ssh", toPathPiece ssh), ("csh", toPathPiece csh)])
       , menuItemModal = False
       , menuItemAccessCallback' = return True
@@ -1274,7 +1299,7 @@ pageActions (CourseR tid ssh csh CShowR) =
   , MenuItem
       { menuItemType = PageActionSecondary
       , menuItemLabel = MsgMenuCourseDelete
-      , menuItemIcon = Nothing
+      , menuItemIcon = Just "trash"
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh CDeleteR
       , menuItemModal = False
       , menuItemAccessCallback' = return True
@@ -1287,21 +1312,9 @@ pageActions (CourseR tid ssh csh SheetListR) =
       , menuItemIcon  = Nothing
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetCurrentR
       , menuItemModal = False
-      , menuItemAccessCallback' = do
+      , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          now <- liftIO getCurrentTime
+          void . MaybeT $ sheetCurrent tid ssh csh
-          sheets <- runDB . E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+          return True
-            E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
-            E.where_ $ sheet E.^. SheetActiveTo   E.>.  E.val now
-                 E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
-                 E.&&. course E.^. CourseTerm      E.==. E.val tid
-                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
-                 E.&&. course E.^. CourseShorthand E.==. E.val csh
-            E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
-            E.limit 1
-            return $ sheet E.^. SheetName
-          case sheets of
-            (E.Value shn):_ -> (== Authorized) <$> isAuthorized (CSheetR tid ssh csh shn SShowR) False
-            _ -> return False
       }
   , MenuItem
       { menuItemType = PageActionPrime
@@ -1310,7 +1323,6 @@ pageActions (CourseR tid ssh csh SheetListR) =
       , menuItemRoute = SomeRoute $ CourseR tid ssh csh SheetOldUnassigned
       , menuItemModal = False
       , menuItemAccessCallback' = runDB . maybeT (return False) $ do
-          guardM $ (== Authorized) <$> evalAccessCorrector tid ssh csh
           void . MaybeT $ sheetOldUnassigned tid ssh csh
           return True
       }
@@ -1367,18 +1379,6 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
           guard $ null submissions
           return True
       }
-  , MenuItem
-      { menuItemType = PageActionPrime
-      , menuItemLabel = MsgMenuCorrectionsOwn
-      , menuItemIcon = Nothing
-      , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
-                                                 , ("corrections-school", CI.original $ unSchoolKey ssh)
-                                                 , ("corrections-course", CI.original csh)
-                                                 , ("corrections-sheet" , CI.original shn)
-                                                 ])
-      , menuItemModal = False
-      , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
-      }
   , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuSubmissionOwn
@@ -1391,6 +1391,18 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
           guard . not $ null submissions
           return True
       }
+  , MenuItem
+      { menuItemType = PageActionPrime
+      , menuItemLabel = MsgMenuCorrectionsOwn
+      , menuItemIcon = Nothing
+      , menuItemRoute = SomeRoute (CorrectionsR, [ ("corrections-term"  , termToText $ unTermKey tid)
+                                                 , ("corrections-school", CI.original $ unSchoolKey ssh)
+                                                 , ("corrections-course", CI.original csh)
+                                                 , ("corrections-sheet" , CI.original shn)
+                                                 ])
+      , menuItemModal = False
+      , menuItemAccessCallback' = (== Authorized) <$> evalAccessCorrector tid ssh csh
+      }
   , MenuItem
       { menuItemType = PageActionPrime
       , menuItemLabel = MsgMenuCorrectors
@@ -1415,10 +1427,18 @@ pageActions (CSheetR tid ssh csh shn SShowR) =
       , menuItemModal = False
       , menuItemAccessCallback' = return True
       }
+  , MenuItem
+      { menuItemType = PageActionSecondary
+      , menuItemLabel = MsgMenuSheetClone
+      , menuItemIcon = Just "copy"
+      , menuItemRoute = SomeRoute (CourseR tid ssh csh SheetNewR, [("shn", toPathPiece shn)])
+      , menuItemModal = False
+      , menuItemAccessCallback' = return True
+      }
   , MenuItem
       { menuItemType = PageActionSecondary
       , menuItemLabel = MsgMenuSheetDelete
-      , menuItemIcon = Nothing
+      , menuItemIcon = Just "trash"
       , menuItemRoute = SomeRoute $ CSheetR tid ssh csh shn SDelR
       , menuItemModal = False
       , menuItemAccessCallback' = return True

src/Handler/Admin.hs

@@ -13,8 +13,6 @@ import Control.Monad.Trans.Except
 -- import Data.Function ((&))
 -- import Yesod.Form.Bootstrap3
 
-import Web.PathPieces (showToPathPiece, readFromPathPiece)
-
 import Database.Persist.Sql (fromSqlKey)
 
 -- import Colonnade hiding (fromMaybe)
@@ -23,19 +21,19 @@ import Database.Persist.Sql (fromSqlKey)
 -- import qualified Data.UUID.Cryptographic as UUID
 
 -- BEGIN - Buttons needed only here
-data CreateButton = CreateMath | CreateInf  -- Dummy for Example
+data ButtonCreate = CreateMath | CreateInf  -- Dummy for Example
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonCreate
+instance Finite ButtonCreate
 
-instance PathPiece CreateButton where    -- for displaying the button only, not really for paths
+nullaryPathPiece ''ButtonCreate camelToPathPiece
-  toPathPiece   = showToPathPiece
-  fromPathPiece = readFromPathPiece
 
-instance Button UniWorX CreateButton where
+instance Button UniWorX ButtonCreate where
-  label CreateMath = [whamlet|Ma<i>thema</i>tik|]
+  btnLabel CreateMath = [whamlet|Ma<i>thema</i>tik|]
-  label CreateInf  = "Informatik"
+  btnLabel CreateInf  = "Informatik"
 
-  cssClass CreateMath = BCInfo
+  btnClasses CreateMath = [BCIsButton, BCInfo]
-  cssClass CreateInf  = BCPrimary
+  btnClasses CreateInf  = [BCIsButton, BCPrimary]
 -- END Button needed here
 
 emailTestForm :: AForm (HandlerT UniWorX IO) (Email, MailContext)
@@ -60,7 +58,7 @@ emailTestForm = (,)
 getAdminTestR, postAdminTestR :: Handler Html -- Demo Page. Referenzimplementierungen sollte hier gezeigt werden!
 getAdminTestR = postAdminTestR
 postAdminTestR = do
-  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form CreateButton)
+  ((btnResult, btnWdgt), btnEnctype) <- runFormPost $ identifyForm "buttons" (buttonForm :: Form ButtonCreate)
   case btnResult of
     (FormSuccess CreateInf)  -> addMessage Info "Informatik-Knopf gedrückt"
     (FormSuccess CreateMath) -> addMessage Warning "Knopf Mathematik erkannt"

src/Handler/Course.hs

@@ -259,25 +259,31 @@ getTermCourseListR tid = do
 getCShowR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getCShowR tid ssh csh = do
   mbAid <- maybeAuthId
-  (courseEnt,(schoolMB,participants,registered),lecturers) <- runDB $ do
+  (course,schoolName,participants,registered,lecturers) <- runDB . maybeT notFound $ do
-      courseEnt@(Entity cid course) <- getBy404 $ TermSchoolCourseShort tid ssh csh
+    [(E.Entity cid course, E.Value schoolName, E.Value participants, E.Value registered)]
-      dependent <- (,,)
+       <- lift . E.select . E.from $
-          <$> get (courseSchool course)               -- join -- just fetch full school name here
+         \((school `E.InnerJoin` course) `E.LeftOuterJoin` participant) -> do
-          <*> count [CourseParticipantCourse ==. cid] -- join
+            E.on $ E.just (course E.^. CourseId) E.==. participant E.?. CourseParticipantCourse
-          <*> (case mbAid of -- TODO: Someone please refactor this late-night mess here!
+                E.&&. E.val mbAid E.==. participant E.?. CourseParticipantUser
-                Nothing -> return False
+            E.on $ course E.^. CourseSchool E.==. school E.^. SchoolId
-                (Just aid) -> do  regL <- getBy (UniqueParticipant aid cid)
+            E.where_ $ course E.^. CourseTerm      E.==. E.val tid
-                                  return $ isJust regL)
+                 E.&&. course E.^. CourseSchool    E.==. E.val ssh
-      lecturers <- E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
+                 E.&&. course E.^. CourseShorthand E.==. E.val csh
-          E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+            let numParticipants = E.sub_select . E.from $ \part -> do
-          E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+                  E.where_ $ part E.^. CourseParticipantCourse E.==. course E.^. CourseId
-          return $ user E.^. UserDisplayName
+                  return ( E.countRows :: E.SqlExpr (E.Value Int64))
-      return (courseEnt,dependent,E.unValue <$> lecturers)
+            return (course,school E.^. SchoolName, numParticipants, participant E.?. CourseParticipantRegistration)
-  let course = entityVal courseEnt
+    lecturers <- lift . E.select $ E.from $ \(lecturer `E.InnerJoin` user) -> do
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+      E.on $ lecturer E.^. LecturerUser E.==. user E.^. UserId
+      E.where_ $ lecturer E.^. LecturerCourse E.==. E.val cid
+      return $ user E.^. UserDisplayName
+    return (course,schoolName,participants,registered,map E.unValue lecturers)
+  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom    course
+  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo      course
+  mDereg   <- traverse (formatTime SelFormatDateTime) $ courseDeregisterUntil course
+  mRegAt   <- traverse (formatTime SelFormatDateTime)   registered
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm (isJust mRegAt) $ courseRegisterSecret course
   registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid ssh csh CRegisterR) True
-  mRegFrom <- traverse (formatTime SelFormatDateTime) $ courseRegisterFrom course
-  mRegTo   <- traverse (formatTime SelFormatDateTime) $ courseRegisterTo course
   defaultLayout $ do
     setTitle [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")

src/Handler/Profile.hs

@@ -222,7 +222,7 @@ getProfileDataR = do
   let tutorialTable = [whamlet|Übungsgruppen werden momentan leider noch nicht unterstützt.|]
 
   -- Delete Button
-  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form BtnDelete)
+  (btnWdgt, btnEnctype) <- generateFormPost (buttonForm :: Form ButtonDelete)
   defaultLayout $ do
     let delWdgt = $(widgetFile "widgets/data-delete")
     $(widgetFile "profileData")

src/Handler/Sheet.hs

@@ -143,25 +143,15 @@ makeSheetForm msId template = identForm FIDsheet $ \html -> do
 
 getSheetCurrentR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetCurrentR tid ssh csh = runDB $ do
-  now <- liftIO getCurrentTime
+  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SShowR
-  sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+  shn <- sheetCurrent tid ssh csh
-    E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
+  maybe notFound redi shn
-    E.where_ $ sheet E.^. SheetActiveTo   E.>.  E.val now
-        E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
-        E.&&. course E.^. CourseTerm      E.==. E.val tid
-        E.&&. course E.^. CourseSchool    E.==. E.val ssh
-        E.&&. course E.^. CourseShorthand E.==. E.val csh
-    E.orderBy [E.asc $ sheet E.^. SheetActiveFrom]
-    E.limit 1
-    return $ sheet E.^. SheetName
-  case sheets of
-    (E.Value shn):_ -> redirectAccess $ CSheetR tid ssh csh shn SShowR
-    _ -> notFound
 
 getSheetOldUnassigned :: TermId -> SchoolId -> CourseShorthand -> Handler ()
 getSheetOldUnassigned tid ssh csh = runDB $ do
-  shn' <- sheetOldUnassigned tid ssh csh
+  let redi shn = redirectAccess $ CSheetR tid ssh csh shn SSubsR
-  maybe notFound (\shn -> redirectAccess $ CSheetR tid ssh csh shn SSubsR) shn'
+  shn <- sheetOldUnassigned tid ssh csh
+  maybe notFound redi shn
 
 getSheetListR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetListR tid ssh csh = do
@@ -287,15 +277,15 @@ getSheetListR tid ssh csh = do
     $(widgetFile "sheetList")
 
 data ButtonGeneratePseudonym = BtnGenerate
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 instance Universe ButtonGeneratePseudonym
 instance Finite ButtonGeneratePseudonym
 
 nullaryPathPiece ''ButtonGeneratePseudonym (camelToPathPiece' 1)
 
 instance Button UniWorX ButtonGeneratePseudonym where
-  label BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
+  btnLabel BtnGenerate = [whamlet|_{MsgSheetGeneratePseudonym}|]
-  cssClass BtnGenerate = BCDefault
+  btnClasses BtnGenerate = [BCIsButton, BCDefault]
 
 -- Show single sheet
 getSShowR :: TermId -> SchoolId -> CourseShorthand -> SheetName -> Handler Html
@@ -435,11 +425,17 @@ getSFileR tid ssh csh shn typ title = do
 
 getSheetNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
 getSheetNewR tid ssh csh = do
+  parShn <- runInputGetResult $ iopt ciField "shn"
+  let searchShn sheet = case parShn of
+        (FormSuccess (Just shn)) -> E.where_ $ sheet E.^. SheetName E.==. E.val shn
+        -- (FormFailure msgs) -> -- not in MonadHandler anymore -- forM_ msgs (addMessage Error . toHtml)
+        _other -> return ()
   lastSheets <- runDB $ E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
       E.on     $ course E.^. CourseId E.==. sheet E.^. SheetCourse
       E.where_ $ course E.^. CourseTerm      E.==. E.val tid
           E.&&.  course E.^. CourseSchool    E.==. E.val ssh
           E.&&.  course E.^. CourseShorthand E.==. E.val csh
+      searchShn sheet
       -- let lastSheetEdit = E.sub_select . E.from $ \sheetEdit -> do
       --       E.where_ $ sheetEdit E.^. SheetEditSheet E.==. sheet E.^. SheetId
       --       return . E.max_ $ sheetEdit E.^. SheetEditTime

src/Handler/Utils/Form.hs

@@ -15,8 +15,6 @@ import qualified Data.Char as Char
 
 import qualified Data.CaseInsensitive as CI
 
-import qualified Data.Foldable as Foldable
-
 -- import Yesod.Core
 import qualified Data.Text as T
 -- import Yesod.Form.Types
@@ -51,64 +49,55 @@ import Data.Aeson.Text (encodeToLazyText)
 -- Buttons (new version ) --
 ----------------------------
 
-data BtnDelete = BtnDelete
+data ButtonDelete = BtnDelete
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonDelete
+instance Finite ButtonDelete
 
-instance Universe BtnDelete
+nullaryPathPiece ''ButtonDelete $ camelToPathPiece' 1
-instance Finite BtnDelete
 
-nullaryPathPiece ''BtnDelete $ camelToPathPiece' 1
+embedRenderMessage ''UniWorX ''ButtonDelete id
+instance Button UniWorX ButtonDelete where
+  btnClasses BtnDelete = [BCIsButton, BCDanger]
 
-instance Button UniWorX BtnDelete where
+data ButtonRegister = BtnRegister | BtnDeregister
-  label BtnDelete = [whamlet|_{MsgBtnDelete}|]
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonRegister
+instance Finite ButtonRegister
 
-  cssClass BtnDelete = BCDanger
+nullaryPathPiece ''ButtonRegister $ camelToPathPiece' 1
 
-data RegisterButton = BtnRegister  | BtnDeregister
+embedRenderMessage ''UniWorX ''ButtonRegister id
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+instance Button UniWorX ButtonRegister where
+  btnClasses BtnRegister   = [BCIsButton, BCPrimary]
+  btnClasses BtnDeregister = [BCIsButton, BCDanger]
 
-instance Universe RegisterButton
+data ButtonHijack = BtnHijack
-instance Finite RegisterButton
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
+instance Universe ButtonHijack
+instance Finite ButtonHijack
 
-nullaryPathPiece ''RegisterButton $ camelToPathPiece' 1
+nullaryPathPiece ''ButtonHijack $ camelToPathPiece' 1
 
-instance Button UniWorX RegisterButton where
+embedRenderMessage ''UniWorX ''ButtonHijack id
-  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
+instance Button UniWorX ButtonHijack where
-  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
+  btnClasses BtnHijack = [BCIsButton, BCDefault]
 
-  cssClass BtnRegister   = BCPrimary
+data ButtonSubmitDelete = BtnSubmit' | BtnDelete'
-  cssClass BtnDeregister = BCDanger
+  deriving (Enum, Eq, Ord, Bounded, Read, Show, Generic, Typeable)
 
-data AdminHijackUserButton = BtnHijack
+instance Universe ButtonSubmitDelete
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+instance Finite ButtonSubmitDelete
 
-instance Universe AdminHijackUserButton
+embedRenderMessage ''UniWorX ''ButtonSubmitDelete $ dropSuffix "'"
-instance Finite AdminHijackUserButton
+instance Button UniWorX ButtonSubmitDelete where
-
+  btnClasses BtnSubmit' = [BCIsButton, BCPrimary]
-nullaryPathPiece ''AdminHijackUserButton $ camelToPathPiece' 1
+  btnClasses BtnDelete' = [BCIsButton, BCDanger]
-
-instance Button UniWorX AdminHijackUserButton where
-  label BtnHijack = [whamlet|_{MsgBtnHijack}|]
-
-  cssClass BtnHijack = BCDefault
-
-data BtnSubmitDelete = BtnSubmit' | BtnDelete'
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
-
-instance Universe BtnSubmitDelete
-instance Finite BtnSubmitDelete
-
-instance Button UniWorX BtnSubmitDelete where
-  label BtnSubmit' = [whamlet|_{MsgBtnSubmit}|]
-  label BtnDelete' = [whamlet|_{MsgBtnDelete}|]
-
-  cssClass BtnSubmit' = BCPrimary
-  cssClass BtnDelete' = BCDanger
 
   btnValidate _ BtnSubmit' = True
   btnValidate _ BtnDelete' = False
 
-nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
+nullaryPathPiece ''ButtonSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
 
 
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
@@ -118,8 +107,14 @@ nullaryPathPiece ''BtnSubmitDelete $ camelToPathPiece' 1 . dropSuffix "'"
 -- instance PathPiece LinkButton where
 --     LinkButton route = ???
 
-linkButton :: Widget -> ButtonCssClass UniWorX -> Route UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
+linkButton :: Widget -> [ButtonClass UniWorX] -> SomeRoute UniWorX -> Widget -- Alternative: Handler.Utils.simpleLink
-linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=button>^{lbl} |]
+linkButton lbl cls url = do
+  url' <- toTextUrl url
+  [whamlet|
+    $newline never
+    <a href=#{url'} class=#{unwords $ map toPathPiece cls} role=button>
+      ^{lbl}
+  |]
 --   [whamlet|
 --     <form method=post action=@{url}>
 --       <input type="hidden" name="_formid" value="identify-linkButton">
@@ -128,31 +123,16 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
   --  <input .btn .#{bcc2txt cls} type="submit" value=^{lbl}>
 
 
--- buttonForm :: Button a => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, (WidgetT UniWorX IO ()))
+-- buttonForm :: (Button UniWorX a, Finite a) => Markup -> MForm (HandlerT UniWorX IO) (FormResult a, Widget)
-buttonForm :: (Button UniWorX a, Show a) => Form a
+buttonForm :: (Button UniWorX a, Finite a) => Form a
 buttonForm csrf = do
-    buttonIdent <- newFormIdent
+   (res, ($ []) -> fViews) <- aFormToForm . disambiguateButtons $ combinedButtonFieldF ""
-    let button b = mopt (buttonField b) ("n/a"{ fsName = Just buttonIdent }) Nothing
+   return (res, [whamlet|
-    (results, btnViews) <- unzip <$> mapM button [minBound..maxBound]
+       $newline never
-    let widget =
+       #{csrf}
-          [whamlet|
+       $forall bView <- fViews
-            #{csrf}
+         ^{fvInput bView}
-            $forall bView <- btnViews
+     |])
-              ^{fvInput bView}
-          |]
-    return (accResult results,widget)
-  where
-    accResult :: Foldable f => f (FormResult (Maybe a)) -> FormResult a
-    accResult = Foldable.foldr accResult' FormMissing
-
-    accResult' :: FormResult (Maybe a) -> FormResult a -> FormResult a
-    -- Find the single FormSuccess Just _; Expected behaviour: all buttons deliver FormFailure, except for one.
-    accResult' (FormSuccess (Just _)) (FormSuccess _) = FormFailure ["Ambiguous button parse"]
-    accResult' (FormSuccess (Just x)) _ = FormSuccess x
-    accResult' _ x@(FormSuccess _) = x --Safe: most buttons deliver FormFailure, one delivers FormSuccess
-    accResult' (FormSuccess Nothing) x = x
-    accResult' FormMissing _ = FormMissing
-    accResult' (FormFailure errs) _ = FormFailure errs
 
 
 

src/Handler/Utils/Table/Pagination.hs

@@ -519,7 +519,7 @@ dbParamsFormWrap DBParamsForm{..} tableForm frag = do
   return . (res,) $ do
     btnId <- newIdent
     act <- traverse toTextUrl dbParamsFormAction
-    let submitField :: Field Handler SubmitButton
+    let submitField :: Field Handler ButtonSubmit
         submitField = buttonField BtnSubmit
         submitView :: Widget
         submitView = fieldView submitField btnId "" mempty (Right BtnSubmit) False

src/Utils.hs

@@ -364,7 +364,7 @@ mcons :: Maybe a -> [a] -> [a]
 mcons Nothing  xs = xs
 mcons (Just x) xs = x:xs
 
-newtype NTop a = NTop a -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
+newtype NTop a = NTop { nBot :: a } -- treat Nothing as Top for Ord (Maybe a); default implementation treats Nothing as bottom
 
 instance Eq a  => Eq (NTop (Maybe a)) where
   (NTop x) == (NTop y) = x == y

src/Utils/Form.hs

@@ -7,7 +7,6 @@ import Settings
 
 import qualified Text.Blaze.Internal as Blaze (null)
 import qualified Data.Text as T
-import qualified Data.Char as Char
 
 import Data.CaseInsensitive (CI)
 import qualified Data.CaseInsensitive as CI
@@ -200,37 +199,36 @@ identForm = identifyForm . toPathPiece
 -- Buttons (new version ) --
 ----------------------------
 
-data family ButtonCssClass site :: *
+data family ButtonClass site :: *
 
-bcc2txt :: Show (ButtonCssClass site) => ButtonCssClass site -> Text -- a Hack; maybe define Read/Show manually
+class (PathPiece a, PathPiece (ButtonClass site), RenderMessage site ButtonMessage) => Button site a where
-bcc2txt bcc = T.pack $ "btn-" ++ (Char.toLower <$> drop 2 (show bcc))
+  btnLabel :: a -> WidgetT site IO ()
 
-class (Enum a, Bounded a, Ord a, PathPiece a) => Button site a where
+  default btnLabel :: RenderMessage site a => a -> WidgetT site IO ()
-  label :: a -> WidgetT site IO ()
+  btnLabel = toWidget <=< ap getMessageRender . return
-  label = toWidget . toPathPiece
 
   btnValidate :: forall p. p site -> a -> Bool
   btnValidate _ _ = True
 
-  cssClass :: a -> ButtonCssClass site
+  btnClasses :: a -> [ButtonClass site]
+  btnClasses _ = []
 
 data ButtonMessage = MsgAmbiguousButtons
                    | MsgWrongButtonValue
                    | MsgMultipleButtonValues
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
-data SubmitButton = BtnSubmit
+data ButtonSubmit = BtnSubmit
-  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+  deriving (Eq, Ord, Enum, Bounded, Read, Show, Generic, Typeable)
 
-instance Universe SubmitButton
+instance Universe ButtonSubmit
-instance Finite SubmitButton
+instance Finite ButtonSubmit
 
-nullaryPathPiece ''SubmitButton $ camelToPathPiece' 1
+nullaryPathPiece ''ButtonSubmit $ camelToPathPiece' 1
 
 buttonField :: forall a m.
              ( Button (HandlerSite m) a
-             , Show (ButtonCssClass (HandlerSite m))
+             , MonadHandler m
-             , RenderMessage (HandlerSite m) ButtonMessage
-             , Monad m
              ) => a -> Field m a
 -- | Already validates that the correct button press was received (result only neccessary for combinedButtonField)
 buttonField btn = Field{..}
@@ -239,12 +237,12 @@ buttonField btn = Field{..}
 
     fieldView :: FieldViewFunc m a
     fieldView fid name attrs _val _ = let
-      cssClass' :: ButtonCssClass (HandlerSite m)
-      cssClass' = cssClass btn
       validate = btnValidate (Proxy @(HandlerSite m)) btn
+      classes :: [ButtonClass (HandlerSite m)]
+      classes = btnClasses btn
       in [whamlet|
         $newline never
-        <button .btn .#{bcc2txt cssClass'} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{label btn}
+        <button class=#{unwords $ map toPathPiece classes} type=submit name=#{name} value=#{toPathPiece btn} *{attrs} ##{fid} :not validate:formnovalidate>^{btnLabel btn}
       |]
 
     fieldParse []    [] = return $ Right Nothing
@@ -255,8 +253,6 @@ buttonField btn = Field{..}
 
 combinedButtonField :: forall a m.
                      ( Button (HandlerSite m) a
-                     , Show (ButtonCssClass (HandlerSite m))
-                     , RenderMessage (HandlerSite m) ButtonMessage
                      , MonadHandler m
                      ) => [a] -> FieldSettings (HandlerSite m) -> AForm m [Maybe a]
 combinedButtonField bs FieldSettings{..} = formToAForm $ do
@@ -280,8 +276,6 @@ combinedButtonField bs FieldSettings{..} = formToAForm $ do
 
 combinedButtonFieldF :: forall m a.
                       ( Button (HandlerSite m) a
-                      , Show (ButtonCssClass (HandlerSite m))
-                      , RenderMessage (HandlerSite m) ButtonMessage
                       , Finite a
                       , MonadHandler m
                       ) => FieldSettings (HandlerSite m) -> AForm m [Maybe a]
@@ -298,26 +292,22 @@ disambiguateButtons = traverseAForm $ \case
 
 combinedButtonField_ :: forall a m.
                       ( Button (HandlerSite m) a
-                      , Show (ButtonCssClass (HandlerSite m))
-                      , RenderMessage (HandlerSite m) ButtonMessage
                       , MonadHandler m
                       ) => [a] -> FieldSettings (HandlerSite m) -> AForm m ()
 combinedButtonField_ = (void .) . combinedButtonField
 
 combinedButtonFieldF_ :: forall m a p.
                        ( Button (HandlerSite m) a
-                       , Show (ButtonCssClass (HandlerSite m))
-                       , RenderMessage (HandlerSite m) ButtonMessage
                        , MonadHandler m
                        , Finite a
                        ) => p a -> FieldSettings (HandlerSite m) -> AForm m ()
 combinedButtonFieldF_ _ = void . combinedButtonFieldF @m @a
 
-submitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
+submitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
-submitButton = combinedButtonFieldF_ (Proxy @SubmitButton) ""
+submitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) ""
 
-autosubmitButton :: (Button (HandlerSite m) SubmitButton, Show (ButtonCssClass (HandlerSite m)), MonadHandler m, RenderMessage (HandlerSite m) ButtonMessage) => AForm m ()
+autosubmitButton :: (Button (HandlerSite m) ButtonSubmit, MonadHandler m) => AForm m ()
-autosubmitButton = combinedButtonFieldF_ (Proxy @SubmitButton) $ "" & addAutosubmit
+autosubmitButton = combinedButtonFieldF_ (Proxy @ButtonSubmit) $ "" & addAutosubmit
 
 -------------------
 -- Custom Fields --

src/Utils/Sheet.hs

@@ -3,6 +3,28 @@ module Utils.Sheet where
 import Import.NoFoundation
 import qualified Database.Esqueleto as E
 
+
+-- DB Queries for Sheets that are used in several places
+
+sheetCurrent :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName)
+sheetCurrent tid ssh csh = do
+  now <- liftIO getCurrentTime
+  sheets <- E.select . E.from $ \(course `E.InnerJoin` sheet) -> do
+    E.on $ sheet      E.^. SheetCourse     E.==. course E.^. CourseId
+    E.where_ $ sheet E.^. SheetActiveTo   E.>.  E.val now
+        E.&&.  sheet E.^. SheetActiveFrom E.<=. E.val now
+        E.&&. course E.^. CourseTerm      E.==. E.val tid
+        E.&&. course E.^. CourseSchool    E.==. E.val ssh
+        E.&&. course E.^. CourseShorthand E.==. E.val csh
+    E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
+    E.limit 1
+    return $ sheet E.^. SheetName
+  return $ case sheets of
+    [] -> Nothing
+    [E.Value shn] -> Just shn
+    _ -> error "SQL Query with limit 1 returned more than one result"
+
+
 sheetOldUnassigned :: MonadIO m => TermId -> SchoolId -> CourseShorthand -> SqlReadT m (Maybe SheetName)
 sheetOldUnassigned tid ssh csh = do
   now <- liftIO getCurrentTime
@@ -12,10 +34,10 @@ sheetOldUnassigned tid ssh csh = do
         E.&&. course E.^. CourseTerm      E.==. E.val tid
         E.&&. course E.^. CourseSchool    E.==. E.val ssh
         E.&&. course E.^. CourseShorthand E.==. E.val csh
-    E.where_ . E.exists . E.from $ \submission -> do
+    E.where_ . E.exists . E.from $ \submission ->
         E.where_ $ submission E.^. SubmissionSheet E.==. sheet E.^. SheetId
           E.&&.  E.isNothing (submission E.^. SubmissionRatingBy)
-    E.orderBy [E.desc $ sheet E.^. SheetActiveTo]
+    E.orderBy [E.asc $ sheet E.^. SheetActiveTo]
     E.limit 1
     return $ sheet E.^. SheetName
   return $ case sheets of

templates/course.hamlet

@@ -1,10 +1,9 @@
 <div .container>
   <dl .deflist>
-    $maybe school <- schoolMB
+    <dt .deflist__dt>Fakultät/Institut
-      <dt .deflist__dt>Fakultät/Institut
+    <dd .deflist__dd>
-      <dd .deflist__dd>
+      <div>
-        <div>
+        #{schoolName}
-          #{schoolName school}
 
     $maybe descr <- courseDescription course
       <dt .deflist__dt>_{MsgCourseDescription}
@@ -33,20 +32,27 @@ $#    $if NTop (Just 0) < NTop (courseCapacity course)
           #{participants}
           $maybe capacity <- courseCapacity course
             \ von #{capacity}
-      $maybe regFrom <- mRegFrom
+    $maybe regFrom <- mRegFrom
-        <dt .deflist__dt>Anmeldezeitraum
+      <dt .deflist__dt>Anmeldezeitraum
-        <dd .deflist__dd>
+      <dd .deflist__dd>
+        <div>
+          Ab #{regFrom}
+          $maybe regTo <- mRegTo
+            \ bis #{regTo}
+        $maybe dereg <- mDereg
           <div>
-            Ab #{regFrom}
+            \ <em>Achtung:</em>
-            $maybe regTo <- mRegTo
+            \ Abmeldung nur bis #{dereg} erlaubt.
-              \ bis #{regTo}
+    $if registrationOpen || isJust mRegAt
-    $if registrationOpen
       <dt .deflist__dt>
       <dd .deflist__dd>
         <div .course__registration>
-          <form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
+          $if registrationOpen
-            $# regWidget is defined through templates/widgets/registerForm
+            <form method=post action=@{CourseR tid ssh csh CRegisterR} enctype=#{regEnctype}>
-            ^{regWidget}
+              $# regWidget is defined through templates/widgets/registerForm
+              ^{regWidget}
+          $maybe date <- mRegAt
+            _{MsgRegisteredSince date}
     <dt .deflist__dt>
       Material
     <dd .deflist__dd>

templates/table/layout-filter-default.hamlet

@@ -3,6 +3,6 @@ $newline never
   <form method=GET action=#{filterAction} enctype=#{filterEnctype}>
     ^{filterWgdt}
     <button>
-      ^{label BtnSubmit}
+      ^{btnLabel BtnSubmit}
 <section>
   ^{scrolltable}

templates/widgets/registerForm.hamlet

@@ -5,4 +5,3 @@ $maybe secretView <- msecretView
   ^{fvInput secretView}
 $# Always display register/deregister button
 ^{fvInput btnView}
-