Fixes to Course New/Edit handling. Update not yet working!

.directory

@@ -0,0 +1,6 @@
+[Dolphin]
+Timestamp=2018,3,14,10,57,55
+Version=4
+
+[Settings]
+HiddenFilesShown=true

.kateproject

@@ -0,0 +1,4 @@
+{
+  "name": "ReWorX"
+, "files": [ { "git": 1, "filters": ["*.hs", "*.hamlet", "*.lucius", "*.cassius", "*.julius"], "recursive": 1 } ]
+}

FragenSJ.txt

@@ -0,0 +1,11 @@
+** i18n:
+
+ - Was ist mit einfachen Text Feldern, z.B. die Beschriftung von Knöpfen wie in Handler.Course.getCourseListTermR, Zeile 66 "pageActions" für menuItemLabel?
+ - Was ist mit PageTitles, z.B. in Handler.Term.termEditHandler:
+    -- setTitle [whamlet| _{MsgTermNewTitle} |] -- TODO, does not work
+
+
+** FORMS
+
+ - Handler.Utils.Form.FormIdentifier: Still needed?
+ - Verification of Ownership during Edit?

README.md

@@ -52,7 +52,7 @@ Assuming Ubuntu or similar
   Build the app:<br>
     `stack build`
 
-  Run the app (with environment variable DUMMY_LUGIN set to true):<br>
+  Run the app (with environment variable DUMMY_LOGIN set to true):<br>
     `env DUMMY_LOGIN=true stack exec  -- yesod devel`
 
   `Devel application launched: http://localhost:3000`<br>
@@ -86,5 +86,19 @@ psql -U uniworx -d uniworx -h 127.0.0.1 -w
 --Zeige Tabellen
 \dt
 
+--Zeige Tabellen Inhalt:
+TABEL "user";
+-- Die Anführungszeichen können manchmal weggelassen werden, aber
+-- bei user sind sie notwendig, da es auch Schlüsselwort in sql ist.
+
 --Lösche Tabelle "course" und alle davon abhängigen:
 DROP TABLE "course" CASCADE;
+
+-- UserId 5 zum Lecturer in SchoolId 1 machen (27 ist laufende Nummer)
+INSERT INTO "user_lecturer" (id,"user",school) VALUES (27,5,1);
+
+-- Beenden:
+\q
+
+-- Hilfe:
+\help

messages/de.msg

@@ -1,3 +1,9 @@
 SummerTerm year@Integer: Sommersemester #{tshow year}
 WinterTerm year@Integer: Wintersemester #{tshow year}/#{tshow $ succ year}
-SemesterEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
+TermEdited tid@TermIdentifier: Semester #{termToText tid} erfolgreich editiert.
+TermNewTitle: Semester editiere/anlegen.
+InvalidInput: Eingaben bitte korrigieren.
+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.
+CourseEditDupShort tid@TermIdentifier courseShortHand@Text: Kurs #{termToText tid}-#{courseShortHand} konnte nicht geändert werden: Es gibt bereits einen anderen Kurs mit dem Kürzel #{courseShortHand} in diesem Semester.

models

@@ -30,8 +30,8 @@ StudyTerms
     name          Text Maybe
     Primary key
 Term json
-    name          TermIdentifier
+    name          TermIdentifier -- unTermKey :: TermId -> TermIdentifier
-    start         Day
+    start         Day            -- TermKey   :: TermIdentifier -< TermId
     end           Day
     holidays      [Day]
     lectureStart  Day 

routes

@@ -13,10 +13,10 @@
 /term/#TermId/edit          TermEditExistR    GET
 
 /course/                    CourseListR       GET
-!/course/new                CourseEditR       GET POST
+!/course/new                CourseNewR        GET POST
-!/course/#TermId    CourseListTermR           GET
+!/course/#TermId            CourseListTermR   GET
-/course/#TermId/#Text/edit CourseEditExistR   GET
+/course/#TermId/#Text/edit  CourseEditR       GET
-/course/#TermId/#Text/show CourseShowR        GET POST
+/course/#TermId/#Text/show  CourseShowR       GET POST
 
 /course/#TermId/#Text/sheet/                SheetListR   GET
 /course/#TermId/#Text/sheet/#Text/show      SheetShowR   GET
@@ -34,4 +34,4 @@
 !/#UUID CryptoUUIDDispatchR GET
 
 -- For demonstration
-/course/#CryptoUUIDCourse/edit CourseEditExistIDR GET
+/course/#CryptoUUIDCourse/edit CourseEditIDR GET

