{-# LANGUAGE RankNTypes, NamedFieldPuns, RecordWildCards, DoRec,
             BangPatterns, OverloadedStrings, CPP, TemplateHaskell #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Distribution.Server.Features.Users (
    initUserFeature,
    UserFeature(..),
    UserResource(..),

    GroupResource(..),
  ) where

import Distribution.Server.Framework
import Distribution.Server.Framework.BackupDump
import qualified Distribution.Server.Framework.Auth as Auth

import Distribution.Server.Users.Types
import Distribution.Server.Users.State
import Distribution.Server.Users.Backup
import qualified Distribution.Server.Users.Users as Users
import qualified Distribution.Server.Users.Group as Group
import Distribution.Server.Users.Group (UserGroup(..), GroupDescription(..), UserList, nullDescription)

import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Maybe (fromMaybe)
import Data.Function (fix)
import Control.Applicative (optional)
import Data.Aeson (toJSON)
import Data.Aeson.TH
import qualified Data.Text as T

import Distribution.Text (display, simpleParse)


-- | A feature to allow manipulation of the database of users.
--
-- TODO: clean up mismatched and duplicate functionality (some noted below).
data UserFeature = UserFeature {
    -- | The users `HackageFeature`.
    userFeatureInterface :: HackageFeature,

    -- | User resources.
    userResource :: UserResource,

    -- | Notification that a user has been added. Currently unused.
    userAdded :: Hook () (), --TODO: delete, other status changes?
    -- | The admin user group, including its description, members, and
    -- modification thereof.
    adminGroup :: UserGroup,

    -- Authorisation
    -- | Require any of a set of privileges.
    guardAuthorised_   :: [PrivilegeCondition] -> ServerPartE (),
    -- | Require any of a set of privileges, giving the id of the current user.
    guardAuthorised    :: [PrivilegeCondition] -> ServerPartE UserId,
    -- | Require being logged in, giving the id of the current user.
    guardAuthenticated :: ServerPartE UserId,
    -- | A hook to override the default authentication error in particular
    -- circumstances.
    authFailHook       :: Hook Auth.AuthError (Maybe ErrorResponse),

    -- | Retrieves the entire user base.
    queryGetUserDb    :: forall m. MonadIO m => m Users.Users,

    -- | Creates a Hackage 2 user credential.
    newUserAuth       :: UserName -> PasswdPlain -> UserAuth,
    -- | Adds a user with a fresh name.
    updateAddUser     :: forall m. MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId),
    -- | Sets the account-enabled status of an existing user to True or False.
    updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool
                               -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)),
    -- | Sets the credentials of an existing user.
    updateSetUserAuth :: MonadIO m => UserId -> UserAuth
                      -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser)),

    -- | Adds a user to a group based on a "user" path component.
    --
    -- Use the UserGroup or GroupResource directly instead, as this is a hack.
    groupAddUser        :: UserGroup -> DynamicPath -> ServerPartE (),
    -- | Likewise, deletes a user, will go away soon.
    groupDeleteUser     :: UserGroup -> DynamicPath -> ServerPartE (),

    -- | Get a username from a path.
    userNameInPath      :: forall m. MonadPlus m => DynamicPath -> m UserName,
    -- | Lookup a `UserId` from a name, if the name exists.
    lookupUserName      :: UserName -> ServerPartE UserId,
    -- | Lookup full `UserInfo` from a name, if the name exists.
    lookupUserNameFull  :: UserName -> ServerPartE (UserId, UserInfo),
    -- | Lookup full `UserInfo` from an id, if the id exists.
    lookupUserInfo      :: UserId -> ServerPartE UserInfo,

    -- | An action to change a password directly, using "password" and
    -- "repeat-password" form fields. Only admins and the user themselves
    -- can do this. This is messy, as it was one of the first things writen
    -- for the users feature.
    --
    -- TODO: update and make more usable.
    changePassword      :: UserName -> ServerPartE (),
    -- | Determine if the first user can change the second user's password,
    -- replicating auth functionality. Avoid using.
    canChangePassword   :: forall m. MonadIO m => UserId -> UserId -> m Bool,
    -- | Action to create a new user with the given credentials. This takes the
    -- desired name, a password, and a repeated password, validating all.
    newUserWithAuth     :: String -> PasswdPlain -> PasswdPlain -> ServerPartE UserName,
    -- | Action for an admin to create a user with "username", "password", and
    -- "repeat-password" username fields.
    adminAddUser        :: ServerPartE Response,

    -- Create a group resource for the given resource path.
    groupResourceAt     :: String -> UserGroup -> IO (UserGroup, GroupResource),
    -- | Create a parameretrized group resource for the given resource path.
    -- The parameter `a` can here be called a group key, and there is
    -- potentially a set of initial values.
    --
    -- This takes functions to create a user group on the fly for the given
    -- key, go from a key to a DynamicPath (for URI generation), as well as
    -- go from a DynamicPath to a key with some possibility of failure. This
    -- should check key membership, as well.
    --
    -- When these parameretrized `UserGroup`s need to be modified, the returned
    -- `a -> UserGroup` function should be used, as it wraps the given
    -- `a -> UserGroup` function to keep user-to-group mappings up-to-date.
    groupResourcesAt    :: forall a. String -> (a -> UserGroup)
                                            -> (a -> DynamicPath)
                                            -> (DynamicPath -> ServerPartE a)
                                            -> [a]
                                            -> IO (a -> UserGroup, GroupResource),
    -- | Look up whether the current user has (add, remove) capabilities for
    -- the given group, erroring out if neither are present.
    lookupGroupEditAuth :: UserGroup -> ServerPartE (Bool, Bool),
    -- | For a given user, return all of the URIs for groups they are in.
    getGroupIndex       :: forall m. (Functor m, MonadIO m) => UserId -> m [String],
    -- | For a given URI, get a GroupDescription for it, if one can be found.
    getIndexDesc        :: forall m. MonadIO m => String -> m GroupDescription
}

