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)
|
toLogStr)
|
||||||
|
|
||||||
-- Import all relevant handler modules here.
|
-- 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.Common
|
||||||
import Handler.Home
|
import Handler.Home
|
||||||
import Handler.Profile
|
import Handler.Profile
|
||||||
|
import Handler.Term
|
||||||
import Handler.Assist
|
import Handler.Assist
|
||||||
|
|
||||||
-- This line actually creates our YesodDispatch instance. It is the second half
|
-- This line actually creates our YesodDispatch instance. It is the second half
|
||||||
|
|||||||
@ -7,36 +7,14 @@
|
|||||||
module Handler.Assist where
|
module Handler.Assist where
|
||||||
|
|
||||||
import Import
|
import Import
|
||||||
|
import Handler.Utils
|
||||||
import qualified Data.Text as T
|
import qualified Data.Text as T
|
||||||
import Data.Maybe
|
-- import Data.Maybe
|
||||||
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
import Yesod.Form.Bootstrap3 (BootstrapFormLayout (..), renderBootstrap3)
|
||||||
import Database.Persist.Class as K (Key)
|
|
||||||
-- import Text.Julius (RawJS (..))
|
-- import Text.Julius (RawJS (..))
|
||||||
|
|
||||||
-- TODO: Move elsewhere
|
-- 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!"
|
setTitle "Welcome To Yesod!"
|
||||||
$(widgetFile "homepage")
|
$(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