130 lines
5.8 KiB
Haskell
130 lines
5.8 KiB
Haskell
-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>
|
|
--
|
|
-- SPDX-License-Identifier: AGPL-3.0-or-later
|
|
|
|
module Handler.Utils.AuthorshipStatement
|
|
( insertAuthorshipStatement
|
|
, forcedAuthorshipStatementField
|
|
, authorshipStatementWidget
|
|
, getSheetAuthorshipStatement
|
|
, acceptAuthorshipStatementField
|
|
) where
|
|
|
|
import Import
|
|
import Utils.Form
|
|
|
|
import qualified Data.Map.Strict as Map
|
|
|
|
import Handler.Utils.Form (i18nLangMap, I18nLang(..))
|
|
|
|
import qualified Database.Esqueleto.Legacy as E
|
|
import qualified Database.Esqueleto.Utils as E
|
|
|
|
import qualified Data.ByteString.Base64.URL as Base64
|
|
import qualified Data.ByteArray as BA
|
|
|
|
|
|
insertAuthorshipStatement :: MonadIO m
|
|
=> I18nStoredMarkup -> SqlWriteT m AuthorshipStatementDefinitionId
|
|
insertAuthorshipStatement authorshipStatementDefinitionContent = withCompatibleBackend @SqlBackend $ do
|
|
let authorshipStatementDefinitionHash = toAuthorshipStatementReference authorshipStatementDefinitionContent
|
|
unlessM (exists [AuthorshipStatementDefinitionHash ==. authorshipStatementDefinitionHash]) $
|
|
insert_ AuthorshipStatementDefinition{..}
|
|
return $ AuthorshipStatementDefinitionKey authorshipStatementDefinitionHash
|
|
|
|
forcedAuthorshipStatementField :: (MonadHandler handler, HandlerSite handler ~ UniWorX)
|
|
=> Field handler AuthorshipStatementDefinition
|
|
forcedAuthorshipStatementField = Field{..}
|
|
where
|
|
fieldParse _ _ = pure . Left $ SomeMessage ("Result of forcedAuthorshipStatementField inspected" :: Text)
|
|
fieldEnctype = UrlEncoded
|
|
fieldView theId _name attrs (preview _Right -> mVal) _isReq
|
|
= [whamlet|
|
|
$newline never
|
|
<div ##{theId} *{attrs}>
|
|
^{maybe mempty authorshipStatementWidget mVal}
|
|
|]
|
|
|
|
authorshipStatementWidget :: AuthorshipStatementDefinition -> Widget
|
|
authorshipStatementWidget AuthorshipStatementDefinition{..}
|
|
= [whamlet|
|
|
$newline never
|
|
<dl .authorship-statement>
|
|
$forall (I18nLang l, t) <- Map.toList (review i18nLangMap authorshipStatementDefinitionContent)
|
|
<dt>
|
|
_{MsgLanguageEndonym l}
|
|
<dd>
|
|
#{markupOutput t}
|
|
|
|
<p .authorship-statement__id>
|
|
#{hashText}
|
|
|]
|
|
where hashText = decodeUtf8 . Base64.encodeUnpadded $ BA.convert authorshipStatementDefinitionHash
|
|
|
|
acceptAuthorshipStatementField :: forall m.
|
|
(MonadHandler m, HandlerSite m ~ UniWorX)
|
|
=> Entity AuthorshipStatementDefinition
|
|
-> Field m AuthorshipStatementDefinitionId
|
|
acceptAuthorshipStatementField (Entity asdId asd)
|
|
= checkBoxField
|
|
& _fieldView %~ adjFieldView
|
|
& checkMap (bool (Left MsgAuthorshipStatementStatementIsRequired) (Right asdId)) (== asdId)
|
|
where
|
|
adjFieldView :: FieldViewFunc m Bool -> FieldViewFunc m Bool
|
|
adjFieldView checkboxView theId theName attrs val isReq = do
|
|
let checkboxWdgt = checkboxView checkboxId theName [] val isReq
|
|
checkboxId = theId <> "__checkbox"
|
|
$(widgetFile "widgets/authorship-statement-accept")
|
|
|
|
|
|
getSheetAuthorshipStatement :: MonadIO m
|
|
=> Entity Sheet
|
|
-> SqlReadT m (Maybe (Entity AuthorshipStatementDefinition))
|
|
getSheetAuthorshipStatement (Entity _ Sheet{..}) = withCompatibleBackend @SqlBackend $ traverse getJustEntity <=< runMaybeT $ do
|
|
Entity _ School{..} <- MaybeT . E.selectMaybe . E.from $ \(school `E.InnerJoin` course) -> do
|
|
E.on $ school E.^. SchoolId E.==. course E.^. CourseSchool
|
|
E.where_ $ course E.^. CourseId E.==. E.val sheetCourse
|
|
return school
|
|
|
|
let examId = fmap Right sheetAuthorshipStatementExam
|
|
<|> fmap Left (sheetType ^? _examPart . re _SqlKey)
|
|
<|> fmap Right sheetRequireExamRegistration
|
|
exam <- lift . for examId $ \case
|
|
Right e -> getJust e
|
|
Left epId -> getJust epId >>= getJust . examPartExam
|
|
|
|
let
|
|
examAuthorshipStatement' = exam >>= examAuthorshipStatement
|
|
sheetAuthorshipStatement' = guardOnM (is _SheetAuthorshipStatementModeEnabled sheetAuthorshipStatementMode) sheetAuthorshipStatement
|
|
sheetDoAuthorshipStatements
|
|
= is _SheetAuthorshipStatementModeEnabled sheetAuthorshipStatementMode
|
|
|| (is _SheetAuthorshipStatementModeExam sheetAuthorshipStatementMode && is _Just examAuthorshipStatement')
|
|
|
|
if
|
|
| is _Just exam
|
|
, is _SchoolAuthorshipStatementModeNone schoolSheetExamAuthorshipStatementMode
|
|
-> mzero
|
|
| is _Just exam
|
|
, not schoolSheetExamAuthorshipStatementAllowOther
|
|
-> guardOnM (is _SchoolAuthorshipStatementModeRequired schoolSheetExamAuthorshipStatementMode || sheetDoAuthorshipStatements) $ hoistMaybe schoolSheetExamAuthorshipStatementDefinition
|
|
| is _Just exam
|
|
, is _SchoolAuthorshipStatementModeRequired schoolSheetExamAuthorshipStatementMode
|
|
-> hoistMaybe $ sheetAuthorshipStatement'
|
|
<|> guardOnM (is _SheetAuthorshipStatementModeExam sheetAuthorshipStatementMode) examAuthorshipStatement'
|
|
<|> schoolSheetExamAuthorshipStatementDefinition
|
|
|
|
| is _Nothing exam
|
|
, is _SchoolAuthorshipStatementModeNone schoolSheetAuthorshipStatementMode
|
|
-> mzero
|
|
| is _Nothing exam
|
|
, not schoolSheetAuthorshipStatementAllowOther
|
|
-> guardOnM (is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode || sheetDoAuthorshipStatements) $ hoistMaybe schoolSheetAuthorshipStatementDefinition
|
|
| is _Nothing exam
|
|
, is _SchoolAuthorshipStatementModeRequired schoolSheetAuthorshipStatementMode
|
|
-> hoistMaybe $ sheetAuthorshipStatement' <|> schoolSheetAuthorshipStatementDefinition
|
|
|
|
| otherwise
|
|
-> case exam of
|
|
Just _ -> hoistMaybe $ sheetAuthorshipStatement' <|> examAuthorshipStatement'
|
|
Nothing -> hoistMaybe sheetAuthorshipStatement'
|