134 lines
3.6 KiB
Haskell
134 lines
3.6 KiB
Haskell
module Handler.School where
|
|
|
|
import Import
|
|
import Handler.Utils
|
|
import Handler.Utils.Table.Columns
|
|
|
|
import qualified Database.Esqueleto as E
|
|
|
|
getSchoolListR :: Handler Html
|
|
getSchoolListR = do
|
|
let
|
|
schoolLink :: SchoolId -> SomeRoute UniWorX
|
|
schoolLink ssh = SomeRoute $ SchoolShowR ssh
|
|
|
|
dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
|
|
dbtSQLQuery = return
|
|
|
|
dbtProj :: DBRow _ -> MaybeT (YesodDB UniWorX) (DBRow (Entity School))
|
|
dbtProj = return
|
|
|
|
dbtRowKey = (E.^. SchoolId)
|
|
|
|
dbtColonnade :: Colonnade Sortable _ _
|
|
dbtColonnade = mconcat
|
|
[ colSchoolShort $ _dbrOutput . _entityKey
|
|
, anchorColonnade (views (_dbrOutput . _entityKey) schoolLink) $ colSchoolName (_dbrOutput . _entityVal . _schoolName)
|
|
]
|
|
|
|
dbtSorting = mconcat
|
|
[ sortSchoolShort $ to (E.^. SchoolId)
|
|
, sortSchoolName $ to (E.^. SchoolName)
|
|
]
|
|
|
|
dbtFilter = mempty
|
|
dbtFilterUI = mempty
|
|
|
|
dbtStyle = def
|
|
dbtParams = def
|
|
|
|
dbtCsvEncode = noCsvEncode
|
|
dbtCsvDecode = Nothing
|
|
|
|
dbtIdent :: Text
|
|
dbtIdent = "schools"
|
|
|
|
psValidator = def
|
|
& defaultSorting [SortAscBy "school-name"]
|
|
|
|
|
|
table <- runDB $ dbTableWidget' psValidator DBTable{..}
|
|
|
|
let title = MsgMenuSchoolList
|
|
siteLayoutMsg title $ do
|
|
setTitleI title
|
|
table
|
|
|
|
data SchoolForm = SchoolForm
|
|
{ sfShorthand :: CI Text
|
|
, sfName :: CI Text
|
|
}
|
|
|
|
mkSchoolForm :: Maybe SchoolId -> Maybe SchoolForm -> Form SchoolForm
|
|
mkSchoolForm mSsh template = renderAForm FormStandard $ SchoolForm
|
|
<$> maybe (\f fs -> areq f fs (sfShorthand <$> template)) (\ssh f fs -> aforced f fs (unSchoolKey ssh)) mSsh ciField (fslI MsgSchoolShort)
|
|
<*> areq ciField (fslI MsgSchoolName) (sfName <$> template)
|
|
|
|
schoolToForm :: SchoolId -> DB (Form SchoolForm)
|
|
schoolToForm ssh = do
|
|
School{..} <- get404 ssh
|
|
return . mkSchoolForm (Just ssh) $ Just SchoolForm
|
|
{ sfShorthand = schoolShorthand
|
|
, sfName = schoolName
|
|
}
|
|
|
|
|
|
getSchoolShowR, postSchoolShowR :: SchoolId -> Handler Html
|
|
getSchoolShowR = postSchoolShowR
|
|
postSchoolShowR ssh = do
|
|
sForm <- runDB $ schoolToForm ssh
|
|
|
|
((sfResult, sfView), sfEnctype) <- runFormPost sForm
|
|
|
|
formResult sfResult $ \SchoolForm{..} -> do
|
|
runDB $ do
|
|
update ssh [ SchoolName =. sfName ]
|
|
addMessageI Success $ MsgSchoolUpdated ssh
|
|
redirect $ SchoolShowR ssh
|
|
|
|
let sfView' = wrapForm sfView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just . SomeRoute $ SchoolShowR ssh
|
|
, formEncoding = sfEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
siteLayoutMsg (MsgSchoolTitle ssh) $ do
|
|
setTitleI $ MsgSchoolTitle ssh
|
|
sfView'
|
|
|
|
getSchoolNewR, postSchoolNewR :: Handler Html
|
|
getSchoolNewR = postSchoolNewR
|
|
postSchoolNewR = do
|
|
((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing
|
|
|
|
formResult sfResult $ \SchoolForm{..} -> do
|
|
let ssh = SchoolKey sfShorthand
|
|
insertOkay <- runDB $ do
|
|
fmap (is _Just) $ insertUnique School
|
|
{ schoolShorthand = sfShorthand
|
|
, schoolName = sfName
|
|
}
|
|
|
|
if
|
|
| insertOkay -> do
|
|
addMessageI Success $ MsgSchoolCreated ssh
|
|
redirect $ SchoolShowR ssh
|
|
| otherwise
|
|
-> addMessageI Error $ MsgSchoolExists ssh
|
|
|
|
let sfView' = wrapForm sfView FormSettings
|
|
{ formMethod = POST
|
|
, formAction = Just $ SomeRoute SchoolNewR
|
|
, formEncoding = sfEnctype
|
|
, formAttrs = []
|
|
, formSubmit = FormSubmit
|
|
, formAnchor = Nothing :: Maybe Text
|
|
}
|
|
|
|
siteLayoutMsg MsgTitleSchoolNew $ do
|
|
setTitleI MsgTitleSchoolNew
|
|
sfView'
|