diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Adam Smyczek 2008. +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are +met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Neil Mitchell nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README b/README new file mode 100644 --- /dev/null +++ b/README @@ -0,0 +1,36 @@ +DESCRIPTION + +Haskell bindings to ReviewBoard (http://code.google.com/p/reviewboard/) + +From the 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..." + +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 in the form: + svn diff | mkrr -r [reviewers] +For details see haddock documentation. + +Implemented and tested for ReviewBoard 1.0 Beta (4/25/2008). + + +REQUIREMENTS + +- GHC (http://www.haskell.org/ghc/) +- HTTP package (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/HTTP-3001.0.4) +- JSON package (http://hackage.haskell.org/cgi-bin/hackage-scripts/package/json-0.3.3) + + +INSTALLATION + +1. Configure: + runhaskell Setup.lhs configure +2. Compile: + runhaskell Setup.lhs build +3. Install: + runhaskell Setup.lhs install (as root) + diff --git a/ReviewBoard.cabal b/ReviewBoard.cabal new file mode 100644 --- /dev/null +++ b/ReviewBoard.cabal @@ -0,0 +1,32 @@ +Name: ReviewBoard +Version: 0.1 +Synopsis: Haskell bindings to ReviewBoard +Description: Haskell bindings to ReviewBoard (). +Author: Adam Smyczek +Maintainer: +Category: Development +License: BSD3 +License-file: LICENSE +Cabal-Version: >= 1.2 +Build-type: Simple +extra-source-files: README Tests/Tests.hs example/mkrr.hs + +Library + Exposed-modules: + ReviewBoard.Api + ReviewBoard.Core + ReviewBoard.Browser + Build-Depends: + base, mtl, random, + network, HTTP, json + +Executable mkrr + main-is: + example/mkrr.hs + other-modules: + ReviewBoard.Api + ReviewBoard.Core + ReviewBoard.Browser + Build-Depends: + base, mtl, random, directory, + network, HTTP, json diff --git a/ReviewBoard/Api.hs b/ReviewBoard/Api.hs new file mode 100644 --- /dev/null +++ b/ReviewBoard/Api.hs @@ -0,0 +1,228 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Api.hs +-- +-- Maintainer : adam.smyczek@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- ReviewBoard API +-- +-- This package 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 +-- two ways: +-- +-- * Network errors, for example connection errors throw an exception. +-- +-- * Response errors resulting in for example invalid request parameters are +-- handled using the 'rbErrHandler' (by default print to stdin). +-- +-- The current version provides mainly API calls to handle review requests, +-- but this can be easily extended using generalized 'rbPostRequest', 'rbGetRequest' +-- or directly the main 'runRequest' functions. +-- +-- Refer to project page for details: +-- +-- +-- TODOs: +-- +-- * Add more API calls, of cause! +-- +-- * Add abstraction for response data, for example 'reviewRequestNew' should +-- return the @id@ of the new created request. Currently this have to be +-- parsed from the JSon response e.g. using 'rrId' function. +-- +----------------------------------------------------------------------------- + +module ReviewBoard.Api ( + + -- Modules + module ReviewBoard.Core, + module ReviewBoard.Browser, + + -- API calls + reviewRequest, + reviewRequestNew, + reviewRequestDelete, + reviewRequestSet, + reviewRequestSetField, + reviewRequestSaveDraft, +-- reviewRequestPublishDraft, not supported yet + reviewRequestDiffNew, + reviewRequestList, + + -- Types + RRField(..), + + -- Util functions + execRBAction, + rbPostRequest, + rbGetRequest, + rrId + + -- * Example + -- $example1 + + ) where + +import ReviewBoard.Core +import ReviewBoard.Browser +import Network.URI +import Network.HTTP +import qualified Network.Browser as NB +import Data.Maybe +import Control.Monad.Error +import Control.Monad.State + +-- | 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 + +-- --------------------------------------------------------------------------- +-- Review request API calls + +-- | Create new review request using the provided repository path and an optional +-- submit_as user. The returned response contains the @id@ of the new created +-- 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)] + +-- | Delete review request with request @id@. +-- +reviewRequestDelete :: Integer -> RBAction RBResponse +reviewRequestDelete id = rbPostRequest ("reviewrequests/" ++ show id ++ "/delete") [] + +-- | Get review request with @id@. +-- +reviewRequest :: Integer -> RBAction RBResponse +reviewRequest id = rbPostRequest ("reviewrequests/" ++ show id ) [] + +-- | Save review request draft whith @id@. +-- +reviewRequestSaveDraft :: Integer -> RBAction RBResponse +reviewRequestSaveDraft id = rbPostRequest ("reviewrequests/" ++ show id ++ "/draft/save") [] + +-- Publish review request draft for id +-- +-- reviewRequestPublishDraft :: Integer -> RBAction RBResponse +-- reviewRequestPublishDraft id = rbRequest ("reviewrequests/" ++ show id ++ "/reviews/draft/publish") [("shipit", "False")] + +-- | 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) + +-- | 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)] + +-- | Add a new diff to a review request with @id@, file path and the basedir parameter. +-- +reviewRequestDiffNew :: Integer -> String -> String -> 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. +-- +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)] + +-- --------------------------------------------------------------------------- +-- 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 + +-- --------------------------------------------------------------------------- +-- API uitl functions + +-- | 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 + +-- | 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 +and uploads a diff file: + +> 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." + +To run this action, execute: + +> execRBAction "url" "user" "password" newRRAction + +-} + diff --git a/ReviewBoard/Browser.hs b/ReviewBoard/Browser.hs new file mode 100644 --- /dev/null +++ b/ReviewBoard/Browser.hs @@ -0,0 +1,158 @@ +----------------------------------------------------------------------------- +-- | +-- Module : Browser.hs +-- +-- Maintainer : adam.smyczek@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- ReviewBoard.Browser extends Network.Browser module (HTTP package) +-- 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. +-- +----------------------------------------------------------------------------- + +module ReviewBoard.Browser ( + + Form(..), + FormVar, + formToRequest, + + textField, + checkBox, + fileUpload + + ) where + +import qualified Network.Browser as NB +import Network.HTTP +import Network.URI +import System.Random + +-- | Form to request for typed form variables, +-- same as 'formToRequest' in Network.Browser module. +-- +formToRequest :: Form -> NB.BrowserAction Request +formToRequest (Form m u vs) + -- Use multipart/form-data content type when + -- the form contains at least one FileUpload variable + | containFileUpload vs = do + bnd <- NB.ioAction mkBoundary + body <- NB.ioAction $ encMultipartVars bnd vs + return Request + { rqMethod = POST + , rqHeaders = + [ Header HdrContentType $ "multipart/form-data; boundary=" ++ bnd, + Header HdrContentLength (show . length $ body) ] + , rqBody = body + , rqURI = u } + + -- Otherwise fall back to Network.Browser formToRequest + | otherwise = return $ NB.formToRequest (NB.Form m u $ map toNBFormVar vs) + + where + -- Check if contains contain file upload + containFileUpload = or. map (isFU . fvValue) + isFU (FileUpload _ _) = True + isFU _ = False + + -- Create random boundary string + mkBoundary = do + rand <- randomRIO (100000000000 :: Integer, 999999999999) + return $ "--------------------" ++ show rand + +-- | Encode form variables and append finish boundary. +-- +encMultipartVars :: String -> [FormVar] -> IO String +encMultipartVars bnd vs = do + vars <- mapM (encVar bnd) vs + return $ concat [concat vars, "--", bnd, "--", crlf] + +-- | Encode variable separated to header and content. +-- +encVar :: String -> FormVar -> IO String +encVar bnd fv = do + vs <- encContent . fvValue $ fv + return $ concat [ "--", bnd, crlf + , concatMap show $ encHeader (fvName fv) (fvValue fv), crlf + , vs, crlf ] + +-- | Encode headers +encHeader :: String -> FormVarValue -> [Header] +encHeader n (FileUpload f t) = + [ Header hdrContentDisposition ("form-data; name=\"" ++ n ++ "\"; filename=\"" ++ f ++ "\"") + , Header HdrContentType t ] +encHeader n _ = [Header hdrContentDisposition ("form-data; name=\"" ++ n ++ "\"")] + +-- | Encode content +-- +encContent :: FormVarValue -> IO String +encContent (TextField v) = return v +encContent (CheckBox True) = return "true" +encContent (CheckBox False) = return "false" +encContent (FileUpload f t) = readFile f >>= return + +hdrContentDisposition :: HeaderName +hdrContentDisposition = HdrCustom "Content-disposition" + +crlf :: String +crlf = "\r\n" + +-- --------------------------------------------------------------------------- +-- Types + +-- | Typed form variable +-- +data FormVar = FormVar + { fvName :: String -- ^ variable name + , fvValue :: FormVarValue -- ^ and content + } deriving Show + +-- | Form content value types +-- +data FormVarValue + = TextField String + | FileUpload FilePath String + | CheckBox Bool + deriving Show + +-- | Typed form +-- +data Form = Form RequestMethod URI [FormVar] + +-- --------------------------------------------------------------------------- +-- Util functions + +-- | Create text field variable +-- +textField :: String -> String -> FormVar +textField n v = FormVar n $ TextField v + +-- | Create checkbox variable +-- +checkBox :: String -> Bool -> FormVar +checkBox n v = FormVar n $ CheckBox v + +-- | Create file upload variable +-- +fileUpload :: String -> FilePath -> String -> FormVar +fileUpload n p t = FormVar n $ FileUpload p t + +-- | Convert FormVar to Network.Browser FormVar +-- +toNBFormVar :: FormVar -> (String, String) +toNBFormVar fv = (fvName fv, toNBValue . fvValue $ fv) + +-- | Convert Form value to Network.Browser strings +-- +toNBValue :: FormVarValue -> String +toNBValue (TextField v) = v +toNBValue (FileUpload f t) = f +toNBValue (CheckBox True) = "true" +toNBValue (CheckBox False) = "false" + diff --git a/ReviewBoard/Core.hs b/ReviewBoard/Core.hs new file mode 100644 --- /dev/null +++ b/ReviewBoard/Core.hs @@ -0,0 +1,260 @@ +{-# OPTIONS -fglasgow-exts #-} +----------------------------------------------------------------------------- +-- | +-- Module : Core.hs +-- +-- Maintainer : adam.smyczek@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- Base types and functions. +-- +----------------------------------------------------------------------------- + +module ReviewBoard.Core ( + + RBAction, + RBState(..), + runRBAction, + + setErrorHandler, + + RBStatus(..), + RBResponse(..), + + runRequest, + + liftBA, + mkURI, + setDebugHTTP, + + jsValue, + jsInt, + jsString + + ) where + +import Text.JSON +import Network.URI +import Network.HTTP +import qualified Network.Browser as NB +import ReviewBoard.Browser +import Data.Maybe +import Control.Monad.Error +import Control.Monad.State +import Data.Ratio + +-- --------------------------------------------------------------------------- +-- Review board action monad + +-- | The action monad, a state with error handler. +-- +-- 'RBAction' represents one ReviewBoard session that handles multiple API calls. +-- The RBAction runner 'runRBAction' performs a login into the ReviewBoard server +-- and initializes the session. All session related parameters are stored in +-- the 'RBState' of the action. +-- +-- Errors are handled in two ways: +-- +-- * Network related error are immediately thrown using ErrorT throwError. +-- +-- * ReviewRequest response errors are handled using the error handler defined +-- in 'RBState' (default print). +-- +newtype RBAction a = RBAction + { exec :: ErrorT String (StateT RBState NB.BrowserAction) a } + deriving (Functor, Monad, MonadState RBState) + +instance MonadIO RBAction where + liftIO = RBAction . lift . lift . NB.ioAction + +instance MonadError String RBAction where + throwError = RBAction . throwError + l `catchError` h = RBAction $ exec l `catchError` (exec . h) + +-- | Run for 'RBAction', performs a login using provided URL, user +-- and password parameters and executes the action. When login fails +-- 'runRBAction' returns immediately with an error. +-- +runRBAction :: String -> String -> String -> RBAction a -> IO (Either String a, RBState) +runRBAction url u p a = NB.browse . runStateT (runErrorT (exec init)) $ initState url u + where init = setDebugHTTP False >> login u p >> a + +-- --------------------------------------------------------------------------- +-- State type and handler functions + +-- | RB action state containing session related information. +-- +data RBState = RBState + { rbUrl :: String -- ^ ReviewBoard server URL + , rbUser :: String -- ^ Logged in user + , rbSessionId :: Maybe NB.Cookie -- ^ Session id cookie retrieve from a successful login + , rbErrHandler :: String -> IO () -- ^ Error handler, for example error or print + } + +-- | Default state initialization including server URL and user. +-- +initState :: String -> String -> RBState +initState url user = RBState + { rbUrl = url + , rbUser = user + , rbSessionId = Nothing + , rbErrHandler = print } + +-- | Session id setter +-- +setSessionId :: NB.Cookie -> RBAction () +setSessionId sid = get >>= \s -> put s { rbSessionId = Just sid } + +-- | Set error handler used for ReviewBoard error responses. +-- +setErrorHandler :: (String -> IO ()) -> RBAction () +setErrorHandler eh = get >>= \s -> put s { rbErrHandler = eh } + +-- --------------------------------------------------------------------------- +-- Response types + +-- | Response status type parsed from ReviewBoard Json response stat object, +-- for example { \"stat\" : \"ok/fail\" } +-- +data RBStatus + = RBok -- ^ Successful response + | RBerr String -- ^ Response error including error message + deriving Eq + +instance Show RBStatus where + show RBok = "Successful" + show (RBerr e) = "Error: " ++ e + +-- | Response type returned by all API calls +-- +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) + +-- --------------------------------------------------------------------------- +-- Request and response handling + +-- | 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 + + -- Execute request + (u, r) <- liftBA $ do + attachSID $ rbSessionId s + 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 + Error e -> throwError e + c -> throwError $ rspReason r ++ " (Code: " ++ show c ++ ")" + where + -- Add session id to request, if exists + attachSID (Just sid) = NB.setCookies [sid] + attachSID _ = return () + + -- Respond + handle :: (RBResponse -> RBAction a) -> RBStatus -> JSValue -> RBAction a + handle f st rsp = f $ RBResponse st rsp + +-- | Login action updates session id cookie from successful login response +-- +login :: String -> String -> RBAction RBResponse +login user password = do + s <- get + uri <- mkURI "accounts/login" + let form = Form POST uri [textField "username" user, textField "password" password] + runRequest form setSessionCookie + where + setSessionCookie rsp = liftBA NB.getCookies >>= setCookie >> return rsp + setCookie [] = throwError "No session cookie found!" + setCookie (c:cs) = setSessionId c + +-- | Create 'RBStatus' from JSon response +-- +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." + +-- --------------------------------------------------------------------------- +-- Util functions + +-- | Convenient lift for BrowserActions +-- +liftBA :: NB.BrowserAction a -> RBAction a +liftBA = RBAction . lift . lift + +-- | Create ReviewBoard specific URI for API call URL. +-- In case of invalid URL an exception is thrown. +-- +mkURI :: String -> RBAction URI +mkURI apiUrl = do + s <- get + case parseURI (rbUrl s ++ "/api/json/" ++ apiUrl ++ "/") of + Just u -> return u + Nothing -> throwError $ "Invalid url: " ++ rbUrl s + +-- | Enable/disable debug output for Browser module +-- +setDebugHTTP :: Bool -> RBAction () +setDebugHTTP True = liftBA $ NB.setOutHandler putStrLn +setDebugHTTP False = liftBA $ NB.setOutHandler (\_ -> return()) + +-- --------------------------------------------------------------------------- +-- JSon utils + +-- | Return value for string path e.g. +-- [] (Int 5) -> Just $ Int 5 +-- ["stat"] (Obj "stat" (Str "ok")) -> Just $ Str "ok" +-- ["stat"] (Obj "nostat" (Str "ok")) -> Nothing +-- +jsValue :: [String] -> JSValue -> Maybe JSValue +jsValue [] v = Just v +jsValue (x:xs) (JSObject m) = maybe Nothing (jsValue xs) $ findValue x (fromJSObject m) +jsValue (x:xs) v = Nothing + +-- | Find value in object map +-- +findValue :: String -> [(String, JSValue)] -> Maybe JSValue +findValue s [] = Nothing +findValue s ((n, v):xs) | s == n = Just v + | otherwise = findValue s xs + +-- | Return Integer value for path or Nothing +-- if path does not exists or is not a JSRational +-- +jsInt :: [String] -> JSValue -> Maybe Integer +jsInt p v = case jsValue p v of + Just (JSRational i) -> Just (numerator i) + _ -> Nothing + +-- | String value for path, same as jsInt +-- +jsString :: [String] -> JSValue -> Maybe String +jsString p v = case jsValue p v of + Just (JSString s) -> Just $ fromJSString s + _ -> Nothing + diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,3 @@ +#!/usr/bin/env runhaskell +> import Distribution.Simple +> main = defaultMain diff --git a/Tests/Tests.hs b/Tests/Tests.hs new file mode 100644 --- /dev/null +++ b/Tests/Tests.hs @@ -0,0 +1,83 @@ +----------------------------------------------------------------------------- +-- | +-- Main test module +-- +-- Execute 'runhaskell Tests/Tests.hs' +-- from reviewboard dir +-- +----------------------------------------------------------------------------- + +module Main where + +import Test.HUnit +import Text.JSON +import Data.Ratio + +import ReviewBoard.Api +import ReviewBoard.Core + +-- | Review board test test suite +-- +tests = TestList + [ TestLabel "Test rrFieldMap" rrFieldMapTest + , TestLabel "Test jsValue" jsValueTest + , TestLabel "Test jsInt" jsIntTest + , TestLabel "Test jsString" jsStringTest + ] + +-- | Main test runner +-- +main = runTestTT tests + +-- --------------------------------------------------------------------------- +-- API tests + +-- Test rrFiledMap coverage for RRField +-- TODO: do we really need a print test? +rrFieldMapTest = TestCase ( do + mapM (print . show) [(minBound::RRField)..(maxBound::RRField)] + return () + ) + +-- --------------------------------------------------------------------------- +-- Tests JSon utils + +-- Helper function takes json value from result +toJson :: Result (JSObject JSValue) -> JSValue +toJson (Ok v) = JSObject v +toJson (Error s) = error s + +-- Json test object +testObject :: JSValue +testObject = toJson $ decode "{ \"stat\" : \"fail\", \"err\" : { \"msg\" : \"test message\", \"code\" : 100 } }" + +statusErr :: JSValue +statusErr = testObject + +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 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) + ) + +-- 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) + ) + diff --git a/example/mkrr.hs b/example/mkrr.hs new file mode 100644 --- /dev/null +++ b/example/mkrr.hs @@ -0,0 +1,197 @@ +#!/usr/bin/env runhaskell +----------------------------------------------------------------------------- +-- | +-- Module : mkrr.hs +-- +-- Maintainer : adam.smyczek@gmail.com +-- Stability : experimental +-- Portability : portable +-- +-- @mkrr@ is a sample application demonstrating the usage of ReviewBoard bindings. +-- To submit a new review request just execute: +-- +-- > 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: +-- +-- * url - ReviewBoard server URL +-- +-- * user - User name +-- +-- * password - Password +-- +-- * repository - Repository path, e.g. +-- +-- * basedir - Diff base dir, e.g. @/trunk@ in case @svn diff@ was executed +-- in @/trunk@ directory +-- +-- * publish - Publish immediately (not supported by ReivewBoard yet) +-- +-- Run @mkrr --help@ or refer to ReviewBoard documentation for details +-- . +-- +----------------------------------------------------------------------------- + +module Main (main) where + +import System.Environment +import System.Console.GetOpt +import System.IO +import System.Directory +import Control.Exception(finally) +import Data.List +import Data.Maybe +import Control.Monad.Trans +import Control.Monad +import Data.Char +import ReviewBoard.Api + +-- | Main +-- +main :: IO () +main = do + -- Parse and validate command line options + (opts, _) <- getArgs >>= parseOpts + validateRequired opts + + -- Create the review request action ... + let action = mkrrAction (fromJust . optRepository $ opts) + (fromJust . optBasedir $ opts) + (fromJust . optReviewers $ opts) + (optDescription opts) + (optPublish opts) + + -- ... and run it + execAction (fromJust . optUrl $ opts) + (fromJust . optUser $ opts) + (fromJust . optPassword $ opts) + action + +-- | Run new review request action +-- +execAction :: String -> String -> String -> (String -> RBAction ()) -> IO () +execAction url user pass action = do + -- Get diff from stdin + diff <- hGetContents stdin + + -- Write diff to temp file + td <- catch (getTemporaryDirectory) (\_ -> return ".") + (tfn, tfh) <- openTempFile td "rbDiff.diff" + mapM (hPutStrLn tfh) $ lines diff + hClose tfh + + -- Run action and delete temp file + finally (execRBAction url user pass $ action tfn) + (do removeFile tfn) + +-- | New review request action +-- +mkrrAction :: String -> String -> String -> Maybe String -> Bool -> String -> RBAction () +mkrrAction rep basedir revs dsc pub tfn = do + -- Create new review request and get the id + rsp <- reviewRequestNew rep Nothing + let id = fromJust . rrId $ rsp + + -- Set some fields + reviewRequestSetField id TARGET_PEOPLE revs + setOptional id DESCRIPTION dsc + + -- Upload the diff + reviewRequestDiffNew id basedir tfn + + -- And store the review request draft + reviewRequestSaveDraft id + liftIO $ print "Done." + + where + setOptional id f (Just v) = reviewRequestSetField id f v >>= \_ -> return () + setOptional id f Nothing = return() + +-- --------------------------------------------------------------------------- +-- Option handling + +-- | Parse options +-- +parseOpts :: [String] -> IO (Options, [String]) +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...]" + +-- | Option set +-- +data Options = Options + { optUrl :: Maybe String + , optUser :: Maybe String + , optPassword :: Maybe String + , optRepository :: Maybe String + , optBasedir :: Maybe String + , optReviewers :: Maybe String + , optDescription :: Maybe String + , optPublish :: Bool + } deriving Show + +-- | Option descriptor list +-- +options :: [OptDescr (Options -> 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 ['l'] [] (NoArg (\ opts -> opts { optPublish = True })) "Publish review" + ] + +-- | Load default options from configuration file +-- +defaultOpts :: IO Options +defaultOpts = do + hd <- getHomeDirectory + cf <- readFile $ hd ++ "/.mkrrrc" + 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 "repository" l = os { optRepository = Just $ parseValue l } + | isPrefixOf "basedir" l = os { optBasedir = Just $ parseValue l } + | isPrefixOf "publish" l = os { optPublish = read $ 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 + , optRepository = Nothing + , optBasedir = Nothing + , optReviewers = Nothing + , optDescription = Nothing + , optPublish = False } + +-- | Validate required options +-- +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 . optRepository $ opts) $ error $ "REPOSITORY required!" ++ help + when (isNothing . optBasedir $ opts) $ error $ "BASEDIR required!" ++ help + when (isNothing . optReviewers $ opts) $ error $ "REVIEWERS required!" ++ help + where + help = " Try mkrr --help" +