{-# OPTIONS_GHC -fallow-overlapping-instances #-}
module Hope.User.Operations (authenticate, 
                             getUserID, doesUserExist, getUsername, getUserInfo,
                             addUser, removeUser, editUser,
                             getAllUsers, countUsers,
                             U.username, joinUser) where


import Hope.DatabaseT
import qualified Hope.MD5 as MD5
import Hope.User.Types
import qualified Hope.User.DB.Users as U
import qualified Hope.User.DB.Users_meta as UM

import Database.HaskellDB.HDBRec

import Control.Monad (liftM, when)


--
-- * Exported operations
--

-- | Authenticates a user with a password. If the username and password
--   match an existing user, the 'UserID' of that user is returned.
authenticate :: MonadDatabase m => 
                Username 
             -> Password 
             -> m (Maybe UserID)
authenticate name pwd = 
    do
    rs <- query $ do u <- table U.users
                     restrict (u!U.username .==. constant name)
                     return u
    case rs of
            []  -> return Nothing
            [r] | hash pwd == r!U.password -> return $ Just $ r!U.userid
                | otherwise -> return Nothing
            _   -> fail $ "Multiple users with name " ++ name

-- | Checks if a username exists, and gets the user id.
getUserID :: MonadDatabase m => Username -> m (Maybe UserID)
getUserID name = 
    do
    rs <- query $ do u <- table U.users
                     restrict (u!U.username .==. constant name)
                     project (U.userid << u!U.userid)
    case rs of
            []  -> return Nothing
            [r] -> return $ Just $ r!U.userid
            _   -> fail $ "Multiple users with name " ++ name

doesUserExist :: MonadDatabase m => UserID -> m Bool
doesUserExist uid = queryIsNonEmpty q
    where q = do u <- table U.users
                 restrict (u!U.userid .==. constant uid)
                 return u

-- | Gets the name of a user. Fails if the user does not
--   exist.
getUsername :: MonadDatabase m => UserID -> m Username
getUsername uid = liftM userName (getUserInfo uid)

-- | Gets info about a user. Fails if the user does not
--   exist.
getUserInfo :: MonadDatabase m => UserID -> m UserInfo
getUserInfo uid =
    do
    r <- query1 $ do u <- table U.users
                     restrict (u!U.userid .==. constant uid)
                     project (U.username << u!U.username)
    return $ UserInfo { userID = uid, userName = (r!U.username) }

-- | Tries to add a new user. Returns the 'UserID' of the new
--   user if successful. If there is already a user with the given
--   username, no user is added, and 'Nothing' is returned.
addUser :: MonadDatabase m => Username -> Password -> m (Maybe UserID)
addUser name pwd =
    do when (null name) $ fail "addUser: Empty username"
       e <- getUserID name
       case e of
         Just _ -> return Nothing
         Nothing -> 
          do uid <- nextUserID
             insert U.users (U.userid <<- uid 
                             # U.username <<- name 
                             # U.password <<- hash pwd)
             return $ Just uid

-- | Removes a user from the user database.
removeUser :: MonadDatabase m => UserID -> m ()
removeUser uid = delete U.users (\r -> r!U.userid .==. constant uid)

-- | Change user information.
editUser :: MonadDatabase m => UserInfo -> Maybe Password -> m ()
editUser (UserInfo { userID = uid, userName = uname }) mp = 
    do when (null uname) $ fail "editUser: Empty username"
       update U.users (\r -> r!U.userid .==. constant uid)
                       (\r -> U.username <<- uname
                            # U.password << pwd r)
        where pwd r = maybe (r!U.password) (constant . hash) mp

-- | Gets a list of all the users.
getAllUsers :: MonadDatabase m => m [UserInfo]
getAllUsers = queryMap mkUserInfo $ table U.users

-- | Get the number of users.
countUsers :: MonadDatabase m => m Int
countUsers = countField (table U.users) U.userid

--
-- * Combinators for writing custom queries using the users database.
--

joinUser :: Expr UserID 
         -> Query (Rel (RecCons U.Username (Expr Username) RecNil))
joinUser uid = do u <- table U.users
                  restrict (u!U.userid .==. uid)
                  project (U.username << u!U.username)

--
-- * Private stuff
--

nextUserID :: MonadDatabase m => m UserID
nextUserID = updateField UM.users_meta UM.next_userid start (+1)
  where start = (UM.next_userid <<- 1)

hash :: String -> String
hash = MD5.md5s . MD5.Str

mkUserInfo r = UserInfo { userID = r!U.userid, userName = r!U.username }