fradrive-old/src/Handler/Users.hs

module Handler.Users where

import Import
-- import Data.Text
import Handler.Utils

import Utils.Lens

import qualified Data.CaseInsensitive as CI

import qualified Data.Set as Set
import qualified Data.Map as Map

import qualified Database.Esqueleto as E


hijackUserForm :: CryptoUUIDUser -> Form ()
hijackUserForm cID csrf = do
  (uidResult, uidView) <- mforced hiddenField "" (cID :: CryptoUUIDUser)
  (btnResult, btnView) <- mreq (buttonField BtnHijack) "" Nothing

  return (() <$ uidResult <* btnResult, mconcat [toWidget csrf, fvInput uidView, fvInput btnView])

getUsersR :: Handler Html
getUsersR = do
  let
    dbtColonnade = dbColonnade . mconcat $
      [ dbRow
      , sortable (Just "name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
          (AdminUserR <$> encrypt uid)
          (nameWidget userDisplayName userSurname)
      , sortable (Just "matriculation") (i18nCell MsgMatrikelNr) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
          (AdminUserR <$> encrypt uid)
          (toWidget . display $ userMatrikelnummer)
--       , sortable (Just "last-name") (i18nCell MsgName) $ \DBRow{ dbrOutput = Entity uid User{..} } -> anchorCellM
--           (AdminUserR <$> encrypt uid)
--           (toWidget . display $ last $ impureNonNull $ words $ userDisplayName)
      , sortable Nothing (i18nCell MsgAdminFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userAdmin) -> do
            E.on $ school E.^. SchoolId E.==. userAdmin E.^. UserAdminSchool
            E.where_ $ userAdmin E.^. UserAdminUser E.==. E.val uid
            E.orderBy [E.asc $ school E.^. SchoolShorthand]
            return $ school E.^. SchoolShorthand
          return [whamlet|
            <ul .list--inline .list--comma-separated>
              $forall (E.Value sh) <- schools
                <li>#{sh}
            |]
      , sortable Nothing (i18nCell MsgLecturerFor) $ \DBRow{ dbrOutput = Entity uid _ } -> flip (set' cellContents) mempty $ do
          schools <- lift . E.select . E.from $ \(school `E.InnerJoin` userLecturer) -> do
            E.on $ school E.^. SchoolId E.==. userLecturer E.^. UserLecturerSchool
            E.where_ $ userLecturer E.^. UserLecturerUser E.==. E.val uid
            E.orderBy [E.asc $ school E.^. SchoolShorthand]
            return $ school E.^. SchoolShorthand
          return [whamlet|
            <ul .list--inline .list--comma-separated>
              $forall (E.Value sh) <- schools
                <li>#{sh}
            |]
      , sortable Nothing mempty $ \DBRow{ dbrOutput = Entity uid _ } -> cell $ do
          cID <- encrypt uid
          mayHijack <- (== Authorized) <$> evalAccess (AdminHijackUserR cID) True
          myUid <- liftHandlerT maybeAuthId
          when (mayHijack && Just uid /= myUid) $ do
            (hijackView, hijackEnctype) <- liftHandlerT . generateFormPost $ hijackUserForm cID
            [whamlet|
              <form method=POST action=@{AdminHijackUserR cID} enctype=#{hijackEnctype}>
                ^{hijackView}
            |]
      ]
    psValidator = def
      & defaultSorting [SortAscBy "name", SortAscBy "display-name"]

  ((), userList) <- runDB $ dbTable psValidator DBTable
    { dbtSQLQuery  = return :: E.SqlExpr (Entity User) -> E.SqlQuery (E.SqlExpr (Entity User))
    , dbtRowKey = (E.^. UserId)
    , dbtColonnade
    , dbtProj      = return
    , dbtSorting   = Map.fromList
        [ ( "name"
          , SortColumn $ \user -> user E.^. UserSurname
          )
        , ( "display-name"
          , SortColumn $ \user -> user E.^. UserDisplayName
          )
        , ( "matriculation"
          , SortColumn $ \user -> user E.^. UserMatrikelnummer
          )
        ]
    , dbtFilter    = mempty
    , dbtFilterUI  = mempty
    , dbtStyle     = def
    , dbtParams    = def
    , dbtIdent     = "users" :: Text
    }

  defaultLayout $ do
    setTitleI MsgUserListTitle
    $(widgetFile "users")

postAdminHijackUserR :: CryptoUUIDUser -> Handler TypedContent
postAdminHijackUserR cID = do
  uid <- decrypt cID
  ((hijackRes, _), _) <- runFormPost $ hijackUserForm cID

  ret <- formResultMaybe hijackRes $ \() -> Just <$> do
    User{userIdent} <- runDB $ get404 uid
    setCredsRedirect $ Creds "dummy" (CI.original userIdent) []

  maybe (redirect UsersR) return ret


getAdminUserR, postAdminUserR :: CryptoUUIDUser -> Handler Html
getAdminUserR = postAdminUserR
postAdminUserR uuid = do
    adminId <- requireAuthId
    uid <- decrypt uuid
    let fromSchoolList = Set.fromList . map (userAdminSchool . entityVal)
    (User{..}, fromSchoolList -> adminSchools, userRights) <- runDB $ (,,)
        <$> get404 uid
        <*> selectList [UserAdminUser ==. adminId] []
        <*> E.select ( E.from $ \school -> do
              E.orderBy [E.asc $ school E.^. SchoolName]
              let schAdmin    = E.exists $ E.from $ \userAdmin    -> do
                    E.where_ $ userAdmin    E.^. UserAdminSchool    E.==. school E.^. SchoolId
                    E.where_ $ userAdmin    E.^. UserAdminUser      E.==. E.val uid
              let schLecturer = E.exists $ E.from $ \userLecturer -> do
                    E.where_ $ userLecturer E.^. UserLecturerSchool E.==. school E.^. SchoolId
                    E.where_ $ userLecturer E.^. UserLecturerUser   E.==. E.val uid
              return (school,schAdmin,schLecturer)
            )
    -- above data is needed for both form generation and result evaluation
    let userRightsForm :: Form [(SchoolId, Bool, Bool)]
        userRightsForm csrf = do
          boxRights <- forM userRights $ \(school@(Entity sid _), E.Value isAdmin, E.Value isLecturer) ->
            if Set.member sid adminSchools
              then do
                cbAdmin    <- mreq    checkBoxField "" (Just isAdmin)
                cbLecturer <- mreq    checkBoxField "" (Just isLecturer)
                return (school, cbAdmin, cbLecturer)
              else do
                cbAdmin    <- mforced checkBoxField ""       isAdmin
                cbLecturer <- mforced checkBoxField ""       isLecturer
                return (school, cbAdmin, cbLecturer)
          let result = forM boxRights $ \(Entity sid _, (resAdmin,_), (resLecturer, _)) ->
                        (,,) <$> pure sid <*> resAdmin <*> resLecturer
          return (result,$(widgetFile "widgets/user-rights-form"))
    let userRightsAction changes = do
          void . runDB $
            forM changes $ \(sid, userAdmin, userLecturer) ->
              if Set.notMember sid adminSchools
                then return ()
                else do
                  if userAdmin
                    then void . insertUnique $ UserAdmin uid sid
                    else deleteBy $ UniqueUserAdmin uid sid
                  if userLecturer
                    then void . insertUnique $ UserLecturer uid sid
                    else deleteBy $ UniqueSchoolLecturer uid sid
                -- Note: deleteWhere would not work well here since we filter by adminSchools
          addMessageI Info MsgAccessRightsSaved
    ((result, formWidget),formEnctype) <- runFormPost userRightsForm
    formResult result userRightsAction
    let heading =
          [whamlet|_{MsgAccessRightsFor} ^{nameWidget userDisplayName userSurname}|]
    siteLayout heading
      $(widgetFile "adminUser")