BUGFIX: Register Button for Lectures works as intended now!

messages/de.msg

@@ -1,3 +1,12 @@
+BtnSubmit: Senden
+BtnAbort: Abbrechen
+BtnDelete: Löschen
+BtnRegister: Anmelden
+BtnDeregister: Abmelden
+
+RegisterFrom: Anmeldungen von
+RegisterTo: Anmeldungen bis
+
 SummerTerm year@Integer: Sommersemester #{tshow year}
 WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
 PSLimitNonPositive: “pagesize” muss größer als null sein
@@ -10,6 +19,7 @@ TermPlaceholder: W/S + vierstellige Jahreszahl
 TermEditHeading: Semester editieren/anlegen
 
 Course: Kurs
+CourseSecret: Zugangspasswort
 CourseNewOk        tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich erstellt.
 CourseEditOk       tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} wurde erfolgreich geändert.
 CourseNewDupShort  tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht erstellt werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.
@@ -43,6 +53,7 @@ UnauthorizedCorrector: Sie sind nicht als Korrektor für diese Veranstaltung ein
 UnauthorizedSheetCorrector: Sie sind nicht als Korrektor für dieses Übungsblatt eingetragen.
 UnauthorizedCorrectorAny: Sie sind nicht als Korrektor für eine Veranstaltung eingetragen.
 UnauthorizedParticipant: Sie sind nicht als Teilnehmer für diese Veranstaltung registriert.
+UnauthorizedCourseTime: Dieses Kurs erlaubt momentan keine Anmeldungen.
 UnauthorizedSheetTime: Dieses Übungsblatt ist momentan nicht freigegeben.
 UnauthorizedSubmissionOwner: Sie sind an dieser Abgabe nicht beteiligt.
 UnauthorizedSubmissionCorrector: Sie sind nicht der Korrektor für diese Abgabe.
@@ -51,6 +62,7 @@ DeprecatedRoute: Diese Ansicht ist obsolet und könnte in Zukunft entfallen.
 UnfreeMaterials: Die Materialien für diese Veranstaltung sind nicht allgemein freigegeben.
 UnauthorizedWrite: Sie haben hierfür keine Schreibberechtigung
 
+
 SubmissionWrongSheet: Abgabenummer gehört nicht zum angegebenen Übungsblatt.
 SubmissionAlreadyExists: Sie haben bereits eine Abgabe zu diesem Übungsblatt.
 SubmissionTitle tid@TermIdentifier courseShortHand@Text sheetName@Text: #{termToText tid}-#{courseShortHand} #{sheetName}: Abgabe editieren/anlegen

models

@@ -60,7 +60,7 @@ Course
     term             TermId
     school           SchoolId
     capacity         Int Maybe
-    hasRegistration  Bool -- canRegisterNow = hasRegistration && maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
+    -- canRegisterNow = maybe False (<= currentTime) registerFrom && maybe True (>= currentTime) registerTo
     registerFrom     UTCTime Maybe
     registerTo       UTCTime Maybe
     deregisterUntil  UTCTime Maybe

routes

@@ -33,6 +33,7 @@
 /                           HomeR             GET             !free
 /users                      UsersR            GET             -- no tags, i.e. admins only
 /admin/test                 AdminTestR        GET POST
+/admin/user/#CryptoUUIDUser AdminUserR        GET
 
 /profile                    ProfileR          GET POST        !free                             !free
 /profile/data               ProfileDataR      GET             !free                             !free
@@ -47,7 +48,8 @@
 /course/                    CourseListR       GET             !free
 !/course/new                CourseNewR        GET POST        !lecturer
 /course/#TermId/#Text       CourseR                           !lecturer:
-  /show                       CShowR          GET POST        !free
+  /show                       CShowR          GET             !free
+  /register                   CRegisterR          POST        !time
   /edit                       CEditR          GET POST
   /ex                         SheetListR      GET             !registered !materials
   !/ex/new                    SheetNewR       GET POST

src/CryptoID.hs

@@ -53,6 +53,7 @@ instance (CI.FoldCase s, PathMultiPiece s) => PathMultiPiece (CI s) where
 -- Generates CryptoUUID... and CryptoFileName... Datatypes
 decCryptoIDs [ ''SubmissionId
              , ''FileId
+             , ''UserId
              ]
 {- TODO: Do we need/want CryptoUUIDs for Sheet numbers? -}
 

