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

import Database.HaskellDB
import Database.HaskellDB.HDBRec

import Control.Monad (liftM)
import Control.Monad.Trans (MonadIO, liftIO)

import Hawl.User.Types
import Hawl.HaskellDB.Util

import qualified Hawl.User.DB.Users as U
import qualified Hawl.User.DB.Users_meta as UM

--
-- * 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 :: MonadIO m => 
                Database 
             -> Username 
             -> Password 
             -> m (Maybe UserID)
authenticate db name pwd = liftIO $
    do
    rs <- query db $ 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 :: MonadIO m => Database -> Username -> m (Maybe UserID)
getUserID db name = liftIO $
    do
    rs <- query db $ 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

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

-- | Gets info about a user. Fails if the user does not
--   exist.
getUserInfo :: MonadIO m => Database -> UserID -> m UserInfo
getUserInfo db uid = liftIO $
    do
    r <- query1 db $ 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 :: MonadIO m => Database -> Username -> Password -> m (Maybe UserID)
addUser db name pwd = liftIO $ 
    do
    e <- getUserID db name
    case e of
           Just _ -> return Nothing
           Nothing -> do
                      uid <- nextUserID db
                      insert db U.users (U.userid <<- uid #
                                         U.username <<- name #
                                         U.password <<- hash pwd)
                      return $ Just uid

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

-- | Gets a list of all the users.
getAllUsers :: MonadIO m => Database -> m [UserInfo]
getAllUsers db =
    do rs <- liftIO $ query db $ table U.users
       return $ map mkUserInfo rs

-- | Get the number of users.
countUsers :: MonadIO m => Database -> m Int
countUsers db = liftIO $ countField db (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 :: Database -> IO UserID
nextUserID db = updateField db UM.users_meta UM.next_userid start (+1)
  where start = (UM.next_userid <<- 1)

hash :: String -> String
hash pwd = pwd -- FIXME: use some hashing function

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