{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeOperators #-}

module Server.Handlers.GroupHandlers
    ( GroupAPI
    , groupServer
    ) where

import Control.Monad (forM_, when)
import Control.Monad.IO.Class
import Hasql.Connection (Connection)
import qualified Hasql.Session as Session
import Servant
import Servant.Auth.Server
import Server.Auth (AuthMethod)
import qualified Server.Auth as Auth
import Server.HandlerUtil
import qualified UserManagement.Group as Group
import qualified UserManagement.Sessions as Sessions
import qualified UserManagement.User as User

import Data.Containers.ListUtils (nubOrd)
import Data.Maybe (isNothing)
import UserManagement.Group (GroupPatch (patchDescription))
import Prelude hiding (readFile)

type GroupAPI =
    "groups"
        :> ( Auth AuthMethod Auth.Token
                :> ReqBody '[JSON] Group.GroupCreate
                :> Post '[JSON] Group.GroupID
                :<|> Auth AuthMethod Auth.Token
                    :> Get '[JSON] [Group.GroupOverview]
                :<|> Auth AuthMethod Auth.Token
                    :> Capture "groupID" Group.GroupID
                    :> Get '[JSON] Group.Group
                :<|> Auth AuthMethod Auth.Token
                    :> Capture "groupID" Group.GroupID
                    :> Delete '[JSON] NoContent
                :<|> Auth AuthMethod Auth.Token
                    :> Capture "groupID" Group.GroupID
                    :> ReqBody '[JSON] Group.GroupPatch
                    :> Patch '[JSON] Group.GroupOverview
           )

groupServer :: Server GroupAPI
groupServer :: Server GroupAPI
groupServer =
    AuthResult Token -> GroupCreate -> Handler GroupID
createGroupHandler
        (AuthResult Token -> GroupCreate -> Handler GroupID)
-> ((AuthResult Token -> Handler [GroupOverview])
    :<|> ((AuthResult Token -> GroupID -> Handler Group)
          :<|> ((AuthResult Token -> GroupID -> Handler NoContent)
                :<|> (AuthResult Token
                      -> GroupID -> GroupPatch -> Handler GroupOverview))))
-> (AuthResult Token -> GroupCreate -> Handler GroupID)
   :<|> ((AuthResult Token -> Handler [GroupOverview])
         :<|> ((AuthResult Token -> GroupID -> Handler Group)
               :<|> ((AuthResult Token -> GroupID -> Handler NoContent)
                     :<|> (AuthResult Token
                           -> GroupID -> GroupPatch -> Handler GroupOverview))))
forall a b. a -> b -> a :<|> b
:<|> AuthResult Token -> Handler [GroupOverview]
getAllGroupsHandler
        (AuthResult Token -> Handler [GroupOverview])
-> ((AuthResult Token -> GroupID -> Handler Group)
    :<|> ((AuthResult Token -> GroupID -> Handler NoContent)
          :<|> (AuthResult Token
                -> GroupID -> GroupPatch -> Handler GroupOverview)))
-> (AuthResult Token -> Handler [GroupOverview])
   :<|> ((AuthResult Token -> GroupID -> Handler Group)
         :<|> ((AuthResult Token -> GroupID -> Handler NoContent)
               :<|> (AuthResult Token
                     -> GroupID -> GroupPatch -> Handler GroupOverview)))
forall a b. a -> b -> a :<|> b
:<|> AuthResult Token -> GroupID -> Handler Group
getGroupHandler
        (AuthResult Token -> GroupID -> Handler Group)
-> ((AuthResult Token -> GroupID -> Handler NoContent)
    :<|> (AuthResult Token
          -> GroupID -> GroupPatch -> Handler GroupOverview))
-> (AuthResult Token -> GroupID -> Handler Group)
   :<|> ((AuthResult Token -> GroupID -> Handler NoContent)
         :<|> (AuthResult Token
               -> GroupID -> GroupPatch -> Handler GroupOverview))
forall a b. a -> b -> a :<|> b
:<|> AuthResult Token -> GroupID -> Handler NoContent
deleteGroupHandler
        (AuthResult Token -> GroupID -> Handler NoContent)
-> (AuthResult Token
    -> GroupID -> GroupPatch -> Handler GroupOverview)
-> (AuthResult Token -> GroupID -> Handler NoContent)
   :<|> (AuthResult Token
         -> GroupID -> GroupPatch -> Handler GroupOverview)
forall a b. a -> b -> a :<|> b
:<|> AuthResult Token -> GroupID -> GroupPatch -> Handler GroupOverview
patchGroupHandler

-- | Creates 'Group', adds sender as 'Admin' and all users listed as 'Member';
--   If adding any user fails, the group is still created
createGroupHandler
    :: AuthResult Auth.Token -> Group.GroupCreate -> Handler Group.GroupID
createGroupHandler :: AuthResult Token -> GroupCreate -> Handler GroupID
createGroupHandler (Authenticated token :: Token
token@Auth.Token {Bool
UserID
subject :: UserID
isSuperadmin :: Bool
isSuperadmin :: Token -> Bool
subject :: Token -> UserID
..}) (Group.GroupCreate {Maybe [UserID]
Maybe Text
Text
groupCreateName :: Text
groupCreateDescription :: Maybe Text
groupCreateUsers :: Maybe [UserID]
groupCreateUsers :: GroupCreate -> Maybe [UserID]
groupCreateDescription :: GroupCreate -> Maybe Text
groupCreateName :: GroupCreate -> Text
..}) = do
    Connection
conn <- Handler Connection
tryGetDBConnection
    Connection -> Token -> Handler GroupID -> Handler GroupID
forall a. Connection -> Token -> Handler a -> Handler a
ifSuperOrAnyAdminDo Connection
conn Token
token (Handler GroupID -> Handler GroupID)
-> Handler GroupID -> Handler GroupID
forall a b. (a -> b) -> a -> b
$ do
        Bool
exists <- Connection -> Session Bool -> Handler Bool
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session Bool -> Handler Bool) -> Session Bool -> Handler Bool
forall a b. (a -> b) -> a -> b
$ Text -> Session Bool
Sessions.checkGroupNameExistence Text
groupCreateName
        Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
            ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler ()) -> ServerError -> Handler ()