instance IsHackageFeature UserFeature where
  getFeatureInterface = userFeatureInterface

data UserResource = UserResource {
    -- | The list of all users.
    userList :: Resource,
    -- | The main page for a given user.
    userPage :: Resource,
    -- | A user's password.
    passwordResource :: Resource,
    -- | A user's enabled status.
    enabledResource  :: Resource,
    -- | The admin group.
    adminResource :: GroupResource,

    -- | URI for `userList` given a format.
    userListUri :: String -> String,
    -- | URI for `userPage` given a format and name.
    userPageUri :: String -> UserName -> String,
    -- | URI for `passwordResource` given a format and name.
    userPasswordUri :: String -> UserName -> String,
    -- | URI for `enabledResource` given a format and name.
    userEnabledUri  :: String -> UserName -> String,
    -- | URI for `adminResource` given a format.
    adminPageUri :: String -> String
}

instance FromReqURI UserName where
  fromReqURI = simpleParse

data GroupResource = GroupResource {
    -- | A group, potentially parametetrized over some collection.
    groupResource :: Resource,
    -- | A user's presence in a group.
    groupUserResource :: Resource,
    -- | A `UserGroup` for a group, with a `DynamicPath` for any parameterization.
    getGroup :: DynamicPath -> ServerPartE UserGroup
}

-- This is a mapping of UserId -> group URI and group URI -> description.
-- Like many reverse mappings, it is probably rather volatile. Still, it is
-- a secondary concern, as user groups should be defined by each feature
-- and not globally, to be perfectly modular.
data GroupIndex = GroupIndex {
    usersToGroupUri :: !(IntMap (Set String)),
    groupUrisToDesc :: !(Map String GroupDescription)
}
emptyGroupIndex :: GroupIndex
emptyGroupIndex = GroupIndex IntMap.empty Map.empty

instance MemSize GroupIndex where
    memSize (GroupIndex a b) = memSize2 a b

