Term creation half-ways, problems with Custom Primary key for Terms

models

@@ -8,7 +8,8 @@ Term json
     start       Day
     end         Day
     holidays    [Day]
-    -- UniqueTerm shorthand
+    active      Bool
+    UniqueTerm name
     Primary name
     deriving Show
 School json

routes

@@ -9,4 +9,6 @@
 /profile ProfileR GET
 
 
-/assist/newcourse NewCourseR GET POST
+/assist/newcourse  NewCourseR GET POST
+/assist/newterm    NewTermR   GET POST
+/assist/showterm   ShowTermR   GET 

src/Foundation.hs

@@ -168,6 +168,8 @@ instance Yesod UniWorX where
     isAuthorized ProfileR _ = isAuthenticated
     -- TODO: change to Assistants
     isAuthorized NewCourseR _ = return Authorized
+    isAuthorized NewTermR   _ = return Authorized
+    isAuthorized ShowTermR  _ = return Authorized
 
     -- This function creates static content files in the static folder
     -- and names them based on a hash of their content. This allows

src/Handler/Assist.hs

@@ -8,9 +8,35 @@ module Handler.Assist where
 
 import Import
 import qualified Data.Text as T
+import Data.Maybe
 import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
+import Database.Persist.Class as K (Key)
 -- import Text.Julius (RawJS (..))
 
+-- TODO: Move elsewhere
+termField :: Field (HandlerT UniWorX IO) TermIdentifier
+termField = checkMMap checkTerm termToText textField
+  where 
+    errTextParse :: Text
+    errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
+    
+    errTextFreigabe :: TermIdentifier -> Text
+    errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
+    
+    checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
+    checkTerm t = case termFromText t of
+      Left  _        -> return $ Left errTextParse
+      res@(Right ti) -> do
+--         term <- runDB $ get $ Key ti -- TODO: membershiptest instead?
+        term <- runDB $ getBy $ UniqueTerm ti -- TODO: use get instead of getBy?        
+        return $ if isNothing term 
+          then Left $ errTextFreigabe ti
+          else res 
+        
+      
+       
+-- Handler for Assistants
+
 data NewCourseForm = NewCourseForm 
   {   ncf_user        :: UserId
   ,   ncf_term        :: TermIdentifier
@@ -21,57 +47,6 @@ data NewCourseForm = NewCourseForm
   ,   ncf_html        :: Html 
   ,   ncf_capacity    :: Maybe Int
   }
--- Handler for Assistants
-
-getShowCourseR :: CourseId -> Handler Html 
-getShowCourseR courseId = do
-    defaultLayout $ do
-        [whamlet|
-            TODO unfinished
-        |]
-
-getNewCourseR :: Handler Html
-getNewCourseR = do
-    aid <- requireAuthId
-    (formWidget, formEnctype) <- generateFormPost $ newCourseForm aid
-    defaultLayout $ do
-        setTitle "Neuen Kurs anlegen"
-        [whamlet|
-            User: #{show aid}
-        |]        
-        $(widgetFile "newcourse")
-
-postNewCourseR :: Handler Html
-postNewCourseR = do
-    aid <- requireAuthId
-    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm aid
-    case result of
-       FormSuccess res -> defaultLayout $ do
-            setMessage "Got something!"
-            $(widgetFile "newcourse")
-       FormMissing -> defaultLayout $ do
-            setMessage "Keine Daten erhalten."
-            $(widgetFile "newcourse")
-       FormFailure errorMsgs -> defaultLayout $ do
-            setMessage [shamlet| <span .error>Fehler:
-                            <ul>
-                                $forall errmsg <- errorMsgs
-                                    <li> #{errmsg} 
-                        |]
-            $(widgetFile "newcourse")
-
-{-
-    defaultLayout $ do
-        let (commentFormId, commentTextareaId, commentListId) = commentIds
-        aDomId <- newIdent
-        setTitle "Welcome To Yesod!"
-        $(widgetFile "homepage")
--}
-
-
--- TODO: Move elsewhere
-termField :: Field (HandlerT UniWorX IO) TermIdentifier
-termField = checkMMap (return . termFromText) termToText textField
 
 newCourseForm :: UserId -> Form NewCourseForm 
 newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm
@@ -94,3 +69,121 @@ newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm
                 [ ("class", "form-control")                
                 ]
             }
