fradrive/src/Handler/Term.hs

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

module Handler.Term where

import Import
import Handler.Utils

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

import Colonnade hiding (bool)

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 :: 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.sub_select . E.from $ \course -> do
            E.where_ $ term E.^. TermId E.==. course E.^. CourseTerm
            return E.countRows
      return (term, courseCount)
  selectRep $ do
    provideRep $ toJSON . map fst <$> runDB (E.select $ E.from termData)
    provideRep $ do
      let colonnadeTerms = widgetColonnade $ mconcat
            [ sortable Nothing "Kürzel" $
                anchorCell' (\(Entity tid _, _) -> TermCourseListR tid)
                            (\(Entity tid _, _) -> [whamlet|#{toPathPiece tid}|])
            , sortable (Just "lecture-start") (i18nCell MsgLectureStart) $ \(Entity _ Term{..},_) ->
                cell $ formatTime SelFormatDate termLectureStart >>= toWidget
            , sortable (Just "lecture-end") "Ende Vorlesungen"   $ \(Entity _ Term{..},_) ->
                cell $ formatTime SelFormatDate termLectureEnd >>= toWidget
            , sortable Nothing "Aktiv" $ \(Entity _ Term{..},_) ->
                textCell $ (bool "" tickmark termActive :: Text)
            , sortable Nothing "Kurse" $ \(_, E.Value numCourses) ->
                cell [whamlet|_{MsgNumCourses numCourses}|]
            , sortable (Just "start") "Semesteranfang" $ \(Entity _ Term{..},_) ->
                cell $ formatTime SelFormatDate termStart >>= toWidget
            , sortable (Just "end") "Semesterende"   $ \(Entity _ Term{..},_) ->
                cell $ formatTime SelFormatDate termEnd >>= toWidget
            , sortable Nothing "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
                cell $ do
                  termHolidays' <- mapM (formatTime SelFormatDate) termHolidays
                  [whamlet|
                    <ul .list--inline .list--comma-separated>
                      $forall holiday <- termHolidays'
                        <li>#{holiday}
                  |]
            ]
--       let adminColonnade =
--           [ 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}
--                 |]
--           ]
      ((), table) <- dbTable def $ DBTable
        { dbtSQLQuery = termData
        , dbtColonnade = colonnadeTerms
        , dbtProj = return . dbrOutput
        , 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
                         )
                       ]
        , dbtFilter = [ ( "active"
                        , FilterColumn $ \term -> (term E.^. TermActive :: E.SqlExpr (E.Value Bool))
                        )
                      , ( "course"
                        , FilterColumn $ \term csh -> case csh of -- FilterColumn-Lambdas are 
                            []   -> E.val True :: E.SqlExpr (E.Value Bool)
                            cshs -> E.exists . E.from $ \course -> do
                              E.where_ $ course E.^. CourseTerm E.==. term E.^. TermId
                                   E.&&. course E.^. CourseShorthand `E.in_` E.valList cshs
                        )
                      ]
        , dbtStyle = def
        , 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
          let tid = TermKey $ termName res
          -- term <- runDB $ get $ TermKey termName
          runDB $ repsert tid 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 tid
          redirect TermShowR
      (FormMissing  ) -> return ()
      (FormFailure _) -> addMessageI "warning" MsgInvalidInput
    let actionUrl   = TermEditR
    defaultLayout $ do
      setTitleI MsgTermEditHeading
      $(widgetFile "formPage")

newTermForm :: Maybe Term -> Form Term
newTermForm template html = do
    renderMessage <- getMessageRender
    (result, widget) <- flip (renderAForm FormStandard) html $ Term
      <$> areq termNewField (fslpI MsgTerm (renderMessage MsgTermPlaceholder)) (termName  <$> template)
      <*> areq dayField  (fsl ("Erster Tag" :: Text)) (termStart <$> template)
      <*> areq dayField  (fsl ("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  (fsl "Beginn Vorlesungen") (termLectureStart <$> template)
      <*> areq dayField  (fsl ("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">
                    <div class="alert__content">
                      <h4> Fehler:
                      <ul>
                        $forall errmsg <- errorMsgs
                          <li> #{errmsg}
                  ^{widget}
                |]
              )
      _ -> (result, widget)
{-
  where
    set :: Text -> FieldSettings site
    set = bfs
-}