src/Foundation.hs

@@ -198,10 +198,10 @@ isAuthorizedDB (SubmissionDownloadSingleR cID _) _ = submissionAccess $ Right cI
 isAuthorizedDB (SubmissionDownloadArchiveR (splitExtension -> (baseName, _))) _ = submissionAccess . Left . CryptoID $ CI.mk baseName
 isAuthorizedDB TermEditR              _ = adminAccess Nothing
 isAuthorizedDB (TermEditExistR _)     _ = adminAccess Nothing
-isAuthorizedDB CourseEditR            _ = lecturerAccess Nothing
+isAuthorizedDB CourseNewR             _ = lecturerAccess Nothing
-isAuthorizedDB (CourseEditExistR t c) _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
+isAuthorizedDB (CourseEditR t c)      _ = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
 isAuthorizedDB (SheetNewR t c) _        = courseLecturerAccess . entityKey =<< getBy404 (CourseTermShort t c)
-isAuthorizedDB (CourseEditExistIDR cID) _ = do
+isAuthorizedDB (CourseEditIDR cID)    _ = do
   courseId <- decrypt cID
   courseLecturerAccess courseId
 isAuthorizedDB _route _isWrite = return  $ Unauthorized "No access to this route." -- Calling isAuthorized here creates infinite loop!
@@ -255,11 +255,11 @@ instance YesodBreadcrumbs UniWorX where
   breadcrumb TermEditR = return ("Neu", Just TermShowR)
   breadcrumb (TermEditExistR _) = return ("Editieren", Just TermShowR)
   
-  breadcrumb CourseListR = return ("Kurs", Just HomeR)
+  breadcrumb  CourseListR              = return ("Kurs", Just HomeR)
-  breadcrumb (CourseListTermR term) = return (toPathPiece term, Just TermShowR)
+  breadcrumb (CourseListTermR term)    = return (toPathPiece term, Just TermShowR)
   breadcrumb (CourseShowR term course) = return (course, Just $ CourseListTermR term)
-  breadcrumb CourseEditR = return ("Neu", Just CourseListR)  
+  breadcrumb  CourseNewR               = return ("Neu", Just CourseListR)
-  breadcrumb (CourseEditExistR _ _) = return ("Editieren", Just CourseListR)
+  breadcrumb (CourseEditR _ _)         = return ("Editieren", Just CourseListR)
 
   breadcrumb (SheetListR tid csh) = return ("Kurs", Just $ CourseShowR tid csh)
   breadcrumb (SheetShowR tid csh _shn) = return ("Übungen", Just $ SheetListR tid csh)

src/Handler/Course.hs

@@ -54,26 +54,26 @@ getCourseListTermR tidini = do
                 shd = courseShorthand c  
                 tid = courseTermId c
             in do
-              adminLink <- handlerToWidget $ isAuthorized (CourseEditExistR tid shd ) False
+              adminLink <- handlerToWidget $ isAuthorized (CourseEditR tid shd ) False
-              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditExistR tid shd) else ""
+              -- if (adminLink==Authorized) then linkButton "Ändern" BCWarning (CourseEditR tid shd) else ""
               [whamlet| 
                 $if adminLink == Authorized
-                  <a href=@{CourseEditExistR tid shd}>
+                  <a href=@{CourseEditR tid shd}>
                     editieren
               |]
           )  
         ]
-  let pageLinks = 
+  let pageActions =
         [ NavbarLeft $ MenuItem
           { menuItemLabel = "Neuer Kurs"
-          , menuItemRoute = CourseEditR
+          , menuItemRoute = CourseNewR
-          , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseEditR False
+          , menuItemAccessCallback = (== Authorized) <$> isAuthorized CourseNewR False
           }
         ] 
-  defaultLinkLayout pageLinks $ do
+  defaultLinkLayout pageActions $ do
 --   defaultLayout $ do
     setTitle "Semesterkurse"  
-    linkButton "Neuen Kurs anlegen" BCPrimary CourseEditR
+    linkButton "Neuen Kurs anlegen" BCPrimary CourseNewR
     encodeWidgetTable tableDefault colonnadeTerms courses -- (map entityVal courses)
 
 getCourseShowR :: TermId -> Text -> Handler Html
@@ -124,101 +124,107 @@ postCourseShowR tid csh = do
   -- redirect or not?! I guess not, since we want GET now
   getCourseShowR tid csh  
   
