Term Handler cleaned again; small changes to Model (Maybe added for some Text Types, courseOwner dropped).

models

@@ -27,12 +27,11 @@ DegreeCourse json
     degreeId DegreeId
     courseId CourseId
     UniqueDegreeCourse degreeId courseId
-Course json
+Course 
     name         Text
     shorthand    Text
-    description  Textarea
+    description  Html Maybe
-    linkexternal Text 
+    linkexternal Text Maybe    
-    owner        UserId    
     schoolId     SchoolId
     termId       TermId -- TermId ist jetzt Text als Typ
     capacity     Int Maybe    
@@ -60,7 +59,7 @@ Sheet
     hintId          FileId Maybe
     solutionId      FileId Maybe
     markingId       FileId Maybe
-    markingText     Text
+    markingText     Text Maybe
     activeFrom      UTCTime
     activeTo        UTCTime
     hintFrom        UTCTime Maybe
@@ -129,7 +128,7 @@ Booking
 Room
     name        Text
     capacity    Int Maybe
-    building    Text
+    building    Text Maybe
 -- BookingRoom
 --    subject     RoomForId
 --    roomId      RoomId

routes

@@ -8,9 +8,8 @@
 
 /profile ProfileR GET
 
-/showterms  ShowTermsR GET 
+/term                       ShowTermsR      GET 
+/term/edit                  EditTermR       GET POST
+/term/#TermIdentifier/edit  EditTermExistR  GET
 
-/assist/newcourse  NewCourseR GET POST
+/assist/newcourse                NewCourseR      GET POST
-/assist/newterm    NewTermR   GET
-/assist/editterm   EditTermR  GET POST
-/assist/editterm/#TermIdentifier EditTermExistR  GET

src/Foundation.hs

@@ -167,8 +167,7 @@ instance Yesod UniWorX where
 
     isAuthorized ProfileR _ = isAuthenticated
     -- TODO: change to Assistants
-    isAuthorized NewCourseR         _ = return Authorized
+    isAuthorized NewCourseR         _ = return Authorized    
-    isAuthorized NewTermR           _ = return Authorized
     isAuthorized EditTermR          _ = return Authorized
     isAuthorized (EditTermExistR _) _ = return Authorized
     isAuthorized ShowTermsR         _ = return Authorized

src/Handler/Term.hs

@@ -23,11 +23,17 @@ getShowTermsR = do
   terms <- runDB $ selectList [] [Desc TermStart]
   selectRep $ do
     provideRep $ return $ toJSON terms
-    provideRep $ do
+    provideRep $ do      
       let colonnadeTerms = mconcat 
