diff --git a/README b/README
--- a/README
+++ b/README
@@ -2,7 +2,7 @@
Haskell bindings to ReviewBoard (http://code.google.com/p/reviewboard/)
-From the project page:
+From the ReviewBoard project page:
"Review Board is a web-based tool designed to help projects and companies
keep track of pending code changes and make code reviews much less painful
and time-consuming..."
@@ -11,7 +11,7 @@
- The WebAPI binding to ReviewBoard.
- Sample command line tool 'mkrr' demonstrating the usage of
the bindings. Using 'mkrr' new review requests can be submitted
- from the local repository copy in the form:
+ from the local repository copy as simple as:
svn diff | mkrr -r [reviewers]
For details see haddock documentation.
@@ -33,4 +33,14 @@
runhaskell Setup.lhs build
3. Install:
runhaskell Setup.lhs install (as root)
+
+
+CHANGES
+
+0.2 - More API calls are supported
+ - Changed RBResponse type to simplify response handling
+ - Added minimalistic DSL for handling JSON responses
+ - mkrr supports screenshot upload now (-s command line flag)
+
+0.1 - Initial implementation supports basic API calls to submit new review requests
diff --git a/ReviewBoard.cabal b/ReviewBoard.cabal
--- a/ReviewBoard.cabal
+++ b/ReviewBoard.cabal
@@ -1,21 +1,22 @@
-Name: ReviewBoard
-Version: 0.1
-Synopsis: Haskell bindings to ReviewBoard
-Description: Haskell bindings to ReviewBoard ().
-Author: Adam Smyczek
-Maintainer:
-Category: Development
-License: BSD3
-License-file: LICENSE
-Cabal-Version: >= 1.2
-Build-type: Simple
-extra-source-files: README Tests/Tests.hs example/mkrr.hs
+Name: ReviewBoard
+Version: 0.2
+Synopsis: Haskell bindings to ReviewBoard
+Description: Haskell bindings to ReviewBoard ().
+Author: Adam Smyczek
+Maintainer:
+Category: Development
+License: BSD3
+License-file: LICENSE
+Cabal-Version: >= 1.2
+Build-type: Simple
+extra-source-files: README Tests/Tests.hs Tests/TestsWithServer.hs example/mkrr.hs
Library
Exposed-modules:
ReviewBoard.Api
ReviewBoard.Core
ReviewBoard.Browser
+ ReviewBoard.Response
Build-Depends:
base, mtl, random,
network, HTTP, json
@@ -27,6 +28,7 @@
ReviewBoard.Api
ReviewBoard.Core
ReviewBoard.Browser
+ ReviewBoard.Response
Build-Depends:
base, mtl, random, directory,
network, HTTP, json
diff --git a/ReviewBoard/Api.hs b/ReviewBoard/Api.hs
--- a/ReviewBoard/Api.hs
+++ b/ReviewBoard/Api.hs
@@ -8,13 +8,14 @@
--
-- ReviewBoard API
--
--- This package provides the basic ReviewBoard API calls.
+-- This module provides the basic ReviewBoard API calls.
-- All calls are executed inside the 'RBAction' monad that represents
-- a session to the ReviewBoard server. A login to the server is performed
-- in the 'RBAction' run method 'runRBAction'.
--
--- All actions return the 'RBResponse' object containing the response
--- status 'RBStatus' and the original JSon response. Errors are handled in
+-- All actions return the 'RBResponse' object that can be a 'RBok' with
+-- the response 'JSValue' or 'RBerr' containing the error message and
+-- the encoded response, if received. Errors are handled in
-- two ways:
--
-- * Network errors, for example connection errors throw an exception.
@@ -22,48 +23,60 @@
-- * Response errors resulting in for example invalid request parameters are
-- handled using the 'rbErrHandler' (by default print to stdin).
--
--- The current version provides mainly API calls to handle review requests,
--- but this can be easily extended using generalized 'rbPostRequest', 'rbGetRequest'
--- or directly the main 'runRequest' functions.
---
--- Refer to project page for details:
---
---
--- TODOs:
---
--- * Add more API calls, of cause!
---
--- * Add abstraction for response data, for example 'reviewRequestNew' should
--- return the @id@ of the new created request. Currently this have to be
--- parsed from the JSon response e.g. using 'rrId' function.
+-- For details see ReviewBoard project page
--
-----------------------------------------------------------------------------
+-- TODO: find a generic way to build API calls based on path
+
module ReviewBoard.Api (
-- Modules
module ReviewBoard.Core,
module ReviewBoard.Browser,
- -- API calls
+ -- * API calls
+
+ -- ** Users and groups
+ userList,
+ groupList,
+ groupStar,
+ groupUnstar,
+
+ -- ** Review request
reviewRequest,
+ reviewRequestByChangenum,
reviewRequestNew,
reviewRequestDelete,
reviewRequestSet,
reviewRequestSetField,
reviewRequestSaveDraft,
--- reviewRequestPublishDraft, not supported yet
+ reviewRequestDiscardDraft,
+ reviewRequestStar,
+ reviewRequestUnstar,
reviewRequestDiffNew,
- reviewRequestList,
+ reviewRequestScreenshotNew,
+ reviewRequestListAll,
+ reviewRequestListToGroup,
+ reviewRequestListToUser,
+ reviewRequestListFromUser,
- -- Types
+ -- ** Review
+ reviewAll,
+ reviewSaveDraft,
+ reviewDeleteDraft,
+ reviewPublishDraft,
+
+ -- ** Others
+ repositoryList,
+
+ -- * Types
RRField(..),
- -- Util functions
+ -- * Util functions
execRBAction,
rbPostRequest,
- rbGetRequest,
- rrId
+ rbGetRequest
-- * Example
-- $example1
@@ -79,14 +92,31 @@
import Control.Monad.Error
import Control.Monad.State
--- | Execute a ReviewBoard action using the provided URL, user
--- and password.
+-- ---------------------------------------------------------------------------
+-- User handling API calls
+
+-- | Search for a user or list all users if user is Nothing
--
-execRBAction :: String -> String -> String -> (RBAction a) -> IO a
-execRBAction url user password action = do
- r <- runRBAction url user password action
- either error return $ fst r
+userList :: Maybe String -> RBAction RBResponse
+userList (Just u) = rbGetRequest "users" [("query", u)]
+userList Nothing = rbGetRequest "users" []
+-- | Search for a group or list all group if Nothing
+--
+groupList :: Maybe String -> RBAction RBResponse
+groupList (Just g) = rbGetRequest "groups" [("query", g)]
+groupList Nothing = rbGetRequest "groups" []
+
+-- | Star group for group name
+--
+groupStar :: String -> RBAction RBResponse
+groupStar g = rbGetRequest (concat ["groups/", g, "/star"]) []
+
+-- | Unstar group for group name
+--
+groupUnstar :: String -> RBAction RBResponse
+groupUnstar g = rbGetRequest (concat ["groups/", g, "/unstar"]) []
+
-- ---------------------------------------------------------------------------
-- Review request API calls
@@ -103,20 +133,25 @@
reviewRequestDelete :: Integer -> RBAction RBResponse
reviewRequestDelete id = rbPostRequest ("reviewrequests/" ++ show id ++ "/delete") []
--- | Get review request with @id@.
+-- | Get review request by @id@.
--
reviewRequest :: Integer -> RBAction RBResponse
reviewRequest id = rbPostRequest ("reviewrequests/" ++ show id ) []
--- | Save review request draft whith @id@.
+-- | Get review request by repository @id@ and changenum @id@
--
+reviewRequestByChangenum :: Integer -> Integer -> RBAction RBResponse
+reviewRequestByChangenum rId cId = rbPostRequest (concat["reviewrequests/repository/", show rId, "/changenum/", show cId]) []
+
+-- | Discard review request draft for @id@.
+--
reviewRequestSaveDraft :: Integer -> RBAction RBResponse
reviewRequestSaveDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/draft/save") []
--- Publish review request draft for id
+-- | Save review request draft whith @id@.
--
--- reviewRequestPublishDraft :: Integer -> RBAction RBResponse
--- reviewRequestPublishDraft id = rbRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/publish") [("shipit", "False")]
+reviewRequestDiscardDraft :: Integer -> RBAction RBResponse
+reviewRequestDiscardDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/draft/discard") []
-- | Set fields to review request draft with @id@.
--
@@ -128,24 +163,97 @@
reviewRequestSetField :: Integer -> RRField -> String -> RBAction RBResponse
reviewRequestSetField id f v = rbPostRequest (concat ["reviewrequests/", show id, "/draft/set/", show f]) [("value", v)]
+-- | Star review request for id
+--
+reviewRequestStar :: Integer -> RBAction RBResponse
+reviewRequestStar id = rbGetRequest (concat ["reviewrequests/", show id, "/star"]) []
+
+-- | Star review request for id
+--
+reviewRequestUnstar :: Integer -> RBAction RBResponse
+reviewRequestUnstar id = rbGetRequest (concat ["reviewrequests/", show id, "/unstar"]) []
+
-- | Add a new diff to a review request with @id@, file path and the basedir parameter.
--
-reviewRequestDiffNew :: Integer -> String -> String -> RBAction RBResponse
+reviewRequestDiffNew :: Integer -> String -> FilePath -> RBAction RBResponse
reviewRequestDiffNew id bd fp = do
uri <- mkURI $ concat ["reviewrequests/", show id, "/diff/new"]
let form = Form POST uri [fileUpload "path" fp "text/plain", textField "basedir" bd]
runRequest form return
--- | List review requests addressed to one user with a status. If user and status are Nothing,
--- 'reviewRequestList' lists all request.
+-- | Add a new screenshot with @file path@ to a review request with @id@
--
-reviewRequestList :: Maybe String -> Maybe String -> RBAction RBResponse
-reviewRequestList Nothing Nothing = rbGetRequest "reviewrequests/all" []
-reviewRequestList (Just u) Nothing = rbGetRequest (concat ["reviewrequests/to/user/", u]) []
-reviewRequestList Nothing (Just s) = rbGetRequest "reviewrequests/all" [(show STATUS, s)]
-reviewRequestList (Just u) (Just s) = rbGetRequest (concat ["reviewrequests/to/user/", u]) [(show STATUS, s)]
+reviewRequestScreenshotNew :: Integer -> FilePath -> RBAction RBResponse
+reviewRequestScreenshotNew id fp = do
+ uri <- mkURI $ concat ["reviewrequests/", show id, "/screenshot/new"]
+ let form = Form POST uri [fileUpload "path" fp ((contentType . extension) fp)]
+ runRequest form return
+ where
+ extension = reverse . takeWhile (/= '.') . reverse
+ contentType "png" = "image/png"
+ contentType "gif" = "image/gif"
+ contentType "jpg" = "image/jpeg"
+ contentType "jpeg" = "image/jpeg"
+ contentType _ = "text/plain" -- fallback
+-- | List all review requests with an optional status
+--
+reviewRequestListAll :: Maybe String -> RBAction RBResponse
+reviewRequestListAll (Just s) = rbGetRequest "reviewrequests/all" [(show STATUS, s)]
+reviewRequestListAll Nothing = rbGetRequest "reviewrequests/all" []
+
+-- | List review request assigned to a group with an optional status
+--
+reviewRequestListToGroup :: String -> Maybe String -> RBAction RBResponse
+reviewRequestListToGroup g (Just s) = rbGetRequest ("reviewrequests/to/group/" ++ g) [(show STATUS, s)]
+reviewRequestListToGroup g Nothing = rbGetRequest ("reviewrequests/to/group/" ++ g) []
+
+-- | List review request assigned to a user, directly or not with an optional status
+--
+reviewRequestListToUser :: String -> Bool -> Maybe String -> RBAction RBResponse
+reviewRequestListToUser u True (Just s) = rbGetRequest ("reviewrequests/to/user/" ++ u ++ "/directly") [(show STATUS, s)]
+reviewRequestListToUser u True Nothing = rbGetRequest ("reviewrequests/to/user/" ++ u ++ "/directly") []
+reviewRequestListToUser u False (Just s) = rbGetRequest ("reviewrequests/to/user/" ++ u) [(show STATUS, s)]
+reviewRequestListToUser u False Nothing = rbGetRequest ("reviewrequests/to/user/" ++ u) []
+
+-- | Liste review request from a user with an optional status
+--
+reviewRequestListFromUser :: String -> Maybe String -> RBAction RBResponse
+reviewRequestListFromUser u (Just s) = rbGetRequest ("reviewrequests/from/user/" ++ u) [(show STATUS, s)]
+reviewRequestListFromUser u Nothing = rbGetRequest ("reviewrequests/from/user/" ++ u) []
+
-- ---------------------------------------------------------------------------
+-- Review API calls
+
+-- | List all reviews for review request @id@
+--
+reviewAll :: Integer -> RBAction RBResponse
+reviewAll id = rbGetRequest ("reviewrequests/" ++ show id ++ "/reviews") []
+
+-- | Publish review request draft for id
+--
+reviewPublishDraft :: Integer -> RBAction RBResponse
+reviewPublishDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/publish") [("shipit", "False")]
+
+-- | Save review draft for review request @id@
+--
+reviewSaveDraft :: Integer -> RBAction RBResponse
+reviewSaveDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/save") []
+
+-- | Delete review draft for review request @id@
+--
+reviewDeleteDraft :: Integer -> RBAction RBResponse
+reviewDeleteDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/delete") []
+
+-- ---------------------------------------------------------------------------
+-- Other API calls
+
+-- | List repositories
+--
+repositoryList :: RBAction RBResponse
+repositoryList = rbGetRequest "repositories" []
+
+-- ---------------------------------------------------------------------------
-- Types
-- | Review request field type.
@@ -182,6 +290,14 @@
-- ---------------------------------------------------------------------------
-- API uitl functions
+-- | Execute a ReviewBoard action using the provided URL, user
+-- and password.
+--
+execRBAction :: String -> String -> String -> (RBAction a) -> IO a
+execRBAction url user password action = do
+ r <- runRBAction url user password action
+ either error return $ fst r
+
-- | Default POST request builder for text field parameters only.
--
rbPostRequest :: String -> [(String, String)] -> RBAction RBResponse
@@ -200,25 +316,26 @@
let form = Form rm uri (map (\(n, v) -> textField n v) attrs)
runRequest form return
--- | Get the @id@ from a review request response.
---
-rrId :: RBResponse -> Maybe Integer
-rrId rsp = jsInt ["review_request", "id"] (rbRspBody rsp)
-
{- $example1
-The following RBAction creates a new review request draft, sets few fields
+The following RBAction creates a new review request draft, sets some fields
and uploads a diff file:
+> import ReviewBoard.Api
+> import qualified ReviewBoard.Response as R
+
> newRRAction :: RBAction ()
> newRRAction = do
> rsp <- reviewRequestNew "repository" Nothing
-> let id = fromJust . rrId $ rsp
-> reviewRequestsSetField id TARGET_PEOPLE "reviewers"
-> reviewRequestsSetField id DESCRIPTION "Request description"
-> reviewRequestsDiffNew id "basedir" "diffFileName"
-> reviewRequestSaveDraft id
-> liftIO $ print "Done."
+> case rsp of
+> RBok r -> do
+> let id = R.id . R.review_request $ r
+> reviewRequestsSetField id TARGET_PEOPLE "reviewers"
+> reviewRequestsSetField id DESCRIPTION "Request description"
+> reviewRequestsDiffNew id "basedir" "diffFileName"
+> reviewRequestSaveDraft id
+> liftIO $ print "Done."
+> RBerr s -> throwError s
To run this action, execute:
diff --git a/ReviewBoard/Browser.hs b/ReviewBoard/Browser.hs
--- a/ReviewBoard/Browser.hs
+++ b/ReviewBoard/Browser.hs
@@ -6,14 +6,15 @@
-- Stability : experimental
-- Portability : portable
--
--- ReviewBoard.Browser extends Network.Browser module (HTTP package)
+-- ReviewBoard.Browser extends Network.Browser module
-- with support for @multipart/form-data@ content type.
--
--- The package contains typed form variables 'FormVar' and
--- chooses the content type encryption based on this.
--- If the form contains a 'FileUpload', @multipart/form-data@
--- encryption is used. Otherwise the request falls back to the default
--- Network.Browser encryption.
+-- The package contains typed 'Form' and form variables 'FormVar'.
+-- The content encryption type is automatically chosen based on the
+-- type of the 'FormVar'. Currently @multipart/form-data@
+-- encryption is used only if 'Form' contains a 'fileUpload' variable.
+-- Otherwise the request falls back to the default Network.Browser
+-- encryption type.
--
-----------------------------------------------------------------------------
diff --git a/ReviewBoard/Core.hs b/ReviewBoard/Core.hs
--- a/ReviewBoard/Core.hs
+++ b/ReviewBoard/Core.hs
@@ -7,42 +7,41 @@
-- Stability : experimental
-- Portability : portable
--
--- Base types and functions.
+-- The core module implements the base types and functions of the bindings.
--
-----------------------------------------------------------------------------
module ReviewBoard.Core (
+ -- * RB action monad
RBAction,
- RBState(..),
runRBAction,
+ liftBA,
+ runRequest,
+ -- * RB state
+ RBState(..),
setErrorHandler,
+ setDebugHTTP,
- RBStatus(..),
+ -- * Response type
RBResponse(..),
-
- runRequest,
-
- liftBA,
- mkURI,
- setDebugHTTP,
+ responseToEither,
- jsValue,
- jsInt,
- jsString
+ -- * Convenient utils
+ mkURI
) where
-import Text.JSON
import Network.URI
import Network.HTTP
import qualified Network.Browser as NB
import ReviewBoard.Browser
-import Data.Maybe
+import qualified ReviewBoard.Response as R
import Control.Monad.Error
import Control.Monad.State
-import Data.Ratio
+import Data.Maybe
+import Text.JSON
-- ---------------------------------------------------------------------------
-- Review board action monad
@@ -114,28 +113,23 @@
-- ---------------------------------------------------------------------------
-- Response types
--- | Response status type parsed from ReviewBoard Json response stat object,
--- for example { \"stat\" : \"ok/fail\" }
+-- | Response type return by every API function
--
-data RBStatus
- = RBok -- ^ Successful response
- | RBerr String -- ^ Response error including error message
+data RBResponse
+ = RBok JSValue -- ^ Successful response, contains JSON response object
+ | RBerr String -- ^ Response error including error message including
+ -- encoded response
deriving Eq
-instance Show RBStatus where
- show RBok = "Successful"
- show (RBerr e) = "Error: " ++ e
+instance Show RBResponse where
+ show (RBok r) = "Ok: " ++ encode r
+ show (RBerr e) = "Error: " ++ e
--- | Response type returned by all API calls
+-- | Convenient response converter
--
-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)
+responseToEither :: RBResponse -> Either String JSValue
+responseToEither (RBok r) = Right r
+responseToEither (RBerr s) = Left s
-- ---------------------------------------------------------------------------
-- Request and response handling
@@ -153,17 +147,10 @@
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
+ Ok rsp -> mkResponse rsp >>= handle f (rbErrHandler s)
Error e -> throwError e
c -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")"
where
@@ -172,8 +159,9 @@
attachSID _ = return ()
-- Respond
- handle :: (RBResponse -> RBAction a) -> RBStatus -> JSValue -> RBAction a
- handle f st rsp = f $ RBResponse st rsp
+ handle :: (RBResponse -> RBAction a) -> (String -> IO ()) -> RBResponse -> RBAction a
+ handle f _ o@(RBok r) = f o
+ handle f eh o@(RBerr e) = liftIO (eh e) >> f o
-- | Login action updates session id cookie from successful login response
--
@@ -188,16 +176,17 @@
setCookie [] = throwError "No session cookie found!"
setCookie (c:cs) = setSessionId c
--- | Create 'RBStatus' from JSon response
+-- | Create RBResponse
--
-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."
+mkResponse :: JSValue -> RBAction RBResponse
+mkResponse v = do
+ stat <- (return $ R.stat v) `catchError` (\_ -> return "")
+ case stat of
+ "ok" -> return $ RBok v
+ "fail" -> do
+ err <- (return $ (R.msg . R.err) v) `catchError` (\_ -> return "No error message received")
+ return $ RBerr (err ++ " (" ++ encode v ++ ")")
+ _ -> return $ RBerr "Invalid response, not status received"
-- ---------------------------------------------------------------------------
-- Util functions
@@ -207,7 +196,7 @@
liftBA :: NB.BrowserAction a -> RBAction a
liftBA = RBAction . lift . lift
--- | Create ReviewBoard specific URI for API call URL.
+-- | Create ReviewBoard specific URI for an API call URL.
-- In case of invalid URL an exception is thrown.
--
mkURI :: String -> RBAction URI
@@ -222,39 +211,4 @@
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
diff --git a/ReviewBoard/Response.hs b/ReviewBoard/Response.hs
new file mode 100644
--- /dev/null
+++ b/ReviewBoard/Response.hs
@@ -0,0 +1,248 @@
+-----------------------------------------------------------------------------
+-- |
+-- Module : Response.hs
+--
+-- Maintainer : adam.smyczek@gmail.com
+-- Stability : experimental
+-- Portability : portable
+--
+-- This is an optional module that provides additional functionality
+-- to simplify handling of ReviewBoard responses.
+--
+-----------------------------------------------------------------------------
+
+module ReviewBoard.Response (
+
+ -- * JSON response utils
+ js4path,
+ js4name,
+ js2v,
+
+ -- * Basic Response DSL
+
+ -- | The DSL provides a function for (almost) every ReviewBoard JSObject member
+ -- that directly returns the value of the member. The function name is equivalent
+ -- to the name of the member element, for example values of a response like:
+ --
+ -- > { "stat": "fail",
+ -- > "err": {
+ -- > "msg": "You are not logged in",
+ -- > "code": 103
+ -- > }
+ -- > }
+ --
+ -- may be accessed as following:
+ --
+ -- > (msg . err) response
+ -- > -- returns 'You are not logged in' :: String
+ --
+ -- > (code . err) response
+ -- > -- returns 103 :: Integer
+ --
+ -- If the entry name represented by the function does not exist,
+ -- an error is thrown.
+ --
+ -- The current function list is build by screen scraping ReviewBoard
+ -- source code, so it's likely that some elements are missing.
+ -- The missing function can be added using 'mkrb' function.
+ -- Please drop me an email if you find one and I will include
+ -- this in the next version.
+ mkrb,
+
+ id,
+ stat,
+ err,
+ msg,
+ code,
+ last_updated,
+ summary,
+ description,
+ bugs_closed,
+ branch,
+ target_groups,
+ target_people,
+ public,
+ name,
+ timestamp,
+ timesince,
+ text,
+ username,
+ first_name,
+ last_name,
+ fullname,
+ email,
+ repository,
+ repositories,
+ display_name,
+ mailing_list,
+ url,
+ submitter,
+ time_added,
+ status,
+ changenum,
+ review_request,
+ testing_done,
+ user,
+ users,
+ ship_it,
+ body_top,
+ body_bottom,
+ comments,
+ path,
+ tool,
+ filediff,
+ interfilediff,
+ first_line,
+ last_line,
+ num_lines,
+ caption,
+ title,
+ image_url,
+ screenshot,
+ x,
+ y,
+ w,
+ h,
+ diffset,
+ source_file,
+ dest_file,
+ source_revision,
+ dest_detail,
+ revision,
+
+ ) where
+
+import Prelude hiding (id)
+import Text.JSON
+
+-- ---------------------------------------------------------------------------
+-- Some JSON helpers
+
+-- | Get value for name from a JSObject or Nothing
+-- if JSValue is not a JSObject
+--
+js4name :: String -> JSValue -> Maybe JSValue
+js4name n (JSObject o) = findValue n (fromJSObject o)
+js4name n _ = Nothing
+
+-- | Get JSValue for name path, for example
+-- for JSON object '{ \"obj1\" : { \"str\" : \"test\" } }'
+-- js4path [\"obj1\", \"str\"] returns Just 'test'
+--
+js4path :: [String] -> JSValue -> Maybe JSValue
+js4path [] v = Just v
+js4path (x:xs) v = maybe Nothing (js4path xs) $ js4name x v
+
+-- | 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
+
+-- | Extract value from JSValue or throw error
+--
+js2v :: (JSON a) => JSValue -> a
+js2v v = case readJSON v of
+ Ok a -> a
+ Error s -> error s
+
+-- ---------------------------------------------------------------------------
+-- Minimalistic DSL for parsing JSON response values
+
+-- | Constructor for DSL functions
+--
+mkrb :: (JSON a) => String -> (JSValue -> a)
+mkrb s = \v -> (js2v . fromJustWithError s) (js4name s v)
+ where
+ fromJustWithError e Nothing = error $ "Invalid response attribute " ++ e
+ fromJustWithError _ (Just v) = v
+
+-- TODO: the dsl should be generated from ReviewBoard source
+
+-- Common attributes
+id = (mkrb "id") :: JSValue -> Integer
+last_updated = (mkrb "last_updated") :: JSValue -> String
+summary = (mkrb "summary") :: JSValue -> String
+description = (mkrb "description") :: JSValue -> String
+bugs_closed = (mkrb "bugs_closed") :: JSValue -> JSValue
+branch = (mkrb "branch") :: JSValue -> String
+target_groups = (mkrb "target_groups") :: JSValue -> JSValue
+target_people = (mkrb "target_people") :: JSValue -> JSValue
+public = (mkrb "public") :: JSValue -> Bool
+name = (mkrb "name") :: JSValue -> String
+timestamp = (mkrb "timestamp") :: JSValue -> JSValue
+timesince = (mkrb "timesince") :: JSValue -> String
+text = (mkrb "text") :: JSValue -> String
+repository = (mkrb "repository") :: JSValue -> JSValue
+repositories = (mkrb "repositories") :: JSValue -> [JSValue]
+
+-- Attribute of status object
+stat = (mkrb "stat") :: JSValue -> String
+err = (mkrb "err") :: JSValue -> JSValue
+msg = (mkrb "msg") :: JSValue -> String
+code = (mkrb "code") :: JSValue -> String
+
+-- Attributes of Group object
+display_name = (mkrb "display_name") :: JSValue -> String
+mailing_list = (mkrb "mailing_list") :: JSValue -> String
+url = (mkrb "url") :: JSValue -> String
+
+-- Attributes of User object
+username = (mkrb "username") :: JSValue -> String
+first_name = (mkrb "first_name") :: JSValue -> String
+last_name = (mkrb "last_name") :: JSValue -> String
+fullname = (mkrb "fullname") :: JSValue -> String
+email = (mkrb "email") :: JSValue -> String
+
+-- Attributes of ReviewRequest object
+submitter = (mkrb "submitter") :: JSValue -> JSValue
+time_added = (mkrb "time_added") :: JSValue -> String
+status = (mkrb "status") :: JSValue -> String
+changenum = (mkrb "changenum") :: JSValue -> Integer
+
+-- Attributes of ReviewRequestDraft object
+review_request = (mkrb "review_request") :: JSValue -> JSValue
+testing_done = (mkrb "testing_done") :: JSValue -> String
+
+-- Attributes of Review
+user = (mkrb "user") :: JSValue -> JSValue
+users = (mkrb "users") :: JSValue -> [JSValue]
+ship_it = (mkrb "ship_it") :: JSValue -> Bool
+body_top = (mkrb "body_top") :: JSValue -> String
+body_bottom = (mkrb "body_bottom") :: JSValue -> String
+comments = (mkrb "comments") :: JSValue -> JSValue
+
+-- Attributes of Repository object
+path = (mkrb "path") :: JSValue -> String
+tool = (mkrb "tool") :: JSValue -> String
+
+-- Attributes of Comment object
+filediff = (mkrb "filediff") :: JSValue -> JSValue
+interfilediff = (mkrb "interfilediff") :: JSValue -> JSValue
+first_line = (mkrb "first_line") :: JSValue -> Integer
+last_line = (mkrb "last_line") :: JSValue -> Integer
+num_lines = (mkrb "num_lines") :: JSValue -> Integer
+
+-- Attributes of Comment object
+caption = (mkrb "caption") :: JSValue -> String
+title = (mkrb "title") :: JSValue -> String
+image_url = (mkrb "image_url") :: JSValue -> String
+
+-- Attributes of ScreenshotComment object
+screenshot = (mkrb "screenshot") :: JSValue -> JSValue
+x = (mkrb "x") :: JSValue -> Integer
+y = (mkrb "y") :: JSValue -> Integer
+w = (mkrb "w") :: JSValue -> Integer
+h = (mkrb "h") :: JSValue -> Integer
+
+-- Attributes of FileDiff object
+diffset = (mkrb "diffset") :: JSValue -> JSValue
+source_file = (mkrb "source_file") :: JSValue -> String
+dest_file = (mkrb "dest_file") :: JSValue -> String
+source_revision = (mkrb "source_revision"):: JSValue -> String
+dest_detail = (mkrb "dest_detail") :: JSValue -> String
+
+-- Attributes of DiffSet object
+revision = (mkrb "revision") :: JSValue -> Integer
+
diff --git a/Tests/Tests.hs b/Tests/Tests.hs
--- a/Tests/Tests.hs
+++ b/Tests/Tests.hs
@@ -12,22 +12,40 @@
import Test.HUnit
import Text.JSON
import Data.Ratio
-
+import Control.Monad
+import System.Environment
import ReviewBoard.Api
import ReviewBoard.Core
+import qualified ReviewBoard.Response as R
+import Tests.TestsWithServer
+import Data.Maybe
--- | Review board test test suite
+-- | Main test runner
--
-tests = TestList
- [ TestLabel "Test rrFieldMap" rrFieldMapTest
- , TestLabel "Test jsValue" jsValueTest
- , TestLabel "Test jsInt" jsIntTest
- , TestLabel "Test jsString" jsStringTest
- ]
+main = do
+ -- Run default test
+ runTestTT defaultTests
--- | Main test runner
+ -- Get ReviewBoard server credentials
+ -- for server depended tests
+ url <- getEnv "RB_URL"
+ user <- getEnv "RB_USER"
+ passwd <- getEnv "RB_PASSWD"
+
+ -- Check if server is available
+ avail <- serverAvailable url user passwd
+
+ -- and run tests
+ runServerTest avail $ apiServerTests url user passwd
+ return ()
+
+-- | Review board test suite
--
-main = runTestTT tests
+defaultTests = TestList
+ [ TestLabel "Test rrFieldMap" rrFieldMapTest
+ , TestLabel "Test JSON util function" jsUtilTest
+ , TestLabel "Test response DSL" responseDSLTest
+ ]
-- ---------------------------------------------------------------------------
-- API tests
@@ -35,7 +53,7 @@
-- Test rrFiledMap coverage for RRField
-- TODO: do we really need a print test?
rrFieldMapTest = TestCase ( do
- mapM (print . show) [(minBound::RRField)..(maxBound::RRField)]
+ mapM (print . show) [(minBound::RRField)..maxBound]
return ()
)
@@ -57,27 +75,41 @@
statusOk :: JSValue
statusOk = toJson $ decode "{ \"stat\" : \"ok\" }"
--- Test jsValue function
-jsValueTest = TestCase ( do
- assertEqual "Empty path" (Just testObject) (jsValue [] testObject)
- assertEqual "One level" (Just . JSString $ toJSString "fail") (jsValue ["stat"] testObject)
- assertEqual "No path match" Nothing (jsValue ["no"] testObject)
- assertEqual "Two levels" (Just $ JSRational (100%1)) (jsValue ["err", "code"] testObject)
- assertEqual "One more" (Just . JSString $ toJSString "test message") (jsValue ["err", "msg"] testObject)
+-- Test value parsing
+-- TODO: old test, add more for new dsl
+jsUtilTest = TestCase ( do
+ assertEqual "Empty path" (Just testObject) (R.js4path [] testObject)
+ assertEqual "One level" (Just . JSString $ toJSString "fail") (R.js4name "stat" testObject)
+ assertEqual "No path match" Nothing (R.js4name "no" testObject)
+ assertEqual "Two levels" (Just $ JSRational (100%1)) (R.js4path ["err", "code"] testObject)
+ assertEqual "One more" (Just . JSString $ toJSString "test message") (R.js4path ["err", "msg"] testObject)
+ assertEqual "No path match" Nothing (R.js4name "noerr" testObject)
+ assertEqual "js2v test 1" (100::Integer) (R.js2v $ fromJust $ R.js4path ["err", "code"] testObject)
+ assertEqual "js2v test 2" "fail" (R.js2v $ fromJust $ R.js4name "stat" testObject)
)
--- Test jsInt function
-jsIntTest = TestCase ( do
- assertEqual "jsInt" (Just 100) (jsInt ["err", "code"] testObject)
- assertEqual "No path match" Nothing (jsInt ["noerr"] testObject)
- assertEqual "Not an int" Nothing (jsInt ["stat"] testObject)
- )
+-- ---------------------------------------------------------------------------
+-- JSon response DLS tests
--- Test jsString function
-jsStringTest = TestCase ( do
- assertEqual "jsString 1" (Just "test message") (jsString ["err", "msg"] testObject)
- assertEqual "jsString 2" (Just "fail") (jsString ["stat"] testObject)
- assertEqual "jsString 2" (Just "fail") (jsString ["stat"] testObject)
- assertEqual "Not a string" Nothing (jsInt ["err"] testObject)
- )
+dslObject :: JSValue
+dslObject = toJson $ decode "{ \"review_request\" : { \"id\" : 123 } }"
+
+responseDSLTest = TestCase ( do
+ assertEqual "rb_review_request DSL" (toJson $ decode "{ \"id\" : 123 }") (R.review_request dslObject)
+ assertEqual "rb_id DSL" 123 $ (R.id . R.review_request) dslObject
+ )
+
+-- ---------------------------------------------------------------------------
+-- Server test utils
+
+-- Perform a login to check if server is available
+serverAvailable :: String -> String -> String -> IO Bool
+serverAvailable url user passwd = do
+ execRBAction url user passwd testLogin
+ where
+ testLogin :: RBAction Bool
+ testLogin = return True
+
+runServerTest True test = runTestTT test >> return ()
+runServerTest False _ = error "Server not available! Skipping tests..."
diff --git a/Tests/TestsWithServer.hs b/Tests/TestsWithServer.hs
new file mode 100644
--- /dev/null
+++ b/Tests/TestsWithServer.hs
@@ -0,0 +1,79 @@
+-----------------------------------------------------------------------------
+-- |
+-- This tests require ReviewBoard server
+--
+-- POC test with server. More to come...
+--
+-----------------------------------------------------------------------------
+module Tests.TestsWithServer (
+
+ apiServerTests
+
+ ) where
+
+import Test.HUnit
+import ReviewBoard.Api
+import qualified ReviewBoard.Response as R
+import Control.Monad.Trans
+import Control.Monad.Error
+
+apiServerTests url user passwd = TestList
+ [ TestLabel "Test repositoryList" $ runServerTest url user passwd repositoryListAction
+
+ -- User tests
+ , TestLabel "Test userList" $ runServerTest url user passwd (userListAction user)
+ , TestLabel "Test userList search" $ runServerTest url user passwd (userListSearchAction user)
+
+ ]
+
+-- Test repositoryList
+repositoryListAction :: RBAction ()
+repositoryListAction = do
+ setErrorHandler error
+ r <- repositoryList >>= return . jsValue
+ assertTrue "Repository list empty" ((length . R.repositories $ r) > 0)
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- User API tests
+
+-- Test userList
+userListAction :: String -> RBAction ()
+userListAction user = do
+ setErrorHandler error
+ r <- userList Nothing >>= return . jsValue
+ let users = R.users r
+ assertTrue "User list empty" (length users > 0)
+ assertTrue "Login user does not exist" ((length . filter (==user) . map R.username) users > 0)
+ return ()
+
+-- Test userList search
+userListSearchAction :: String -> RBAction ()
+userListSearchAction user = do
+ setErrorHandler error
+ vr <- userList (Just user) >>= return . jsValue
+ assertTrue "User list is not empty" (length (R.users vr) == 1)
+ assertTrue "No login user found" (((R.username . (!!0) . R.users) vr) == user)
+ ir <- userList (Just "not_a_user_2345234") >>= return . jsValue
+ assertTrue "User list is not empty" (length (R.users ir) == 0)
+ return ()
+
+-- ---------------------------------------------------------------------------
+-- Util function
+
+-- | General test action runner
+--
+runServerTest :: String -> String -> String -> RBAction () -> Test
+runServerTest url user passwd action = TestCase ( execRBAction url user passwd action )
+
+-- | Assert for RBAction
+--
+assertTrue :: String -> Bool -> RBAction()
+assertTrue s True = return ()
+assertTrue s False = throwError $ "Assertion: " ++ s
+
+-- | Get JSValue from respnse
+--
+jsValue (RBok r) = r
+jsValue (RBerr e) = error e
+
diff --git a/example/mkrr.hs b/example/mkrr.hs
--- a/example/mkrr.hs
+++ b/example/mkrr.hs
@@ -29,7 +29,7 @@
--
-- * publish - Publish immediately (not supported by ReivewBoard yet)
--
--- Run @mkrr --help@ or refer to ReviewBoard documentation for details
+-- Run @mkrr --help@ and see ReviewBoard documentation at
-- .
--
-----------------------------------------------------------------------------
@@ -47,6 +47,8 @@
import Control.Monad
import Data.Char
import ReviewBoard.Api
+import qualified ReviewBoard.Response as R
+import Control.Monad.Error
-- | Main
--
@@ -61,6 +63,7 @@
(fromJust . optBasedir $ opts)
(fromJust . optReviewers $ opts)
(optDescription opts)
+ (optScreenshot opts)
(optPublish opts)
-- ... and run it
@@ -88,23 +91,33 @@
-- | New review request action
--
-mkrrAction :: String -> String -> String -> Maybe String -> Bool -> String -> RBAction ()
-mkrrAction rep basedir revs dsc pub tfn = do
+mkrrAction :: String -> String -> String -> Maybe String -> Maybe String -> Bool -> String -> RBAction ()
+mkrrAction rep basedir revs dsc ss pub tfn = do
-- Create new review request and get the id
rsp <- reviewRequestNew rep Nothing
- let id = fromJust . rrId $ rsp
+ case rsp of
+ RBok r -> do
+ let id = R.id . R.review_request $ r
- -- Set some fields
- reviewRequestSetField id TARGET_PEOPLE revs
- setOptional id DESCRIPTION dsc
+ -- Set some fields
+ reviewRequestSetField id TARGET_PEOPLE revs
+ setOptional id DESCRIPTION dsc
- -- Upload the diff
- reviewRequestDiffNew id basedir tfn
+ -- Upload the diff
+ reviewRequestDiffNew id basedir tfn
- -- And store the review request draft
- reviewRequestSaveDraft id
- liftIO $ print "Done."
+ -- Upload screenshot if provided
+ when (isJust ss) ( do
+ reviewRequestScreenshotNew id $ fromJust ss
+ return ()
+ )
+ -- And store the review request draft
+ reviewRequestSaveDraft id
+ liftIO $ print "Done."
+
+ RBerr e -> throwError e
+
where
setOptional id f (Just v) = reviewRequestSetField id f v >>= \_ -> return ()
setOptional id f Nothing = return()
@@ -133,6 +146,7 @@
, optBasedir :: Maybe String
, optReviewers :: Maybe String
, optDescription :: Maybe String
+ , optScreenshot :: Maybe String
, optPublish :: Bool
} deriving Show
@@ -147,6 +161,7 @@
, Option ['b'] [] (ReqArg (\ r opts -> opts { optBasedir = Just r }) "BASEDIR") "Diff base dir"
, Option ['r'] [] (ReqArg (\ r opts -> opts { optReviewers = Just r }) "REVIEWERS") "Comma separated REVIEWERS list"
, Option ['d'] [] (ReqArg (\ r opts -> opts { optDescription = Just r }) "DESCRIPTION") "Optional request description"
+ , Option ['s'] [] (ReqArg (\ f opts -> opts { optScreenshot = Just f }) "SCREENSHOT") "attach SCREENSHOT"
, Option ['l'] [] (NoArg (\ opts -> opts { optPublish = True })) "Publish review"
]
@@ -179,6 +194,7 @@
, optBasedir = Nothing
, optReviewers = Nothing
, optDescription = Nothing
+ , optScreenshot = Nothing
, optPublish = False }
-- | Validate required options