src/Foundation.hs

@@ -278,20 +278,28 @@ knownTags = Map.fromList -- should not throw exceptions, i.e. no getBy404 or req
            return Authorized
    )
   ,("time", APDB $ \case
-       CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
+      CSheetR tid csh shn subRoute -> maybeT (unauthorizedI MsgUnauthorizedSheetTime) $ do
-         Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
+        Entity cid _ <- MaybeT . getBy $ CourseTermShort tid csh
-         Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
+        Entity sid Sheet{..} <- MaybeT . getBy $ CourseSheet cid shn
-         cTime <- liftIO getCurrentTime
+        cTime <- liftIO getCurrentTime
-         let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
+        let started = sheetActiveFrom <= cTime  ||  NTop sheetVisibleFrom <= (NTop $ Just cTime)
-         case subRoute of
+        case subRoute of
-           SFileR SheetExercise _ -> guard started
+          SFileR SheetExercise _ -> guard started
-           SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
+          SFileR SheetHint     _ -> guard $ maybe False (<= cTime) sheetHintFrom
-           SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
+          SFileR SheetSolution _ -> guard $ maybe False (<= cTime) sheetSolutionFrom
-           SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
+          SFileR SheetMarking  _ -> mzero -- only for correctors and lecturers
-           SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
+          SubmissionNewR         -> guard $ sheetActiveFrom <= cTime && cTime <= sheetActiveTo
-           _ -> guard started
+          _ -> guard started
-         return Authorized
+        return Authorized
-       r -> do
+
+      CourseR tid csh CRegisterR -> maybeT (unauthorizedI MsgUnauthorizedCourseTime) $ do
+        Entity cid Course{..} <- MaybeT . getBy $ CourseTermShort tid csh
+        cTime <- (NTop . Just) <$> liftIO getCurrentTime
+        guard $ NTop courseRegisterFrom <= cTime
+             && NTop courseRegisterTo   >= cTime
+        return Authorized
+
+      r -> do
          $logErrorS "AccessControl" $ "'!time' used on route that doesn't support it: " <> tshow r
          unauthorizedI MsgUnauthorized
    )
@@ -420,8 +428,7 @@ instance Yesod UniWorX where
               lift $ mapM_ delete oldFavs
 
           _other -> return ()
-      res <- defaultYesodMiddleware handler -- handler is executed before Favourites are update
+      defaultYesodMiddleware handler -- handler is executed afterwards, so Favourites are updated immediately
-      return res
 
     defaultLayout widget = do
         master <- getYesod

src/Handler/Admin.hs

@@ -58,3 +58,14 @@ postAdminTestR = do
     _other -> return ()
   getAdminTestR
 
+
+getAdminUserR :: CryptoUUIDUser -> Handler Html
+getAdminUserR uuid = do
+  uid <- decrypt uuid
+  User{..} <- runDB $ get404 uid
+  defaultLayout $
+    [whamlet|
+      <h1>TODO
+      <h2>Admin Page for User #{display userDisplayName}
+    |]
+

src/Handler/Course.hs

@@ -16,9 +16,9 @@ import Handler.Utils
 -- import Data.Time
 import qualified Data.Text as T
 import Data.Function ((&))
-import Yesod.Form.Bootstrap3
+-- import Yesod.Form.Bootstrap3
 
-import Colonnade hiding (fromMaybe)
+import Colonnade hiding (fromMaybe,bool)
 import Yesod.Colonnade
 
 import qualified Data.UUID.Cryptographic as UUID
@@ -79,7 +79,7 @@ getTermCourseListR tidini = do
 getCShowR :: TermId -> Text -> Handler Html
 getCShowR tid csh = do
   mbAid <- maybeAuthId
-  (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
+  (courseEnt,(schoolMB,participants,registered)) <- runDB $ do
       courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort tid csh
       dependent <- (,,)
           <$> get (courseSchool course)               -- join
@@ -91,26 +91,33 @@ getCShowR tid csh = do
                                 return $ isJust regL)
       return $ (courseEnt,dependent)
   let course = entityVal courseEnt
