ReviewBoard-0.1: ReviewBoard/Core.hs
{-# 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