sproxy-web-0.3.1: src/Entities.hs

{-# LANGUAGE OverloadedStrings #-}

module Entities where

import Data.Int
import Data.Monoid
import Data.Text.Lazy (Text)
import Database.PostgreSQL.Simple
import Database.PostgreSQL.Simple.Types

-- get the list of groups
getGroups :: Connection -> IO [[Text]]
getGroups conn =
    query_ conn "select * from \"group\" order by \"group\" asc"

-- change a group's name
updateGroup :: Text -> Text -> Connection -> IO Int64
updateGroup old new conn =
    execute conn "UPDATE \"group\" \
                 \ SET \"group\" = ? \
                 \ WHERE \"group\" = ?"
                 (new, old)

-- add a new group
addGroup :: Text -> Connection -> IO Int64
addGroup gname conn =
    execute conn "INSERT INTO \"group\" \
                 \ VALUES (?)"
                 (Only gname)

-- remove a group
removeGroup :: Text -> Connection -> IO Int64
removeGroup gname conn =
    execute conn "DELETE FROM \"group\" \
                 \ WHERE \"group\" = ?"
                 (Only gname)

-- get members of a group
getMembersFor :: Text -> Connection -> IO [[Text]]
getMembersFor gname conn =
    query conn "SELECT email::text FROM group_member \
               \ WHERE \"group\" = ? \
               \ ORDER BY email ASC"
               (Only gname)

-- add a member to a group
addMemberTo :: Text -> Text -> Connection -> IO Int64
addMemberTo new groupName conn =
    execute conn "INSERT INTO group_member (\"group\", email) \
               \ VALUES (?, ?)"
               (groupName, new)

-- remove a user from a group
removeMemberOf :: Text -> Text -> Connection -> IO Int64
removeMemberOf member groupName conn =
    execute conn "DELETE FROM group_member \
                 \ WHERE \"group\" = ? AND email = ?"
                 (groupName, member)

-- update a (meta-)user's email
updateMemberOf :: Text -> Text -> Text -> Connection -> IO Int64
updateMemberOf old new groupName conn =
    execute conn "UPDATE group_member \ 
                 \ SET email = ? \
                 \ WHERE \"group\" = ? AND email = ?"
                 (new, groupName, old)

-- list the different domains
getDomains :: Connection -> IO [[Text]]
getDomains conn = 
    query_ conn "SELECT domain \ 
                \ FROM domain \ 
                \ ORDER BY domain ASC"

-- add a domain
addDomain :: Text -> Connection -> IO Int64
addDomain d conn =
    execute conn "INSERT INTO domain (domain) \
                 \ VALUES (?)"
                 (Only d)

-- update a domain's "name"
updateDomain :: Text -> Text -> Connection -> IO Int64
updateDomain old new conn =
    execute conn "UPDATE domain \ 
                 \ SET domain = ? \
                 \ WHERE domain = ?"
                 (new, old)

-- remove a domain
removeDomain :: Text -> Connection -> IO Int64
removeDomain d conn =
    execute conn "DELETE FROM domain \ 
                 \ WHERE domain = ?"
                 (Only d)

-- get the privileges associated to a domain
getDomainPrivileges :: Text -> Connection -> IO [[Text]]
getDomainPrivileges domain conn =
    query conn "SELECT privilege \ 
               \ FROM privilege \ 
               \ WHERE domain = ? \ 
               \ ORDER BY privilege ASC"
               (Only domain)

-- update the name of a privilege associated to a domain
updatePrivilegeOfDomain :: Text -> Text -> Text -> Connection -> IO Int64
updatePrivilegeOfDomain old new domain conn =
    execute conn "UPDATE privilege \ 
                 \ SET privilege = ? \ 
                 \ WHERE domain = ? AND privilege = ?"
                 (new, domain, old)

-- add a privilege for the given domain
addPrivilegeToDomain :: Text -> Text -> Connection -> IO Int64
addPrivilegeToDomain new domain conn =
    execute conn "INSERT INTO privilege (domain, privilege) \ 
                 \ VALUES (?, ?)"
                 (domain, new)

-- remove a privilege for the given domain
removePrivilegeOfDomain :: Text -> Text -> Connection -> IO Int64                 
removePrivilegeOfDomain old domain conn =
    execute conn "DELETE FROM privilege \ 
                 \ WHERE domain = ? AND privilege = ?"
                 (domain, old)

-- list the path/method rules for a given privilege on a given domain
getRules :: Text -> Text -> Connection -> IO [(Text, Text)]
getRules domain privilege conn =
    query conn "SELECT path, method \ 
               \ FROM privilege_rule \ 
               \ WHERE domain = ? \
               \   AND privilege = ? \ 
               \ ORDER BY path, method ASC"
               (domain, privilege)

-- add a path/method rule for a given privilege on a given domain
addRuleToPrivilege :: Text -> Text -> Text -> Text -> Connection -> IO Int64
addRuleToPrivilege domain privilege path method conn =
    execute conn "INSERT INTO privilege_rule \
                 \   (domain, privilege, path, method) \
                 \ VALUES \
                 \   (?, ?, ?, ?)"
                 (domain, privilege, path, method)

-- delete a privilege rule
deleteRuleFromPrivilege :: Text -> Text -> Text -> Text -> Connection -> IO Int64
deleteRuleFromPrivilege domain privilege path method conn =
    execute conn "DELETE FROM privilege_rule \ 
                 \ WHERE domain = ? \
                 \   AND privilege = ? \
                 \   AND path = ? \
                 \   AND method = ?"
                 (domain, privilege, path, method)

-- update just the path for a given rule
updatePathFor :: Text -> Text -> Text -> Text -> Text -> Connection -> IO Int64
updatePathFor domain privilege newpath oldpath method conn =
    execute conn "UPDATE privilege_rule \ 
                 \ SET path = ? \ 
                 \ WHERE domain = ? \
                 \   AND privilege = ? \ 
                 \   AND path = ? \ 
                 \   AND method = ?"
                 (newpath, domain, privilege, oldpath, method)

-- update just the method for a given rule
updateMethodFor :: Text -> Text -> Text -> Text -> Text -> Connection -> IO Int64
updateMethodFor domain privilege newmethod oldmethod path conn = 
    execute conn "UPDATE privilege_rule \ 
                 \ SET method = ? \ 
                 \ WHERE domain = ? \ 
                 \   AND privilege = ? \ 
                 \   AND path = ? \ 
                 \   AND method = ?"
                 (newmethod, domain, privilege, path, oldmethod)

-- get the list of privileges granted to groups for a given domain
getGroupPrivsFor :: Text -> Connection -> IO [(Text, Text)]
getGroupPrivsFor domain conn =
    query conn "SELECT \"group\", privilege \
               \ FROM group_privilege \
               \ WHERE domain = ? \ 
               \ ORDER BY \"group\", privilege ASC"
               (Only domain)

-- grant a privilege to a group on a domain
addGPFor :: Text -> Text -> Text -> Connection -> IO Int64
addGPFor domain gr priv conn = 
    execute conn "INSERT INTO group_privilege \
                 \  (\"group\", domain, privilege) \
                 \ VALUES (?, ?, ?)"
                 (gr, domain, priv)

-- remove a privilege for a group on a domain
deleteGPOf :: Text -> Text -> Text -> Connection -> IO Int64
deleteGPOf domain gr priv conn =
    execute conn "DELETE FROM group_privilege \ 
                 \ WHERE domain = ? \ 
                 \   AND \"group\" = ? \
                 \   AND privilege = ?"
                 (domain, gr, priv)

-- | completely remove a user from the sproxy db by
--   removing it from any group it belongs to.
removeUser :: Text -> Connection -> IO Int64
removeUser email conn =
    execute conn "DELETE FROM group_member \
                 \ WHERE email = ?"
                 (Only email)

-- | Search an user. Returns a list of matching emails
searchUser :: Text -> Connection -> IO [(Text, [Text])]
searchUser searchQuery conn = fmap postprocess $
    query conn "SELECT email::text, array_agg(\"group\") \
               \ FROM group_member \
               \ WHERE email LIKE ? \
               \ GROUP BY email"
               (Only $ "%" <> searchQuery <> "%")

    where postprocess = map (\(mail, groups) -> (mail, fromPGArray groups))

renameUser :: Text -> Text -> Connection -> IO Int64
renameUser oldemail newemail conn =
  execute conn
              "UPDATE group_member \
              \ SET email = ? \
              \ WHERE email = ?"
              (newemail, oldemail)