-  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
+  registrationOpen <- (==Authorized) <$> isAuthorized (CourseR tid csh CRegisterR) True
   defaultLayout $ do
     setTitle $ [shamlet| #{toPathPiece tid} - #{csh}|]
     $(widgetFile "course")
 
-registerButton :: Bool -> Form ()
-registerButton registered = renderAForm FormStandard $
-      pure () <*  bootstrapSubmit regMsg
-  where
-    msg    = if registered then "Abmelden" else "Anmelden"
-    regMsg = msg :: BootstrapSubmit Text
 
-postCShowR :: TermId -> Text -> Handler Html
+registerForm :: Bool -> Maybe Text -> Form Bool
-postCShowR tid csh = do
+registerForm registered msecret extra = do
+  (msecretRes', msecretView) <- case msecret of
+    Nothing  -> return (Nothing,Nothing)
+    (Just _) -> bimap Just Just <$> (mreq textField (fslpI MsgCourseSecret "Code") Nothing)
+  (btnRes, btnView) <- mreq (buttonField $ bool BtnRegister BtnDeregister registered) "buttonField ignores settings anyway" Nothing
+  let widget = $(widgetFile "widgets/registerForm")
+  let msecretRes | Just res <- msecretRes' = Just <$> res
+                 | otherwise               = FormSuccess Nothing
+  return (btnRes *> ((==msecret) <$> msecretRes), widget) -- checks that correct button was pressed, and ignores result of btnRes
+
+
+postCRegisterR :: TermId -> Text -> Handler Html
+postCRegisterR tid csh = do
   aid <- requireAuthId
-  (cid, registered) <- runDB $ do
+  (cid, course, registered) <- runDB $ do
-      (Entity cid _) <- getBy404 $ CourseTermShort tid csh
+      (Entity cid course) <- getBy404 $ CourseTermShort tid csh
       registered <- isJust <$> (getBy $ UniqueParticipant aid cid)
-      return (cid, registered)
+      return (cid, course, registered)
-  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered
+  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerForm registered $ courseRegisterSecret course
   case regResult of
     (FormSuccess _)
       | registered -> do
@@ -121,8 +128,7 @@ postCShowR tid csh = do
           regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
           when (isJust regOk) $ addMessage "success" "Erfolgreich angemeldet!"
     (_other) -> return () -- TODO check this!
-  -- redirect or not?! I guess not, since we want GET now
+  redirect $ CourseR tid csh CShowR
-  getCShowR tid csh
 
 getCourseNewR :: Handler Html
 getCourseNewR = do
@@ -174,11 +180,10 @@ courseEditHandler isGet course = do
             , courseTerm            = cfTerm     res
             , courseSchool          = cfSchool   res
             , courseCapacity        = cfCapacity res
-            , courseHasRegistration = cfHasReg   res
+            , courseRegisterSecret  = cfSecret   res
             , courseRegisterFrom    = cfRegFrom  res
             , courseRegisterTo      = cfRegTo    res
             , courseDeregisterUntil = Nothing -- TODO
-            , courseRegisterSecret  = Nothing -- TODO
             , courseMaterialFree    = True    -- TODO
             }
           case insertOkay of
@@ -230,11 +235,10 @@ courseEditHandler isGet course = do
                             ,  courseTerm            = cfTerm     res
                             ,  courseSchool          = cfSchool   res
                             ,  courseCapacity        = cfCapacity res
-                            ,  courseHasRegistration = cfHasReg   res
+                            ,  courseRegisterSecret  = cfSecret   res
                             ,  courseRegisterFrom    = cfRegFrom  res
                             ,  courseRegisterTo      = cfRegTo    res
                             ,  courseDeregisterUntil = Nothing -- TODO
-                            ,  courseRegisterSecret  = Nothing -- TODO
                             ,  courseMaterialFree    = True    -- TODO
                     }
                   )
@@ -263,7 +267,7 @@ data CourseForm = CourseForm
         , cfTerm     :: TermId
         , cfSchool   :: SchoolId
         , cfCapacity :: Maybe Int
-        , cfHasReg   :: Bool
+        , cfSecret   :: Maybe Text
         , cfRegFrom  :: Maybe UTCTime
         , cfRegTo    :: Maybe UTCTime
         }
@@ -282,7 +286,7 @@ courseToForm cEntity = CourseForm
         , cfTerm     = courseTerm               course
         , cfSchool   = courseSchool             course
         , cfCapacity = courseCapacity           course
-        , cfHasReg   = courseHasRegistration    course
+        , cfSecret   = courseRegisterSecret     course
         , cfRegFrom  = courseRegisterFrom       course
         , cfRegTo    = courseRegisterTo         course
         }