forall a b. (a -> b) -> a -> b
$
                ServerError
err409 {errBody = "\"A group with that name exists already.\""}
        GroupID
groupID <- Connection -> Session GroupID -> Handler GroupID
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session GroupID -> Handler GroupID)
-> Session GroupID -> Handler GroupID
forall a b. (a -> b) -> a -> b
$ Text -> Maybe Text -> Session GroupID
Sessions.addGroup Text
groupCreateName Maybe Text
groupCreateDescription
        Connection -> UserID -> GroupID -> Role -> Handler ()
addRoleInGroup Connection
conn UserID
subject GroupID
groupID Role
User.Admin
        Maybe [UserID] -> ([UserID] -> Handler ()) -> Handler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe [UserID]
groupCreateUsers (([UserID] -> Handler ()) -> Handler ())
-> ([UserID] -> Handler ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \[UserID]
users ->
            [UserID] -> (UserID -> Handler ()) -> Handler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([UserID] -> [UserID]
forall a. Ord a => [a] -> [a]
nubOrd ([UserID] -> [UserID]) -> [UserID] -> [UserID]
forall a b. (a -> b) -> a -> b
$ (UserID -> Bool) -> [UserID] -> [UserID]
forall a. (a -> Bool) -> [a] -> [a]
filter (UserID -> UserID -> Bool
forall a. Eq a => a -> a -> Bool
/= UserID
subject) [UserID]
users) ((UserID -> Handler ()) -> Handler ())
-> (UserID -> Handler ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \UserID
user ->
                Connection -> UserID -> GroupID -> Role -> Handler ()
addRoleInGroup Connection
conn UserID
user GroupID
groupID Role
User.Member
        GroupID -> Handler GroupID
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return GroupID
groupID
createGroupHandler AuthResult Token
_ GroupCreate
_ = ServerError -> Handler GroupID
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn

-- | If the logged in user is SuperAdmin returns list of all existing groups as
--   [(GroupID, GroupName)]
getAllGroupsHandler :: AuthResult Auth.Token -> Handler [Group.GroupOverview]
getAllGroupsHandler :: AuthResult Token -> Handler [GroupOverview]
getAllGroupsHandler (Authenticated Auth.Token {Bool
UserID
isSuperadmin :: Token -> Bool
subject :: Token -> UserID
subject :: UserID
isSuperadmin :: Bool
..}) = do
    Bool -> Handler ()
guardSuperAdmin Bool
isSuperadmin
    Connection
conn <- Handler Connection
tryGetDBConnection
    Connection -> Session [GroupOverview] -> Handler [GroupOverview]
forall a. Connection -> Session a -> Handler a
runDB Connection
conn Session [GroupOverview]
Sessions.getAllGroupsOverview
getAllGroupsHandler AuthResult Token
_ = ServerError -> Handler [GroupOverview]
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn

getGroupHandler
    :: AuthResult Auth.Token -> Group.GroupID -> Handler Group.Group
getGroupHandler :: AuthResult Token -> GroupID -> Handler Group
getGroupHandler (Authenticated Token
token) GroupID
groupID = do
    Connection
conn <- Handler Connection
tryGetDBConnection
    Connection -> Token -> GroupID -> Handler Group -> Handler Group
forall a. Connection -> Token -> GroupID -> Handler a -> Handler a
ifSuperOrGroupMemberDo Connection
conn Token
token GroupID
groupID (Handler Group -> Handler Group) -> Handler Group -> Handler Group
forall a b. (a -> b) -> a -> b
$ do
        Group.GroupOverview GroupID
_ Text
name Maybe Text
mDesc <- Connection -> Session GroupOverview -> Handler GroupOverview
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session GroupOverview -> Handler GroupOverview)
-> Session GroupOverview -> Handler GroupOverview
forall a b. (a -> b) -> a -> b
$ GroupID -> Session GroupOverview
Sessions.getGroupInfo GroupID
groupID
        [UserInfo]
members <- Connection -> Session [UserInfo] -> Handler [UserInfo]
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session [UserInfo] -> Handler [UserInfo])
-> Session [UserInfo] -> Handler [UserInfo]
forall a b. (a -> b) -> a -> b
$ GroupID -> Session [UserInfo]
Sessions.getMembersOfGroup GroupID
groupID
        Group -> Handler Group
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return (Group -> Handler Group) -> Group -> Handler Group
forall a b. (a -> b) -> a -> b
$ GroupID -> Text -> Maybe Text -> [UserInfo] -> Group
Group.Group GroupID
groupID Text
name Maybe Text
mDesc [UserInfo]
members
getGroupHandler AuthResult Token
_ GroupID
_ = ServerError -> Handler Group
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn

