Term Handler moved to its own module
This commit is contained in:
SJost
parent
d9c6380807
commit
40fab9a362
@ -38,10 +38,11 @@ import System.Log.FastLogger (defaultBufSize, newStdoutLoggerSet,
|
||||
toLogStr)
|
||||
|
||||
-- Import all relevant handler modules here.
|
||||
-- Don't forget to add new modules to your cabal file!
|
||||
-- Don't forget to add new modules to your cabal file!
|
||||
import Handler.Common
|
||||
import Handler.Home
|
||||
import Handler.Profile
|
||||
import Handler.Term
|
||||
import Handler.Assist
|
||||
|
||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||
|
||||
@ -7,36 +7,14 @@
|
||||
module Handler.Assist where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import qualified Data.Text as T
|
||||
import Data.Maybe
|
||||
-- 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
|
||||
|
||||
|
||||
|
||||
@ -119,93 +97,3 @@ postNewCourseR = do
|
||||
setTitle "Welcome To Yesod!"
|
||||
$(widgetFile "homepage")
|
||||
-}
|
||||
|
||||
|
||||
getShowTermsR :: Handler Html
|
||||
getShowTermsR = 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=@{EditTermExistR $ termName term}>
|
||||
#{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
|
||||
getEditTermMaybeR Nothing
|
||||
|
||||
getEditTermR :: Handler Html
|
||||
getEditTermR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
getEditTermMaybeR Nothing
|
||||
|
||||
getEditTermExistR :: TermIdentifier -> Handler Html
|
||||
getEditTermExistR tid = do
|
||||
term <- runDB $ get $ TermKey tid
|
||||
getEditTermMaybeR term
|
||||
|
||||
getEditTermMaybeR :: Maybe Term -> Handler Html
|
||||
getEditTermMaybeR mbTerm= do
|
||||
aid <- requireAuthId
|
||||
(formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
|
||||
defaultLayout $ do
|
||||
setTitle "Semester editieren/anlegen"
|
||||
$(widgetFile "editTerm")
|
||||
|
||||
postEditTermR :: Handler Html
|
||||
postEditTermR = 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 ShowTermsR
|
||||
FormMissing -> defaultLayout $ do
|
||||
setMessage "Keine Formulardaten erhalten."
|
||||
$(widgetFile "editTerm")
|
||||
FormFailure errorMsgs -> defaultLayout $ do
|
||||
setMessage [shamlet| <span .error>Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
|]
|
||||
$(widgetFile "editTerm")
|
||||
|
||||
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")
|
||||
]
|
||||
}
|
||||
|
||||
108
src/Handler/Term.hs
Normal file
108
src/Handler/Term.hs
Normal file
@ -0,0 +1,108 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Handler.Term where
|
||||
|
||||
import Import
|
||||
import Handler.Utils
|
||||
import qualified Data.Text as T
|
||||
-- import Data.Maybe
|
||||
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
||||
-- import Text.Julius (RawJS (..))
|
||||
|
||||
|
||||
|
||||
getShowTermsR :: Handler Html
|
||||
getShowTermsR = 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=@{EditTermExistR $ termName term}>
|
||||
#{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)
|
||||
$with holidays <- termHolidays term
|
||||
$if not (null holidays)
|
||||
Feiertage im Semester: #{show holidays}
|
||||
|]
|
||||
|
||||
getNewTermR :: Handler Html
|
||||
getNewTermR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
getEditTermMaybeR Nothing
|
||||
|
||||
getEditTermR :: Handler Html
|
||||
getEditTermR = do
|
||||
-- TODO: Defaults für Semester hier ermitteln und übergeben
|
||||
getEditTermMaybeR Nothing
|
||||
|
||||
getEditTermExistR :: TermIdentifier -> Handler Html
|
||||
getEditTermExistR tid = do
|
||||
term <- runDB $ get $ TermKey tid
|
||||
getEditTermMaybeR term
|
||||
|
||||
getEditTermMaybeR :: Maybe Term -> Handler Html
|
||||
getEditTermMaybeR mbTerm= do
|
||||
aid <- requireAuthId
|
||||
(formWidget, formEnctype) <- generateFormPost $ newTermForm mbTerm
|
||||
defaultLayout $ do
|
||||
setTitle "Semester editieren/anlegen"
|
||||
$(widgetFile "editTerm")
|
||||
|
||||
postEditTermR :: Handler Html
|
||||
postEditTermR = 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 editiert!"
|
||||
-- setMessage $ toHtml msg -- FIXME
|
||||
setMessage "Semester gespeichert"
|
||||
redirect ShowTermsR
|
||||
FormMissing -> defaultLayout $ do
|
||||
setMessage "Keine Formulardaten erhalten."
|
||||
$(widgetFile "editTerm")
|
||||
FormFailure errorMsgs -> defaultLayout $ do
|
||||
setMessage [shamlet| <span .error>Fehler:
|
||||
<ul>
|
||||
$forall errmsg <- errorMsgs
|
||||
<li> #{errmsg}
|
||||
|]
|
||||
$(widgetFile "editTerm")
|
||||
|
||||
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")
|
||||
]
|
||||
}
|
||||
5
src/Handler/Utils.hs
Normal file
5
src/Handler/Utils.hs
Normal file
@ -0,0 +1,5 @@
|
||||
module Handler.Utils
|
||||
( module Handler.Utils
|
||||
) where
|
||||
|
||||
import Handler.Utils.Term as Handler.Utils
|
||||
35
src/Handler/Utils/Term.hs
Normal file
35
src/Handler/Utils/Term.hs
Normal file
@ -0,0 +1,35 @@
|
||||
{-# LANGUAGE NoImplicitPrelude #-}
|
||||
{-# LANGUAGE OverloadedStrings #-}
|
||||
{-# LANGUAGE TemplateHaskell #-}
|
||||
{-# LANGUAGE QuasiQuotes #-}
|
||||
{-# LANGUAGE MultiParamTypeClasses #-}
|
||||
{-# LANGUAGE TypeFamilies #-}
|
||||
module Handler.Utils.Term where
|
||||
|
||||
import Import
|
||||
import qualified Data.Text as T
|
||||
-- import Data.Maybe
|
||||
|
||||
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
|
||||
Loading…
Reference in New Issue
Block a user