diff --git a/README b/README --- a/README +++ b/README @@ -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 diff --git a/ReviewBoard.cabal b/ReviewBoard.cabal --- a/ReviewBoard.cabal +++ b/ReviewBoard.cabal @@ -1,5 +1,5 @@ Name: ReviewBoard -Version: 0.2 +Version: 0.2.1 Synopsis: Haskell bindings to ReviewBoard Description: Haskell bindings to 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 diff --git a/ReviewBoard/Api.hs b/ReviewBoard/Api.hs --- a/ReviewBoard/Api.hs +++ b/ReviewBoard/Api.hs @@ -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 diff --git a/ReviewBoard/Browser.hs b/ReviewBoard/Browser.hs --- a/ReviewBoard/Browser.hs +++ b/ReviewBoard/Browser.hs @@ -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 -- diff --git a/ReviewBoard/Core.hs b/ReviewBoard/Core.hs --- a/ReviewBoard/Core.hs +++ b/ReviewBoard/Core.hs @@ -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 -- diff --git a/ReviewBoard/Request.hs b/ReviewBoard/Request.hs new file mode 100644 --- /dev/null +++ b/ReviewBoard/Request.hs @@ -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) + diff --git a/ReviewBoard/Response.hs b/ReviewBoard/Response.hs --- a/ReviewBoard/Response.hs +++ b/ReviewBoard/Response.hs @@ -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 diff --git a/Tests/TestsWithServer.hs b/Tests/TestsWithServer.hs --- a/Tests/TestsWithServer.hs +++ b/Tests/TestsWithServer.hs @@ -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