fradrive/src/Handler/Term.hs

{-# LANGUAGE NoImplicitPrelude
           , OverloadedStrings
           , OverloadedLists
           , RecordWildCards
           , TemplateHaskell
           , QuasiQuotes
           , MultiParamTypeClasses
           , TypeFamilies
           , FlexibleContexts
  #-}

module Handler.Term where

import Import
import Handler.Utils

-- import qualified Data.Text as T
import Yesod.Form.Bootstrap3

import Colonnade hiding (bool)
import Yesod.Colonnade

import qualified Database.Esqueleto as E

getTermShowR :: Handler TypedContent
getTermShowR = do
--   terms <- runDB $ selectList [] [Desc TermStart]
-------   ÄQUIVALENT:
--   term <- runDB $ E.select . E.from $ \(term) -> do
--              E.orderBy [E.desc $ term E.^. TermStart ]
--              return term
--
  let
    termData term = do
      -- E.orderBy [E.desc $ term E.^. TermStart ]
      let courseCount :: E.SqlExpr (E.Value Int)
          courseCount = E.sub_select . E.from $ \course -> do
            E.where_ $ term E.^. TermId E.==. course E.^. CourseTermId
            return E.countRows
      return (term, courseCount)
  selectRep $ do
    provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
    provideRep $ do
      let colonnadeTerms = mconcat
            [ sortable Nothing "Kürzel" $ \(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}
                |]
            , sortable (Just "lecture-start") "Beginn Vorlesungen" $ \(Entity _ Term{..},_) ->
                stringCell $ formatTimeGerWD termLectureStart
            , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
                stringCell $ formatTimeGerWD termLectureEnd
            , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
                textCell $ bool "" tickmark termActive
            , sortable Nothing "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
                cell [whamlet|
                  <a href=@{CourseListTermR tid}>
                    #{show numCourses} Kurse
                |]
            , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
              stringCell $ formatTimeGerWD termStart
            , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
              stringCell $ formatTimeGerWD termEnd
            , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
              stringCell $ (intercalate ", ") $ map formatTimeGerWD termHolidays
            ]
      table <- dbTable def $ DBTable
        { dbtSQLQuery = termData
        , dbtColonnade = colonnadeTerms
        , dbtSorting = [ ( "start"
                         , SortColumn $ \term -> term E.^. TermStart
                         )
                       , ( "end"
                         , SortColumn $ \term -> term E.^. TermEnd
                         )
                       , ( "lecture-start"
                         , SortColumn $ \term -> term E.^. TermLectureStart
                         )
                       , ( "lecture-end"
                         , SortColumn $ \term -> term E.^. TermLectureEnd
                         )
                       ]
        , dbtAttrs = tableDefault
        , dbtIdent = "terms" :: Text
        }
      defaultLayout $ do
        setTitle "Freigeschaltete Semester"
        $(widgetFile "terms")

getTermEditR :: Handler Html
getTermEditR = do
  -- TODO: Defaults für Semester hier ermitteln und übergeben
  termEditHandler Nothing

postTermEditR :: Handler Html
postTermEditR = termEditHandler Nothing

getTermEditExistR :: TermId -> Handler Html
getTermEditExistR tid = do
  term <- runDB $ get tid
  termEditHandler term


termEditHandler :: Maybe Term -> Handler Html
termEditHandler term = do
    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm term
    case result of
      (FormSuccess res) -> do
          -- term <- runDB $ get $ TermKey termName
          runDB $ repsert (TermKey $ termName res) res
-- 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 $ termName res
          redirect TermShowR
      (FormMissing  ) -> return ()
      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
    let formTitle   = "Semester editieren/anlegen" :: Text
    let actionUrl   = TermEditR
    defaultLayout $ do
      setTitle [shamlet| #{formTitle} |]
      $(widgetFile "formPage")

newTermForm :: Maybe Term -> Form Term
newTermForm template html = do
    (result, widget) <- flip (renderAForm FormStandard) html $ Term
      <$> areq termNewField (bfs ("Semester" :: Text)) (termName  <$> template)
      <*> areq dayField  (bfs ("Erster Tag" :: Text)) (termStart <$> template)
      <*> areq dayField  (bfs ("Letzer Tag" :: Text)) (termEnd   <$> template)
      <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
      <*> areq dayField  (bfs ("Beginn Vorlesungen" :: Text)) (termLectureStart <$> template)
      <*> areq dayField  (bfs ("Ende Vorlesungen" :: Text)) (termLectureEnd   <$> template)
      <*> areq checkBoxField (bfs ("Aktiv" :: Text)) (termActive <$> template)
      <*  submitButton
    return $ case result of
      FormSuccess termResult
        | errorMsgs <- validateTerm termResult
        , not $ null errorMsgs ->
          (FormFailure errorMsgs,
                [whamlet|
                  <div class="alert alert-danger">
                    <h4> Fehler:
                    <ul>
                      $forall errmsg <- errorMsgs
                        <li> #{errmsg}
                  ^{widget}
                |]
              )
      _ -> (result, widget)
{-
  where
    set :: Text -> FieldSettings site
    set = bfs
-}