deleteGroupHandler
    :: AuthResult Auth.Token -> Group.GroupID -> Handler NoContent
deleteGroupHandler :: AuthResult Token -> GroupID -> Handler NoContent
deleteGroupHandler (Authenticated Token
token) GroupID
groupID = do
    Connection
conn <- Handler Connection
tryGetDBConnection
    Connection
-> Token -> GroupID -> Handler NoContent -> Handler NoContent
forall a. Connection -> Token -> GroupID -> Handler a -> Handler a
ifSuperOrAdminDo Connection
conn Token
token GroupID
groupID (Handler NoContent -> Handler NoContent)
-> Handler NoContent -> Handler NoContent
forall a b. (a -> b) -> a -> b
$ do
        Connection -> Session () -> Handler ()
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session () -> Handler ()) -> Session () -> Handler ()
forall a b. (a -> b) -> a -> b
$ GroupID -> Session ()
Sessions.deleteGroup GroupID
groupID
        NoContent -> Handler NoContent
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return NoContent
NoContent
deleteGroupHandler AuthResult Token
_ GroupID
_ = ServerError -> Handler NoContent
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn

-- | Updates a group's name and/or description via PATCH
--   Requires SuperAdmin or Admin of the specific group
patchGroupHandler
    :: AuthResult Auth.Token
    -> Group.GroupID
    -> Group.GroupPatch
    -> Handler Group.GroupOverview
patchGroupHandler :: AuthResult Token -> GroupID -> GroupPatch -> Handler GroupOverview
patchGroupHandler (Authenticated Token
token) GroupID
groupID (Group.GroupPatch {Maybe (Maybe Text)
Maybe Text
patchDescription :: GroupPatch -> Maybe (Maybe Text)
patchName :: Maybe Text
patchDescription :: Maybe (Maybe Text)
patchName :: GroupPatch -> Maybe Text
..}) = do
    Connection
conn <- Handler Connection
tryGetDBConnection
    Connection
-> Token
-> GroupID
-> Handler GroupOverview
-> Handler GroupOverview
forall a. Connection -> Token -> GroupID -> Handler a -> Handler a
ifSuperOrAdminDo Connection
conn Token
token GroupID
groupID (Handler GroupOverview -> Handler GroupOverview)
-> Handler GroupOverview -> Handler GroupOverview
forall a b. (a -> b) -> a -> b
$ do
        -- Validate that at least one field is provided
        Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Maybe Text -> Bool
