fradrive/src/Handler/School.hs

module Handler.School where

import Import
import Handler.Utils

import qualified Database.Esqueleto as E

import qualified Data.Set as Set
import qualified Data.CaseInsensitive as CI
import qualified Data.Text as Text


getSchoolListR :: Handler Html
getSchoolListR = do
  let
    schoolLink :: SchoolId -> SomeRoute UniWorX
    schoolLink ssh = SomeRoute $ SchoolR ssh SchoolEditR

    dbtSQLQuery :: E.SqlExpr (Entity School) -> E.SqlQuery _
    dbtSQLQuery = return

    dbtProj :: DBRow _ -> DB (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
  , sfOrgUnits :: Set (CI Text)
  , sfExamMinimumRegisterBeforeStart
  , sfExamMinimumRegisterDuration :: Maybe NominalDiffTime
  , sfExamRequireModeForRegistration :: Bool
  , sfExamDiscouragedModes :: ExamModeDNF
  , sfExamCloseMode :: ExamCloseMode
  }

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 (textField & cfStrip & cfCI) (fslI MsgSchoolShort)
  <*> areq (textField & cfStrip & cfCI) (fslI MsgSchoolName) (sfName <$> template)
  <*> (Set.fromList . mapMaybe (fmap CI.mk . assertM' (not . Text.null) . Text.strip . CI.original) <$> massInputListA (ciField & addDatalist ldapOrgs) (const "") MsgSchoolLdapOrganisationMissing (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
  <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterBeforeStart & setTooltip MsgSchoolExamMinimumRegisterBeforeStartTip) (sfExamMinimumRegisterBeforeStart <$> template)
  <*> aopt daysField (fslI MsgSchoolExamMinimumRegisterDuration & setTooltip MsgSchoolExamMinimumRegisterDurationTip) (sfExamMinimumRegisterDuration <$> template)
  <*> apopt checkBoxField (fslI MsgSchoolExamRequireModeForRegistration & setTooltip MsgSchoolExamRequireModeForRegistration) (sfExamRequireModeForRegistration <$> template)
  <*> areq pathPieceField (fslI MsgSchoolExamDiscouragedModes) (sfExamDiscouragedModes <$> template <|> pure (ExamModeDNF predDNFFalse))
  <*> apopt (selectField optionsFinite) (fslI MsgExamCloseMode) (sfExamCloseMode <$> template <|> pure ExamCloseSeparate)
  where
    ldapOrgs :: HandlerFor UniWorX (OptionList (CI Text))
    ldapOrgs = fmap (mkOptionList . map (\t -> Option (CI.original t) t (CI.original t)) . Set.toAscList) . runDB $
      setOf (folded . _entityVal . _schoolLdapOrgUnit) <$> selectList [] []

schoolToForm :: SchoolId -> DB (Form SchoolForm)
schoolToForm ssh = do
  School{..} <- get404 ssh
  ldapFrags <- selectList [SchoolLdapSchool ==. Just ssh] []
  return . mkSchoolForm (Just ssh) $ Just SchoolForm
    { sfShorthand = schoolShorthand
    , sfName = schoolName
    , sfOrgUnits = setOf (folded . _entityVal . _schoolLdapOrgUnit) ldapFrags
    , sfExamMinimumRegisterBeforeStart = schoolExamMinimumRegisterBeforeStart
    , sfExamMinimumRegisterDuration = schoolExamMinimumRegisterDuration
    , sfExamRequireModeForRegistration = schoolExamRequireModeForRegistration
    , sfExamDiscouragedModes = schoolExamDiscouragedModes
    , sfExamCloseMode = schoolExamCloseMode
    }


getSchoolEditR, postSchoolEditR :: SchoolId -> Handler Html
getSchoolEditR = postSchoolEditR
postSchoolEditR ssh = do
  sForm <- runDB $ schoolToForm ssh

  ((sfResult, sfView), sfEnctype) <- runFormPost sForm

  formResult sfResult $ \SchoolForm{..} -> do
    runDB $ do
      update ssh
        [ SchoolName =. sfName
        , SchoolExamMinimumRegisterBeforeStart =. sfExamMinimumRegisterBeforeStart
        , SchoolExamMinimumRegisterDuration =. sfExamMinimumRegisterDuration
        , SchoolExamRequireModeForRegistration =. sfExamRequireModeForRegistration
        , SchoolExamDiscouragedModes =. sfExamDiscouragedModes
        , SchoolExamCloseMode =. sfExamCloseMode
        ]
      forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
        void $ upsert SchoolLdap
          { schoolLdapSchool = Just ssh
          , ..
          }
          [ SchoolLdapSchool =. Just ssh
          ]
      deleteWhere [SchoolLdapSchool ==. Just ssh, SchoolLdapOrgUnit /<-. Set.toList sfOrgUnits]
      addMessageI Success $ MsgSchoolUpdated ssh
    redirect $ SchoolR ssh SchoolEditR

  let sfView' = wrapForm sfView FormSettings
        { formMethod = POST
        , formAction = Just . SomeRoute $ SchoolR ssh SchoolEditR
        , 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
  uid <- requireAuthId
  ((sfResult, sfView), sfEnctype) <- runFormPost $ mkSchoolForm Nothing Nothing

  formResult sfResult $ \SchoolForm{..} -> do
    let ssh = SchoolKey sfShorthand
    insertOkay <- runDB $ do
      didInsert <- is _Just <$> insertUnique School
        { schoolShorthand = sfShorthand
        , schoolName = sfName
        , schoolExamMinimumRegisterBeforeStart = sfExamMinimumRegisterBeforeStart
        , schoolExamMinimumRegisterDuration = sfExamMinimumRegisterDuration
        , schoolExamRequireModeForRegistration = sfExamRequireModeForRegistration
        , schoolExamDiscouragedModes = sfExamDiscouragedModes
        , schoolExamCloseMode = sfExamCloseMode
        }
      when didInsert $ do
        insert_ UserFunction
          { userFunctionUser     = uid
          , userFunctionSchool   = ssh
          , userFunctionFunction = SchoolAdmin
          }
        forM_ sfOrgUnits $ \schoolLdapOrgUnit ->
          void $ upsert SchoolLdap
            { schoolLdapSchool = Just ssh
            , ..
            }
            [ SchoolLdapSchool =. Just ssh
            ]
      return didInsert

    if
      | insertOkay -> do
          addMessageI Success $ MsgSchoolCreated ssh
          redirect $ SchoolR ssh SchoolEditR
      | 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'