Registering for courses works now.

models

@@ -61,10 +61,10 @@ Corrector
     --      )
     UniqueCorrector userId courseId
 CourseParticipant
-    userId          UserId
     courseId        CourseId
+    userId          UserId
     registration    UTCTime
-    UniqueCourseParticipant userId courseId 
+    UniqueCourseParticipant courseId userId 
 Sheet
     courseId        CourseId
     name            Text

routes

@@ -16,7 +16,7 @@
 !/course/edit               CourseEditR       GET POST
 !/course/#TermIdentifier    CourseListTermR   GET
 /course/#TermIdentifier/#Text/edit CourseEditExistR GET
-/course/#TermIdentifier/#Text/show CourseShowR GET
+/course/#TermIdentifier/#Text/show CourseShowR GET POST
 
 -- For demonstration
 /course/#CryptoUUIDCourse/edit CourseEditExistIDR GET

src/Handler/Course.hs

@@ -16,8 +16,8 @@ import Data.Time
 import qualified Data.Text as T
 import Yesod.Form.Bootstrap3 
 
-import Colonnade
-import Yesod.Colonnade
+import Colonnade hiding (fromMaybe)
+import Yesod.Colonnade 
 
 import qualified Data.UUID.Cryptographic as UUID
 
@@ -58,18 +58,52 @@ getCourseListTermR tidini = do
 
 getCourseShowR :: TermIdentifier -> Text -> Handler Html
 getCourseShowR tid csh = do
-  (courseEnt,(schoolMB,participants)) <- runDB $ do
+  mbAid <- maybeAuthId
+  (courseEnt,(schoolMB,participants,mbRegistered)) <- runDB $ do
       courseEnt@(Entity cid course) <- getBy404 $ CourseTermShort (TermKey tid) csh
-      dependent <- (,) 
+      dependent <- (,,) 
           <$> get (courseSchoolId course)               -- join
           <*> count [CourseParticipantCourseId ==. cid] -- join 
+          <*> (case mbAid of -- Someone please refactor this late-night mess here!
+                Nothing -> return False
+                (Just aid) -> do
+                                regL <- getBy (UniqueCourseParticipant cid aid)
+                                return $ isJust regL)
       return $ (courseEnt,dependent)
-  let course = entityVal courseEnt
+  let course = entityVal courseEnt  
+  (regWidget, regEnctype) <- generateFormPost $ identifyForm "registerBtn" $ registerButton $ mbRegistered      
   defaultLayout $ do
     setTitle $ [shamlet| #{termToText tid} - #{csh}|]
     $(widgetFile "course")
-
+      
+registerButton :: Bool -> Form ()
+registerButton registered =
+    renderBootstrap3  bsHorizontalDefault $       
+      pure () <*  bootstrapSubmit regMsg 
+  where 
+    msg    = if registered then "Abmelden" else "Anmelden"
+    regMsg = msg :: BootstrapSubmit Text
     
+postCourseShowR :: TermIdentifier -> Text -> Handler Html
+postCourseShowR tid csh = do
+  aid <- requireAuthId
+  (cid, registered) <- runDB $ do
+      (Entity cid _) <- getBy404 $ CourseTermShort (TermKey tid) csh
+      registered <- isJust <$> (getBy $ UniqueCourseParticipant cid aid)
+      return (cid, registered)
+  ((regResult,_), _) <- runFormPost $ identifyForm "registerBtn" $ registerButton registered      
+  case regResult of 
+    (FormSuccess _)
+      | registered -> do                    
+          runDB $ deleteBy $ UniqueCourseParticipant cid aid 
+          setMessage "Sie wurden abgemeldet."
+      | otherwise  -> do
+          actTime <- liftIO $ getCurrentTime
+          regOk <- runDB $ insertUnique $ CourseParticipant cid aid actTime
+          when (isJust regOk) $ setMessage "Erfolgreich angemeldet!"
+  -- redirect or not?! I guess not, since we want GET now
+  getCourseShowR tid csh  
+  
 getCourseEditR :: Handler Html
 getCourseEditR = do
   -- TODO: Defaults für Semester hier ermitteln und übergeben

src/Handler/Home.bak

@@ -0,0 +1,67 @@
+{-# LANGUAGE NoImplicitPrelude #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE MultiParamTypeClasses #-}
+{-# LANGUAGE TypeFamilies #-}
+module Handler.Home where
+
+import Import
+import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
+import Text.Julius (RawJS (..))
+
+-- Define our data that will be used for creating the form.
+data FileForm = FileForm
+    { fileInfo :: FileInfo
+    , fileDescription :: Text
+    }
+
+-- This is a handler function for the GET request method on the HomeR
+-- resource pattern. All of your resource patterns are defined in
+-- config/routes
+--
+-- The majority of the code you will write in Yesod lives in these handler
+-- functions. You can spread them across multiple files if you are so
+-- inclined, or create a single monolithic file.
+getHomeR :: Handler Html
+getHomeR = do
+    (formWidget, formEnctype) <- generateFormPost sampleForm
+    let submission = Nothing :: Maybe FileForm
+        handlerName = "getHomeR" :: Text
+    defaultLayout $ do
+        let (commentFormId, commentTextareaId, commentListId) = commentIds
+        aDomId <- newIdent
+        setTitle "Welcome To Yesod!"
+        $(widgetFile "homepage")
+
+postHomeR :: Handler Html
+postHomeR = do
+    ((result, formWidget), formEnctype) <- runFormPost sampleForm
+    let handlerName = "postHomeR" :: Text
+        submission = case result of
+            FormSuccess res -> Just res
+            _ -> Nothing
+
+    defaultLayout $ do
+        let (commentFormId, commentTextareaId, commentListId) = commentIds
+        aDomId <- newIdent
+        setTitle "Welcome To Yesod!"
+        $(widgetFile "homepage")
+
+sampleForm :: Form FileForm
+sampleForm = renderBootstrap3 BootstrapBasicForm $ FileForm
+    <$> fileAFormReq "Choose a file"
+    <*> areq textField textSettings Nothing
+    -- Add attributes like the placeholder and CSS classes.
+    where textSettings = FieldSettings
+            { fsLabel = "What's on the file?"
+            , fsTooltip = Nothing
+            , fsId = Nothing
+            , fsName = Nothing
+            , fsAttrs =
+                [ ("class", "form-control")
+                , ("placeholder", "File description")
+                ]
+            }
+
+commentIds :: (Text, Text, Text)
+commentIds = ("js-commentForm", "js-createCommentTextarea", "js-commentList")

templates/course.hamlet

@@ -24,6 +24,9 @@
                 #{participants}
                 $maybe capacity <- courseCapacity course
                   \ von #{capacity}
+                <form method=post action=@{CourseShowR tid csh} enctype=#{regEnctype}>
+                  ^{regWidget}
+                
 
 
     <hr>