ReviewBoard 0.2 → 0.2.1
raw patch · 8 files changed
+355/−120 lines, 8 files
Files
- README +8/−6
- ReviewBoard.cabal +3/−1
- ReviewBoard/Api.hs +39/−94
- ReviewBoard/Browser.hs +14/−5
- ReviewBoard/Core.hs +5/−4
- ReviewBoard/Request.hs +197/−0
- ReviewBoard/Response.hs +24/−3
- Tests/TestsWithServer.hs +65/−7
README view
@@ -15,7 +15,7 @@ svn diff | mkrr -r [reviewers] For details see haddock documentation. -Implemented and tested for ReviewBoard 1.0 Beta (4/25/2008).+Implemented and tested with ReviewBoard 1.0 Beta (4/25/2008). REQUIREMENTS@@ -37,10 +37,12 @@ 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.2.1 - Change the method API calls are constructed (internal change) -0.1 - Initial implementation supports basic API calls to submit new review requests+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,5 +1,5 @@ Name: ReviewBoard-Version: 0.2+Version: 0.2.1 Synopsis: Haskell bindings to ReviewBoard Description: Haskell bindings to ReviewBoard (<http://code.google.com/p/reviewboard/>). Author: Adam Smyczek@@ -17,6 +17,7 @@ ReviewBoard.Core ReviewBoard.Browser ReviewBoard.Response+ ReviewBoard.Request Build-Depends: base, mtl, random, network, HTTP, json@@ -29,6 +30,7 @@ ReviewBoard.Core ReviewBoard.Browser ReviewBoard.Response+ ReviewBoard.Request Build-Depends: base, mtl, random, directory, network, HTTP, json
ReviewBoard/Api.hs view
@@ -34,6 +34,7 @@ -- Modules module ReviewBoard.Core, module ReviewBoard.Browser,+ module ReviewBoard.Request, -- * API calls @@ -70,27 +71,22 @@ -- ** Others repositoryList, - -- * Types- RRField(..),- -- * Util functions execRBAction,- rbPostRequest,- rbGetRequest -- * Example -- $example1 ) where +import Prelude hiding (all) import ReviewBoard.Core import ReviewBoard.Browser+import ReviewBoard.Request import Network.URI-import Network.HTTP+import Network.HTTP hiding (user) import qualified Network.Browser as NB-import Data.Maybe import Control.Monad.Error-import Control.Monad.State -- --------------------------------------------------------------------------- -- User handling API calls@@ -98,24 +94,24 @@ -- | Search for a user or list all users if user is Nothing -- userList :: Maybe String -> RBAction RBResponse-userList (Just u) = rbGetRequest "users" [("query", u)]-userList Nothing = rbGetRequest "users" []+userList (Just u) = get (users Nothing) [textField "query" u]+userList Nothing = get (users Nothing) [] -- | 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" []+groupList (Just g) = get (groups Nothing) [textField "query" g]+groupList Nothing = get (groups Nothing) [] -- | Star group for group name -- groupStar :: String -> RBAction RBResponse-groupStar g = rbGetRequest (concat ["groups/", g, "/star"]) []+groupStar g = get (groups (Just g) . star) [] -- | Unstar group for group name -- groupUnstar :: String -> RBAction RBResponse-groupUnstar g = rbGetRequest (concat ["groups/", g, "/unstar"]) []+groupUnstar g = get (groups (Just g) . unstar) [] -- --------------------------------------------------------------------------- -- Review request API calls@@ -125,59 +121,59 @@ -- review request that can be accessed using 'rrId' helper function. -- reviewRequestNew :: String -> Maybe String -> RBAction RBResponse-reviewRequestNew p (Just u) = rbPostRequest "reviewrequests/new" [("repository_path", p), ("submit_as", u)]-reviewRequestNew p Nothing = rbPostRequest "reviewrequests/new" [("repository_path", p)]+reviewRequestNew p (Just u) = post (reviewrequests Nothing . new) $ toFormVar [("repository_path", p), ("submit_as", u)]+reviewRequestNew p Nothing = post (reviewrequests Nothing . new) [textField "repository_path" p] -- | Delete review request with request @id@. -- reviewRequestDelete :: Integer -> RBAction RBResponse-reviewRequestDelete id = rbPostRequest ("reviewrequests/" ++ show id ++ "/delete") []+reviewRequestDelete id = post (reviewrequests (Just id) . delete) [] -- | Get review request by @id@. -- reviewRequest :: Integer -> RBAction RBResponse-reviewRequest id = rbPostRequest ("reviewrequests/" ++ show id ) []+reviewRequest id = post (reviewrequests (Just 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]) []+reviewRequestByChangenum rId cId = post (reviewrequests Nothing . repository rId . changenum cId) [] -- | Discard review request draft for @id@. -- reviewRequestSaveDraft :: Integer -> RBAction RBResponse-reviewRequestSaveDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/draft/save") []+reviewRequestSaveDraft id = post (reviewrequests (Just id) . draft . save) [] -- | Save review request draft whith @id@. -- reviewRequestDiscardDraft :: Integer -> RBAction RBResponse-reviewRequestDiscardDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/draft/discard") []+reviewRequestDiscardDraft id = post (reviewrequests (Just id) . draft . discard) [] -- | Set fields to review request draft with @id@. -- reviewRequestSet :: Integer -> [(RRField, String)] -> RBAction RBResponse-reviewRequestSet id fs = rbPostRequest (concat ["reviewrequests/", show id, "/draft/set/"]) (map (\(f, v) -> (show f, v)) fs)+reviewRequestSet id fs = post (reviewrequests (Just id) . draft . set Nothing) (map (\(f, v) -> textField (show f) v) fs) -- | Set one field for review request draft with @id@. -- reviewRequestSetField :: Integer -> RRField -> String -> RBAction RBResponse-reviewRequestSetField id f v = rbPostRequest (concat ["reviewrequests/", show id, "/draft/set/", show f]) [("value", v)]+reviewRequestSetField id f v = post (reviewrequests (Just id) . draft . set (Just f)) $ [textField "value" v] -- | Star review request for id -- reviewRequestStar :: Integer -> RBAction RBResponse-reviewRequestStar id = rbGetRequest (concat ["reviewrequests/", show id, "/star"]) []+reviewRequestStar id = get (reviewrequests (Just id) . star) [] -- | Star review request for id -- reviewRequestUnstar :: Integer -> RBAction RBResponse-reviewRequestUnstar id = rbGetRequest (concat ["reviewrequests/", show id, "/unstar"]) []+reviewRequestUnstar id = get (reviewrequests (Just id) . unstar) [] -- | Add a new diff to a review request with @id@, file path and the basedir parameter. -- reviewRequestDiffNew :: Integer -> String -> FilePath -> RBAction RBResponse reviewRequestDiffNew id bd fp = do- uri <- mkURI $ concat ["reviewrequests/", show id, "/diff/new"]+ uri <- mkURI $ (reviewrequests (Just id) . diff . new) "" let form = Form POST uri [fileUpload "path" fp "text/plain", textField "basedir" bd] runRequest form return @@ -185,7 +181,7 @@ -- reviewRequestScreenshotNew :: Integer -> FilePath -> RBAction RBResponse reviewRequestScreenshotNew id fp = do- uri <- mkURI $ concat ["reviewrequests/", show id, "/screenshot/new"]+ uri <- mkURI $ (reviewrequests (Just id) . screenshot . new) "" let form = Form POST uri [fileUpload "path" fp ((contentType . extension) fp)] runRequest form return where@@ -199,28 +195,29 @@ -- | 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" []+reviewRequestListAll (Just s) = get (reviewrequests Nothing . all) [textField (show STATUS) s]+reviewRequestListAll Nothing = get (reviewrequests Nothing . 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) []+reviewRequestListToGroup g (Just s) = get (reviewrequests Nothing . to . group (Just g)) [textField (show STATUS) s]+reviewRequestListToGroup g Nothing = get (reviewrequests Nothing . to . group (Just 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) []+reviewRequestListToUser u True (Just s) = get (rr2u u . directly) [textField (show STATUS) s]+reviewRequestListToUser u True Nothing = get (rr2u u . directly) []+reviewRequestListToUser u False (Just s) = get (rr2u u) [textField (show STATUS) s]+reviewRequestListToUser u False Nothing = get (rr2u u) []+rr2u u = reviewrequests Nothing . to . user (Just 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) []+reviewRequestListFromUser u (Just s) = get (reviewrequests Nothing . from . user (Just u)) [textField (show STATUS) s]+reviewRequestListFromUser u Nothing = get (reviewrequests Nothing . from . user (Just u)) [] -- --------------------------------------------------------------------------- -- Review API calls@@ -228,22 +225,22 @@ -- | List all reviews for review request @id@ -- reviewAll :: Integer -> RBAction RBResponse-reviewAll id = rbGetRequest ("reviewrequests/" ++ show id ++ "/reviews") []+reviewAll id = get (reviewrequests (Just id) . reviews Nothing) [] -- | Publish review request draft for id -- reviewPublishDraft :: Integer -> RBAction RBResponse-reviewPublishDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/publish") [("shipit", "False")]+reviewPublishDraft id = post (reviewrequests (Just id) . reviews Nothing . draft . publish) [checkBox "shipit" False] -- | Save review draft for review request @id@ -- reviewSaveDraft :: Integer -> RBAction RBResponse-reviewSaveDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/save") []+reviewSaveDraft id = post (reviewrequests (Just id) . reviews Nothing . draft . save) [] -- | Delete review draft for review request @id@ -- reviewDeleteDraft :: Integer -> RBAction RBResponse-reviewDeleteDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/delete") []+reviewDeleteDraft id = post (reviewrequests (Just id) . reviews Nothing . draft . delete) [] -- --------------------------------------------------------------------------- -- Other API calls@@ -251,41 +248,7 @@ -- | List repositories -- repositoryList :: RBAction RBResponse-repositoryList = rbGetRequest "repositories" []---- ------------------------------------------------------------------------------ Types---- | Review request field type.----data RRField - = STATUS- | PUBLIC- | SUMMARY- | DESCRIPTION- | TESTING_DONE- | BUGS_CLOSED- | BRANCH- | TARGET_GROUPS- | TARGET_PEOPLE- deriving (Eq, Enum, Bounded)---- | Request field to name map.----rrFieldMap :: [(RRField, String)]-rrFieldMap =- [ (STATUS, "status")- , (PUBLIC, "public")- , (SUMMARY, "summary")- , (DESCRIPTION, "description")- , (TESTING_DONE, "testing_done")- , (BUGS_CLOSED, "bugs_closed")- , (BRANCH, "branch")- , (TARGET_GROUPS, "target_groups")- , (TARGET_PEOPLE, "target_people") ]--instance Show RRField where- show = fromJust . flip lookup rrFieldMap+repositoryList = get repositories [] -- --------------------------------------------------------------------------- -- API uitl functions@@ -297,24 +260,6 @@ 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-rbPostRequest = rbRequest POST---- | Default GET request builder for text field parameters only.----rbGetRequest :: String -> [(String, String)] -> RBAction RBResponse-rbGetRequest = rbRequest GET---- | Generalized request runner for text field parameters only.----rbRequest :: RequestMethod -> String -> [(String, String)] -> RBAction RBResponse-rbRequest rm apiUrl attrs = do- uri <- mkURI apiUrl- let form = Form rm uri (map (\(n, v) -> textField n v) attrs)- runRequest form return {- $example1
ReviewBoard/Browser.hs view
@@ -26,8 +26,11 @@ textField, checkBox,- fileUpload+ fileUpload, + toMap,+ toFormVar,+ ) where import qualified Network.Browser as NB@@ -54,7 +57,7 @@ , rqURI = u } -- Otherwise fall back to Network.Browser formToRequest- | otherwise = return $ NB.formToRequest (NB.Form m u $ map toNBFormVar vs)+ | otherwise = return $ NB.formToRequest (NB.Form m u $ toMap vs) where -- Check if contains contain file upload@@ -144,10 +147,16 @@ fileUpload :: String -> FilePath -> String -> FormVar fileUpload n p t = FormVar n $ FileUpload p t --- | Convert FormVar to Network.Browser FormVar+-- | Convert [FormVar] to Network.Browser FormVar, a (String, String) map ---toNBFormVar :: FormVar -> (String, String)-toNBFormVar fv = (fvName fv, toNBValue . fvValue $ fv)+toMap :: [FormVar] -> [(String, String)]+toMap = map (\fv -> (fvName fv, toNBValue . fvValue $ fv))++-- | Opposite to toNBFormVar+-- Converts a String tuple to 'FormVar'+--+toFormVar :: [(String, String)] -> [FormVar]+toFormVar = map (\(n, v) -> textField n v) -- | Convert Form value to Network.Browser strings --
ReviewBoard/Core.hs view
@@ -28,7 +28,7 @@ RBResponse(..), responseToEither, - -- * Convenient utils+ -- * Utils mkURI ) where@@ -168,7 +168,7 @@ login :: String -> String -> RBAction RBResponse login user password = do s <- get- uri <- mkURI "accounts/login"+ uri <- mkURI "accounts/login/" let form = Form POST uri [textField "username" user, textField "password" password] runRequest form setSessionCookie where@@ -202,9 +202,10 @@ mkURI :: String -> RBAction URI mkURI apiUrl = do s <- get- case parseURI (rbUrl s ++ "/api/json/" ++ apiUrl ++ "/") of+ let url = rbUrl s ++ "/api/json/" ++ apiUrl+ case parseURI url of Just u -> return u- Nothing -> throwError $ "Invalid url: " ++ rbUrl s+ Nothing -> throwError $ "Invalid url: " ++ url -- | Enable/disable debug output for Browser module --
+ ReviewBoard/Request.hs view
@@ -0,0 +1,197 @@+-----------------------------------------------------------------------------+-- |+-- Module : Request.hs+--+-- Maintainer : adam.smyczek@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- This module provides util functions to build ReviewBoard requests.+-- The current implementation for this small project is maybe an overkill, but it +-- provides constants for URL path elements and+-- simplifies building API calls.+--+-- The call format is @method (path1 . path2 . path3) [form var]@+-- , for example the API GET call to+-- @\/api\/json\/reviewrequests\/5\/delete\/@ can be executed by calling+--+-- > get (reviewrequests (Just 5) . delete) []+--+-- The current approach to handle request may change if I find a way+-- to automatically generate API calls from ReviewBoard code.+--+-----------------------------------------------------------------------------+module ReviewBoard.Request (+ -- * URL path elements+ new,+ delete,+ save,+ discard,+ publish,+ update_from_changenum,+ star,+ unstar,+ all,+ to,+ from,+ count,+ directly,+ repositories,+ reviewrequest,+ comments,+ replies,+ draft,+ diff,+ screenshot,+ reviewrequests,+ reviews,+ groups,+ group,+ users,+ user,+ set,+ file,+ line,+ repository,+ changenum,++ -- * Types+ RRField(..),++ -- * Request methods+ get,+ post,++ -- * Util types and functions+ UrlPath,+ mkup,+ mkpup++ ) where++import Prelude hiding (all)+import ReviewBoard.Browser+import ReviewBoard.Core+import Network.HTTP hiding (user)+import Control.Monad.Trans+import Data.Maybe++-- ---------------------------------------------------------------------------+-- URL path elements++-- Constant definitions (UrlPath -> UrlPath)+new = mkup "new"+delete = mkup "delete"+save = mkup "save"+discard = mkup "discard"+publish = mkup "publish"+update_from_changenum = mkup "repositories"++star = mkup "star"+unstar = mkup "unstar"++all = mkup "all"+to = mkup "to"+from = mkup "from"+count = mkup "count"+directly = mkup "directly"++repositories = mkup "repositories"+reviewrequest = mkup "reviewrequest"+comments = mkup "comments"+replies = mkup "replies"+draft = mkup "draft"+diff = mkup "diff"+screenshot = mkup "screenshot"++-- Path elements with optional parameter+reviewrequests = mkpup "reviewrequests" :: (Maybe Integer -> UrlPath -> UrlPath)+reviews = mkpup "reviews" :: (Maybe Integer -> UrlPath -> UrlPath)+groups = mkpup "groups" :: (Maybe String -> UrlPath -> UrlPath)+group = mkpup "group" :: (Maybe String -> UrlPath -> UrlPath)+users = mkpup "users" :: (Maybe String -> UrlPath -> UrlPath)+user = mkpup "user" :: (Maybe String -> UrlPath -> UrlPath)+set = mkpup "set" :: (Maybe RRField -> UrlPath -> UrlPath)+file = mkpup "file" :: (Maybe Integer -> UrlPath -> UrlPath)+line = mkpup "line" :: (Maybe Integer -> UrlPath -> UrlPath)++-- Other definitions+repository id = mkup "repository" . mkup (show id)+changenum n = mkup "changenum " . mkup (show n)++-- ---------------------------------------------------------------------------+-- Types++-- | Review request field type.+--+data RRField + = STATUS+ | PUBLIC+ | SUMMARY+ | DESCRIPTION+ | TESTING_DONE+ | BUGS_CLOSED+ | BRANCH+ | TARGET_GROUPS+ | TARGET_PEOPLE+ deriving (Eq, Enum, Bounded)++-- | Request field to name map.+--+rrFieldMap :: [(RRField, String)]+rrFieldMap =+ [ (STATUS, "status")+ , (PUBLIC, "public")+ , (SUMMARY, "summary")+ , (DESCRIPTION, "description")+ , (TESTING_DONE, "testing_done")+ , (BUGS_CLOSED, "bugs_closed")+ , (BRANCH, "branch")+ , (TARGET_GROUPS, "target_groups")+ , (TARGET_PEOPLE, "target_people") ]++instance Show RRField where+ show = fromJust . flip lookup rrFieldMap++-- ---------------------------------------------------------------------------+-- Request functions++-- | GET request method+--+get :: (UrlPath -> UrlPath) -> [FormVar] -> RBAction RBResponse+get u vs = rbRequest GET (u "") vs++-- | GET request method+--+post :: (UrlPath -> UrlPath) -> [FormVar] -> RBAction RBResponse+post u vs = rbRequest POST (u "") vs++-- | Internal generalized request runner+--+rbRequest :: RequestMethod -> String -> [FormVar] -> RBAction RBResponse+rbRequest rm apiUrl vs = do+ uri <- mkURI apiUrl+ let form = Form rm uri vs+ runRequest form return++-- ---------------------------------------------------------------------------+-- Util types and functions++-- | Synonym for URL path element+--+type UrlPath = String++-- | (MaKe UrlPath) Default URL element path maker+--+mkup :: String -> (UrlPath -> UrlPath)+mkup s = ((s ++ "/") ++)++-- | Make path element with a parameter of type a e.g.+-- reviewrequests (Just 5) => \"reviewrequests\/5\/\"+--+mkpup :: Show a => String -> (Maybe a -> UrlPath -> UrlPath)+mkpup s = \p u -> maybe (noparam u) (flip param u) p+ where+ noparam = mkup s+ param i = mkup s . mkup (show i)+
ReviewBoard/Response.hs view
@@ -14,15 +14,16 @@ module ReviewBoard.Response ( -- * JSON response utils- js4path, js4name,+ js4path,+ js4spath, js2v, -- * Basic Response DSL - -- | The DSL provides a function for (almost) every ReviewBoard JSObject member+ -- | The DSL provides a function for most ReviewBoard JSObject members -- 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:+ -- to the name of the member element, for example values of a response: -- -- > { "stat": "fail", -- > "err": {@@ -47,6 +48,10 @@ -- 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.+ --+ -- This approach for handling responses may change if I find a way+ -- to generate the DSL methods directly from ReviewBoard code.+ -- mkrb, id,@@ -66,6 +71,7 @@ timestamp, timesince, text,+ draft, username, first_name, last_name,@@ -81,6 +87,7 @@ status, changenum, review_request,+ review_requests, testing_done, user, users,@@ -114,6 +121,7 @@ import Prelude hiding (id) import Text.JSON+import Data.List -- --------------------------------------------------------------------------- -- Some JSON helpers@@ -133,6 +141,17 @@ js4path [] v = Just v js4path (x:xs) v = maybe Nothing (js4path xs) $ js4name x v +-- | Get JSValue for string path of the form+-- @reviewrequests.5.delete@. Dots inside a name+-- are not supported.+--+js4spath :: String -> JSValue -> Maybe JSValue+js4spath = js4path . split+ where+ split s | xs == [] = [x]+ | otherwise = x : split (tail xs)+ where (x, xs) = span (/='.') s+ -- | Find value in object map -- findValue :: String -> [(String, JSValue)] -> Maybe JSValue@@ -174,6 +193,7 @@ timestamp = (mkrb "timestamp") :: JSValue -> JSValue timesince = (mkrb "timesince") :: JSValue -> String text = (mkrb "text") :: JSValue -> String+draft = (mkrb "draft") :: JSValue -> JSValue repository = (mkrb "repository") :: JSValue -> JSValue repositories = (mkrb "repositories") :: JSValue -> [JSValue] @@ -203,6 +223,7 @@ -- Attributes of ReviewRequestDraft object review_request = (mkrb "review_request") :: JSValue -> JSValue+review_requests = (mkrb "review_requests") :: JSValue -> [JSValue] testing_done = (mkrb "testing_done") :: JSValue -> String -- Attributes of Review
Tests/TestsWithServer.hs view
@@ -4,6 +4,8 @@ -- -- POC test with server. More to come... --+-- TODO: Add negative tests+-- ----------------------------------------------------------------------------- module Tests.TestsWithServer ( @@ -16,6 +18,7 @@ import qualified ReviewBoard.Response as R import Control.Monad.Trans import Control.Monad.Error+import System.Environment apiServerTests url user passwd = TestList [ TestLabel "Test repositoryList" $ runServerTest url user passwd repositoryListAction@@ -24,13 +27,16 @@ , TestLabel "Test userList" $ runServerTest url user passwd (userListAction user) , TestLabel "Test userList search" $ runServerTest url user passwd (userListSearchAction user) + -- Review request tests+ , TestLabel "Test create/delete rr" $ runServerTest url user passwd (createDeleteRR user)+ , TestLabel "Test set rr fields" $ runServerTest url user passwd (setFieldsRR user) ] -- Test repositoryList repositoryListAction :: RBAction () repositoryListAction = do setErrorHandler error - r <- repositoryList >>= return . jsValue+ r <- repositoryList >>= return . assertOkStatus assertTrue "Repository list empty" ((length . R.repositories $ r) > 0) return () @@ -41,7 +47,7 @@ userListAction :: String -> RBAction () userListAction user = do setErrorHandler error - r <- userList Nothing >>= return . jsValue+ r <- userList Nothing >>= return . assertOkStatus 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)@@ -51,14 +57,66 @@ userListSearchAction :: String -> RBAction () userListSearchAction user = do setErrorHandler error - vr <- userList (Just user) >>= return . jsValue+ vr <- userList (Just user) >>= return . assertOkStatus 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+ ir <- userList (Just "not_a_user_2345234") >>= return . assertOkStatus assertTrue "User list is not empty" (length (R.users ir) == 0) return () -- ---------------------------------------------------------------------------+-- Revire request tests++-- Plain create/delete review request+createDeleteRR :: String -> RBAction ()+createDeleteRR user = do+ setErrorHandler error + id <- createRR user+ deleteRR id+ return ()++-- Set fields to RR tests+setFieldsRR :: String -> RBAction ()+setFieldsRR user = do+ setErrorHandler error + id <- createRR user+ + -- Single fields+ let summary = "Test summary"+ sf <- reviewRequestSetField id SUMMARY summary >>= return . assertOkStatus+ assertTrue "Summary not set" (R.summary sf == summary)++ -- Multiple fields+ let description = "Test description"+ branch = "branches/test"+ sfs <- reviewRequestSet id [(DESCRIPTION, description), (BRANCH, branch)] >>= return . assertOkStatus+ assertTrue "Description not set" ((R.description . R.draft) sfs == description)+ assertTrue "Branch not set" ((R.branch . R.draft) sfs == branch)++ deleteRR id+ return ()++-- Create review request+createRR :: String -> RBAction Integer+createRR user = do+ rep <- liftIO $ getEnv "RB_REPOSITORY"+ rr <- reviewRequestNew rep Nothing >>= return . assertOkStatus+ -- Check some response values+ assertTrue "Review request not created" ((R.id . R.review_request) rr > 0)+ assertTrue "Status not pending" ((R.status . R.review_request) rr == "pending")+ assertTrue "Not the submitting user" ((R.username . R.submitter . R.review_request) rr == user)+ return $ (R.id . R.review_request) rr++-- Delete review request+deleteRR :: Integer -> RBAction ()+deleteRR id = do+ reviewRequestDelete id >>= return . assertOkStatus+ ls <- reviewRequestListAll Nothing >>= return . assertOkStatus+ let ids = map R.id $ (R.review_requests) ls+ assertTrue "Request not deleted" (null $ filter (==id) ids)+ return ()++-- --------------------------------------------------------------------------- -- Util function -- | General test action runner@@ -72,8 +130,8 @@ assertTrue s True = return () assertTrue s False = throwError $ "Assertion: " ++ s --- | Get JSValue from respnse+-- | Get JSValue from response, ensures request was successful ---jsValue (RBok r) = r-jsValue (RBerr e) = error e+assertOkStatus (RBok r) = r+assertOkStatus (RBerr e) = error e