@@ -309,9 +313,15 @@ newCourseForm template = identForm FIDcourse $ \html -> do
       <*> areq termActiveField        (fsb "Semester")       (cfTerm     <$> template)
       <*> areq schoolField            (fsb "Institut")       (cfSchool   <$> template)
       <*> aopt (natField "Kapazität") (fsb "Kapazität")      (cfCapacity <$> template)
-      <*> areq checkBoxField          (fsb "Anmeldung")      (cfHasReg   <$> template)
+      <*> aopt textField              (fslpI MsgCourseSecret "beliebige Zeichenkette"
-      <*> aopt utcTimeField           (fsb "Anmeldung von:") (cfRegFrom  <$> template)
+            & setTooltip "Optional: Anmeldung zum Kurs benötigt ein Passwort")
-      <*> aopt utcTimeField           (fsb "Anmeldung bis:") (cfRegTo    <$> template)
+                                                             (cfSecret   <$> template)
+      <*> aopt utcTimeField           (fslpI MsgRegisterFrom "(ohne Datum keine Anmeldung möglich)"
+            & setTooltip "Ohne Datum ist keine Anmeldung zu diesem Kurs möglich!")
+                                                             (cfRegFrom  <$> template)
+      <*> aopt utcTimeField           (fslpI MsgRegisterTo   "(ohne Datum unbegrenzte Anmeldung möglich)"
+            & setTooltip "Die Anmeldung darf ohne Begrenzung sein")
+                                                             (cfRegTo    <$> template)
       <*  submitButton
     return $ case result of
       FormSuccess courseResult
@@ -338,20 +348,12 @@ validateCourse :: CourseForm -> [Text]
 validateCourse (CourseForm{..}) =
   [ msg | (False, msg) <-
     [
-      ( cfRegFrom <= cfRegTo
+      ( NTop cfRegFrom <= NTop cfRegTo
       , "Ende des Anmeldezeitraums muss nach dem Anfang liegen"
       )
-    ,
 --    No starting date is okay: effective immediately
 --       ( cfHasReg <= (isNothing cfRegFrom)
 --       , "Beginn der Anmeldung angeben oder Anmeldungen deaktivieren"
 --       )
 --     ,
-      ( cfHasReg == (isJust cfRegTo)
-      , "Ende des Anmeldezeitraums angeben oder Anmeldungen deaktivieren"
-      )
-    ,
-      ( isJust cfRegFrom <= cfHasReg
-      , "Anmeldungen aktivieren oder Anmeldezeitraum löschen"
-      )
   ] ]

src/Handler/CryptoIDDispatch.hs

@@ -54,7 +54,11 @@ instance CryptoRoute (CI FilePath) SubmissionId where
       Course{..} <- get404 sheetCourse
       return (courseTerm, courseShorthand, sheetName)
     return $ CSheetR tid csh shn $ SubmissionR cID
-  
+
+instance CryptoRoute UUID UserId where
+  cryptoIDRoute _ (CryptoID -> cID) = do
+    (_ :: UserId) <- decrypt cID
+    return $ AdminUserR cID
 
 class Dispatch ciphertext (x :: [*]) where
   dispatchID :: p x -> ciphertext -> Handler (Maybe (Route UniWorX))
@@ -79,6 +83,7 @@ getCryptoUUIDDispatchR :: UUID -> Handler ()
 getCryptoUUIDDispatchR uuid = dispatchID p uuid >>= maybe notFound (redirectWith found302)
   where
     p :: Proxy '[ SubmissionId
+                , UserId
                 ]
     p = Proxy
 

src/Handler/Home.hs

@@ -57,10 +57,10 @@ homeAnonymous = do
   let tableData :: E.SqlExpr (Entity Course)
                   -> E.SqlQuery (E.SqlExpr (Entity Course))
       tableData course = do