-            -- TODO Edit-Links only $if isAdmin, otherwise breadcrumb navigation
+            [ headed "Kürzel" $ (\t -> let tn = termName t in do
-            [ headed "Kürzel" $ (\t -> let tn = termName t in
+                adminLink <- handlerToWidget $ isAuthorized (EditTermExistR tn) False
-                [whamlet| <a href=@{EditTermExistR tn}>#{termToText tn}|] )        
+                [whamlet| 
+                  $if adminLink == Authorized
+                    <a href=@{EditTermExistR tn}>
+                      #{termToText tn}
+                  $else 
+                      #{termToText tn}
+                |] )        
             , headed "Beginn Vorlesungen" $ fromString.formatTimeGerWD.termLectureStart
             , headed "Ende Vorlesungen"   $ fromString.formatTimeGerWD.termLectureEnd
             , headed "Aktiv"  (\t -> if termActive t then tickmark else "")
@@ -42,36 +48,23 @@ getShowTermsR = do
         encodeHeadedWidgetTable tableDefault colonnadeTerms (map entityVal terms)
 
     
-getNewTermR :: Handler Html
-getNewTermR = do
-  -- TODO: Defaults für Semester hier ermitteln und übergeben
-  getEditTermMaybeR Nothing
-  
-  
 getEditTermR :: Handler Html
 getEditTermR = do
   -- TODO: Defaults für Semester hier ermitteln und übergeben
-  getEditTermMaybeR Nothing
+  termEditHandler Nothing
   
+postEditTermR :: Handler Html
+postEditTermR = termEditHandler Nothing
   
 getEditTermExistR :: TermIdentifier -> Handler Html  
 getEditTermExistR tid = do
   term <- runDB $ get $ TermKey tid
-  getEditTermMaybeR term
+  termEditHandler term
 
-  
+     
-getEditTermMaybeR :: Maybe Term -> Handler Html
+termEditHandler :: Maybe Term -> Handler Html
-getEditTermMaybeR mbTerm= do 
+termEditHandler term = do
-    aid <- requireAuthId
+    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
-    -- TODO: verify Admin 
-    (formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
-    wdgtTermForm formWidget formEnctype
-        
-postEditTermR :: Handler Html
-postEditTermR = do
-    aid <- requireAuthId
-    -- TODO: verify Admin 
-    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm Nothing
     action <- lookupPostParam "formaction"
     case (result,action) of
       (FormSuccess res, fAct) 
@@ -79,7 +72,7 @@ postEditTermR = do
           runDB $ delete (TermKey $ termName res) 
           let tid = termToText $ termName res
           let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht."            
-          setMessage [shamlet| #{msg} |]
+          setMessage $ [shamlet| #{msg} |]
           redirect ShowTermsR
         | fAct == formActionSave -> do
           -- term <- runDB $ get $ TermKey termName 
@@ -88,15 +81,17 @@ postEditTermR = do
           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."            
           setMessage [shamlet| #{msg} |]
           redirect ShowTermsR   
-        | otherwise -> redirect ShowTermsR
+        | otherwise -> redirect ShowTermsR      
-      (FormMissing,_) -> do
+      (FormMissing,_)   -> return ()
-            setMessage "Keine Formulardaten erhalten."
+      (FormFailure _,_) -> setMessage "Bitte Eingabe korrigieren."            
-            wdgtTermForm formWidget formEnctype
+    let formTitle   = "Semester editieren/anlegen" :: Text
-            
+    let actionUrl   = EditTermR
-      (FormFailure _,_) -> do
+    let formActions = defaultFormActions
-            setMessage "Bitte Eingabe korrigieren."
+    defaultLayout $ do
-            wdgtTermForm formWidget formEnctype
+      setTitle [shamlet| #{formTitle} |]
+      $(widgetFile "generic_form")
 
+{-            
 wdgtTermForm :: (ToWidget UniWorX a) => a -> Enctype ->  Handler Html              
 wdgtTermForm formWidget formEnctype = do
     let formTitle   = "Semester editieren/anlegen" :: Text
@@ -105,7 +100,8 @@ wdgtTermForm formWidget formEnctype = do
     defaultLayout $ do
       setTitle [shamlet| #{formTitle} |]
       $(widgetFile "generic_form")
-          
+-}
+      
 newTermForm :: Maybe Term -> Form Term
 newTermForm template html = do
     (result, widget) <- flip (renderBootstrap3 bsHorizontalDefault) html $ Term

src/Handler/Utils/Table.hs

@@ -5,7 +5,7 @@ module Handler.Utils.Table where
 -- General Utilities for Tables
 
 import Import hiding  ((<>))
-import Data.Monoid ((<>))
+-- import Data.Monoid ((<>))
 import Data.Profunctor
 
 import Text.Blaze as B
@@ -31,7 +31,7 @@ encodeHeadedWidgetTableNumbered :: Attribute -> Colonnade Headed a (WidgetT site
 encodeHeadedWidgetTableNumbered attrs colo tdata =
     encodeHeadedWidgetTable attrs (mconcat [numberCol, lmap snd colo]) (zip [1..] tdata)
   where
-    numberCol = headed "Nr" (fromString.show.fst)
+    numberCol :: Colonnade Headed (Int,a) (WidgetT site IO ())
-  
+    numberCol = headed "Nr" (fromString.show.fst)    
   
   

src/Model/Types.hs

@@ -58,7 +58,7 @@ seasonFromChar c
 data TermIdentifier = TermIdentifier
   { year :: Integer -- ^ Using 'Integer' to model years is consistent with 'Data.Time.Calendar'
   , season :: Season
-  } deriving (Show, Read, Eq, Generic, Typeable)
+  } 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
@@ -71,11 +71,6 @@ termFromText t
   , Right season <- seasonFromChar s
   = Right TermIdentifier{..}
   | otherwise = Left $ "Invalid TermIdentifier: “" <> t <> "”"
-
-instance Ord TermIdentifier where
-  ti1 <= ti2 =
-    year ti1 <= year ti2 || 
-    (year ti1 == year ti2 || season ti1 <= season ti2)
   
 instance PersistField TermIdentifier where
   toPersistValue = PersistText . termToText