forall a. Maybe a -> Bool
isNothing Maybe Text
patchName Bool -> Bool -> Bool
&& Maybe (Maybe Text) -> Bool
forall a. Maybe a -> Bool
isNothing Maybe (Maybe Text)
patchDescription) (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
            ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler ()) -> ServerError -> Handler ()
forall a b. (a -> b) -> a -> b
$
                ServerError
err400
                    { errBody =
                        "\"At least one of 'patchName' or 'patchDescription' must be provided.\""
                    }

        -- If name is being changed, check for uniqueness
        Maybe Text -> (Text -> Handler ()) -> Handler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe Text
patchName ((Text -> Handler ()) -> Handler ())
-> (Text -> Handler ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \Text
newName -> do
            Bool
exists <- Connection -> Session Bool -> Handler Bool
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session Bool -> Handler Bool) -> Session Bool -> Handler Bool
forall a b. (a -> b) -> a -> b
$ Text -> Session Bool
Sessions.checkGroupNameExistence Text
newName
            Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
exists (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$ do
                -- Check if it's the same group (allow keeping same name)
                Group.GroupOverview GroupID
_ Text
currentName Maybe Text
_ <-
                    Connection -> Session GroupOverview -> Handler GroupOverview
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session GroupOverview -> Handler GroupOverview)
-> Session GroupOverview -> Handler GroupOverview
forall a b. (a -> b) -> a -> b
$ GroupID -> Session GroupOverview
Sessions.getGroupInfo GroupID
groupID
                Bool -> Handler () -> Handler ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Text
currentName Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
/= Text
newName) (Handler () -> Handler ()) -> Handler () -> Handler ()
forall a b. (a -> b) -> a -> b
$
                    ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ServerError -> Handler ()) -> ServerError -> Handler ()
forall a b. (a -> b) -> a -> b
$
                        ServerError
err409 {errBody = "\"A group with that name exists already.\""}
            Connection -> Session () -> Handler ()
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session () -> Handler ()) -> Session () -> Handler ()
forall a b. (a -> b) -> a -> b
$ GroupID -> Text -> Session ()
Sessions.updateGroupName GroupID
groupID Text
newName

        -- Update description if provided
        Maybe (Maybe Text) -> (Maybe Text -> Handler ()) -> Handler ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Maybe (Maybe Text)
patchDescription ((Maybe Text -> Handler ()) -> Handler ())
-> (Maybe Text -> Handler ()) -> Handler ()
forall a b. (a -> b) -> a -> b
$ \Maybe Text
newDesc ->
            Connection -> Session () -> Handler ()
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session () -> Handler ()) -> Session () -> Handler ()
forall a b. (a -> b) -> a -> b
$ GroupID -> Maybe Text -> Session ()
Sessions.updateGroupDescription GroupID
groupID Maybe Text
newDesc

        -- Return updated group info
        Connection -> Session GroupOverview -> Handler GroupOverview
forall a. Connection -> Session a -> Handler a
runDB Connection
conn (Session GroupOverview -> Handler GroupOverview)
-> Session GroupOverview -> Handler GroupOverview
forall a b. (a -> b) -> a -> b
$ GroupID -> Session GroupOverview
Sessions.getGroupInfo GroupID
groupID
patchGroupHandler AuthResult Token
_ GroupID
_ GroupPatch
_ = ServerError -> Handler GroupOverview
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errNotLoggedIn

runDB :: Connection -> Session.Session a -> Handler a
runDB :: forall a. Connection -> Session a -> Handler a
runDB Connection
conn Session a
session = do
    Either SessionError a
result <- IO (Either SessionError a) -> Handler (Either SessionError a)
forall a. IO a -> Handler a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO (Either SessionError a) -> Handler (Either SessionError a))
-> IO (Either SessionError a) -> Handler (Either SessionError a)
forall a b. (a -> b) -> a -> b
$ Session a -> Connection -> IO (Either SessionError a)
forall a. Session a -> Connection -> IO (Either SessionError a)
Session.run Session a
session Connection
conn
    case Either SessionError a
result of
        Left SessionError
_ -> ServerError -> Handler a
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errDatabaseAccessFailed
        Right a
val -> a -> Handler a
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return a
val

guardSuperAdmin :: Bool -> Handler ()
guardSuperAdmin :: Bool -> Handler ()
guardSuperAdmin Bool
True = () -> Handler ()
forall a. a -> Handler a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
guardSuperAdmin Bool
False = ServerError -> Handler ()
forall a. ServerError -> Handler a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ServerError
errSuperAdminOnly