-            E.where_ $ course E.^. CourseHasRegistration E.==. E.val True
+            E.where_ $ (E.not_ $ E.isNothing $ course E.^. CourseRegisterFrom)
-                 E.&&. course E.^. CourseRegisterFrom    E.<=. E.val (Just cTime)
+                E.&&.  (course E.^. CourseRegisterFrom E.<=. E.val (Just cTime))
-                 E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
+                E.&&. ((E.isNothing $ course E.^. CourseRegisterTo)
-                        E.||.         (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
+                        E.||. (course E.^. CourseRegisterTo E.>=. E.val (Just cTime)))
             E.limit nrSheetDeadlines
             E.orderBy [ E.asc  $ course E.^. CourseRegisterTo
                       , E.desc $ course E.^. CourseShorthand

src/Handler/Users.hs

@@ -1,6 +1,7 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE QuasiQuotes #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE TypeFamilies #-}
 
@@ -34,7 +35,10 @@ getUsersR = do
           Nothing -> "???"
           (Just school) -> schoolShorthand school
   let colonnadeUsers = mconcat $
-        [ headed "User" $ text2widget.userDisplayName.entityVal.fst3
+        [ headed "User" $ \u -> do
+            cID <- encrypt $ entityKey $ fst3 u
+            let name = display $ userDisplayName $ entityVal $ fst3 u
+            [whamlet|<a href=@{AdminUserR cID}>#{name}|]
         , headed "Admin for Schools"   $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userAdminSchool   .entityVal) $ snd3 u)
         , headed "Lecturer at Schools" $ (\u -> text2widget $ intercalate ", " $ map (getSchoolname.userLecturerSchool.entityVal) $ trd3 u)
         ]

src/Handler/Utils/Form.hs

@@ -100,8 +100,8 @@ instance PathPiece BtnDelete where    -- for displaying the button only, not rea
   fromPathPiece = readFromPathPiece
 
 instance Button BtnDelete where
-  label BtnDelete = "Löschen"
+  label BtnDelete = [whamlet|_{MsgBtnDelete}|]
-  label BtnAbort  = "Abrechen"
+  label BtnAbort  = [whamlet|_{MsgBtnAbort}|]
 
   cssClass BtnDelete = BCDanger
   cssClass BtnAbort  = BCDefault
@@ -115,10 +115,26 @@ instance PathPiece SubmitButton where
   fromPathPiece = readFromPathPiece
 
 instance Button SubmitButton where
-  label BtnSubmit = "Submit"
+  label BtnSubmit = [whamlet|_{MsgBtnSubmit}|]
 
   cssClass BtnSubmit = BCPrimary
 
+
+data RegisterButton = BtnRegister  | BtnDeregister
+  deriving (Enum, Eq, Ord, Bounded, Read, Show)
+
+instance PathPiece RegisterButton where
+  toPathPiece   = showToPathPiece
+  fromPathPiece = readFromPathPiece
+
+instance Button RegisterButton where
+  label BtnRegister   = [whamlet|_{MsgBtnRegister}|]
+  label BtnDeregister = [whamlet|_{MsgBtnDeregister}|]
+
+  cssClass BtnRegister   = BCPrimary
+  cssClass BtnDeregister = BCDanger
+
+
 -- -- Looks like a button, but is just a link (e.g. for create course, etc.)
 -- data LinkButton = LinkButton (Route UniWorX)
 --   deriving (Enum, Eq, Ord, Bounded, Read, Show)
@@ -138,7 +154,7 @@ linkButton lbl cls url = [whamlet| <a href=@{url} .btn .#{bcc2txt cls} role=butt
 simpleLink :: Widget -> Route UniWorX -> Widget
 simpleLink lbl url = [whamlet| <a href=@{url}>^{lbl} |]
 
-buttonField :: Button a => a -> Field Handler a
+buttonField :: Button a => a -> Field Handler a -- already validates that the correct button press was received (result only neccessary for combinedButtonField)
 buttonField btn = Field {fieldParse, fieldView, fieldEnctype}
   where
     fieldEnctype = UrlEncoded

templates/course.hamlet

@@ -32,13 +32,10 @@
     <tr>
       <th>
       <td>
-        $# if allowed to register
+        $if registrationOpen
-        <div .course__registration.container>
+          <div .course__registration.container>
-          <button class="btn btn-primary">
+            <form method=post action=@{CourseR tid csh CRegisterR} enctype=#{regEnctype}>
-            <a href="#">TODO: Kurs-Anmeldung
+              ^{regWidget}
-
-  $# <form method=post action=@{CourseR tid csh CShow} enctype=#{regEnctype}>
-  $#   ^{regWidget}
 
 $# <div .container>
 $#   <div .tab-group>

templates/widgets/registerForm.hamlet

@@ -0,0 +1,8 @@
+$# protects against CSRF
+#{extra}
+$# Maybe display textField for passcode
+$maybe secretView <- msecretView
+  ^{fvInput secretView}
+$# Always display register/deregister button
+^{fvInput btnView}
+