feat(terms): improve term display/editing

Fixes #485

src/Handler/Term.hs

@@ -1,4 +1,8 @@
-module Handler.Term where
+module Handler.Term
+  ( getTermShowR
+  , getTermEditR, postTermEditR
+  , getTermEditExistR, postTermEditExistR
+  ) where
 
 import Import
 import Handler.Utils
@@ -31,69 +35,58 @@ validateTerm = do
   guardValidation MsgTermEndMustBeAfterLectureEnd $ termEnd >= termLectureEnd
 
 
-getTermShowR :: Handler TypedContent
+getTermShowR :: Handler Html
 getTermShowR = do
---   terms <- runDB $ selectList [] [Desc TermStart]
+  table <- runDB $
--------   ÄQUIVALENT:
+    let termDBTable = DBTable{..}
---   term <- runDB $ E.select . E.from $ \(term) -> do
+          where dbtSQLQuery term = return (term, courseCount)
---              E.orderBy [E.desc $ term E.^. TermStart ]
+                  where courseCount = E.subSelectCount . E.from $ \course ->
---              return term
---
-  let
-    termData :: E.SqlExpr (Entity Term) -> E.SqlQuery (E.SqlExpr (Entity Term), E.SqlExpr (E.Value Int64))
-    termData term = do
-      -- E.orderBy [E.desc $ term E.^. TermStart ]
-      let courseCount = E.subSelectCount . E.from $ \course ->
                           E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
-      return (term, courseCount)
+                dbtRowKey = (E.^. TermId)
-  selectRep $ do
+                dbtProj = return . dbrOutput
-    provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
+                dbtColonnade = widgetColonnade $ mconcat
-    provideRep $ do
+                  [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _)
-      let colonnadeTerms = widgetColonnade $ mconcat
+                      -> cell $ do
-            [ sortable (Just "term-id") (i18nCell MsgTermShort) $ \(Entity tid _, _) -> anchorCell
+                           mayEdit <- hasWriteAccessTo $ TermEditExistR tid
-                (TermCourseListR tid)
+                           [whamlet|
-                [whamlet|#{toPathPiece tid}|]
+                             $newline never
-            , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
+                             <a href=@{TermCourseListR tid}>
-                cell $ formatTime SelFormatDate termLectureStart >>= toWidget
+                               #{toPathPiece tid}
-            , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_) ->
+                             $if mayEdit
-                cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
+                               &nbsp;
-            , sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_) ->
+                               <a href=@{TermEditExistR tid}>
-                tickmarkCell termActive
+                                 #{iconMenuAdmin}
-            , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses) ->
+                           |]
-                cell [whamlet|_{MsgNumCourses numCourses}|]
+                  , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_)
-            , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_) ->
+                      -> cell $ formatTime SelFormatDate termLectureStart >>= toWidget
-                cell $ formatTime SelFormatDate termStart >>= toWidget
+                  , sortable (Just "lecture-end") (i18nCell MsgTermLectureEnd) $ \(Entity _ Term{..},_)
-            , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_) ->
+                      -> cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
-                cell $ formatTime SelFormatDate termEnd >>= toWidget
+                  , sortable Nothing (i18nCell MsgTermActive) $ \(Entity _ Term{..},_)
-            , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_) ->
+                      -> tickmarkCell termActive
-                cell $ do
+                  , sortable Nothing (i18nCell MsgTermCourseCount) $ \(_, E.Value numCourses)
-                  termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
+                      -> cell [whamlet|_{MsgNumCourses numCourses}|]
+                  , sortable (Just "start") (i18nCell MsgTermStart) $ \(Entity _ Term{..},_)
+                      -> cell $ formatTime SelFormatDate termStart >>= toWidget
+                  , sortable (Just "end") (i18nCell MsgTermEnd) $ \(Entity _ Term{..},_)
+                      -> cell $ formatTime SelFormatDate termEnd >>= toWidget
+                  , sortable Nothing (i18nCell MsgTermHolidays) $ \(Entity _ Term{..},_)
+                      -> cell $ do
+                           let termHolidays' = groupHolidays termHolidays
                            [whamlet|
                              $newline never
                              <ul .list--inline .list--comma-separated>
                                $forall holiday <- termHolidays'
-                        <li>#{holiday}
+                                 $case holiday
+                                   $of Left singleHoliday
+                                     <li>^{formatTimeW SelFormatDate singleHoliday}
+                                   $of Right (startD, endD)
+                                     <li>
+                                       ^{formatTimeW SelFormatDate startD}
+                                       –
+                                       ^{formatTimeW SelFormatDate endD}
                            |]
                   ]
---       let adminColonnade =
+                dbtSorting = Map.fromList
---           [ sortable Nothing "Edit" $ \(Entity tid Term{..},_) -> cell $ do
---                 -- Scrap this if to slow, create term edit page instead
---                 adminLink <- handlerToWidget $ isAuthorized (TermEditExistR tid) False
---                 [whamlet|
---                   $if adminLink == Authorized
---                     <a href=@{TermEditExistR tid}>
---                       #{termToText termName}
---                   $else
---                       #{termToText termName}
---                 |]
---           ]
-      let validator = def & defaultSorting [SortDescBy "term-id"]
-      table <- runDB $ dbTableWidget' validator DBTable
-        { dbtSQLQuery = termData
-        , dbtRowKey = (E.^. TermId)
-        , dbtColonnade = colonnadeTerms
-        , dbtProj = return . dbrOutput
-        , dbtSorting = Map.fromList
                   [ ( "start"
                     , SortColumn $ \term -> term E.^. TermStart
                     )
@@ -110,7 +103,7 @@ getTermShowR = do
                     , SortColumn $ \term -> term E.^. TermId
                     )
                   ]