-getCourseEditR :: Handler Html
+getCourseNewR :: Handler Html
-getCourseEditR = do
+getCourseNewR = do
   -- TODO: Defaults für Semester hier ermitteln und übergeben
   courseEditHandler Nothing
 
-postCourseEditR :: Handler Html
+postCourseNewR :: Handler Html
-postCourseEditR = courseEditHandler Nothing
+postCourseNewR = courseEditHandler Nothing
   
-getCourseEditExistR :: TermId -> Text -> Handler Html
+getCourseEditR :: TermId -> Text -> Handler Html
-getCourseEditExistR tid csh = do  
+getCourseEditR tid csh = do
   course <- runDB $ getBy $ CourseTermShort tid csh
   courseEditHandler course
 
-getCourseEditExistIDR :: CryptoUUIDCourse -> Handler Html
+getCourseEditIDR :: CryptoUUIDCourse -> Handler Html
-getCourseEditExistIDR cID = do
+getCourseEditIDR cID = do
   cIDKey <- getsYesod appCryptoIDKey
   courseID <- UUID.decrypt cIDKey cID
   courseEditHandler =<< runDB (getEntity courseID)
 
 
-courseEditHandler :: Maybe (Entity Course) -> Handler Html
+courseDeleteHandler :: Handler Html -- not called anywhere yet
-courseEditHandler course = do
+courseDeleteHandler = undefined
-    aid <- requireAuthId
+{- TODO
-    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
+        | False -- DELETE -- TODO: This no longer works that way!!! See new way in Handler.Term.termEditHandler
-    action <- lookupPostParam "formaction"
-    case (result,action) of
-      (FormSuccess res, fAct) 
-        | fAct == formActionDelete
         , Just cid <- cfCourseId res -> do
             runDB $ deleteCascade cid -- TODO Sicherheitsabfrage einbauen!
             let cti = toPathPiece $ cfTerm res
             addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde gelöscht!|]
             redirect $ CourseListTermR $ cfTerm res
