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 _ -> 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
  , sfOrgUnits :: Set (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 (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 "") (const Nothing) ("ldap-organisations" :: Text) (fslI MsgSchoolLdapOrganisations & setTooltip MsgSchoolLdapOrganisationsTip) False (Set.toList . sfOrgUnits <$> template))
  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
    }


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 ]
      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
        }
      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'