-        , dbtFilter = Map.fromList
+                dbtFilter = Map.fromList
                   [ ( "active"
                     , FilterColumn $ \term -> term E.^. TermActive :: E.SqlExpr (E.Value Bool)
                     )
@@ -122,19 +115,21 @@ getTermShowR = do
                                E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
                     )
                   ]
-        , dbtFilterUI = mempty
+                dbtFilterUI = mempty
-        , dbtStyle = def
+                dbtStyle = def
-        , dbtParams = def
+                dbtParams = def
-        , dbtIdent = "terms" :: Text
+                dbtIdent = "terms" :: Text
-        , dbtCsvEncode = noCsvEncode
+                dbtCsvEncode = noCsvEncode
-        , dbtCsvDecode = Nothing
+                dbtCsvDecode = Nothing
-        }
+        termDBTableValidator = def & defaultSorting [SortDescBy "term-id"]
+    in dbTableWidget' termDBTableValidator termDBTable
   defaultLayout $ do
     setTitleI MsgTermsHeading
     $(widgetFile "terms")
 
 getTermEditR, postTermEditR :: Handler Html
-getTermEditR = do
+getTermEditR = postTermEditR
+postTermEditR = do
   mbLastTerm <- runDB $ selectFirst [] [Desc TermName]
   let template = case mbLastTerm of
         Nothing -> mempty
@@ -148,32 +143,25 @@ getTermEditR = do
               , tftStart = Just $ defaultDay True  seas & setYear yr
               , tftEnd   = Just $ defaultDay False seas & setYear yr'
               }
-  termEditHandler template
+  termEditHandler Nothing template
-postTermEditR = termEditHandler mempty
 
 getTermEditExistR, postTermEditExistR :: TermId -> Handler Html
 getTermEditExistR = postTermEditExistR
 postTermEditExistR tid = do
   term <- runDB $ get tid
-  termEditHandler $ termToTemplate term
+  termEditHandler (Just tid) $ termToTemplate term
 
 
-termEditHandler :: TermFormTemplate -> Handler Html
+termEditHandler :: Maybe TermId -> TermFormTemplate -> Handler Html
-termEditHandler term = do
+termEditHandler mtid term = do
     eHandler <- fromMaybe (error "termEditHandler called from 404-handler") <$> getCurrentRoute
-    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
+    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm mtid term
     case result of
       (FormSuccess res) -> do
-          let tid = TermKey $ termName res
+          let tid = fromMaybe (TermKey $ termName res) mtid
-          -- term <- runDB $ get $ TermKey termName
           runDB $ do
             repsert tid res
             audit $ TransactionTermEdit tid
--- VOR INTERNATIONALISIERUNG:
---           let tid = termToText $ termName res
---           let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."
---           addMessage Success [shamlet| #{msg} |]
--- MIT INTERNATIONALISIERUNG:
           addMessageI Success $ MsgTermEdited tid
           redirect TermShowR
       FormMissing     -> return ()
@@ -231,15 +219,15 @@ termToTemplate (Just Term{..}) = TermFormTemplate
     , tftActive       = Just termActive
     }
 
-newTermForm :: TermFormTemplate -> Form Term
+newTermForm :: Maybe TermId -> TermFormTemplate -> Form Term
-newTermForm template = validateForm validateTerm $ \html -> do
+newTermForm mtid template = validateForm validateTerm $ \html -> do
     mr <- getMessageRender
     let
       tidForm
-        | Just tid <- tftName template
+        | Just tid <- unTermKey <$> mtid
         = aforced termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) tid
         | otherwise
-        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) Nothing
+        = areq termNewField (fslpI MsgTerm (mr MsgTermPlaceholder)) (tftName template)
       holidayForm = massInputListA
         dayField
         (const $ "" & addPlaceholder (mr MsgTermHolidayPlaceholder))

src/Handler/Utils.hs

@@ -26,6 +26,8 @@ import Handler.Utils.Database   as Handler.Utils
 import Handler.Utils.Occurrences as Handler.Utils
 import Handler.Utils.Memcached  as Handler.Utils
   
+import Handler.Utils.Term as Handler.Utils
+
 import Control.Monad.Logger
 
 

src/Handler/Utils/Term.hs

@@ -0,0 +1,22 @@
+module Handler.Utils.Term
+  ( groupHolidays
+  ) where
+
+import Import
+
+import qualified Data.Set as Set
+import qualified Data.Sequence as Seq
+
+groupHolidays :: ( MonoFoldable mono
+                 , Enum (Element mono)
+                 , Ord (Element mono)
+                 )
+              => mono -> [Either (Element mono) (Element mono, Element mono)]
+groupHolidays = go Seq.empty . foldMap Set.singleton
+  where go (acc Seq.:|> Left   x')       (Set.minView -> Just (x, xs))
+          | x <= succ x' = go (acc Seq.:|> Right (x', x)) xs
+        go (acc Seq.:|> Right (x', x'')) (Set.minView -> Just (x, xs))
+          | x <= succ x'' = go (acc Seq.:|> Right (x', x)) xs
+        go  acc                          xs'
+          | Just (x, xs) <- Set.minView xs' = go (acc Seq.:|> Left x) xs
+          | otherwise                       = toList acc