-        | fAct == formActionSave 
+-}
-        , Just cid <- cfCourseId res -> do 
+
-            let tid = cfTerm  res
+courseEditHandler :: Maybe (Entity Course) -> Handler Html
-            actTime <- liftIO getCurrentTime
+courseEditHandler course = do
-            updateokay <- runDB $ do
+    aid <- requireAuthId -- TODO: Verify that Editor is owner of the Course to be Edited!!!
-              exists <- getBy $ CourseTermShort tid $ cfShort res 
+    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm $ courseToForm <$> course
-              let upokay = isNothing exists
+    case result of
-              when upokay $ update cid 
+      (FormSuccess res@(
-                [ CourseName         =. cfName     res
+        CourseForm  { cfCourseId = Nothing
-                , CourseDescription  =. cfDesc     res
+                    , cfShort    = csh
-                , CourseLinkExternal =. cfLink     res
+                    , cfTerm     = tid
-                , CourseShorthand    =. cfShort    res -- TODO: change here should generate a warning, or only allowed for Admins?!
+                    })) ->  do -- create new course
-                , CourseTermId       =. tid            -- TODO: change here should generate a warning, or only allowed for Admins?!
+          let tident = unTermKey tid
-                , CourseSchoolId     =. cfSchool   res
+          actTime <- liftIO getCurrentTime
-                , CourseCapacity     =. cfCapacity res
+          insertOkay <- runDB $ insertUnique $ Course
-                , CourseRegisterFrom =. cfRegFrom  res
+            { courseName            = cfName     res
-                , CourseRegisterTo   =. cfRegTo    res
+            , courseDescription     = cfDesc     res
-                , CourseChangedBy    =. aid
+            , courseLinkExternal    = cfLink     res
-                , CourseChanged      =. actTime
+            , courseShorthand       = cfShort    res
-                ]
+            , courseTermId          = cfTerm     res
-              return upokay
+            , courseSchoolId        = cfSchool   res
-            let cti = toPathPiece $ cfTerm res
+            , courseCapacity        = cfCapacity res
-            if updateokay 
+            , courseHasRegistration = cfHasReg   res
-              then do 
+            , courseRegisterFrom    = cfRegFrom  res
-                addMessage "info" [shamlet| Kurs #{cti}/#{cfShort res} wurde geändert. |]
+            , courseRegisterTo      = cfRegTo    res
-                redirect $ CourseListTermR $ cfTerm res
+            , courseCreated         = actTime
-              else do
+            , courseChanged         = actTime
-                addMessage "danger" [shamlet| Kurs #{cti}/#{cfShort res} konnte nicht geändert werden. 
+            , courseCreatedBy       = aid
-                    \ Es gibt bereits einen anderen Kurs mit diesem Kürzel in diesem Semester.|]
+            , courseChangedBy       = aid
-        | fAct == formActionSave
-        , Nothing <- cfCourseId res -> do
-            actTime <- liftIO getCurrentTime
-            insertOkay <- runDB $ insertUnique $ Course 
-                { courseName            = cfName     res
-                , courseDescription     = cfDesc     res
-                , courseLinkExternal    = cfLink     res
-                , courseShorthand       = cfShort    res
-                , courseTermId          = cfTerm     res
-                , courseSchoolId        = cfSchool   res
-                , courseCapacity        = cfCapacity res
-                , courseHasRegistration = cfHasReg   res
-                , courseRegisterFrom    = cfRegFrom  res
-                , courseRegisterTo      = cfRegTo    res
-                , courseCreated         = actTime
-                , courseChanged         = actTime
-                , courseCreatedBy       = aid
-                , courseChangedBy       = aid
                 }
-            case insertOkay of 
+          case insertOkay of
-                (Just cid) -> do
+            (Just cid) -> do
-                  runDB $ insert_ $ Lecturer aid cid 
+              runDB $ insert_ $ Lecturer aid cid
-                  let cti = toPathPiece $ cfTerm res
+              addMessageI "info" $ MsgCourseNewOk tident csh
-                  addMessage "info" [shamlet|Kurs #{cti}/#{cfShort res} wurde angelegt.|]
+              redirect $ CourseListTermR tid
-                  redirect $ CourseListTermR $ cfTerm res
+            Nothing ->
-                Nothing -> do
+              addMessageI "danger" $ MsgCourseNewDupShort tident csh
-                  let cti = toPathPiece $ cfTerm res
+
-                  addMessage "danger" [shamlet|Es gibt bereits einen Kurs #{cfShort res} in Semester #{cti}.|]      
+      (FormSuccess res@(
-      (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."            
+        CourseForm  { cfCourseId = Just cid
-      _other -> return ()
+                    , cfShort    = csh
+                    , cfTerm     = tid
+                    })) -> do -- edit existing course
+          let tident = unTermKey tid
+          actTime <- liftIO getCurrentTime
+          addMessage "info" [shamlet| #{show res}|]
+          runDB $ do
+            -- existing <- getBy $ CourseTermShort tid csh
+            -- if ((entityKey <$> existing) /= Just cid)
+            --  then addMessageI "danger" $ MsgCourseEditDupShort tident csh
+            --   else do
+                addMessage "info" $ fromMaybe [shamlet|No description given.|] $ cfDesc res
+                update cid
+                  [ CourseName         =. cfName     res
+                  , CourseDescription  =. cfDesc     res
+                  , CourseLinkExternal =. cfLink     res
+                  , CourseShorthand    =. cfShort    res -- TODO: change here should generate a warning, or only allowed for Admins?!
+                  , CourseTermId       =. tid            -- TODO: change here should generate a warning, or only allowed for Admins?!
+                  , CourseSchoolId     =. cfSchool   res
+                  , CourseCapacity     =. cfCapacity res
+                  , CourseRegisterFrom =. cfRegFrom  res
+                  , CourseRegisterTo   =. cfRegTo    res
+                  , CourseChangedBy    =. aid
+                  , CourseChanged      =. actTime
+                  ]
+                addMessageI "info" $ MsgCourseEditOk tident csh
+                redirect $ CourseListTermR tid
+
+      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
+      other -> addMessage "error" $ [shamlet| Error: #{show other}|]
     let formTitle   = "Kurs editieren/anlegen" :: Text
-    let actionUrl   = CourseEditR
+    let actionUrl   = CourseNewR -- CourseEditR -- TODO
-    let formActions = defaultFormActions
     defaultLayout $ do
       setTitle [shamlet| #{formTitle} |]
       $(widgetFile "formPage")
@@ -282,7 +288,7 @@ newCourseForm template = identForm FIDcourse $ \html -> do
       <*> areq checkBoxField          (fsb "Anmeldung")      (cfHasReg   <$> template)
       <*> aopt utcTimeField           (fsb "Anmeldung von:") (cfRegFrom  <$> template)
       <*> aopt utcTimeField           (fsb "Anmeldung bis:") (cfRegTo    <$> template)
-      -- <*  bootstrapSubmit (bsSubmit (show cid)) 
+      <*  submitButton
     return $ case result of  
       FormSuccess courseResult 
         | errorMsgs <- validateCourse courseResult

src/Handler/Term.hs

@@ -12,7 +12,7 @@ module Handler.Term where
 import Import 
 import Handler.Utils
 
-import qualified Data.Text as T
+-- import qualified Data.Text as T
 import Yesod.Form.Bootstrap3 
 
 import Colonnade hiding (bool)
@@ -67,7 +67,14 @@ getTermShowR = do
             , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
               fromString $ (intercalate ", ") $ map formatTimeGerWD termHolidays
             ]  
-      defaultLayout $ do
+      let pageActions =
+            [ NavbarLeft $ MenuItem
+              { menuItemLabel = "Neues Semester"
+              , menuItemRoute = TermEditR
+              , menuItemAccessCallback = (== Authorized) <$> isAuthorized TermEditR True
+              }
+            ]
+      defaultLinkLayout pageActions $ do
         setTitle "Freigeschaltete Semester"
         encodeWidgetTable tableDefault colonnadeTerms termData
 
@@ -98,14 +105,15 @@ termEditHandler term = do
 --           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
 --           addMessage "success" [shamlet| #{msg} |]
 -- MIT INTERNATIONALISIERUNG:
-          addMessageI "success" $ MsgSemesterEdited $ termName res
+          addMessageI "success" $ MsgTermEdited $ termName res
           redirect TermShowR
       (FormMissing  ) -> return ()
-      (FormFailure _) -> addMessage "warning" "Bitte Eingabe korrigieren."
+      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
     let formTitle   = "Semester editieren/anlegen" :: Text
     let actionUrl   = TermEditR
     defaultLayout $ do
       setTitle [shamlet| #{formTitle} |]
+      -- setTitle [whamlet| _{MsgTermNewTitle} |] -- TODO, does not work
       $(widgetFile "formPage")
       
 newTermForm :: Maybe Term -> Form Term

src/Handler/Utils/Form.hs

@@ -28,14 +28,14 @@ import qualified Text.Blaze.Internal as Blaze (null)
 import Web.PathPieces (showToPathPiece, readFromPathPiece)
 
 ------------------------------------------------
--- Unique Form Identifiers to avoid accidents --
+-- Unique Form Identifiers to avoid aSccidents --
 ------------------------------------------------
 
 data FormIdentifier = FIDcourse | FIDsheet
   deriving (Enum, Eq, Ord, Bounded, Read, Show)
 
 
-identForm :: FormIdentifier -> Form a -> Form a  
+identForm :: FormIdentifier -> Form a -> Form a   -- TODO: Still needed?
 identForm fid = identifyForm (T.pack $ show fid)
 
 -------------------
@@ -244,6 +244,9 @@ postButtonForm lblId = identifyForm lblId buttonF
 natField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
 natField d = checkBool (>= 0) (T.append  d " muss eine natürliche Zahl sein.") $ intField
 
+natIntField ::(Monad m, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m Integer
+natIntField = natField
+
 posIntField :: (Monad m, Integral i, RenderMessage (HandlerSite m) FormMessage) => Text -> Field m i
 posIntField d = checkBool (>= 1) (T.append  d " muss eine positive Zahl sein.") $ intField
 

src/Model/Types.hs

@@ -96,6 +96,10 @@ data TermIdentifier = TermIdentifier
   , season :: Season
   } deriving (Show, Read, Eq, Ord, Generic, Typeable)
 
+-- Conversion TermId <-> TermIdentifier::
+-- from_TermId_to_TermIdentifier = unTermKey
+-- from_TermIdentifier_to_TermId = TermKey
+
 --TODO: Enforce the number of digits within year, with parsing filling in the current leading digits? Goal: short urls
 termToText :: TermIdentifier -> Text
 termToText TermIdentifier{..} = Text.pack $ seasonToChar season : show year

templates/home.hamlet

@@ -61,7 +61,7 @@
 
                         
                       <li .list-group-item>
-                        <a href=@{CourseEditR}>Kurse anlegen
+                        <a href=@{CourseNewR}>Kurse anlegen
                         editieren und anzeigen
 
                        <li .list-group-item>
@@ -77,6 +77,6 @@
                             ^{btnWdgt}
                         
                       <li .list-group-item>
-                        <a href=@{CourseEditR}>Kurse anlegen
+                        <a href=@{CourseNewR}>Kurse anlegen
                         editieren und anzeigen