-- TODO: add renaming
initUserFeature :: ServerEnv -> IO (IO UserFeature)
initUserFeature ServerEnv{serverStateDir} = do
  -- Canonical state
  usersState  <- usersStateComponent  serverStateDir
  adminsState <- adminsStateComponent serverStateDir

  -- Ephemeral state
  groupIndex   <- newMemStateWHNF emptyGroupIndex

  -- Extension hooks
  userAdded     <- newHook
  authFailHook  <- newHook

  return $ do
    -- Slightly tricky: we have an almost recursive knot between the group
    -- resource management functions, and creating the admin group
    -- resource that is part of the user feature.
    --
    -- Instead of trying to pull it apart, we just use a 'do rec'
    --
    rec let (feature@UserFeature{groupResourceAt}, adminGroupDesc)
              = userFeature usersState
                            adminsState
                            groupIndex
                            userAdded authFailHook
                            adminG adminR

        (adminG, adminR) <- groupResourceAt "/users/admins/" adminGroupDesc

    return feature

usersStateComponent :: FilePath -> IO (StateComponent AcidState Users.Users)
usersStateComponent stateDir = do
  st <- openLocalStateFrom (stateDir </> "db" </> "Users") initialUsers
  return StateComponent {
      stateDesc    = "List of users"
    , stateHandle  = st
    , getState     = query st GetUserDb
    , putState     = update st . ReplaceUserDb
    , backupState  = \backuptype users ->
        [csvToBackup ["users.csv"] (usersToCSV backuptype users)]
    , restoreState = userBackup
    , resetState   = usersStateComponent
    }

adminsStateComponent :: FilePath -> IO (StateComponent AcidState HackageAdmins)
adminsStateComponent stateDir = do
  st <- openLocalStateFrom (stateDir </> "db" </> "HackageAdmins") initialHackageAdmins
  return StateComponent {
      stateDesc    = "Admins"
    , stateHandle  = st
    , getState     = query st GetHackageAdmins
    , putState     = update st . ReplaceHackageAdmins . adminList
    , backupState  = \_ (HackageAdmins admins) -> [csvToBackup ["admins.csv"] (groupToCSV admins)]
    , restoreState = HackageAdmins <$> groupBackup ["admins.csv"]
    , resetState   = adminsStateComponent
    }

userFeature :: StateComponent AcidState Users.Users
            -> StateComponent AcidState HackageAdmins
            -> MemState GroupIndex
            -> Hook () ()
            -> Hook Auth.AuthError (Maybe ErrorResponse)
            -> UserGroup
            -> GroupResource
            -> (UserFeature, UserGroup)
