{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module RESTng.RESTngMonad where

import Database.HDBC.PostgreSQL (connectPostgreSQL, Connection)
import qualified Database.HDBC as HDBC (handleSqlError, disconnect, catchSql)
import Control.Monad.Reader

import Network.HTTP.RedHandler (RqHandlerT, mapRqHandlerT)
import RESTng.Resources.User

-----------------------------------------------
-- the monad definition and running methods ---
-----------------------------------------------

newtype RESTng a = RESTng {unRESTng::ReaderT (Connection, Maybe User) IO a}
                   deriving (Functor, Monad, MonadIO, MonadReader (Connection, Maybe User))


runRESTng :: String -> RESTng a -> IO a
runRESTng connString m = HDBC.handleSqlError $ runRESTng' connString m

safeRunRESTng :: String -> (String -> a) -> RESTng a -> IO a
safeRunRESTng connString errHandl m = safeHandleSqlError errHandl $ runRESTng' connString m

safeRunRESTng' :: String -> RESTng a -> IO (Either String{-error msg-} a)
safeRunRESTng' connString m = safeHandleSqlError' $ runRESTng' connString m

runRESTng' :: String -> RESTng a -> IO a
runRESTng' connString m = do
                              conn <-  connectPostgreSQL connString
                              result  <- runReaderT (unRESTng m) (conn, Nothing)
--                              HDBC.commit conn
                              HDBC.disconnect conn
                              return result

-------------------------------------------
-- methods that lift HDBC functionality ---
-------------------------------------------

liftHDBC_0 :: (Connection -> IO a) -> RESTng a
liftHDBC_0 f = fmap fst ask >>= \conn -> liftIO (f conn)

liftHDBC_1 :: (Connection -> a -> IO b) -> a -> RESTng b
liftHDBC_1 f a = fmap fst ask >>= \conn -> liftIO (f conn a)

liftHDBC_2 :: (Connection -> a -> b -> IO c) -> a -> b -> RESTng c
liftHDBC_2 f a b = fmap fst ask >>= \conn -> liftIO (f conn a b)

safeHandleSqlError :: (String -> a) -> IO a -> IO a
safeHandleSqlError errHandl action =
    HDBC.catchSql action handler
    where handler e = return $ errHandl ("SQL error: " ++ show e)

safeHandleSqlError' :: IO a -> IO (Either String{-error msg-} a)
safeHandleSqlError' action =
    HDBC.catchSql (action >>= return . Right) handler
    where handler e = return $ Left ("SQL error: " ++ show e)

--------------------------------------------------------------------------
-- methods that deal with the context info. (just the user currently) ----
--------------------------------------------------------------------------
getAuthUser :: RESTng (Maybe User)
getAuthUser = fmap snd ask

withAuthUser :: (Maybe User) -> RESTng a -> RESTng a
withAuthUser u = local (\(c,_)->(c,u))

authdUsername :: RESTng String
authdUsername = do authUser <- getAuthUser
                   case authUser of
                     Just u -> return $ username u
                     Nothing -> return "Guest" --HOOKME

--------------------------------------------------------------------------
-- request handlers that use the database or context for the response ----
--------------------------------------------------------------------------
dbRqHandler :: String -> RqHandlerT RESTng a -> RqHandlerT IO a
dbRqHandler connString = mapRqHandlerT (runRESTng connString)

safeDbRqHandler :: String -> (String -> a) -> RqHandlerT RESTng a -> RqHandlerT IO a
safeDbRqHandler connString strhan = mapRqHandlerT $ safeRunRESTng connString (Just . strhan)