fradrive/src/Handler/Term.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE 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
-- 
  termData <- runDB $ E.select . E.from $ \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 $ return $ toJSON $ map fst termData
    provideRep $ do      
      let colonnadeTerms = mconcat 
            [ headed "Kürzel" $ \(Entity tid Term{..},_) -> 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}
                |] 
            , headed "Beginn Vorlesungen" $ \(Entity _ Term{..},_) -> 
                fromString $ formatTimeGerWD termLectureStart
            , headed "Ende Vorlesungen"   $ \(Entity _ Term{..},_) -> 
                fromString $ formatTimeGerWD termLectureEnd
            , headed "Aktiv" $ \(Entity _ Term{..},_) -> 
                bool "" tickmark termActive
            , headed "Kursliste" $ \(Entity tid Term{..}, E.Value numCourses) ->
                [whamlet|
                  <a href=@{CourseListTermR tid}>
                    #{show numCourses} Kurse
                |] 
            , headed "Semesteranfang" $ \(Entity _ Term{..},_) ->
              fromString $ formatTimeGerWD termStart
            , headed "Semesterende"   $ \(Entity _ Term{..},_) ->
              fromString $ formatTimeGerWD termEnd
            , headed "Feiertage im Semester" $ \(Entity _ Term{..},_) ->
              fromString $ (intercalate ", ") $ map formatTimeGerWD termHolidays
            ]  
      defaultLayout $ do
        setTitle "Freigeschaltete Semester"            
        encodeWidgetTable tableDefault colonnadeTerms termData

    
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
    action <- lookupPostParam "formaction"
    case (result,action) of
      (FormSuccess res, fAct) 
        | fAct == formActionDelete -> do
          runDB $ delete (TermKey $ termName res) 
          let tid = termToText $ termName res
          let msg = "Semester " `T.append` tid `T.append` " erfolgreich gelöscht."            
          addMessage "warning" [shamlet| #{msg} |]
          redirect TermShowR
        | fAct == formActionSave -> do
          -- term <- runDB $ get $ TermKey termName 
          runDB $ repsert (TermKey $ termName res) res
          let tid = termToText $ termName res
          let msg = "Semester " `T.append` tid `T.append` " erfolgreich editiert."            
          addMessage "success" [shamlet| #{msg} |]
          redirect TermShowR   
        | otherwise -> redirect TermShowR      
      (FormMissing,_)   -> return ()
      (FormFailure _,_) -> addMessage "warning" "Bitte Eingabe korrigieren."            
    let formTitle   = "Semester editieren/anlegen" :: Text
    let actionUrl   = TermEditR
    let formActions = defaultFormActions
    defaultLayout $ do
      setTitle [shamlet| #{formTitle} |]
      $(widgetFile "generic_form")

{-            
wdgtTermForm :: (ToWidget UniWorX a) => a -> Enctype ->  Handler Html              
wdgtTermForm formWidget formEnctype = do
    let formTitle   = "Semester editieren/anlegen" :: Text
    let actionUrl   = TermEditR
    let formActions = defaultFormActions
    defaultLayout $ do
      setTitle [shamlet| #{formTitle} |]
      $(widgetFile "generic_form")
-}
      
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)
      -- <*  bootstrapSubmit (bsSubmit "Semester bearbeiten")      
    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 
-}