userFeature  usersState adminsState
             groupIndex userAdded authFailHook
             adminGroup adminResource
  = (UserFeature {..}, adminGroupDesc)
  where
    userFeatureInterface = (emptyHackageFeature "users") {
        featureDesc = "Manipulate the user database."
      , featureResources =
          map ($ userResource)
            [ userList
            , userPage
            , passwordResource
            , enabledResource
            ]
          ++ [
              groupResource adminResource
            , groupUserResource adminResource
            ]
      , featureState = [
            abstractAcidStateComponent usersState
          , abstractAcidStateComponent adminsState
          ]
      , featureCaches = [
            CacheComponent {
              cacheDesc       = "user group index",
              getCacheMemSize = memSize <$> readMemState groupIndex
            }
          ]
      }

    userResource = fix $ \r -> UserResource {
        userList = (resourceAt "/users/.:format") {
            resourceDesc   = [ (GET, "list of users") ]
          , resourceGet    = [ ("json", serveUsersGet) ]
          }
      , userPage = (resourceAt "/user/:username.:format") {
            resourceDesc   = [ (GET,    "user id info")
                             , (PUT,    "create user")
                             , (DELETE, "delete user")
                             ]
          , resourceGet    = [ ("json", serveUserGet) ]
          , resourcePut    = [ ("", serveUserPut) ]
          , resourceDelete = [ ("", serveUserDelete) ]
          }
      , passwordResource = resourceAt "/user/:username/password.:format"
                           --TODO: PUT
      , enabledResource  = (resourceAt "/user/:username/enabled.:format") {
            resourceDesc = [ (GET, "return if the user is enabled")
                           , (PUT, "set if the user is enabled")
                           ]
          , resourceGet  = [("json", serveUserEnabledGet)]
          , resourcePut  = [("json", serveUserEnabledPut)]
          }

      , adminResource = adminResource

      , userListUri = \format ->
          renderResource (userList r) [format]
      , userPageUri = \format uname ->
          renderResource (userPage r) [display uname, format]
      , userPasswordUri = \format uname ->
          renderResource (passwordResource r) [display uname, format]
      , userEnabledUri  = \format uname ->
          renderResource (enabledResource  r) [display uname, format]
      , adminPageUri = \format ->
          renderResource (groupResource adminResource) [format]
      }

    -- Queries and updates
    --

    queryGetUserDb :: MonadIO m => m Users.Users
    queryGetUserDb = queryState usersState GetUserDb

    updateAddUser :: MonadIO m => UserName -> UserAuth -> m (Either Users.ErrUserNameClash UserId)
    updateAddUser uname auth = updateState usersState (AddUserEnabled uname auth)

    updateSetUserEnabledStatus :: MonadIO m => UserId -> Bool
                               -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser))
    updateSetUserEnabledStatus uid isenabled = updateState usersState (SetUserEnabledStatus uid isenabled)

    updateSetUserAuth :: MonadIO m => UserId -> UserAuth
                      -> m (Maybe (Either Users.ErrNoSuchUserId Users.ErrDeletedUser))
    updateSetUserAuth uid auth = updateState usersState (SetUserAuth uid auth)

    --
    -- Authorisation: authentication checks and privilege checks
    --

    -- High level, all in one check that the client is authenticated as a
    -- particular user and has an appropriate privilege, but then ignore the
    -- identity of the user.
    guardAuthorised_ :: [PrivilegeCondition] -> ServerPartE ()
    guardAuthorised_ = void . guardAuthorised

    -- As above but also return the identity of the client
    guardAuthorised :: [PrivilegeCondition] -> ServerPartE UserId
    guardAuthorised privconds = do
        users <- queryGetUserDb
        uid   <- guardAuthenticatedWithErrHook users
        Auth.guardPriviledged users uid privconds
        return uid

    -- Simply check if the user is authenticated as some user, without any
    -- check that they have any particular priveledges. Only useful as a
    -- building block.
    guardAuthenticated :: ServerPartE UserId
    guardAuthenticated = do
        users   <- queryGetUserDb
        guardAuthenticatedWithErrHook users

    -- As above but using the given userdb snapshot
    guardAuthenticatedWithErrHook :: Users.Users -> ServerPartE UserId
    guardAuthenticatedWithErrHook users = do
        (uid,_) <- Auth.checkAuthenticated realm users
                   >>= either handleAuthError return
        return uid
      where
        realm = Auth.hackageRealm --TODO: should be configurable

        handleAuthError :: Auth.AuthError -> ServerPartE a
        handleAuthError err = do
          defaultResponse  <- Auth.authErrorResponse realm err
          overrideResponse <- msum <$> runHook authFailHook err
          throwError (fromMaybe defaultResponse overrideResponse)


    -- | Resources representing the collection of known users.
    --
    -- Features:
    --
    -- * listing the collection of users
    -- * adding and deleting users
    -- * enabling and disabling accounts
    -- * changing user's name and password
    --

    serveUsersGet :: DynamicPath -> ServerPartE Response
    serveUsersGet _ = do
      userlist <- Users.enumerateActiveUsers <$> queryGetUserDb
      let users = [ UserNameIdResource {
                      ui_username = userName uinfo,
                      ui_userid   = uid
                    }
                  | (uid, uinfo) <- userlist ]
      return . toResponse $ toJSON users

    serveUserGet :: DynamicPath -> ServerPartE Response
    serveUserGet dpath = do
      (uid, uinfo)  <- lookupUserNameFull =<< userNameInPath dpath
      groups        <- getGroupIndex uid
      return . toResponse $
        toJSON UserInfoResource {
                 ui1_username = userName uinfo,
                 ui1_userid   = uid,
                 ui1_groups   = map T.pack groups
               }

    serveUserPut :: DynamicPath -> ServerPartE Response
    serveUserPut dpath = do
      guardAuthorised_ [InGroup adminGroup]
      username <- userNameInPath dpath
      muid     <- updateState usersState $ AddUserDisabled username
      case muid of
        Left  Users.ErrUserNameClash ->
          errBadRequest "Username already exists"
            [MText "Cannot create a new user account with that username because already exists"]
        Right uid -> return . toResponse $
          toJSON UserNameIdResource {
                   ui_username = username,
                   ui_userid   = uid
                 }

    serveUserDelete :: DynamicPath -> ServerPartE Response
    serveUserDelete dpath = do
      guardAuthorised_ [InGroup adminGroup]
      uid  <- lookupUserName =<< userNameInPath dpath
      merr <- updateState usersState $ DeleteUser uid
      case merr of
        Nothing -> noContent $ toResponse ()
        --TODO: need to be able to delete user by name to fix this race condition
        Just Users.ErrNoSuchUserId -> errInternalError [MText "uid does not exist"]

    serveUserEnabledGet :: DynamicPath -> ServerPartE Response
    serveUserEnabledGet dpath = do
      guardAuthorised_ [InGroup adminGroup]
      (_uid, uinfo) <- lookupUserNameFull =<< userNameInPath dpath
      let enabled = case userStatus uinfo of
                      AccountEnabled _ -> True
                      _                -> False
      return . toResponse $ toJSON EnabledResource { ui_enabled = enabled }

    serveUserEnabledPut :: DynamicPath -> ServerPartE Response
    serveUserEnabledPut dpath = do
      guardAuthorised_ [InGroup adminGroup]
      uid  <- lookupUserName =<< userNameInPath dpath
      EnabledResource enabled <- expectAesonContent
      merr <- updateState usersState (SetUserEnabledStatus uid enabled)
      case merr of
        Nothing -> noContent $ toResponse ()
        Just (Left Users.ErrNoSuchUserId) ->
          errInternalError [MText "uid does not exist"]
        Just (Right Users.ErrDeletedUser) ->
          errBadRequest "User deleted"
            [MText "Cannot disable account, it has already been deleted"]

    --
    --  Exported utils for looking up user names in URLs\/paths
    --

    userNameInPath :: forall m. MonadPlus m => DynamicPath -> m UserName
    userNameInPath dpath = maybe mzero return (simpleParse =<< lookup "username" dpath)

    lookupUserName :: UserName -> ServerPartE UserId
    lookupUserName = fmap fst . lookupUserNameFull

    lookupUserNameFull :: UserName -> ServerPartE (UserId, UserInfo)
    lookupUserNameFull uname = do
        users <- queryState usersState GetUserDb
        case Users.lookupUserName uname users of
          Just u  -> return u
          Nothing -> userLost "Could not find user: not presently registered"
      where userLost = errNotFound "User not found" . return . MText
            --FIXME: 404 is only the right error for operating on User resources
            -- not when users are being looked up for other reasons, like setting
            -- ownership of packages. In that case needs errBadRequest

    lookupUserInfo :: UserId -> ServerPartE UserInfo
    lookupUserInfo uid = do
        users <- queryState usersState GetUserDb
        case Users.lookupUserId uid users of
          Just uinfo -> return uinfo
          Nothing    -> errInternalError [MText "user id does not exist"]

    adminAddUser :: ServerPartE Response
    adminAddUser = do
        -- with this line commented out, self-registration is allowed
        guardAuthorised_ [InGroup adminGroup]
        reqData <- getDataFn lookUserNamePasswords
        case reqData of
            (Left errs) -> errBadRequest "Error registering user"
                       ((MText "Username, password, or repeated password invalid.") : map MText errs)
            (Right (ustr, pwd1, pwd2)) -> do
                uname <- newUserWithAuth ustr (PasswdPlain pwd1) (PasswdPlain pwd2)
                seeOther ("/user/" ++ display uname) (toResponse ())
       where lookUserNamePasswords = do
                 (,,) <$> look "username"
                      <*> look "password"
                      <*> look "repeat-password"

    newUserWithAuth :: String -> PasswdPlain -> PasswdPlain -> ServerPartE UserName
    newUserWithAuth _ pwd1 pwd2 | pwd1 /= pwd2 = errBadRequest "Error registering user" [MText "Entered passwords do not match"]
    newUserWithAuth userNameStr password _ =
      case simpleParse userNameStr of
        Nothing -> errBadRequest "Error registering user" [MText "Not a valid user name!"]
        Just uname -> do
          let auth = newUserAuth uname password
          muid <- updateState usersState $ AddUserEnabled uname auth
          case muid of
            Left Users.ErrUserNameClash -> errForbidden "Error registering user" [MText "A user account with that user name already exists."]
            Right _                     -> return uname

    -- Arguments: the auth'd user id, the user path id (derived from the :username)
    canChangePassword :: MonadIO m => UserId -> UserId -> m Bool
    canChangePassword uid userPathId = do
        admins <- queryState adminsState GetAdminList
        return $ uid == userPathId || (uid `Group.member` admins)

    --FIXME: this thing is a total mess!
    -- Do admins need to change user's passwords? Why not just reset passwords & (de)activate accounts.
    changePassword :: UserName -> ServerPartE ()
    changePassword username = do
        uid <- lookupUserName username
        guardAuthorised [IsUserId uid, InGroup adminGroup]
        passwd1 <- look "password"        --TODO: fail rather than mzero if missing
        passwd2 <- look "repeat-password"
        when (passwd1 /= passwd2) $
          forbidChange "Copies of new password do not match or is an invalid password (ex: blank)"
        let passwd = PasswdPlain passwd1
            auth   = newUserAuth username passwd
        res <- updateState usersState (SetUserAuth uid auth)
        case res of
          Nothing -> return ()
          Just (Left  Users.ErrNoSuchUserId) -> errInternalError [MText "user id lookup failure"]
          Just (Right Users.ErrDeletedUser)  -> forbidChange "Cannot set passwords for deleted users"
      where
        forbidChange = errForbidden "Error changing password" . return . MText

    newUserAuth :: UserName -> PasswdPlain -> UserAuth
    newUserAuth name pwd = UserAuth (Auth.newPasswdHash Auth.hackageRealm name pwd)

    ------ User group management
    adminGroupDesc :: UserGroup
    adminGroupDesc = UserGroup {
          groupDesc      = nullDescription { groupTitle = "Hackage admins" },
          queryUserList  = queryState adminsState GetAdminList,
          addUserList    = updateState adminsState . AddHackageAdmin,
          removeUserList = updateState adminsState . RemoveHackageAdmin,
          canAddGroup    = [adminGroupDesc],
          canRemoveGroup = [adminGroupDesc]
        }

    groupAddUser :: UserGroup -> DynamicPath -> ServerPartE ()
    groupAddUser group _ = do
        guardAuthorised_ (map InGroup (canAddGroup group))
        users <- queryState usersState GetUserDb
        muser <- optional $ look "user"
        case muser of
            Nothing -> addError "Bad request (could not find 'user' argument)"
            Just ustr -> case simpleParse ustr >>= \uname -> Users.lookupUserName uname users of
                Nothing      -> addError $ "No user with name " ++ show ustr ++ " found"
                Just (uid,_) -> liftIO $ addUserList group uid
       where addError = errBadRequest "Failed to add user" . return . MText

    groupDeleteUser :: UserGroup -> DynamicPath -> ServerPartE ()
    groupDeleteUser group dpath = do
      guardAuthorised_ (map InGroup (canRemoveGroup group))
      uid <- lookupUserName =<< userNameInPath dpath
      liftIO $ removeUserList group uid

    lookupGroupEditAuth :: UserGroup -> ServerPartE (Bool, Bool)
    lookupGroupEditAuth group = do
      addList    <- liftIO . Group.queryGroups $ canAddGroup group
      removeList <- liftIO . Group.queryGroups $ canRemoveGroup group
      uid <- guardAuthenticated
      let (canAdd, canDelete) = (uid `Group.member` addList, uid `Group.member` removeList)
      if not (canAdd || canDelete)
          then errForbidden "Forbidden" [MText "Can't edit permissions for user group"]
          else return (canAdd, canDelete)

    ------------ Encapsulation of resources related to editing a user group.

    -- | Registers a user group for external display. It takes the index group
    -- mapping (groupIndex from UserFeature), the base uri of the group, and a
    -- UserGroup object with all the necessary hooks. The base uri shouldn't
    -- contain any dynamic or varying components. It returns the GroupResource
    -- object, and also an adapted UserGroup that updates the cache. You should
    -- use this in order to keep the index updated.
    groupResourceAt :: String -> UserGroup -> IO (UserGroup, GroupResource)
    groupResourceAt uri group = do
        let mainr = resourceAt uri
            descr = groupDesc group
            groupUri = renderResource mainr []
            group' = group
              { addUserList = \uid -> do
                    addGroupIndex uid groupUri descr
                    addUserList group uid
              , removeUserList = \uid -> do
                    removeGroupIndex uid groupUri
                    removeUserList group uid
              }
        ulist <- queryUserList group
        initGroupIndex ulist groupUri descr
        let groupr = GroupResource {
                groupResource = (extendResourcePath "/.:format" mainr) {
                    resourceDesc = [ (GET, "Description of the group and a list of its members (defined in 'users' feature)") ]
                  , resourceGet  = [ ("json", serveUserGroupGet groupr) ]
                  }
              , groupUserResource = (extendResourcePath "/user/:username.:format" mainr) {
                    resourceDesc   = [ (PUT, "Add a user to the group (defined in 'users' feature)")
                                     , (DELETE, "Remove a user from the group (defined in 'users' feature)")
                                     ]
                  , resourcePut    = [ ("", serveUserGroupUserPut groupr) ]
                  , resourceDelete = [ ("", serveUserGroupUserDelete groupr) ]
                  }
              , getGroup = \_ -> return group'
              }
        return (group', groupr)

    -- | Registers a collection of user groups for external display. These groups
    -- are usually backing a separate collection. Like groupResourceAt, it takes the
    -- index group mapping and a base uri The base uri can contain varying path
    -- components, so there should be a group-generating function that, given a
    -- DynamicPath, yields the proper UserGroup. The final argument is the initial
    -- list of DynamicPaths to build the initial group index. Like groupResourceAt,
    -- this function returns an adaptor function that keeps the index updated.
    groupResourcesAt :: String
                     -> (a -> UserGroup)
                     -> (a -> DynamicPath)
                     -> (DynamicPath -> ServerPartE a)
                     -> [a]
                     -> IO (a -> UserGroup, GroupResource)
    groupResourcesAt uri mkGroup mkPath getGroupData initialGroupData = do
        let mainr = resourceAt uri
        sequence_
          [ do let group = mkGroup x
                   dpath = mkPath x
               ulist <- queryUserList group
               initGroupIndex ulist (renderResource' mainr dpath) (groupDesc group)
          | x <- initialGroupData ]

        let mkGroup' x =
              let group = mkGroup x
                  dpath = mkPath x
               in group {
                    addUserList = \uid -> do
                        addGroupIndex uid (renderResource' mainr dpath) (groupDesc group)
                        addUserList group uid
                  , removeUserList = \uid -> do
                        removeGroupIndex uid (renderResource' mainr dpath)
                        removeUserList group uid
                  }

            groupr = GroupResource {
                groupResource = (extendResourcePath "/.:format" mainr) {
                    resourceDesc = [ (GET, "Description of the group and a list of the members (defined in 'users' feature)") ]
                  , resourceGet  = [ ("json", serveUserGroupGet groupr) ]
                  }
              , groupUserResource = (extendResourcePath "/user/:username.:format" mainr) {
                    resourceDesc   = [ (PUT,    "Add a user to the group (defined in 'users' feature)")
                                     , (DELETE, "Delete a user from the group (defined in 'users' feature)")
                                     ]
                  , resourcePut    = [ ("", serveUserGroupUserPut groupr) ]
                  , resourceDelete = [ ("", serveUserGroupUserDelete groupr) ]
                  }
              , getGroup = \dpath -> mkGroup' <$> getGroupData dpath
              }
        return (mkGroup', groupr)

    serveUserGroupGet groupr dpath = do
      group    <- getGroup groupr dpath
      userDb   <- queryGetUserDb
      userlist <- liftIO $ queryUserList group
      return . toResponse $ toJSON
          UserGroupResource {
            ui_title       = T.pack $ groupTitle (groupDesc group),
            ui_description = T.pack $ groupPrologue (groupDesc group),
            ui_members     = [ UserNameIdResource {
                                 ui_username = Users.userIdToName userDb uid,
                                 ui_userid   = uid
                               }
                             | uid <- Group.enumerate userlist ]
          }

    --TODO: add serveUserGroupUserPost for the sake of the html frontend
    --      and then remove groupAddUser & groupDeleteUser
    serveUserGroupUserPut groupr dpath = do
      group <- getGroup groupr dpath
      guardAuthorised_ (map InGroup (canAddGroup group))
      uid <- lookupUserName =<< userNameInPath dpath
      liftIO $ addUserList group uid
      goToList groupr dpath

    serveUserGroupUserDelete groupr dpath = do
      group <- getGroup groupr dpath
      guardAuthorised_ (map InGroup (canRemoveGroup group))
      uid <- lookupUserName =<< userNameInPath dpath
      liftIO $ removeUserList group uid
      goToList groupr dpath

    goToList group dpath = seeOther (renderResource' (groupResource group) dpath)
                                    (toResponse ())

    ---------------------------------------------------------------
    addGroupIndex :: MonadIO m => UserId -> String -> GroupDescription -> m ()
    addGroupIndex (UserId uid) uri desc =
        modifyMemState groupIndex $
          adjustGroupIndex
            (IntMap.insertWith Set.union uid (Set.singleton uri))
            (Map.insert uri desc)

    removeGroupIndex :: MonadIO m => UserId -> String -> m ()
    removeGroupIndex (UserId uid) uri =
        modifyMemState groupIndex $
          adjustGroupIndex
            (IntMap.update (keepSet . Set.delete uri) uid)
            id
      where
        keepSet m = if Set.null m then Nothing else Just m

    initGroupIndex :: MonadIO m => UserList -> String -> GroupDescription -> m ()
    initGroupIndex ulist uri desc =
        modifyMemState groupIndex $
          adjustGroupIndex
            (IntMap.unionWith Set.union (IntMap.fromList . map mkEntry $ Group.enumerate ulist))
            (Map.insert uri desc)
      where
        mkEntry (UserId uid) = (uid, Set.singleton uri)

    getGroupIndex :: (Functor m, MonadIO m) => UserId -> m [String]
    getGroupIndex (UserId uid) =
      liftM (maybe [] Set.toList . IntMap.lookup uid . usersToGroupUri) $ readMemState groupIndex

    getIndexDesc :: MonadIO m => String -> m GroupDescription
    getIndexDesc uri =
      liftM (Map.findWithDefault nullDescription uri . groupUrisToDesc) $ readMemState groupIndex

    -- partitioning index modifications, a cheap combinator
    adjustGroupIndex :: (IntMap (Set String) -> IntMap (Set String))
                     -> (Map String GroupDescription -> Map String GroupDescription)
                     -> GroupIndex -> GroupIndex
    adjustGroupIndex f g (GroupIndex a b) = GroupIndex (f a) (g b)


{------------------------------------------------------------------------------
  Some types for JSON resources
------------------------------------------------------------------------------}

data UserNameIdResource = UserNameIdResource { ui_username    :: UserName,
                                               ui_userid      :: UserId }
data UserInfoResource   = UserInfoResource   { ui1_username    :: UserName,
                                               ui1_userid      :: UserId,
                                               ui1_groups      :: [T.Text] }
data EnabledResource    = EnabledResource    { ui_enabled     :: Bool }
data UserGroupResource  = UserGroupResource  { ui_title       :: T.Text,
                                               ui_description :: T.Text,
                                               ui_members     :: [UserNameIdResource] }

#if MIN_VERSION_aeson(0,6,2)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''UserNameIdResource)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 4} ''UserInfoResource)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''EnabledResource)
$(deriveJSON defaultOptions{fieldLabelModifier = drop 3} ''UserGroupResource)
#else
$(deriveJSON (drop 3) ''UserNameIdResource)
$(deriveJSON (drop 4) ''UserInfoResource)
$(deriveJSON (drop 3) ''EnabledResource)
$(deriveJSON (drop 3) ''UserGroupResource)
#endif