ReviewBoard 0.1 → 0.2
raw patch · 9 files changed
+664/−205 lines, 9 files
Files
- README +12/−2
- ReviewBoard.cabal +14/−12
- ReviewBoard/Api.hs +172/−55
- ReviewBoard/Browser.hs +7/−6
- ReviewBoard/Core.hs +41/−87
- ReviewBoard/Response.hs +248/−0
- Tests/Tests.hs +63/−31
- Tests/TestsWithServer.hs +79/−0
- example/mkrr.hs +28/−12
README view
@@ -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
ReviewBoard.cabal view
@@ -1,21 +1,22 @@-Name: ReviewBoard-Version: 0.1-Synopsis: Haskell bindings to ReviewBoard-Description: Haskell bindings to ReviewBoard (<http://code.google.com/p/reviewboard/>).-Author: Adam Smyczek-Maintainer: <adam.smyczek@gmail.com>-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 (<http://code.google.com/p/reviewboard/>).+Author: Adam Smyczek+Maintainer: <adam.smyczek@gmail.com>+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
ReviewBoard/Api.hs view
@@ -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:--- <http://code.google.com/p/reviewboard/wiki/ReviewBoardAPI>------ 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 <http://code.google.com/p/reviewboard/> -- ----------------------------------------------------------------------------- +-- 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:
ReviewBoard/Browser.hs view
@@ -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. -- -----------------------------------------------------------------------------
ReviewBoard/Core.hs view
@@ -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
+ ReviewBoard/Response.hs view
@@ -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+
Tests/Tests.hs view
@@ -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..."
+ Tests/TestsWithServer.hs view
@@ -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+
example/mkrr.hs view
@@ -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 -- <http://code.google.com/p/reviewboard/wiki/ReviewBoardAPI>. -- -----------------------------------------------------------------------------@@ -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