packages feed

ReviewBoard (empty) → 0.1

raw patch · 9 files changed

+1027/−0 lines, 9 filesdep +HTTPdep +basedep +directorysetup-changed

Dependencies added: HTTP, base, directory, json, mtl, network, random

Files

+ LICENSE view
@@ -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.
+ README view
@@ -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)+
+ ReviewBoard.cabal view
@@ -0,0 +1,32 @@+Name:           ReviewBoard+Version:        0.1+Synopsis:		Haskell bindings to ReviewBoard+Description:    Haskell bindings to ReviewBoard (<http://code.google.com/p/reviewboard/>).+Author:         Adam Smyczek+Maintainer:     <adam.smyczek@gmail.com>+Category:       Development+License:        BSD3+License-file:   LICENSE+Cabal-Version:  >= 1.2+Build-type: 	Simple+extra-source-files: README Tests/Tests.hs example/mkrr.hs++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
+ ReviewBoard/Api.hs view
@@ -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:+-- <http://code.google.com/p/reviewboard/wiki/ReviewBoardAPI>+--+-- TODOs:+-- +-- * Add more API calls, of cause!+--+-- * Add abstraction for response data, for example 'reviewRequestNew' should+-- return the @id@ of the new created request. Currently this have to be+-- parsed from the JSon response e.g. using 'rrId' function.+--+-----------------------------------------------------------------------------++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++-}+
+ ReviewBoard/Browser.hs view
@@ -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"+
+ ReviewBoard/Core.hs view
@@ -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+
+ Setup.lhs view
@@ -0,0 +1,3 @@+#!/usr/bin/env runhaskell+> import Distribution.Simple+> main = defaultMain
+ Tests/Tests.hs view
@@ -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)+    )+
+ example/mkrr.hs view
@@ -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. <http://svn.mycompany.com/svn/>+--+-- * 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 +-- <http://code.google.com/p/reviewboard/wiki/ReviewBoardAPI>.+--+-----------------------------------------------------------------------------++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"+