+
+getShowCourseR :: CourseId -> Handler Html 
+getShowCourseR courseId = do
+    defaultLayout $ do
+        [whamlet|
+            TODO unfinished
+        |]
+
+getNewCourseR :: Handler Html
+getNewCourseR = do
+    aid <- requireAuthId
+    (formWidget, formEnctype) <- generateFormPost $ newCourseForm aid
+    defaultLayout $ do
+        setTitle "Neuen Kurs anlegen"
+        [whamlet|
+            User: #{show aid}
+        |]        
+        $(widgetFile "newCourse")
+
+postNewCourseR :: Handler Html
+postNewCourseR = do
+    aid <- requireAuthId
+    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm aid
+    case result of
+       FormSuccess res -> defaultLayout $ do
+            setMessage "Got something!"
+            $(widgetFile "newCourse")
+       FormMissing -> defaultLayout $ do
+            setMessage "Keine Formulardaten erhalten."
+            $(widgetFile "newCourse")
+       FormFailure errorMsgs -> defaultLayout $ do
+            setMessage [shamlet| <span .error>Fehler:
+                            <ul>
+                                $forall errmsg <- errorMsgs
+                                    <li> #{errmsg} 
+                        |]
+            $(widgetFile "newCourse")
+
+{-
+    defaultLayout $ do
+        let (commentFormId, commentTextareaId, commentListId) = commentIds
+        aDomId <- newIdent
+        setTitle "Welcome To Yesod!"
+        $(widgetFile "homepage")
+-}
+
+
+getShowTermR :: Handler Html
+getShowTermR = do
+  terms <- runDB $ selectList [] [Desc TermStart]
+  defaultLayout $ do
+    setTitle "Freigeschaltete Semester"
+    [whamlet|
+      <h2>
+        Liste der freigeschalteten Semeser:
+      $if null terms 
+        <p> Es wurden noch kein Semester freigeschaltetet.
+      $else 
+        <ul>
+          $forall term <- terms
+            <li> #{show term}
+    |]
+
+getNewTermR :: Handler Html
+getNewTermR = do
+  -- TODO: Defaults für Semester hier ermitteln und übergeben
+  getNewTermDefR Nothing
+
+
+getNewTermDefR :: Maybe Term -> Handler Html
+getNewTermDefR mbTerm= do 
+    aid <- requireAuthId
+    (formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
+    defaultLayout $ do
+        setTitle "Neues Semester anlegen"        
+        $(widgetFile "newTerm")
+        
+postNewTermR :: Handler Html
+postNewTermR = do
+    aid <- requireAuthId
+    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm Nothing
+    case result of
+       FormSuccess res -> do
+          -- term <- runDB $ getBy UniqueTerm $ termName 
+          runDB $ insert res
+          let tid = termToText $ termName res
+          let msg = "Semester " `T.append` tid `T.append` " wurde angelegt!"        
+          -- setMessage $ toHtml msg -- FIXME
+          setMessage "Semester wurde angelegt" 
+          redirect ShowTermR
+       FormMissing -> defaultLayout $ do
+            setMessage "Keine Formulardaten erhalten."
+            $(widgetFile "newTerm")
+       FormFailure errorMsgs -> defaultLayout $ do
+            setMessage [shamlet| <span .error>Fehler:
+                            <ul>
+                                $forall errmsg <- errorMsgs
+                                    <li> #{errmsg} 
+                        |]
+            $(widgetFile "newTerm")
+
+newTermForm :: Maybe Term -> Form Term
+newTermForm template = 
+    renderBootstrap3 BootstrapBasicForm $ Term
+      <$> areq termField (set "Semester")   (termName  <$> template)
+      <*> areq dayField  (set "Erster Tag") (termStart <$> template)
+      <*> areq dayField  (set "Letzer Tag") (termEnd   <$> template)
+      <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
+      <*> areq checkBoxField (set "Aktiv") (termActive <$> template)
+  where set txt = FieldSettings
+            { fsLabel = txt
+            , fsTooltip = Nothing
+            , fsId = Nothing
+            , fsName = Nothing
+            , fsAttrs =
+                [ ("class", "form-control")                
+                ]
+            }

src/Model/Types.hs

@@ -58,6 +58,7 @@ data TermIdentifier = TermIdentifier
   , season :: Season
   } deriving (Show, Read, Eq, Ord, Generic, Typeable)
 
+--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/newCourse.hamlet

@@ -15,6 +15,6 @@
                         ^{formWidget}
 
                         <button .btn.btn-primary type="submit">
-                            Kurs anlegen!
+                            Kurs anlegen
 
 

templates/newTerm.hamlet

@@ -0,0 +1,20 @@
+<div .container>
+    <div .bs-docs-section>
+        <div .row>
+            <div .col-lg-12>
+                <div .page-header>
+                    <h1 #forms>Neues Semester anlegen:
+
+                    <p>
+                        Bitte alles ausfüllen!
+
+        <div .row>
+            <div .col-lg-6>
+                <div .bs-callout bs-callout-info well>
+                    <form .form-horizontal method=post action=@{NewTermR}#forms enctype=#{formEnctype}>
+                        ^{formWidget}
+
+                        <button .btn.btn-primary type="submit">
+                            Semester anlegen
+
+