fradrive-old/src/Handler/Assist.hs

{-# LANGUAGE NoImplicitPrelude #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE TypeFamilies #-}
module Handler.Assist where

import Import
import qualified Data.Text as T
import Data.Maybe
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
import Database.Persist.Class as K (Key)
-- import Text.Julius (RawJS (..))

-- TODO: Move elsewhere
termExistsField :: Field (HandlerT UniWorX IO) TermIdentifier
termExistsField = termField True

termNewField :: Field (HandlerT UniWorX IO) TermIdentifier
termNewField = termField False 

termField :: Bool -> Field (HandlerT UniWorX IO) TermIdentifier
termField mustexist = checkMMap checkTerm termToText textField
  where 
    errTextParse :: Text
    errTextParse = "Semester: S oder W gefolgt von Jahreszahl"
    
    errTextFreigabe :: TermIdentifier -> Text
    errTextFreigabe ti = "Semester " `T.append` (termToText ti) `T.append` " wurde noch nicht freigegeben."
    
    checkTerm :: Text -> HandlerT UniWorX IO (Either Text TermIdentifier)
    checkTerm t = case termFromText t of
      Left  _        -> return $ Left errTextParse
      res@(Right ti) -> do
        term <- runDB $ get $ TermKey ti -- TODO: membershiptest instead?
        return $ if mustexist && isNothing term 
          then Left $ errTextFreigabe ti
          else res 
        
      
       
-- Handler for Assistants

data NewCourseForm = NewCourseForm 
  {   ncf_user        :: UserId
  ,   ncf_term        :: TermIdentifier
  ,   ncf_name        :: Text 
  ,   ncf_short       :: Text 
  ,   ncf_description :: Textarea 
  ,   ncf_homepage    :: Maybe Text 
  ,   ncf_html        :: Html 
  ,   ncf_capacity    :: Maybe Int
  }

newCourseForm :: UserId -> Form NewCourseForm 
newCourseForm uid = renderBootstrap3 BootstrapBasicForm $ NewCourseForm
    <$> pure uid 
    <*> areq termExistsField (set "Semester") Nothing
--     <*> areq textField (set "Semester") Nothing
    <*> areq textField (set "Name des Kurses")           Nothing
    <*> areq textField (set "Kurs Kürzel (3-4 Zeichen)") Nothing
    <*> areq textareaField (set "Beschreibung des Kurses")       Nothing
    <*> aopt urlField  (set "Externe Kurshomepage")       Nothing
    <*> areq htmlField (set "Beschreibung in HTML")       Nothing
    <*> aopt intField  (set "Maximale Teilnehmer")       Nothing
    -- Add attributes like the placeholder and CSS classes.
   where set txt = FieldSettings
            { fsLabel = txt
            , fsTooltip = Nothing
            , fsId = Nothing
            , fsName = Nothing
            , fsAttrs =
                [ ("class", "form-control")                
                ]
            }

getShowCourseR :: CourseId -> Handler Html 
getShowCourseR courseId = do
    defaultLayout $ do
        [whamlet|
            TODO unfinished
        |]

getNewCourseR :: Handler Html
getNewCourseR = do
    aid <- requireAuthId
    (formWidget, formEnctype) <- generateFormPost $ newCourseForm aid
    defaultLayout $ do
        setTitle "Neuen Kurs anlegen"
        [whamlet|
            User: #{show aid}
        |]        
        $(widgetFile "newCourse")

postNewCourseR :: Handler Html
postNewCourseR = do
    aid <- requireAuthId
    ((result, formWidget), formEnctype) <- runFormPost $ newCourseForm aid
    case result of
       FormSuccess res -> defaultLayout $ do
            setMessage "Got something!"
            $(widgetFile "newCourse")
       FormMissing -> defaultLayout $ do
            setMessage "Keine Formulardaten erhalten."
            $(widgetFile "newCourse")
       FormFailure errorMsgs -> defaultLayout $ do
            setMessage [shamlet| <span .error>Fehler:
                            <ul>
                                $forall errmsg <- errorMsgs
                                    <li> #{errmsg} 
                        |]
            $(widgetFile "newCourse")

{-
    defaultLayout $ do
        let (commentFormId, commentTextareaId, commentListId) = commentIds
        aDomId <- newIdent
        setTitle "Welcome To Yesod!"
        $(widgetFile "homepage")
-}


getShowTermR :: Handler Html
getShowTermR = do
  terms <- runDB $ selectList [] [Desc TermStart]
  defaultLayout $ do
    setTitle "Freigeschaltete Semester"
    -- TODO: provide common utility function for formatting Times
    -- TODO: turn into proper table
    [whamlet|
      <h2>
        Liste der freigeschalteten Semester:
      $if null terms 
        <p> Es wurden noch kein Semester freigeschaltetet.
      $else 
        <ul>
          $forall Entity _ term <- terms
            <li>
              <a href=@{NewTermR}>
                #{termToText $ termName term}               
              from  #{formatTime defaultTimeLocale "%d.%m.%Y" $ termStart term}
              to: #{formatTime defaultTimeLocale "%d.%m.%Y" $ termEnd term}
              $if termActive term 
                (Semester ist aktiv)
    |]

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


getNewTermDefR :: Maybe Term -> Handler Html
getNewTermDefR mbTerm= do 
    aid <- requireAuthId
    (formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
    defaultLayout $ do
        setTitle "Neues Semester anlegen"        
        $(widgetFile "newTerm")
        
postNewTermR :: Handler Html
postNewTermR = do
    aid <- requireAuthId
    ((result, formWidget), formEnctype) <- runFormPost $ newTermForm Nothing
    case result of
       FormSuccess res -> 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` " wurde angelegt!"        
          -- setMessage $ toHtml msg -- FIXME
          setMessage "Semester wurde angelegt" 
          redirect ShowTermR
       FormMissing -> defaultLayout $ do
            setMessage "Keine Formulardaten erhalten."
            $(widgetFile "newTerm")
       FormFailure errorMsgs -> defaultLayout $ do
            setMessage [shamlet| <span .error>Fehler:
                            <ul>
                                $forall errmsg <- errorMsgs
                                    <li> #{errmsg} 
                        |]
            $(widgetFile "newTerm")

newTermForm :: Maybe Term -> Form Term
newTermForm template = 
    renderBootstrap3 BootstrapBasicForm $ Term
      <$> areq termNewField (set "Semester")   (termName  <$> template)
      <*> areq dayField  (set "Erster Tag") (termStart <$> template)
      <*> areq dayField  (set "Letzer Tag") (termEnd   <$> template)
      <*> pure [] -- TODO: List of Day field required, must probably be done as its own form and then combined
      <*> areq checkBoxField (set "Aktiv") (termActive <$> template)
  where set txt = FieldSettings
            { fsLabel = txt
            , fsTooltip = Nothing
            , fsId = Nothing
            , fsName = Nothing
            , fsAttrs =
                [ ("class", "form-control")                
                ]
            }