This repository has been archived on 2024-10-24. You can view files and clone it, but cannot push or open issues or pull requests.
fradrive-old/src/Handler/Course/News/New.hs
2019-10-01 19:46:40 +02:00

48 lines
1.6 KiB
Haskell

module Handler.Course.News.New
( getCNewsNewR, postCNewsNewR
) where
import Import
import Handler.Utils
import Handler.Course.News.Form
import qualified Data.Conduit.List as C
getCNewsNewR, postCNewsNewR :: TermId -> SchoolId -> CourseShorthand -> Handler Html
getCNewsNewR = postCNewsNewR
postCNewsNewR tid ssh csh = do
cid <- runDB . getKeyBy404 $ TermSchoolCourseShort tid ssh csh
((newsRes, newsWgt'), newsEnctype) <- runFormPost $ courseNewsForm Nothing
formResult newsRes $ \CourseNewsForm{..} -> do
now <- liftIO getCurrentTime
cID <- runDB $ do
nId <- insert CourseNews
{ courseNewsCourse = cid
, courseNewsVisibleFrom = cnfVisibleFrom
, courseNewsParticipantsOnly = cnfParticipantsOnly
, courseNewsTitle = cnfTitle
, courseNewsContent = cnfContent
, courseNewsSummary = cnfSummary
, courseNewsLastEdit = now
}
let
insertFile (Left fId) = insert_ $ CourseNewsFile nId fId
insertFile (Right f ) = insert_ . CourseNewsFile nId =<< insert f
forM_ cnfFiles $ \fSource ->
runConduit $ transPipe lift fSource .| C.mapM_ insertFile
encrypt nId :: DB CryptoUUIDCourseNews
addMessageI Success MsgCourseNewsCreated
redirect $ CourseR tid ssh csh CShowR :#: [st|news-#{toPathPiece cID}|]
siteLayoutMsg MsgMenuCourseNewsNew $ do
setTitleI MsgMenuCourseNewsNew
wrapForm newsWgt' def
{ formAction = Just . SomeRoute $ CourseR tid ssh csh CNewsNewR
, formEncoding = newsEnctype
}