ReviewBoard 0.2.1 → 0.2.2
raw patch · 9 files changed
+436/−121 lines, 9 filesdep +processnew-component:exe:rbpatch
Dependencies added: process
Files
- README +15/−7
- ReviewBoard.cabal +17/−2
- ReviewBoard/Api.hs +38/−42
- ReviewBoard/Core.hs +61/−22
- ReviewBoard/Request.hs +46/−19
- ReviewBoard/Response.hs +9/−2
- Tests/TestsWithServer.hs +15/−0
- example/mkrr.hs +34/−27
- example/rbpatch.hs +201/−0
README view
@@ -9,13 +9,15 @@ This package contains: - 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 as simple as:- svn diff | mkrr -r [reviewers]-For details see haddock documentation.+- Sample command line tools mkrr and rbpatch demonstrating the usage + of the bindings. + - Using 'mkrr' new review requests can be submitted + from the local repository copy as simple as:+ svn diff | mkrr -r [reviewers]+ - 'rbpatch' applies patches to local repository from a review request diff.+ For details see the tools haddock documentation. -Implemented and tested with ReviewBoard 1.0 Beta (4/25/2008).+Implemented and tested using ReviewBoard 1.0 Beta (4/25/2008). REQUIREMENTS@@ -37,12 +39,18 @@ CHANGES +0.2.2 - Added support for plain http server requests, httpGet and httpPost+ - Changed get and post request methods to apiGet and apiPost+ - Added rbpatch, an example command line tool that applies patches + from a review request diff to local repository+ - Added summary flag to mkrr and support for publishing + 0.2.1 - Change the method API calls are constructed (internal change) 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)+ - 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.1+Version: 0.2.2 Synopsis: Haskell bindings to ReviewBoard Description: Haskell bindings to ReviewBoard (<http://code.google.com/p/reviewboard/>). Author: Adam Smyczek@@ -9,7 +9,8 @@ License-file: LICENSE Cabal-Version: >= 1.2 Build-type: Simple-extra-source-files: README Tests/Tests.hs Tests/TestsWithServer.hs example/mkrr.hs+extra-source-files: README Tests/Tests.hs Tests/TestsWithServer.hs + example/mkrr.hs example/rbpatch.hs Library Exposed-modules: @@ -34,3 +35,17 @@ Build-Depends: base, mtl, random, directory, network, HTTP, json++Executable rbpatch+ main-is:+ example/rbpatch.hs+ other-modules:+ ReviewBoard.Api+ ReviewBoard.Core+ ReviewBoard.Browser+ ReviewBoard.Response+ ReviewBoard.Request+ Build-Depends:+ base, mtl, random, directory, process,+ network, HTTP, json+
ReviewBoard/Api.hs view
@@ -23,7 +23,7 @@ -- * Response errors resulting in for example invalid request parameters are -- handled using the 'rbErrHandler' (by default print to stdin). ----- For details see ReviewBoard project page <http://code.google.com/p/reviewboard/>+-- For API details see ReviewBoard project page <http://code.google.com/p/reviewboard/> -- ----------------------------------------------------------------------------- @@ -94,24 +94,24 @@ -- | Search for a user or list all users if user is Nothing -- userList :: Maybe String -> RBAction RBResponse-userList (Just u) = get (users Nothing) [textField "query" u]-userList Nothing = get (users Nothing) []+userList (Just u) = apiGet (users Nothing) [textField "query" u]+userList Nothing = apiGet (users Nothing) [] -- | Search for a group or list all group if Nothing -- groupList :: Maybe String -> RBAction RBResponse-groupList (Just g) = get (groups Nothing) [textField "query" g]-groupList Nothing = get (groups Nothing) []+groupList (Just g) = apiGet (groups Nothing) [textField "query" g]+groupList Nothing = apiGet (groups Nothing) [] -- | Star group for group name -- groupStar :: String -> RBAction RBResponse-groupStar g = get (groups (Just g) . star) []+groupStar g = apiGet (groups (Just g) . star) [] -- | Unstar group for group name -- groupUnstar :: String -> RBAction RBResponse-groupUnstar g = get (groups (Just g) . unstar) []+groupUnstar g = apiGet (groups (Just g) . unstar) [] -- --------------------------------------------------------------------------- -- Review request API calls@@ -121,69 +121,65 @@ -- review request that can be accessed using 'rrId' helper function. -- reviewRequestNew :: String -> Maybe String -> RBAction RBResponse-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]+reviewRequestNew p (Just u) = apiPost (reviewrequests Nothing . new) $ toFormVar [("repository_path", p), ("submit_as", u)]+reviewRequestNew p Nothing = apiPost (reviewrequests Nothing . new) [textField "repository_path" p] -- | Delete review request with request @id@. -- reviewRequestDelete :: Integer -> RBAction RBResponse-reviewRequestDelete id = post (reviewrequests (Just id) . delete) []+reviewRequestDelete id = apiPost (reviewrequests (Just id) . delete) [] -- | Get review request by @id@. -- reviewRequest :: Integer -> RBAction RBResponse-reviewRequest id = post (reviewrequests (Just id)) []+reviewRequest id = apiPost (reviewrequests (Just id)) [] -- | Get review request by repository @id@ and changenum @id@ -- reviewRequestByChangenum :: Integer -> Integer -> RBAction RBResponse-reviewRequestByChangenum rId cId = post (reviewrequests Nothing . repository rId . changenum cId) []+reviewRequestByChangenum rId cId = apiPost (reviewrequests Nothing . repository rId . changenum cId) [] -- | Discard review request draft for @id@. -- reviewRequestSaveDraft :: Integer -> RBAction RBResponse-reviewRequestSaveDraft id = post (reviewrequests (Just id) . draft . save) []+reviewRequestSaveDraft id = apiPost (reviewrequests (Just id) . draft . save) [] -- | Save review request draft whith @id@. -- reviewRequestDiscardDraft :: Integer -> RBAction RBResponse-reviewRequestDiscardDraft id = post (reviewrequests (Just id) . draft . discard) []+reviewRequestDiscardDraft id = apiPost (reviewrequests (Just id) . draft . discard) [] -- | Set fields to review request draft with @id@. -- reviewRequestSet :: Integer -> [(RRField, String)] -> RBAction RBResponse-reviewRequestSet id fs = post (reviewrequests (Just id) . draft . set Nothing) (map (\(f, v) -> textField (show f) v) fs)+reviewRequestSet id fs = apiPost (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 = post (reviewrequests (Just id) . draft . set (Just f)) $ [textField "value" v]+reviewRequestSetField id f v = apiPost (reviewrequests (Just id) . draft . set (Just f)) $ [textField "value" v] -- | Star review request for id -- reviewRequestStar :: Integer -> RBAction RBResponse-reviewRequestStar id = get (reviewrequests (Just id) . star) []+reviewRequestStar id = apiGet (reviewrequests (Just id) . star) [] -- | Star review request for id -- reviewRequestUnstar :: Integer -> RBAction RBResponse-reviewRequestUnstar id = get (reviewrequests (Just id) . unstar) []+reviewRequestUnstar id = apiGet (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 $ (reviewrequests (Just id) . diff . new) ""- let form = Form POST uri [fileUpload "path" fp "text/plain", textField "basedir" bd]- runRequest form return+reviewRequestDiffNew id bd fp = + apiPost (reviewrequests (Just id) . diff . new) [fileUpload "path" fp "text/plain", textField "basedir" bd] -- | Add a new screenshot with @file path@ to a review request with @id@ -- reviewRequestScreenshotNew :: Integer -> FilePath -> RBAction RBResponse-reviewRequestScreenshotNew id fp = do- uri <- mkURI $ (reviewrequests (Just id) . screenshot . new) ""- let form = Form POST uri [fileUpload "path" fp ((contentType . extension) fp)]- runRequest form return+reviewRequestScreenshotNew id fp =+ apiPost (reviewrequests (Just id) . screenshot . new) [fileUpload "path" fp ((contentType . extension) fp)] where extension = reverse . takeWhile (/= '.') . reverse contentType "png" = "image/png"@@ -195,29 +191,29 @@ -- | List all review requests with an optional status -- reviewRequestListAll :: Maybe String -> RBAction RBResponse-reviewRequestListAll (Just s) = get (reviewrequests Nothing . all) [textField (show STATUS) s]-reviewRequestListAll Nothing = get (reviewrequests Nothing . all) []+reviewRequestListAll (Just s) = apiGet (reviewrequests Nothing . all) [textField (show STATUS) s]+reviewRequestListAll Nothing = apiGet (reviewrequests Nothing . all) [] -- | List review request assigned to a group with an optional status -- reviewRequestListToGroup :: String -> Maybe String -> RBAction RBResponse-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)) []+reviewRequestListToGroup g (Just s) = apiGet (reviewrequests Nothing . to . group (Just g)) [textField (show STATUS) s]+reviewRequestListToGroup g Nothing = apiGet (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) = 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) []+reviewRequestListToUser u True (Just s) = apiGet (rr2u u . directly) [textField (show STATUS) s]+reviewRequestListToUser u True Nothing = apiGet (rr2u u . directly) []+reviewRequestListToUser u False (Just s) = apiGet (rr2u u) [textField (show STATUS) s]+reviewRequestListToUser u False Nothing = apiGet (rr2u u) [] rr2u u = reviewrequests Nothing . to . user (Just u) --- | Liste review request from a user with an optional status+-- | List review request from a user with an optional status -- reviewRequestListFromUser :: String -> Maybe String -> RBAction RBResponse-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)) []+reviewRequestListFromUser u (Just s) = apiGet (reviewrequests Nothing . from . user (Just u)) [textField (show STATUS) s]+reviewRequestListFromUser u Nothing = apiGet (reviewrequests Nothing . from . user (Just u)) [] -- --------------------------------------------------------------------------- -- Review API calls@@ -225,22 +221,22 @@ -- | List all reviews for review request @id@ -- reviewAll :: Integer -> RBAction RBResponse-reviewAll id = get (reviewrequests (Just id) . reviews Nothing) []+reviewAll id = apiGet (reviewrequests (Just id) . reviews Nothing) [] -- | Publish review request draft for id -- reviewPublishDraft :: Integer -> RBAction RBResponse-reviewPublishDraft id = post (reviewrequests (Just id) . reviews Nothing . draft . publish) [checkBox "shipit" False]+reviewPublishDraft id = apiPost (reviewrequests (Just id) . reviews Nothing . draft . publish) [checkBox "shipit" False] -- | Save review draft for review request @id@ -- reviewSaveDraft :: Integer -> RBAction RBResponse-reviewSaveDraft id = post (reviewrequests (Just id) . reviews Nothing . draft . save) []+reviewSaveDraft id = apiPost (reviewrequests (Just id) . reviews Nothing . draft . save) [] -- | Delete review draft for review request @id@ -- reviewDeleteDraft :: Integer -> RBAction RBResponse-reviewDeleteDraft id = post (reviewrequests (Just id) . reviews Nothing . draft . delete) []+reviewDeleteDraft id = apiPost (reviewrequests (Just id) . reviews Nothing . draft . delete) [] -- --------------------------------------------------------------------------- -- Other API calls@@ -248,7 +244,7 @@ -- | List repositories -- repositoryList :: RBAction RBResponse-repositoryList = get repositories []+repositoryList = apiGet repositories [] -- --------------------------------------------------------------------------- -- API uitl functions
ReviewBoard/Core.hs view
@@ -18,6 +18,7 @@ runRBAction, liftBA, runRequest,+ RBRequestType(..), -- * RB state RBState(..),@@ -29,7 +30,8 @@ responseToEither, -- * Utils- mkURI+ mkApiURI,+ mkHttpURI ) where @@ -113,6 +115,13 @@ -- --------------------------------------------------------------------------- -- Response types +-- | Type of the request, Web API or default HTTP+--+data RBRequestType+ = API+ | HTTP+ deriving Show+ -- | Response type return by every API function -- data RBResponse@@ -128,8 +137,8 @@ -- | Convenient response converter -- responseToEither :: RBResponse -> Either String JSValue-responseToEither (RBok r) = Right r-responseToEither (RBerr s) = Left s+responseToEither (RBok r) = Right r+responseToEither (RBerr s) = Left s -- --------------------------------------------------------------------------- -- Request and response handling@@ -137,10 +146,12 @@ -- | The request runner, generates request from provided 'Form' parameter, -- executes the requests and handles the response using the handler function. ---runRequest :: Form -> (RBResponse -> RBAction a) -> RBAction a-runRequest form f = do- s <- get+runRequest :: RBRequestType -> Form -> (RBResponse -> RBAction a) -> RBAction a +-- API request runner+runRequest rt form f = do+ s <- get+ -- Execute request (u, r) <- liftBA $ do attachSID $ rbSessionId s@@ -148,17 +159,20 @@ -- Check response status case rspCode r of- (2,0,0) -> do- case (decode . rspBody) r of- Ok rsp -> mkResponse rsp >>= handle f (rbErrHandler s)- Error e -> throwError e+ (2,0,0) -> respond rt r s c -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")" where -- Add session id to request, if exists attachSID (Just sid) = NB.setCookies [sid] attachSID _ = return () - -- Respond+ -- Respond based on request type+ respond API r s = case (decode . rspBody) r of+ Ok rsp -> mkApiResponse rsp >>= handle f (rbErrHandler s)+ Error e -> throwError e+ respond HTTP r s = mkHttpResponse r >>= handle f (rbErrHandler s)++ -- Run handler on response 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@@ -168,18 +182,18 @@ login :: String -> String -> RBAction RBResponse login user password = do s <- get- uri <- mkURI "accounts/login/"+ uri <- mkApiURI "accounts/login/" let form = Form POST uri [textField "username" user, textField "password" password]- runRequest form setSessionCookie+ runRequest API form setSessionCookie where setSessionCookie rsp = liftBA NB.getCookies >>= setCookie >> return rsp- setCookie [] = throwError "No session cookie found!"+ setCookie [] = throwError "No session cookie received!" setCookie (c:cs) = setSessionId c --- | Create RBResponse+-- | Create API request RBResponse ---mkResponse :: JSValue -> RBAction RBResponse-mkResponse v = do+mkApiResponse :: JSValue -> RBAction RBResponse+mkApiResponse v = do stat <- (return $ R.stat v) `catchError` (\_ -> return "") case stat of "ok" -> return $ RBok v@@ -188,6 +202,24 @@ return $ RBerr (err ++ " (" ++ encode v ++ ")") _ -> return $ RBerr "Invalid response, not status received" +-- | Create Http request RBResponse+-- The successful response returns a JSObject of the from:+-- { head : [+-- { name = "header name"+-- value = "header value" }+-- ],+-- body : "body content" }+--+mkHttpResponse :: Response -> RBAction RBResponse+mkHttpResponse r = return $ RBok . JSObject . toJSObject $+ [ ("head", mkHead (rspHeaders r))+ , ("body", mkBody (rspBody r)) ]+ where+ mkHead = JSArray . map (\(Header n v) -> JSObject . toJSObject $+ [ ("name", JSString . toJSString . show $ n)+ , ("value", JSString . toJSString $ v)])+ mkBody = JSString . toJSString+ -- --------------------------------------------------------------------------- -- Util functions @@ -196,14 +228,21 @@ liftBA :: NB.BrowserAction a -> RBAction a liftBA = RBAction . lift . lift --- | Create ReviewBoard specific URI for an API call URL.--- In case of invalid URL an exception is thrown.+-- | Create ReviewBoard specific URI for a Web API call URL. --+mkApiURI :: String -> RBAction URI+mkApiURI apiUrl = mkURI ("/api/json/" ++ apiUrl)++-- | Create ReviewBoard specific URI for direct HTTP request.+--+mkHttpURI = mkURI++-- | General URI maker+-- mkURI :: String -> RBAction URI-mkURI apiUrl = do+mkURI url = do s <- get- let url = rbUrl s ++ "/api/json/" ++ apiUrl- case parseURI url of+ case parseURI (rbUrl s ++ url) of Just u -> return u Nothing -> throwError $ "Invalid url: " ++ url
ReviewBoard/Request.hs view
@@ -7,17 +7,30 @@ -- 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 current implementation is maybe an overkill for a project of this size, +-- but it provides some constants for URL path elements and definitely simplifies +-- building API calls. ----- The call format is @method (path1 . path2 . path3) [form var]@+-- The request 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) []+-- > apiGet (reviewrequests (Just 5) . delete) [] ----- The current approach to handle request may change if I find a way+-- The supported methods are 'apiGet', 'apiPost', 'httpGet' and 'httpPost'.+-- Http methods may be used to perform direct requests to ReviewBoard web UI+-- that are not supported by the API. As an example see @rbpatch@ command+-- line tool in examples. Http methods, same as API methods return 'RBResponse'+-- object with a JSValue result of the form:+--+-- > { "head": [+-- > { "name" : <header name>,+-- > "value": <header value> }+-- > ]+-- > "body" : <content>+-- > }+--+-- The current approach to handle requests may change if I find a way -- to automatically generate API calls from ReviewBoard code. -- -----------------------------------------------------------------------------@@ -59,8 +72,10 @@ RRField(..), -- * Request methods- get,- post,+ apiGet,+ apiPost,+ httpGet,+ httpPost, -- * Util types and functions UrlPath,@@ -74,7 +89,9 @@ import ReviewBoard.Core import Network.HTTP hiding (user) import Control.Monad.Trans+import qualified Control.Monad.State as S import Data.Maybe+import Network.URI -- --------------------------------------------------------------------------- -- URL path elements@@ -156,23 +173,33 @@ -- --------------------------------------------------------------------------- -- Request functions --- | GET request method+-- | API GET request method ---get :: (UrlPath -> UrlPath) -> [FormVar] -> RBAction RBResponse-get u vs = rbRequest GET (u "") vs+apiGet :: (UrlPath -> UrlPath) -> [FormVar] -> RBAction RBResponse+apiGet u vs = mkApiURI (u "") >>= rbRequest API GET vs --- | GET request method+-- | API POST request method ---post :: (UrlPath -> UrlPath) -> [FormVar] -> RBAction RBResponse-post u vs = rbRequest POST (u "") vs+apiPost :: (UrlPath -> UrlPath) -> [FormVar] -> RBAction RBResponse+apiPost u vs = mkApiURI (u "") >>= rbRequest API POST vs +-- | Fall back to default http request for the case an action is not supported +-- by the ReviewBoard WebAPI (HTTP GET)+--+httpGet :: String -> [FormVar] -> RBAction RBResponse+httpGet u vs = mkHttpURI u >>= rbRequest HTTP GET vs++-- | Same as 'httpGet' for HTTP POST requests+--+httpPost :: String -> [FormVar] -> RBAction RBResponse+httpPost u vs = mkHttpURI u >>= rbRequest HTTP POST 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+rbRequest :: RBRequestType -> RequestMethod -> [FormVar] -> URI -> RBAction RBResponse+rbRequest rt rm vs u = do+ let form = Form rm u vs+ runRequest rt form return -- --------------------------------------------------------------------------- -- Util types and functions
ReviewBoard/Response.hs view
@@ -116,12 +116,13 @@ source_revision, dest_detail, revision,+ head, + body ) where -import Prelude hiding (id)+import Prelude hiding (id, head) import Text.JSON-import Data.List -- --------------------------------------------------------------------------- -- Some JSON helpers@@ -266,4 +267,10 @@ -- Attributes of DiffSet object revision = (mkrb "revision") :: JSValue -> Integer++-- Attributes of http response+++head = (mkrb "head") :: JSValue -> [JSValue]+body = (mkrb "body") :: JSValue -> String
Tests/TestsWithServer.hs view
@@ -30,6 +30,9 @@ -- 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 http method+ , TestLabel "Test http requests" $ runServerTest url user passwd (testHttpRequests user) ] -- Test repositoryList@@ -114,6 +117,18 @@ ls <- reviewRequestListAll Nothing >>= return . assertOkStatus let ids = map R.id $ (R.review_requests) ls assertTrue "Request not deleted" (null $ filter (==id) ids)+ return ()+++-- ---------------------------------------------------------------------------+-- Http method tests++testHttpRequests :: String -> RBAction ()+testHttpRequests user = do+ rsp <- httpGet "" []+ case rsp of+ RBok r -> liftIO . print . R.body $ r+ RBerr e -> throwError e return () -- ---------------------------------------------------------------------------
example/mkrr.hs view
@@ -8,13 +8,12 @@ -- Portability : portable -- -- @mkrr@ is a sample application demonstrating the usage of ReviewBoard bindings.--- To submit a new review request just execute:+-- Using @mkrr@ new review requests can be submitted as easy as executing: -- -- > svn diff | mkrr -r [reviewers] -- -- from the local repository copy. Most of the required/optional parameters--- may be pre-defined in @~/.mkrrrc@ config file. The configuration options--- are:+-- may be pre-defined in @~/.mkrrrc@ config file. The supported parameters are: -- -- * url - ReviewBoard server URL --@@ -27,7 +26,7 @@ -- * basedir - Diff base dir, e.g. @/trunk@ in case @svn diff@ was executed -- in @/trunk@ directory ----- * publish - Publish immediately (not supported by ReivewBoard yet)+-- * publish - Publish immediately -- -- Run @mkrr --help@ and see ReviewBoard documentation at -- <http://code.google.com/p/reviewboard/wiki/ReviewBoardAPI>.@@ -43,12 +42,11 @@ import Control.Exception(finally) import Data.List import Data.Maybe-import Control.Monad.Trans-import Control.Monad import Data.Char import ReviewBoard.Api-import qualified ReviewBoard.Response as R import Control.Monad.Error+import qualified ReviewBoard.Response as R+import System.Exit -- | Main --@@ -63,6 +61,7 @@ (fromJust . optBasedir $ opts) (fromJust . optReviewers $ opts) (optDescription opts)+ (optSummary opts) (optScreenshot opts) (optPublish opts) @@ -91,8 +90,8 @@ -- | New review request action ---mkrrAction :: String -> String -> String -> Maybe String -> Maybe String -> Bool -> String -> RBAction ()-mkrrAction rep basedir revs dsc ss pub tfn = do+mkrrAction :: String -> String -> String -> Maybe String -> Maybe String -> Maybe String -> Bool -> String -> RBAction ()+mkrrAction rep basedir revs dsc sum ss pub tfn = do -- Create new review request and get the id rsp <- reviewRequestNew rep Nothing case rsp of@@ -102,18 +101,20 @@ -- Set some fields reviewRequestSetField id TARGET_PEOPLE revs setOptional id DESCRIPTION dsc + setOptional id SUMMARY sum -- Upload the diff reviewRequestDiffNew id basedir tfn -- Upload screenshot if provided- when (isJust ss) ( do- reviewRequestScreenshotNew id $ fromJust ss- return ()- )+ when (isJust ss) (reviewRequestScreenshotNew id (fromJust ss) >> return ()) -- And store the review request draft reviewRequestSaveDraft id++ -- Publish if enabled+ when (pub) (httpGet ("/r/" ++ show id ++ "/publish/") [] >> return ())+ liftIO $ print "Done." RBerr e -> throwError e@@ -131,11 +132,13 @@ parseOpts argv = do dos <- defaultOpts case getOpt Permute options argv of- (o,n,[] ) -> return (foldl (flip id) dos o, n)- (_,_,errs) -> ioError (userError (concat errs ++ usageInfo header options))- where- header = "Usage: mkrr [OPTION...]"+ (o, n, []) -> foldM (flip id) dos o >>= \os -> return (os, n)+ (_, _, es) -> ioError (userError (concat es ++ usageInfo header options)) +-- | Usage info header+--+header = "Usage: mkrr [OPTION...]"+ -- | Option set -- data Options = Options@@ -146,23 +149,26 @@ , optBasedir :: Maybe String , optReviewers :: Maybe String , optDescription :: Maybe String+ , optSummary :: Maybe String , optScreenshot :: Maybe String , optPublish :: Bool } deriving Show -- | Option descriptor list ---options :: [OptDescr (Options -> Options)]+options :: [OptDescr (Options -> IO Options)] options =- [ Option ['u'] [] (ReqArg (\ u opts -> opts { optUrl = Just u }) "URL") "URL to ReviewBoard server"- , Option ['U'] [] (ReqArg (\ u opts -> opts { optUser = Just u }) "USER") "USER name"- , Option ['P'] [] (ReqArg (\ p opts -> opts { optPassword = Just p }) "PASSWORD") "User PASSWORD"- , Option ['R'] [] (ReqArg (\ r opts -> opts { optRepository = Just r }) "REROSITORY") "Repository path"- , 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"+ [ Option ['u'] [] (ReqArg (\ u opts -> return opts { optUrl = Just u }) "URL") "URL to ReviewBoard server"+ , Option ['U'] [] (ReqArg (\ u opts -> return opts { optUser = Just u }) "USER") "USER name"+ , Option ['P'] [] (ReqArg (\ p opts -> return opts { optPassword = Just p }) "PASSWORD") "User PASSWORD"+ , Option ['R'] [] (ReqArg (\ r opts -> return opts { optRepository = Just r }) "REROSITORY") "Repository path"+ , Option ['b'] [] (ReqArg (\ r opts -> return opts { optBasedir = Just r }) "BASEDIR") "Diff base dir"+ , Option ['r'] [] (ReqArg (\ r opts -> return opts { optReviewers = Just r }) "REVIEWERS") "Comma separated REVIEWERS list"+ , Option ['d'] [] (ReqArg (\ r opts -> return opts { optDescription = Just r }) "DESCRIPTION") "Optional request description"+ , Option ['s'] [] (ReqArg (\ s opts -> return opts { optSummary = Just s }) "SUMMARY") "Optional request summary"+ , Option ['S'] [] (ReqArg (\ f opts -> return opts { optScreenshot = Just f }) "SCREENSHOT") "attach SCREENSHOT"+ , Option ['l'] [] (NoArg (\ opts -> return opts { optPublish = True })) "Publish review"+ , Option ['h'] ["help"] (NoArg (\ opts -> putStr (usageInfo header options) >> exitWith ExitSuccess)) "Print this help" ] -- | Load default options from configuration file@@ -194,6 +200,7 @@ , optBasedir = Nothing , optReviewers = Nothing , optDescription = Nothing+ , optSummary = Nothing , optScreenshot = Nothing , optPublish = False }
+ example/rbpatch.hs view
@@ -0,0 +1,201 @@+#!/usr/bin/env runhaskell+-----------------------------------------------------------------------------+-- |+-- Module : rbpatch.hs+--+-- Maintainer : adam.smyczek@gmail.com+-- Stability : experimental+-- Portability : portable+--+-- A command line tool to patch local repository from a review request diff+--+-- Sample usage:+-- > rbpatch -r <review request id>+--+-- Same as for @mkrr@ most of the required/optional command line parameters+-- may be pre-defined in @~/.rbpatchrc@ config file. The supported parameters+-- are:+--+-- * url - ReviewBoard server URL+--+-- * user - User name+-- +-- * password - Password+--+-- * localbasedir - Path to the repository root+--+-- Run @rbpatch --help@ for details.+--+-----------------------------------------------------------------------------+module Main (main) where++import System.Environment+import System.Console.GetOpt+import System.Directory+import Data.List+import Data.Maybe+import Data.Char+import ReviewBoard.Api+import qualified ReviewBoard.Response as R+import Control.Monad.Error+import System.Process+import System.IO+import System.Exit++-- | Main+--+main :: IO ()+main = do+ -- Parse and validate command line options+ (opts, _) <- getArgs >>= parseOpts+ validateRequired opts++ -- Create the patch action+ let action = patchAction (fromJust . optRRId $ opts) + (optBasedir opts)+ (optPrintOnly opts) ++ -- ... and run it+ execRBAction (fromJust . optUrl $ opts) + (fromJust . optUser $ opts) + (fromJust . optPassword $ opts) + action++-- | The patch action+--+patchAction :: String -> Maybe String -> Bool -> RBAction ()+patchAction id basedir po = do+ rsp <- httpGet ("/r/" ++ id ++ "/diff/raw/") []+ case rsp of+ RBok r -> liftIO . (patch po basedir) . R.body $ r+ RBerr e -> throwError e+ where+ patch True _ = putStr+ patch False Nothing = doPatch ["-p0"]+ patch False (Just bd) = doPatch ["-d " ++ bd, "-p0"]++-- | Execute patch command+--+doPatch :: [String] -> String -> IO ()+doPatch args p = do+ pf <- findPatch+ (inp, out, err, pid) <- runInteractiveProcess pf args Nothing Nothing+ hPutStr inp p+ hClose inp+ result <- hGetContents out+ errors <- hGetContents err+ when (result == result) $ return ()+ when (errors == errors) $ return ()+ hClose out+ hClose err+ waitForProcess pid+ when (not . null $ result) $ putStr (result ++ "\nDone.\n")+ when (not . null $ errors) $ putStr errors+ return () + +-- ---------------------------------------------------------------------------+-- Option handling++-- | Parse options+--+parseOpts :: [String] -> IO (Options, [String])+parseOpts argv = do+ dos <- defaultOpts+ case getOpt Permute options argv of+ (o, n, []) -> foldM (flip id) dos o >>= \os -> return (os, n)+ (_, _, es) -> ioError (userError (concat es ++ usageInfo header options))++-- | rbpatch help header+--+header = "Usage: rbpatch [OPTION...]"++-- | Option set+--+data Options = Options+ { optUrl :: Maybe String+ , optUser :: Maybe String+ , optPassword :: Maybe String+ , optRRId :: Maybe String+ , optBasedir :: Maybe String+ , optPrintOnly :: Bool+ } deriving Show++-- | Option descriptor list+--+options :: [OptDescr (Options -> IO Options)]+options =+ [ Option ['u'] [] (ReqArg (\ u opts -> return opts { optUrl = Just u }) "URL") "URL to ReviewBoard server"+ , Option ['U'] [] (ReqArg (\ u opts -> return opts { optUser = Just u }) "USER") "USER name"+ , Option ['P'] [] (ReqArg (\ p opts -> return opts { optPassword = Just p }) "PASSWORD") "User PASSWORD"+ , Option ['b'] [] (ReqArg (\ b opts -> return opts { optBasedir = Just b }) "BASEDIR") "Local base dir"+ , Option ['r'] [] (ReqArg (\ r opts -> return opts { optRRId = Just r }) "REVIEW_REQUEST_ID") "Review request id"+ , Option ['p'] [] (NoArg (\ opts -> return opts { optPrintOnly = True })) "Print only, do not apply the patch"+ , Option ['h'] ["help"] (NoArg (\ opts -> putStr (usageInfo header options) >> exitWith ExitSuccess)) "Print this help"+ ]++-- | Load default options from configuration file+--+defaultOpts :: IO Options+defaultOpts = do+ hd <- getHomeDirectory+ cf <- readFile $ hd ++ "/.rbpatchrc"+ return $ foldl parseOpt initOpts $ lines cf+ where+ parseOpt os l | isPrefixOf "url" l = os { optUrl = Just $ parseValue l }+ | isPrefixOf "user" l = os { optUser = Just $ parseValue l }+ | isPrefixOf "password" l = os { optPassword = Just $ parseValue l }+ | isPrefixOf "localbasedir" l = os { optBasedir = Just $ parseValue l }+ | otherwise = os+ parseValue :: String -> String+ parseValue = takeWhile (not . isSeparator) . dropWhile isSeparator . drop 1 . dropWhile (/= '=')++-- | Initial option set+--+initOpts :: Options+initOpts = Options+ { optUrl = Nothing+ , optUser = Nothing+ , optPassword = Nothing+ , optRRId = Nothing+ , optBasedir = Nothing+ , optPrintOnly = False }++-- | Validate required arguments+--+validateRequired :: Options -> IO ()+validateRequired opts = do+ -- TODO: this is imperative, improve this+ when (isNothing . optUrl $ opts) $ error $ "URL required!" ++ help+ when (isNothing . optUser $ opts) $ error $ "USER required!" ++ help+ when (isNothing . optPassword $ opts) $ error $ "PASSWORD required!" ++ help+ when (isNothing . optRRId $ opts) $ error $ "REVIEW_REQUEST_ID required!" ++ help+ where+ help = " Try rbpatch --help"++-- ---------------------------------------------------------------------------+-- Patch command utils++-- | Common patch locations+--+patchCmds = + [ "/usr/bin/patch"+ , "/usr/local/bin/patch"+ , "/opt/bin/sendmail"+ , "/opt/local/bin/sendmail"+ ] :: [String]+++-- | Find patch command and throw error if patch +-- is not installed in one of patchCmds locations+-- +findPatch :: IO String+findPatch = do+ pf <- foldM fExist "" patchCmds+ if null pf then error "No patch file found!"+ else return pf+ where+ fExist r f | (not . null) r = return r+ | otherwise = do+ e <- doesFileExist f + return $ if e then f else ""+