{-# OPTIONS -fglasgow-exts #-}
-----------------------------------------------------------------------------
-- |
-- Module      :  Core.hs
--
-- Maintainer  :  adam.smyczek@gmail.com
-- Stability   :  experimental
-- Portability :  portable
--
-- Base types and functions.
--
-----------------------------------------------------------------------------

module ReviewBoard.Core (

    RBAction,
    RBState(..),
    runRBAction,

    setErrorHandler,

    RBStatus(..),
    RBResponse(..),
    
    runRequest,

    liftBA,
    mkURI,
    setDebugHTTP,

    jsValue,
    jsInt,
    jsString

    ) where

import Text.JSON
import Network.URI
import Network.HTTP
import qualified Network.Browser as NB
import ReviewBoard.Browser
import Data.Maybe
import Control.Monad.Error
import Control.Monad.State
import Data.Ratio

-- ---------------------------------------------------------------------------
-- Review board action monad

-- | The action monad, a state with error handler.
--
-- 'RBAction' represents one ReviewBoard session that handles multiple API calls.
-- The RBAction runner 'runRBAction' performs a login into the ReviewBoard server 
-- and initializes the session.  All session related parameters are stored in 
-- the 'RBState' of the action.
--
-- Errors are handled in two ways:
--
-- * Network related error are immediately thrown using ErrorT throwError.
--
-- * ReviewRequest response errors are handled using the error handler defined 
-- in 'RBState' (default print).
--
newtype RBAction a = RBAction
    { exec :: ErrorT String (StateT RBState NB.BrowserAction) a }
    deriving (Functor, Monad, MonadState RBState)

instance MonadIO RBAction where
  liftIO = RBAction . lift . lift . NB.ioAction

instance MonadError String RBAction where
    throwError = RBAction . throwError
    l `catchError` h = RBAction $ exec l `catchError` (exec . h)

-- | Run for 'RBAction', performs a login using provided URL, user 
-- and password parameters and executes the action. When login fails 
-- 'runRBAction' returns immediately with an error.
--
runRBAction :: String -> String -> String -> RBAction a -> IO (Either String a, RBState)
runRBAction url u p a = NB.browse . runStateT (runErrorT (exec init)) $ initState url u
    where init = setDebugHTTP False >> login u p >> a

-- ---------------------------------------------------------------------------
-- State type and handler functions

-- | RB action state containing session related information.
--
data RBState = RBState
    { rbUrl        :: String          -- ^ ReviewBoard server URL
    , rbUser       :: String          -- ^ Logged in user
    , rbSessionId  :: Maybe NB.Cookie -- ^ Session id cookie retrieve from a successful login
    , rbErrHandler :: String -> IO () -- ^ Error handler, for example error or print
    }

-- | Default state initialization including server URL and user.
--
initState :: String -> String -> RBState
initState url user = RBState 
    { rbUrl        = url
    , rbUser       = user
    , rbSessionId  = Nothing
    , rbErrHandler = print }

-- | Session id setter
--
setSessionId :: NB.Cookie -> RBAction ()
setSessionId sid = get >>= \s -> put s { rbSessionId = Just sid } 

-- | Set error handler used for ReviewBoard error responses.
--
setErrorHandler :: (String -> IO ()) -> RBAction ()
setErrorHandler eh = get >>= \s -> put s { rbErrHandler = eh } 

-- ---------------------------------------------------------------------------
-- Response types

-- | Response status type parsed from ReviewBoard Json response stat object, 
-- for example { \"stat\" : \"ok/fail\" }
--
data RBStatus 
    = RBok          -- ^ Successful response
    | RBerr String  -- ^ Response error including error message
    deriving Eq

instance Show RBStatus where
   show RBok      = "Successful"
   show (RBerr e) = "Error: " ++ e

-- | Response type returned by all API calls
--
data RBResponse = RBResponse
    { rbRspStatus :: RBStatus -- ^ parsed 'RBStatus'
    , rbRspBody   :: JSValue  -- ^ original Json response, including stat object
    }

instance Show RBResponse where
   show rsp = show (rbRspStatus rsp) ++ "\n" ++ 
              "Response: " ++ encode (rbRspBody rsp)

-- ---------------------------------------------------------------------------
-- Request and response handling

-- | The request runner, generates request from provided 'Form' parameter,
-- executes the requests and handles the response using the handler function.
--
runRequest :: Form -> (RBResponse -> RBAction a) -> RBAction a
runRequest form f = do
    s      <- get

    -- Execute request
    (u, r) <- liftBA $ do
        attachSID $ rbSessionId s
        formToRequest form >>= NB.request

    -- Check response status
    -- TODO: improve error handling
    case rspCode r of
        (2,0,0) -> do
            case (decode . rspBody) r of
                Ok rsp  -> do
                    let st = status rsp
                    case st of
                        RBok    -> handle f st rsp
                        RBerr e -> do
                            liftIO $ (rbErrHandler s) $ concat [e, " (Response: ", encode rsp, ")"]
                            handle f st rsp
                Error e -> throwError e
        c       -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")"
    where
        -- Add session id to request, if exists
        attachSID (Just sid) = NB.setCookies [sid]
        attachSID _          = return ()

        -- Respond
        handle :: (RBResponse -> RBAction a) -> RBStatus -> JSValue -> RBAction a
        handle f st rsp = f $ RBResponse st rsp

-- | Login action updates session id cookie from successful login response
--
login :: String -> String -> RBAction RBResponse
login user password = do
    s   <- get
    uri <- mkURI "accounts/login"
    let form = Form POST uri [textField "username" user, textField "password" password]
    runRequest form setSessionCookie
    where
        setSessionCookie rsp = liftBA NB.getCookies >>= setCookie >> return rsp
        setCookie []       = throwError "No session cookie found!"
        setCookie (c:cs)   = setSessionId c

-- | Create 'RBStatus' from JSon response
--
status :: JSValue -> RBStatus
status v = 
    case jsString ["stat"] v of
        Just "ok"   -> RBok
        Just "fail" -> case jsString ["err", "msg"] v of
                           Just m  -> RBerr m
                           Nothing -> RBerr "No error message found."
        Nothing   -> RBerr "Invalid response, no status message."

-- ---------------------------------------------------------------------------
-- Util functions

-- | Convenient lift for BrowserActions
--
liftBA :: NB.BrowserAction a -> RBAction a
liftBA = RBAction . lift . lift

-- | Create ReviewBoard specific URI for API call URL.
-- In case of invalid URL an exception is thrown.
--
mkURI :: String -> RBAction URI
mkURI apiUrl = do
    s <- get
    case parseURI (rbUrl s ++ "/api/json/" ++ apiUrl ++ "/") of
        Just u  -> return u
        Nothing -> throwError $ "Invalid url: " ++ rbUrl s

-- | Enable/disable debug output for Browser module
--
setDebugHTTP :: Bool -> RBAction ()
setDebugHTTP True  = liftBA $ NB.setOutHandler putStrLn
setDebugHTTP False = liftBA $ NB.setOutHandler (\_ -> return())

-- ---------------------------------------------------------------------------
-- JSon utils

-- | Return value for string path e.g.
-- [] (Int 5) -> Just $ Int 5
-- ["stat"] (Obj "stat" (Str "ok")) -> Just $ Str "ok"
-- ["stat"] (Obj "nostat" (Str "ok")) -> Nothing
--
jsValue :: [String] -> JSValue -> Maybe JSValue
jsValue [] v                = Just v
jsValue (x:xs) (JSObject m) = maybe Nothing (jsValue xs) $ findValue x (fromJSObject m)
jsValue (x:xs) v            = Nothing

-- | Find value in object map
--
findValue :: String -> [(String, JSValue)] -> Maybe JSValue
findValue s []          = Nothing
findValue s ((n, v):xs) | s == n    = Just v
                        | otherwise = findValue s xs

-- | Return Integer value for path or Nothing
-- if path does not exists or is not a JSRational
--
jsInt :: [String] -> JSValue -> Maybe Integer
jsInt p v = case jsValue p v of
    Just (JSRational i) -> Just (numerator i)
    _            -> Nothing

-- | String value for path, same as jsInt
--
jsString :: [String] -> JSValue -> Maybe String
jsString p v = case jsValue p v of
    Just (JSString s) -> Just $ fromJSString s
    _                 -> Nothing