bugzilla (empty) → 0.1.0.0
raw patch · 10 files changed
+1460/−0 lines, 10 filesdep +aesondep +basedep +blaze-buildersetup-changed
Dependencies added: aeson, base, blaze-builder, bugzilla, bytestring, connection, containers, data-default, http-conduit, http-types, iso8601-time, resourcet, text, time, transformers, unordered-containers, vector
Files
- LICENSE +27/−0
- README.md +10/−0
- Setup.hs +2/−0
- bugzilla.cabal +70/−0
- demo/BugzillaDemo.hs +158/−0
- src/Web/Bugzilla.hs +219/−0
- src/Web/Bugzilla/Internal/Network.hs +111/−0
- src/Web/Bugzilla/Internal/Search.hs +88/−0
- src/Web/Bugzilla/Internal/Types.hs +655/−0
- src/Web/Bugzilla/Search.hs +120/−0
+ LICENSE view
@@ -0,0 +1,27 @@+Copyright (c) 2014, Seth Fowler+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 the {organization} nor the names of its+ 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 HOLDER 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.md view
@@ -0,0 +1,10 @@+hsbugzilla+==========++A Haskell interface to the Bugzilla native REST API.++Relevant links:++- The Bugzilla [native REST API](https://wiki.mozilla.org/BMO/REST).+- The (obsolete) [non-native REST API](https://wiki.mozilla.org/Bugzilla%3aREST_API).+- ["Interfacing with RESTful JSON APIs"](https://www.fpcomplete.com/school/to-infinity-and-beyond/competition-winners/interfacing-with-restful-json-apis) on School of Haskell.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ bugzilla.cabal view
@@ -0,0 +1,70 @@+-- Initial bugzilla.cabal generated by cabal init. For further +-- documentation, see http://haskell.org/cabal/users-guide/++name: bugzilla+version: 0.1.0.0+synopsis: A Haskell interface to the Bugzilla native REST API+description: This package is designed to provide an easy-to-use, typesafe+ interface to querying Bugzilla from Haskell.+homepage: https://github.com/sethfowler/hsbugzilla+license: BSD3+license-file: LICENSE+author: Seth Fowler+maintainer: mark.seth.fowler@gmail.com+copyright: Copyright 2014 Seth Fowler+category: Web+build-type: Simple+extra-source-files: README.md+cabal-version: >=1.10++source-repository head+ type: git+ location: https://github.com/sethfowler/hsbugzilla.git+ tag: 0.1++flag BuildDemo+ description: Build the 'bugzilla' demo program+ default: False++library+ ghc-options: -Wall+ exposed-modules: Web.Bugzilla,+ Web.Bugzilla.Search+ other-modules: Web.Bugzilla.Internal.Network,+ Web.Bugzilla.Internal.Search,+ Web.Bugzilla.Internal.Types+ -- other-extensions: + build-depends: base >=4.6 && <4.7,+ aeson >=0.7 && <0.8,+ blaze-builder >=0.3 && <0.4,+ bytestring >=0.10 && <0.11,+ connection >=0.2 && <0.3,+ containers >=0.5 && <0.6,+ data-default >=0.5 && <0.6,+ http-conduit >=2.0 && <2.1,+ http-types >=0.8 && <0.9,+ iso8601-time >=0.1 && <0.2,+ resourcet >=0.4 && <0.5,+ text >=0.11 && <0.12,+ time >=1.4 && <1.5,+ transformers >=0.3 && <0.4,+ unordered-containers >=0.2 && <0.3,+ vector >= 0.10 && <0.11+ hs-source-dirs: src+ default-language: Haskell2010++executable bugzilla+ if flag(BuildDemo)+ buildable: True+ else+ buildable: False++ ghc-options: -Wall+ main-is: BugzillaDemo.hs+ build-depends: base >=4.6 && <4.7,+ bugzilla,+ containers >=0.5 && <0.6,+ text >=0.11 && <0.12,+ time >=1.4 && <1.5+ hs-source-dirs: demo+ default-language: Haskell2010
+ demo/BugzillaDemo.hs view
@@ -0,0 +1,158 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RecordWildCards #-}++import Control.Applicative+import Control.Exception (bracket)+import Control.Monad+import Data.Maybe+import qualified Data.Text as T+import Data.Time.Clock (diffUTCTime)+import System.Environment (getArgs)+import System.IO++import Web.Bugzilla+import Web.Bugzilla.Search++main :: IO ()+main = dispatch Nothing Nothing =<< getArgs++dispatch :: Maybe UserEmail -> Maybe BugzillaServer -> [String] -> IO ()+dispatch Nothing s ("--login" : user : as) = dispatch (Just $ T.pack user) s as+dispatch l Nothing ("--server" : server : as) = dispatch l (Just $ T.pack server) as+dispatch l s ["--assigned-to", user] = withBz l s $ doAssignedTo (T.pack user)+dispatch l s ["--requests", user] = withBz l s $ doRequests (T.pack user)+dispatch l s ["--history", bug, n] = withBz l s $ doHistory (read bug) (read n)+dispatch _ _ _ = usage++usage :: IO ()+usage = hPutStrLn stderr "Connection options:"+ >> hPutStrLn stderr " --server [domain name] - REQUIRED. The Bugzilla server to access."+ >> hPutStrLn stderr " --login [user email] - The user to log in with."+ >> hPutStrLn stderr ""+ >> hPutStrLn stderr "Bugzilla queries:"+ >> hPutStrLn stderr " --assigned-to [user email] - List bugs assigned to the user."+ >> hPutStrLn stderr " --requests [user email] - List requests for the user."+ >> hPutStrLn stderr " --history [bug number] [n] - List the most recent 'n' changes to the bug."++withBz :: Maybe UserEmail -> Maybe BugzillaServer -> (BugzillaSession -> IO ()) -> IO ()+withBz mLogin mServer f = do+ let server = case mServer of+ Just s -> s+ Nothing -> error "Please specify a server with '--server'"+ withBugzillaContext server $ \ctx ->+ case mLogin of+ Just login -> do hPutStrLn stderr "Enter password: "+ password <- T.pack <$> withEcho False getLine+ mSession <- loginSession ctx login password+ case mSession of+ Just session -> do hPutStrLn stderr "Login successful."+ f session+ Nothing -> do hPutStrLn stderr "Login failed. Falling back to anonymous session."+ f $ anonymousSession ctx+ Nothing -> f $ anonymousSession ctx+ + +doAssignedTo :: UserEmail -> BugzillaSession -> IO ()+doAssignedTo user session = do+ let search = AssignedToField .==. user+ bugs <- searchBugs session search+ mapM_ showBug bugs+ where+ showBug (Bug {..}) = putStrLn $ show bugId ++ ": " ++ show bugSummary+ ++ " [" ++ T.unpack bugStatus ++ ": " ++ T.unpack bugResolution ++ "] Updated: "+ ++ show bugLastChangeTime++doRequests :: UserEmail -> BugzillaSession -> IO ()+doRequests user session = do+ let needinfoSearch = FlagRequesteeField .==. user .&&. FlagsField `contains` "needinfo"+ needinfoBugs <- searchBugs session needinfoSearch+ mapM_ showNeedinfo needinfoBugs++ let reviewSearch = FlagRequesteeField .==. user .&&.+ (FlagsField `contains` "review" .||. FlagsField `contains` "feedback")+ reviewBugs <- map bugId <$> searchBugs session reviewSearch+ forM_ reviewBugs $ \rBugId -> do+ attachments <- getAttachments session rBugId+ mapM_ showReview $ filter (any hasReviewFlag . attachmentFlags) attachments+ mapM_ showFeedback $ filter (any hasFeedbackFlag . attachmentFlags) attachments++ where+ showNeedinfo (Bug {..}) = do+ let flags = filter hasNeedinfoFlag bugFlags+ forM_ flags $ \flag ->+ putStrLn $ "[NEEDINFO] " ++ show bugId ++ ": " ++ show bugSummary+ ++ " (" ++ show (flagSetter flag) ++ " " ++ show (flagCreationDate flag) ++ ")"++ showReview (Attachment {..}) =+ putStrLn $ "[REVIEW] " ++ show attachmentBugId ++ ": " ++ show attachmentSummary+ ++ " (" ++ show attachmentCreator ++ " " ++ show attachmentCreationTime ++ ")"++ showFeedback (Attachment {..}) =+ putStrLn $ "[FEEDBACK] " ++ show attachmentBugId ++ ": " ++ show attachmentSummary+ ++ " (" ++ show attachmentCreator ++ " " ++ show attachmentCreationTime ++ ")"++ hasNeedinfoFlag f = flagRequestee f == Just user && flagName f == "needinfo"+ hasReviewFlag f = flagRequestee f == Just user && flagName f == "review"+ hasFeedbackFlag f = flagRequestee f == Just user && flagName f == "feedback"++doHistory :: BugId -> Int -> BugzillaSession -> IO ()+doHistory bug count session = do+ comments <- getComments session bug+ history <- getHistory session bug+ recentEventsRev <- takeRecent count (reverse comments)+ (reverse $ historyEvents history)+ mapM_ putStrLn (reverse recentEventsRev)+ where+ takeRecent :: Int -> [Comment] -> [HistoryEvent] -> IO [String]+ takeRecent 0 _ _ = return []+ takeRecent n (c:cs) (e:es)+ | commentCreationTime c `diffUTCTime` historyEventTime e >= 0 = (:) <$> showComment c+ <*> takeRecent (n - 1) cs (e:es)+ | otherwise = (:) <$> showEvent e+ <*> takeRecent (n - 1) (c:cs) es+ takeRecent n cs@(_:_) [] = mapM showComment $ take n cs+ takeRecent n [] es@(_:_) = mapM showEvent $ take n es+ takeRecent _ [] [] = return []++ -- FIXME: showComment and showEvent will call getUser for the same+ -- user over and over again. You should never do this in a real application.+ showComment (Comment {..}) = do+ user <- getUser session commentCreator+ let commentUserRealName = fromMaybe commentCreator $ userRealName <$> user+ let commentUserEmail = fromMaybe commentCreator $ userEmail <$> user+ return $ "(" ++ show commentId ++ ") " ++ T.unpack commentUserRealName+ ++ " <" ++ T.unpack commentUserEmail ++ "> " ++ show commentCreationTime+ ++ "\n" ++ (unlines . map (" " ++) . lines . T.unpack $ commentText)++ showEvent (HistoryEvent {..}) = do+ user <- getUser session historyEventUser+ let eventUserRealName = fromMaybe historyEventUser $ userRealName <$> user+ let eventUserEmail = fromMaybe historyEventUser $ userEmail <$> user+ return $ T.unpack eventUserRealName ++ " <" ++ T.unpack eventUserEmail ++ ">\n"+ ++ concatMap showChange historyEventChanges++ showChange (TextFieldChange f (Modification r a aid)) = showChange' f r a aid+ showChange (ListFieldChange f (Modification r a aid)) = showChange' f r a aid+ showChange (IntFieldChange f (Modification r a aid)) = showChange' f r a aid+ showChange (TimeFieldChange f (Modification r a aid)) = showChange' f r a aid+ showChange (BoolFieldChange f (Modification r a aid)) = showChange' f r a aid++ showChange' f r a aid = " " ++ showField f ++ ": "+ ++ showMod r ++ " -> " ++ showMod a+ ++ showAid aid ++ "\n"++ showField = T.unpack . fieldName++ showMod :: Show a => Maybe a -> String+ showMod (Just v) = show v+ showMod Nothing = "___"++ showAid :: Maybe AttachmentId -> String+ showAid (Just aid) = " (Attachment " ++ show aid ++ ")"+ showAid Nothing = ""++withEcho :: Bool -> IO a -> IO a+withEcho echo action =+ bracket (hGetEcho stdin)+ (hSetEcho stdin)+ (const $ hSetEcho stdin echo >> action)
+ src/Web/Bugzilla.hs view
@@ -0,0 +1,219 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++-- | This package is designed to provide an easy-to-use, typesafe+-- interface to querying Bugzilla from Haskell.+--+-- A very simple program using this package might look like this:+--+-- > withBugzillaContext "bugzilla.example.org" $ \ctx -> do+-- > let session = anonymousSession ctx+-- > user = "me@example.org"+-- > query = AssignedToField .==. user .&&.+-- > FlagRequesteeField .==. user .&&.+-- > (FlagsField `contains` "review" .||. FlagsField `contains` "feedback")+-- > bugs <- searchBugs session query+-- > mapM_ (putStrLn . show . bugSummary) bugs+--+-- There's a somewhat more in-depth demo program included with the+-- source code to this package.+module Web.Bugzilla+( -- * Connecting to Bugzilla+ newBugzillaContext+, closeBugzillaContext+, withBugzillaContext+, loginSession+, anonymousSession++, BugzillaServer+, BugzillaContext+, BugzillaSession (..)+, BugzillaToken++ -- * Querying Bugzilla+, searchBugs+, searchBugsWithLimit+, getBug+, getAttachment+, getAttachments+, getComments+, getHistory+, searchUsers+, getUser+, getUserById+++, BugId+, AttachmentId+, CommentId+, UserId+, FlagId+, FlagType+, UserEmail+, Field (..)+, User (..)+, Flag (..)+, Bug (..)+, Attachment (..)+, Comment (..)+, History (..)+, HistoryEvent (..)+, Change (..)+, Modification (..)+, fieldName++, BugzillaException (..)+) where++import Control.Exception (bracket, throw, try)+import Control.Monad.IO.Class (liftIO)+import qualified Data.Text as T+import Network.Connection (TLSSettings(..))+import Network.HTTP.Conduit (mkManagerSettings, newManager, closeManager)++import Web.Bugzilla.Internal.Network+import Web.Bugzilla.Internal.Search+import Web.Bugzilla.Internal.Types++-- | Creates a new 'BugzillaContext', suitable for connecting to the+-- provided server. You should try to reuse 'BugzillaContext's+-- whenever possible, because creating them is expensive.+newBugzillaContext :: BugzillaServer -> IO BugzillaContext+newBugzillaContext server = do+ let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing+ manager <- liftIO $ newManager settings+ return $ BugzillaContext server manager++-- | Closes the provided 'BugzillaContext'. Using it afterwards is an error.+closeBugzillaContext :: BugzillaContext -> IO ()+closeBugzillaContext = closeManager . bzManager++-- | Creates a 'BugzillaContext' and ensures that it will be closed+-- automatically, even if an exception is thrown.+withBugzillaContext :: BugzillaServer -> (BugzillaContext -> IO a) -> IO a+withBugzillaContext server f = bracket (newBugzillaContext server) closeBugzillaContext f++-- | Attempts to create a logged-in 'BugzillaSession' using the+-- provided username and password. Returns 'Nothing' if login+-- fails.+loginSession :: BugzillaContext -> UserEmail -> T.Text -> IO (Maybe BugzillaSession)+loginSession ctx user password = do+ let loginQuery = [("login", Just user),+ ("password", Just password)]+ session = anonymousSession ctx+ req = newBzRequest session ["login"] loginQuery+ eToken <- try $ sendBzRequest session req+ return $ case eToken of+ Left (BugzillaAPIError 300 _) -> Nothing+ Left e -> throw e+ Right token -> Just $ LoginSession ctx token++-- | Creates an anonymous 'BugzillaSession'. Note that some content+-- will be hidden by Bugzilla when you make queries in this state.+anonymousSession :: BugzillaContext -> BugzillaSession+anonymousSession ctx = AnonymousSession ctx++intAsText :: Int -> T.Text+intAsText = T.pack . show++-- | Search Bugzilla and returns a list of 'Bug's. The 'SearchExpression'+-- can be constructed conveniently using the operators in "Web.Bugzilla.Search".+searchBugs :: BugzillaSession -> SearchExpression -> IO [Bug]+searchBugs session search = do+ let searchQuery = evalSearchExpr search+ req = newBzRequest session ["bug"] searchQuery+ (BugList bugs) <- sendBzRequest session req+ return bugs++-- | Search Bugzilla and returns a limited number of results. You can+-- call this repeatedly and use 'offset' to retrieve the results of+-- a large query incrementally. Note that most Bugzillas won't+-- return all of the results for a very large query by default, but+-- you can request this by calling 'searchBugsWithLimit' with 0 for+-- the limit.+searchBugsWithLimit :: BugzillaSession+ -> Int -- ^ The maximum number of results to return.+ -> Int -- ^ The offset from the first result to start from.+ -> SearchExpression+ -> IO [Bug]+searchBugsWithLimit session limit offset search = do+ let limitQuery = [("limit", Just $ intAsText limit),+ ("offset", Just $ intAsText offset)]+ searchQuery = evalSearchExpr search+ req = newBzRequest session ["bug"] (limitQuery ++ searchQuery)+ (BugList bugs) <- sendBzRequest session req+ return bugs++-- | Retrieve a bug by bug number.+getBug :: BugzillaSession -> BugId -> IO (Maybe Bug)+getBug session bid = do+ let req = newBzRequest session ["bug", intAsText bid] []+ (BugList bugs) <- sendBzRequest session req+ case bugs of+ [bug] -> return $ Just bug+ [] -> return Nothing+ _ -> throw $ BugzillaUnexpectedValue+ "Request for a single bug returned multiple bugs"++-- | Retrieve a bug by attachment number.+getAttachment :: BugzillaSession -> AttachmentId -> IO (Maybe Attachment)+getAttachment session aid = do+ let req = newBzRequest session ["bug", "attachment", intAsText aid] []+ (AttachmentList as) <- sendBzRequest session req+ case as of+ [a] -> return $ Just a+ [] -> return Nothing+ _ -> throw $ BugzillaUnexpectedValue+ "Request for a single attachment returned multiple attachments"+ +-- | Get all attachments for a bug.+getAttachments :: BugzillaSession -> BugId -> IO [Attachment]+getAttachments session bid = do+ let req = newBzRequest session ["bug", intAsText bid, "attachment"] []+ (AttachmentList as) <- sendBzRequest session req+ return as++-- | Get all comments for a bug.+getComments :: BugzillaSession -> BugId -> IO [Comment]+getComments session bid = do+ let req = newBzRequest session ["bug", intAsText bid, "comment"] []+ (CommentList as) <- sendBzRequest session req+ return as++-- | Get the history for a bug.+getHistory :: BugzillaSession -> BugId -> IO History+getHistory session bid = do+ let req = newBzRequest session ["bug", intAsText bid, "history"] []+ sendBzRequest session req++-- | Search user names and emails using a substring search.+searchUsers :: BugzillaSession -> T.Text -> IO [User]+searchUsers session text = do+ let req = newBzRequest session ["user"] [("match", Just text)]+ (UserList users) <- sendBzRequest session req+ return users++-- | Get a user by email.+getUser :: BugzillaSession -> UserEmail -> IO (Maybe User)+getUser session user = do+ let req = newBzRequest session ["user", user] []+ (UserList users) <- sendBzRequest session req+ case users of+ [u] -> return $ Just u+ [] -> return Nothing+ _ -> throw $ BugzillaUnexpectedValue+ "Request for a single user returned multiple users"++-- | Get a user by user ID.+getUserById :: BugzillaSession -> UserId -> IO (Maybe User)+getUserById session uid = do+ let req = newBzRequest session ["user", intAsText uid] []+ (UserList users) <- sendBzRequest session req+ case users of+ [u] -> return $ Just u+ [] -> return Nothing+ _ -> throw $ BugzillaUnexpectedValue+ "Request for a single user returned multiple users"
+ src/Web/Bugzilla/Internal/Network.hs view
@@ -0,0 +1,111 @@+{-# LANGUAGE DeriveDataTypeable #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Bugzilla.Internal.Network+( BugzillaServer+, BugzillaContext (..)+, BugzillaToken+, BugzillaSession (..)+, BugzillaException (..)+, QueryPart+, Request+, requestUrl+, newBzRequest+, sendBzRequest+) where++import Blaze.ByteString.Builder (toByteString)+import Control.Applicative+import Control.Exception (Exception, throw)+import Control.Monad (mzero)+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Resource (runResourceT)+import Data.Aeson+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import Data.Default (def)+import Data.Monoid ((<>))+import qualified Data.Text as T+import qualified Data.Text.Encoding as TE+import Data.Typeable+import Network.HTTP.Conduit (Manager, Request(..), Response(..), host, httpLbs, path, queryString, secure)+import Network.HTTP.Types.URI (QueryText, encodePathSegments, renderQueryText)++type BugzillaServer = T.Text++-- | Holds information about a 'BugzillaServer' and manages outgoing+-- connections. You can use 'newBugzillaContext' or+-- 'withBugzillaContext' to create one.+data BugzillaContext = BugzillaContext+ { bzServer :: BugzillaServer+ , bzManager :: Manager+ }++data BugzillaToken = BugzillaToken T.Text++instance FromJSON BugzillaToken where+ parseJSON (Object v) = BugzillaToken <$> v .: "token"+ parseJSON _ = mzero++-- | A session for Bugzilla queries. Use 'anonymousSession' and+-- 'loginSession', as appropriate, to create one.+data BugzillaSession = AnonymousSession BugzillaContext+ | LoginSession BugzillaContext BugzillaToken++bzContext :: BugzillaSession -> BugzillaContext+bzContext (AnonymousSession ctx) = ctx+bzContext (LoginSession ctx _) = ctx++data BugzillaException+ = BugzillaJSONParseError String+ | BugzillaAPIError Int String+ | BugzillaUnexpectedValue String+ deriving (Show, Typeable)+instance Exception BugzillaException++type QueryPart = (T.Text, Maybe T.Text)++requestUrl :: Request -> B.ByteString+requestUrl req = "https://" <> host req <> path req <> queryString req++sslRequest :: Request+sslRequest =+ def {+ secure = True,+ port = 443+ }++newBzRequest :: BugzillaSession -> [T.Text] -> QueryText -> Request+newBzRequest session methodParts query =+ sslRequest {+ host = TE.encodeUtf8 . bzServer . bzContext $ session,+ path = toByteString $ encodePathSegments $ "rest" : methodParts,+ queryString = toByteString $ renderQueryText True queryWithToken+ }+ where+ queryWithToken = case session of+ AnonymousSession _ -> query+ LoginSession _ (BugzillaToken token) -> ("token", Just token) : query++data BzError = BzError Int String+ deriving (Eq, Show)++instance FromJSON BzError where+ parseJSON (Object v) = BzError <$> v .: "code"+ <*> v .: "message"+ parseJSON _ = mzero++handleError :: String -> BL.ByteString -> IO b+handleError parseError body = do+ let mError = eitherDecode body+ case mError of+ Left _ -> throw $ BugzillaJSONParseError parseError+ Right (BzError code msg) -> throw $ BugzillaAPIError code msg++sendBzRequest :: FromJSON a => BugzillaSession -> Request -> IO a+sendBzRequest session req = runResourceT $ do+ response <- liftIO $ httpLbs req . bzManager . bzContext $ session+ let mResult = eitherDecode $ responseBody response+ case mResult of+ Left msg -> liftIO $ handleError msg (responseBody response)+ Right decoded -> return decoded
+ src/Web/Bugzilla/Internal/Search.hs view
@@ -0,0 +1,88 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++-- | Operators which can be used to construct queries for Bugzilla.+-- These operators are intended to be typesafe: you should not be+-- able to construct a query that causes Bugzilla to return an+-- error. If you *are* able to construct an erroneous query, please+-- report a bug.+module Web.Bugzilla.Internal.Search+( FieldType+, SearchTerm (..)+, SearchExpression (..)+, evalSearchExpr+) where++import Data.List+import qualified Data.Text as T+import Data.Time.Clock (UTCTime(..))+import Data.Time.ISO8601 (formatISO8601)++import Web.Bugzilla.Internal.Network+import Web.Bugzilla.Internal.Types++class FieldType a where fvAsText :: a -> T.Text++instance FieldType T.Text where fvAsText = id+instance FieldType Int where fvAsText = T.pack . show+instance FieldType UTCTime where fvAsText = T.pack . formatISO8601++instance FieldType Bool where+ fvAsText True = "true"+ fvAsText False = "false"++instance FieldType a => FieldType [a] where+ fvAsText = T.intercalate "," . map fvAsText++data SearchTerm where+ UnaryOp :: FieldType a => T.Text -> Field a -> SearchTerm+ BinaryOp :: (FieldType a, FieldType b) => T.Text -> Field a -> b -> SearchTerm++-- | A Boolean expression which can be used to query Bugzilla.+data SearchExpression+ = And [SearchExpression]+ | Or [SearchExpression]+ | Not SearchExpression+ | Term SearchTerm++taggedQueryPart :: Int -> Char -> T.Text -> QueryPart+taggedQueryPart t k v = (T.cons k . T.pack . show $ t, Just v)++termQuery :: FieldType b => Int -> Field a -> T.Text -> b -> [QueryPart]+termQuery t f o v = [taggedQueryPart t 'f' (searchFieldName f),+ taggedQueryPart t 'o' o,+ taggedQueryPart t 'v' (fvAsText v)]++evalSearchTerm :: Int -> SearchTerm -> [QueryPart]+evalSearchTerm t (UnaryOp op field) = termQuery t field op ("" :: T.Text)+evalSearchTerm t (BinaryOp op field val) = termQuery t field op val++evalSearchExpr :: SearchExpression -> [QueryPart]+evalSearchExpr e = snd $ evalSearchExpr' 1 e+ where+ evalExprGroup :: Int -> [SearchExpression] -> (Int, [QueryPart])+ evalExprGroup t es =+ let (subExprT, subExprQs) = foldl' evalSubExpr (t + 1, []) es+ qs = (taggedQueryPart t 'f' "OP") :+ (taggedQueryPart subExprT 'f' "CP") :+ subExprQs+ in (subExprT + 1, qs)++ evalSubExpr :: (Int, [QueryPart]) -> SearchExpression -> (Int, [QueryPart])+ evalSubExpr (t, qs) expr = let (nextT, qs') = evalSearchExpr' t expr+ in (nextT, qs ++ qs')++ evalSearchExpr' :: Int -> SearchExpression -> (Int, [QueryPart])+ evalSearchExpr' t (And es) = evalExprGroup t es++ evalSearchExpr' t (Or es) =+ let (groupT, groupQs) = evalExprGroup t es+ qs = (taggedQueryPart t 'j' "OR") : groupQs+ in (groupT + 1, qs)++ evalSearchExpr' t (Not es) =+ let (groupT, groupQs) = evalSearchExpr' t es+ qs = (taggedQueryPart t 'n' "1") : groupQs+ in (groupT + 1, qs)++ evalSearchExpr' t (Term term) = (t + 1, evalSearchTerm t term)
+ src/Web/Bugzilla/Internal/Types.hs view
@@ -0,0 +1,655 @@+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE FunctionalDependencies #-}+{-# LANGUAGE GADTs #-}+{-# LANGUAGE MultiParamTypeClasses #-}+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE ViewPatterns #-}++module Web.Bugzilla.Internal.Types+( BugId+, AttachmentId+, CommentId+, UserId+, FlagId+, FlagType+, UserEmail+, Field (..)+, User (..)+, UserList (..)+, Flag (..)+, Bug (..)+, BugList (..)+, Attachment (..)+, AttachmentList (..)+, Comment (..)+, CommentList (..)+, History (..)+, HistoryEvent (..)+, Change (..)+, Modification (..)+, fieldName+, searchFieldName+) where++import Control.Applicative+import Control.Monad (MonadPlus, mzero)+import Data.Aeson+import Data.Aeson.Encode+import Data.Aeson.Types+import qualified Data.HashMap.Strict as H+import qualified Data.Text as T+import qualified Data.Text.Lazy as TL+import qualified Data.Text.Lazy.Builder as TLB+import qualified Data.Text.Read as TR+import qualified Data.Vector as V+import Data.Time.Clock (UTCTime(..))++type BugId = Int+type AttachmentId = Int+type CommentId = Int+type UserId = Int+type FlagId = Int+type FlagType = Int+type UserEmail = T.Text++-- | A field which you can search by using 'Web.Bugzilla.searchBugs' or track+-- changes to using 'Web.Bugzilla.getHistory'. To get a human-readable name for+-- a field, use 'fieldName'.+data Field a where+ AliasField :: Field T.Text -- Alias+ AssignedToField :: Field UserEmail -- Assignee+ AttachmentCreatorField :: Field UserEmail -- Attachment creator+ AttachmentDataField :: Field T.Text -- Attachment data+ AttachmentDescriptionField :: Field T.Text -- Attachment description+ AttachmentFilenameField :: Field T.Text -- Attachment filename+ AttachmentIsObsoleteField :: Field Bool -- Attachment is obsolete+ AttachmentIsPatchField :: Field Bool -- Attachment is patch+ AttachmentIsPrivateField :: Field Bool -- Attachment is private+ AttachmentMimetypeField :: Field T.Text -- Attachment mime type+ BlocksField :: Field Int -- Blocks+ BugIdField :: Field Int -- Bug ID+ CcField :: Field UserEmail -- CC+ CcListAccessibleField :: Field Bool -- CC list accessible+ ClassificationField :: Field T.Text -- Classification+ CommentField :: Field T.Text -- Comment+ CommentIsPrivateField :: Field T.Text -- Comment is private+ CommentTagsField :: Field T.Text -- Comment Tags+ CommenterField :: Field UserEmail -- Commenter+ ComponentField :: Field T.Text -- Component+ ContentField :: Field T.Text -- Content+ CreationDateField :: Field UTCTime -- Creation date+ DaysElapsedField :: Field Int -- Days since bug changed+ DependsOnField :: Field Int -- Depends on+ EverConfirmedField :: Field Bool -- Ever confirmed+ FlagRequesteeField :: Field UserEmail -- Flag Requestee+ FlagSetterField :: Field UserEmail -- Flag Setter+ FlagsField :: Field T.Text -- Flags+ GroupField :: Field T.Text -- Group+ KeywordsField :: Field [T.Text] -- Keywords+ ChangedField :: Field UTCTime -- Changed+ CommentCountField :: Field Int -- Number of Comments+ OperatingSystemField :: Field T.Text -- OS+ HardwareField :: Field T.Text -- Hardware+ PriorityField :: Field T.Text -- Priority+ ProductField :: Field T.Text -- Product+ QaContactField :: Field UserEmail -- QA Contact+ ReporterField :: Field UserEmail -- Reporter+ ReporterAccessibleField :: Field Bool -- Reporter accessible+ ResolutionField :: Field T.Text -- Resolution+ RestrictCommentsField :: Field Bool -- Restrict Comments+ SeeAlsoField :: Field T.Text -- See Also+ SeverityField :: Field T.Text -- Severity+ StatusField :: Field T.Text -- Status+ WhiteboardField :: Field T.Text -- Whiteboard+ SummaryField :: Field T.Text -- Summary+ TagsField :: Field T.Text -- Tags+ TargetMilestoneField :: Field T.Text -- Target Milestone+ TimeSinceAssigneeTouchedField :: Field Int -- Time Since Assignee Touched+ BugURLField :: Field T.Text -- URL+ VersionField :: Field T.Text -- Version+ VotesField :: Field T.Text -- Votes+ CustomField :: T.Text -> Field T.Text -- (Custom fields)++instance Eq (Field a) where+ (CustomField a) == (CustomField b) = a == b+ (CustomField _) == _ = False+ _ == (CustomField _) = False+ a == b = searchFieldName a == searchFieldName b++instance Show (Field a) where+ show AliasField = "AliasField"+ show AssignedToField = "AssignedToField"+ show AttachmentCreatorField = "AttachmentCreatorField"+ show AttachmentDataField = "AttachmentDataField"+ show AttachmentDescriptionField = "AttachmentDescriptionField"+ show AttachmentFilenameField = "AttachmentFilenameField"+ show AttachmentIsObsoleteField = "AttachmentIsObsoleteField"+ show AttachmentIsPatchField = "AttachmentIsPatchField"+ show AttachmentIsPrivateField = "AttachmentIsPrivateField"+ show AttachmentMimetypeField = "AttachmentMimetypeField"+ show BlocksField = "BlocksField"+ show BugIdField = "BugIdField"+ show CcField = "CcField"+ show CcListAccessibleField = "CcListAccessibleField"+ show ClassificationField = "ClassificationField"+ show CommentField = "CommentField"+ show CommentIsPrivateField = "CommentIsPrivateField"+ show CommentTagsField = "CommentTagsField"+ show CommenterField = "CommenterField"+ show ComponentField = "ComponentField"+ show ContentField = "ContentField"+ show CreationDateField = "CreationDateField"+ show DaysElapsedField = "DaysElapsedField"+ show DependsOnField = "DependsOnField"+ show EverConfirmedField = "EverConfirmedField"+ show FlagRequesteeField = "FlagRequesteeField"+ show FlagSetterField = "FlagSetterField"+ show FlagsField = "FlagsField"+ show GroupField = "GroupField"+ show KeywordsField = "KeywordsField"+ show ChangedField = "ChangedField"+ show CommentCountField = "CommentCountField"+ show OperatingSystemField = "OperatingSystemField"+ show HardwareField = "HardwareField"+ show PriorityField = "PriorityField"+ show ProductField = "ProductField"+ show QaContactField = "QaContactField"+ show ReporterField = "ReporterField"+ show ReporterAccessibleField = "ReporterAccessibleField"+ show ResolutionField = "ResolutionField"+ show RestrictCommentsField = "RestrictCommentsField"+ show SeeAlsoField = "SeeAlsoField"+ show SeverityField = "SeverityField"+ show StatusField = "StatusField"+ show WhiteboardField = "WhiteboardField"+ show SummaryField = "SummaryField"+ show TagsField = "TagsField"+ show TargetMilestoneField = "TargetMilestoneField"+ show TimeSinceAssigneeTouchedField = "TimeSinceAssigneeTouchedField"+ show BugURLField = "BugURLField"+ show VersionField = "VersionField"+ show VotesField = "VotesField"+ show (CustomField name) = "CustomField " ++ show name++-- | Provides a human-readable name for a 'Field'.+fieldName :: Field a -> T.Text+fieldName AliasField = "Alias"+fieldName AssignedToField = "Assigned to"+fieldName AttachmentCreatorField = "Attachment creator"+fieldName AttachmentDataField = "Attachment data"+fieldName AttachmentDescriptionField = "Attachment description"+fieldName AttachmentFilenameField = "Attachment filename"+fieldName AttachmentIsObsoleteField = "Attachment is obsolete"+fieldName AttachmentIsPatchField = "Attachment is patch"+fieldName AttachmentIsPrivateField = "Attachment is private"+fieldName AttachmentMimetypeField = "Attachment MIME type"+fieldName BlocksField = "Blocks"+fieldName BugIdField = "BugId"+fieldName CcField = "CC"+fieldName CcListAccessibleField = "CC list is accessible"+fieldName ClassificationField = "Classification"+fieldName CommentField = "Comment"+fieldName CommentIsPrivateField = "Comment is private"+fieldName CommentTagsField = "Comment tags"+fieldName CommenterField = "Commenter"+fieldName ComponentField = "Component"+fieldName ContentField = "Content"+fieldName CreationDateField = "Creation date"+fieldName DaysElapsedField = "Days elapsed"+fieldName DependsOnField = "Depends on"+fieldName EverConfirmedField = "Ever confirmed"+fieldName FlagRequesteeField = "Flag requestee"+fieldName FlagSetterField = "Flag setter"+fieldName FlagsField = "Flags"+fieldName GroupField = "Group"+fieldName KeywordsField = "Keywords"+fieldName ChangedField = "Changed"+fieldName CommentCountField = "Comment count"+fieldName OperatingSystemField = "Operating system"+fieldName HardwareField = "Hardware"+fieldName PriorityField = "Priority"+fieldName ProductField = "Product"+fieldName QaContactField = "QA contact"+fieldName ReporterField = "Reporter"+fieldName ReporterAccessibleField = "Reporter accessible"+fieldName ResolutionField = "Resolution"+fieldName RestrictCommentsField = "Restrict comments"+fieldName SeeAlsoField = "See also"+fieldName SeverityField = "Severity"+fieldName StatusField = "Status"+fieldName WhiteboardField = "Whiteboard"+fieldName SummaryField = "Summary"+fieldName TagsField = "Tags"+fieldName TargetMilestoneField = "Target milestone"+fieldName TimeSinceAssigneeTouchedField = "Time since assignee touched"+fieldName BugURLField = "Bug URL"+fieldName VersionField = "Version"+fieldName VotesField = "Votes"+fieldName (CustomField name) = T.concat ["Custom field \"", T.pack (show name), "\""]++searchFieldName :: Field a -> T.Text+searchFieldName AliasField = "alias"+searchFieldName AssignedToField = "assigned_to"+searchFieldName AttachmentCreatorField = "attachments.submitter"+searchFieldName AttachmentDataField = "attach_data.thedata"+searchFieldName AttachmentDescriptionField = "attachments.description"+searchFieldName AttachmentFilenameField = "attachments.filename"+searchFieldName AttachmentIsObsoleteField = "attachments.isobsolete"+searchFieldName AttachmentIsPatchField = "attachments.ispatch"+searchFieldName AttachmentIsPrivateField = "attachments.isprivate"+searchFieldName AttachmentMimetypeField = "attachments.mimetype"+searchFieldName BlocksField = "blocked"+searchFieldName BugIdField = "bug_id"+searchFieldName CcField = "cc"+searchFieldName CcListAccessibleField = "cclist_accessible"+searchFieldName ClassificationField = "classification"+searchFieldName CommentField = "longdesc"+searchFieldName CommentIsPrivateField = "longdescs.isprivate"+searchFieldName CommentTagsField = "comment_tag"+searchFieldName CommenterField = "commenter"+searchFieldName ComponentField = "component"+searchFieldName ContentField = "content"+searchFieldName CreationDateField = "creation_ts"+searchFieldName DaysElapsedField = "days_elapsed"+searchFieldName DependsOnField = "dependson"+searchFieldName EverConfirmedField = "everconfirmed"+searchFieldName FlagRequesteeField = "requestees.login_name"+searchFieldName FlagSetterField = "setters.login_name"+searchFieldName FlagsField = "flagtypes.name"+searchFieldName GroupField = "bug_group"+searchFieldName KeywordsField = "keywords"+searchFieldName ChangedField = "delta_ts"+searchFieldName CommentCountField = "longdescs.count"+searchFieldName OperatingSystemField = "op_sys"+searchFieldName HardwareField = "rep_platform"+searchFieldName PriorityField = "priority"+searchFieldName ProductField = "product"+searchFieldName QaContactField = "qa_contact"+searchFieldName ReporterField = "reporter"+searchFieldName ReporterAccessibleField = "reporter_accessible"+searchFieldName ResolutionField = "resolution"+searchFieldName RestrictCommentsField = "restrict_comments"+searchFieldName SeeAlsoField = "see_also"+searchFieldName SeverityField = "bug_severity"+searchFieldName StatusField = "bug_status"+searchFieldName WhiteboardField = "status_whiteboard"+searchFieldName SummaryField = "short_desc"+searchFieldName TagsField = "tag"+searchFieldName TargetMilestoneField = "target_milestone"+searchFieldName TimeSinceAssigneeTouchedField = "owner_idle_time"+searchFieldName BugURLField = "bug_file_loc"+searchFieldName VersionField = "version"+searchFieldName VotesField = "votes"+searchFieldName (CustomField name) = name++-- | A Bugzilla user.+data User = User+ { userId :: !UserId+ , userEmail :: T.Text+ , userName :: T.Text+ , userRealName :: T.Text+ } deriving (Eq, Ord, Show)++instance FromJSON User where+ parseJSON (Object v) =+ User <$> v .: "id"+ <*> v .: "email"+ <*> v .: "name"+ <*> v .: "real_name"+ parseJSON _ = mzero++data UserList = UserList [User]+ deriving (Eq, Show)++instance FromJSON UserList where+ parseJSON (Object v) = UserList <$> v .: "users"+ parseJSON _ = mzero++-- | Flags, which may be set on an attachment or on a bug directly.+data Flag = Flag+ { flagId :: !FlagId+ , flagTypeId :: !FlagType+ , flagName :: T.Text+ , flagSetter :: UserEmail+ , flagStatus :: T.Text+ , flagCreationDate :: UTCTime+ , flagModificationDate :: UTCTime+ , flagRequestee :: Maybe UserEmail+ } deriving (Eq, Ord, Show)+ +instance FromJSON Flag where+ parseJSON (Object v) =+ Flag <$> v .: "id"+ <*> v .: "type_id"+ <*> v .: "name"+ <*> v .: "setter"+ <*> v .: "status"+ <*> v .: "creation_date"+ <*> v .: "modification_date"+ <*> v .:? "requestee"+ parseJSON _ = mzero+ +-- | A Bugzilla bug.+data Bug = Bug+ { bugId :: !BugId+ , bugAlias :: Maybe T.Text+ , bugAssignedTo :: UserEmail+ , bugAssignedToDetail :: User+ , bugBlocks :: [BugId]+ , bugCc :: [UserEmail]+ , bugCcDetail :: [User]+ , bugClassification :: T.Text+ , bugComponent :: T.Text+ , bugCreationTime :: UTCTime+ , bugCreator :: UserEmail+ , bugCreatorDetail :: User+ , bugDependsOn :: [BugId]+ , bugDupeOf :: Maybe BugId+ , bugFlags :: [Flag]+ , bugGroups :: [T.Text]+ , bugIsCcAccessible :: Bool+ , bugIsConfirmed :: Bool+ , bugIsCreatorAccessible :: Bool+ , bugIsOpen :: Bool+ , bugKeywords :: [T.Text]+ , bugLastChangeTime :: UTCTime+ , bugOpSys :: T.Text+ , bugPlatform :: T.Text+ , bugPriority :: T.Text+ , bugProduct :: T.Text+ , bugQaContact :: UserEmail+ , bugResolution :: T.Text+ , bugSeeAlso :: [T.Text]+ , bugSeverity :: T.Text+ , bugStatus :: T.Text+ , bugSummary :: T.Text+ , bugTargetMilestone :: T.Text+ , bugUrl :: T.Text+ , bugVersion :: T.Text+ , bugWhiteboard :: T.Text+ , bugCustomFields :: H.HashMap T.Text T.Text+ } deriving (Eq, Show)++instance FromJSON Bug where+ parseJSON (Object v) =+ Bug <$> v .: "id"+ <*> v .:? "alias"+ <*> v .: "assigned_to"+ <*> v .: "assigned_to_detail"+ <*> v .: "blocks"+ <*> v .: "cc"+ <*> v .: "cc_detail"+ <*> v .: "classification"+ <*> v .: "component"+ <*> v .: "creation_time"+ <*> v .: "creator"+ <*> v .: "creator_detail"+ <*> v .: "depends_on"+ <*> v .:? "dupe_of"+ <*> v .: "flags"+ <*> v .: "groups"+ <*> v .: "is_cc_accessible"+ <*> v .: "is_confirmed"+ <*> v .: "is_creator_accessible"+ <*> v .: "is_open"+ <*> v .: "keywords"+ <*> v .: "last_change_time"+ <*> v .: "op_sys"+ <*> v .: "platform"+ <*> v .: "priority"+ <*> v .: "product"+ <*> v .: "qa_contact"+ <*> v .: "resolution"+ <*> v .: "see_also"+ <*> v .: "severity"+ <*> v .: "status"+ <*> v .: "summary"+ <*> v .: "target_milestone"+ <*> v .: "url"+ <*> v .: "version"+ <*> v .: "whiteboard"+ <*> pure (customFields v)+ parseJSON _ = mzero++customFields :: Object -> H.HashMap T.Text T.Text+customFields = H.map stringifyCustomFields+ . H.filterWithKey filterCustomFields+ where+ stringifyCustomFields :: Value -> T.Text+ stringifyCustomFields (String t) = t+ stringifyCustomFields v = T.concat+ . TL.toChunks+ . TLB.toLazyText+ . encodeToTextBuilder+ . toJSON+ $ v++ filterCustomFields k _ = "cf_" `T.isPrefixOf` k++data BugList = BugList [Bug]+ deriving (Eq, Show)++instance FromJSON BugList where+ parseJSON (Object v) = BugList <$> v .: "bugs"+ parseJSON _ = mzero++-- | An attachment to a bug.+data Attachment = Attachment+ { attachmentId :: !AttachmentId+ , attachmentBugId :: !BugId+ , attachmentFileName :: T.Text+ , attachmentSummary :: T.Text+ , attachmentCreator :: UserEmail+ , attachmentIsPrivate :: Bool+ , attachmentIsObsolete :: Bool+ , attachmentIsPatch :: Bool+ , attachmentFlags :: [Flag]+ , attachmentCreationTime :: UTCTime+ , attachmentLastChangeTime :: UTCTime+ , attachmentContentType :: T.Text+ , attachmentSize :: !Int+ , attachmentData :: T.Text+ } deriving (Eq, Show)++instance FromJSON Attachment where+ parseJSON (Object v) = do+ Attachment <$> v .: "id"+ <*> v .: "bug_id"+ <*> v .: "file_name"+ <*> v .: "summary"+ <*> v .: "creator"+ <*> (fromNumericBool <$> v .: "is_private")+ <*> (fromNumericBool <$> v .: "is_obsolete")+ <*> (fromNumericBool <$> v .: "is_patch")+ <*> v .: "flags"+ <*> v .: "creation_time"+ <*> v .: "last_change_time"+ <*> v .: "content_type"+ <*> v .: "size"+ <*> v .: "data"+ parseJSON _ = mzero++fromNumericBool :: Int -> Bool+fromNumericBool 0 = False+fromNumericBool _ = True++data AttachmentList = AttachmentList [Attachment]+ deriving (Eq, Show)++instance FromJSON AttachmentList where+ parseJSON (Object v) = do+ attachmentsVal <- v .: "attachments"+ bugsVal <- v .: "bugs"+ case (attachmentsVal, bugsVal) of+ (Object (H.toList -> [(_, as)]), _) -> AttachmentList . (:[]) <$> parseJSON as+ (_, Object (H.toList -> [(_, as)])) -> AttachmentList <$> parseJSON as+ _ -> mzero+ parseJSON _ = mzero++-- | A bug comment. To display these the way Bugzilla does, you'll+-- need to call 'getUser' and use the 'userRealName' for each user.+data Comment = Comment+ { commentId :: !CommentId+ , commentBugId :: !BugId+ , commentAttachmentId :: Maybe AttachmentId+ , commentCount :: !Int+ , commentText :: T.Text+ , commentCreator :: UserEmail+ , commentCreationTime :: UTCTime+ , commentIsPrivate :: Bool+ } deriving (Eq, Show)++instance FromJSON Comment where+ parseJSON (Object v) = do+ Comment <$> v .: "id"+ <*> v .: "bug_id"+ <*> v .: "attachment_id"+ <*> v .: "count"+ <*> v .: "text"+ <*> v .: "creator"+ <*> v .: "creation_time"+ <*> v .: "is_private"+ parseJSON _ = mzero++data CommentList = CommentList [Comment]+ deriving (Eq, Show)++instance FromJSON CommentList where+ parseJSON (Object v) = do+ bugsVal <- v .: "bugs"+ case bugsVal of+ Object (H.toList -> [(_, cs)]) ->+ do comments <- withObject "comments" (.: "comments") cs+ withArray "comment list" (\a -> CommentList <$> parseJSON (addCount a)) comments+ _ -> mzero+ parseJSON _ = mzero++-- Note that we make the (possibly unwise) assumption that Bugzilla+-- returns the comments in order. If it turns out that's not true, we+-- can always sort by their 'id' to ensure correct results.+addCount :: V.Vector Value -> Value +addCount vs = Array $ V.zipWith addCount' (V.enumFromN 0 $ V.length vs) vs+ where+ addCount' :: Int -> Value -> Value+ addCount' c (Object v) = Object $ H.insert "count" (Number $ fromIntegral c) v+ addCount' _ v = v++-- | History information for a bug.+data History = History+ { historyBugId :: !BugId+ , historyEvents :: [HistoryEvent]+ } deriving (Eq, Show)++instance FromJSON History where+ parseJSON (Object v) = do+ bugsVal <- v .: "bugs"+ case bugsVal of+ Array (V.toList -> [history]) ->+ withObject "history" (\h -> History <$> h .: "id" <*> h .: "history") history+ _ -> mzero+ parseJSON _ = mzero+ +-- | An event in a bug's history.+data HistoryEvent = HistoryEvent+ { historyEventTime :: UTCTime -- ^ When the event occurred.+ , historyEventUser :: UserEmail -- ^ Which user was responsible.+ , historyEventChanges :: [Change] -- ^ All the changes which are+ -- part of this event.+ } deriving (Eq, Show)++instance FromJSON HistoryEvent where+ parseJSON (Object v) = HistoryEvent <$> v .: "when"+ <*> v .: "who"+ <*> v .: "changes"+ parseJSON _ = mzero++-- | A single change which is part of an event. Different constructors+-- are used according to the type of the field. The 'Modification'+-- describes the value of the field before and after the change.+data Change+ = TextFieldChange (Field T.Text) (Modification T.Text)+ | ListFieldChange (Field [T.Text]) (Modification [T.Text])+ | IntFieldChange (Field Int) (Modification Int)+ | TimeFieldChange (Field UTCTime) (Modification UTCTime)+ | BoolFieldChange (Field Bool) (Modification Bool)+ deriving (Eq, Show)++instance FromJSON Change where+ parseJSON (Object v) = do+ changedField <- v .: "field_name"+ case changedField of+ "alias" -> TextFieldChange AliasField <$> parseModification v+ "assigned_to" -> TextFieldChange AssignedToField <$> parseModification v+ "attachments.submitter" -> TextFieldChange AttachmentCreatorField <$> parseModification v+ "attach_data.thedata" -> TextFieldChange AttachmentDataField <$> parseModification v+ "attachments.description"-> TextFieldChange AttachmentDescriptionField <$> parseModification v+ "attachments.filename" -> TextFieldChange AttachmentFilenameField <$> parseModification v+ "attachments.isobsolete" -> BoolFieldChange AttachmentIsObsoleteField <$> parseModification v+ "attachments.ispatch" -> BoolFieldChange AttachmentIsPatchField <$> parseModification v+ "attachments.isprivate" -> BoolFieldChange AttachmentIsPrivateField <$> parseModification v+ "attachments.mimetype" -> TextFieldChange AttachmentMimetypeField <$> parseModification v+ "blocks" -> IntFieldChange BlocksField <$> parseModification v+ "bug_id" -> IntFieldChange BugIdField <$> parseModification v+ "cc" -> TextFieldChange CcField <$> parseModification v+ "is_cc_accessible" -> BoolFieldChange CcListAccessibleField <$> parseModification v+ "classification" -> TextFieldChange ClassificationField <$> parseModification v+ "component" -> TextFieldChange ComponentField <$> parseModification v+ "content" -> TextFieldChange ContentField <$> parseModification v+ "creation_time" -> TimeFieldChange CreationDateField <$> parseModification v+ "days_elapsed" -> IntFieldChange DaysElapsedField <$> parseModification v+ "depends_on" -> IntFieldChange DependsOnField <$> parseModification v+ "everconfirmed" -> BoolFieldChange EverConfirmedField <$> parseModification v+ "flagtypes.name" -> TextFieldChange FlagsField <$> parseModification v+ "bug_group" -> TextFieldChange GroupField <$> parseModification v+ "keywords" -> ListFieldChange KeywordsField <$> parseModification v+ "op_sys" -> TextFieldChange OperatingSystemField <$> parseModification v+ "platform" -> TextFieldChange HardwareField <$> parseModification v+ "priority" -> TextFieldChange PriorityField <$> parseModification v+ "product" -> TextFieldChange ProductField <$> parseModification v+ "qa_contact" -> TextFieldChange QaContactField <$> parseModification v+ "reporter" -> TextFieldChange ReporterField <$> parseModification v+ "reporter_accessible" -> BoolFieldChange ReporterAccessibleField <$> parseModification v+ "resolution" -> TextFieldChange ResolutionField <$> parseModification v+ "restrict_comments" -> BoolFieldChange RestrictCommentsField <$> parseModification v+ "see_also" -> TextFieldChange SeeAlsoField <$> parseModification v+ "severity" -> TextFieldChange SeverityField <$> parseModification v+ "status" -> TextFieldChange StatusField <$> parseModification v+ "whiteboard" -> TextFieldChange WhiteboardField <$> parseModification v+ "summary" -> TextFieldChange SummaryField <$> parseModification v+ "tag" -> TextFieldChange TagsField <$> parseModification v+ "target_milestone" -> TextFieldChange TargetMilestoneField <$> parseModification v+ "url" -> TextFieldChange BugURLField <$> parseModification v+ "version" -> TextFieldChange VersionField <$> parseModification v+ "votes" -> TextFieldChange VotesField <$> parseModification v+ name -> TextFieldChange (CustomField name) <$> parseModification v+ parseJSON _ = mzero+ +-- | A description of how a field changed during a 'HistoryEvent'.+data (Eq a, Show a) => Modification a = Modification+ { modRemoved :: Maybe a+ , modAdded :: Maybe a+ , modAttachmentId :: Maybe AttachmentId+ } deriving (Eq, Show)++parseModification :: (FromJSON a, Eq b, Show b, ToModification a b) => Object -> Parser (Modification b)+parseModification v = Modification <$> (toMod =<< v .: "removed")+ <*> (toMod =<< v .: "added")+ <*> v .:? "attachment_id"++class ToModification a b | b -> a where toMod :: a -> Parser (Maybe b)+instance ToModification T.Text T.Text where toMod = return . Just+instance ToModification UTCTime UTCTime where toMod = return . Just++instance ToModification T.Text Int where+ toMod v | v == "" = return Nothing+ | otherwise = case TR.decimal v of+ Left _ -> mzero+ Right (i, _) -> return $ Just i+ +instance ToModification T.Text Bool where+ toMod v | v == "0" = return $ Just False+ | v == "1" = return $ Just True+ | otherwise = mzero++instance ToModification T.Text [T.Text] where+ toMod v = return . Just $ T.splitOn ", " v
+ src/Web/Bugzilla/Search.hs view
@@ -0,0 +1,120 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE OverloadedStrings #-}++module Web.Bugzilla.Search+( + -- * Search operators+ (.==.)+, (./=.)+, (.<.)+, (.<=.)+, (.>.)+, (.>=.)+, (.=~.)+, (./=~.)+, equalsAny+, contains+, containsCase+, containsAny+, containsAll+, changedBefore+, changedAfter+, changedFrom+, changedTo+, changedBy+, contentMatches+, isEmpty+, (.&&.)+, (.||.)+, not'++ -- * Search expressions+, Field (..)+, SearchExpression+) where++import qualified Data.Text as T+import Data.Time.Clock (UTCTime(..))++import Web.Bugzilla.Internal.Search+import Web.Bugzilla.Internal.Types++(.==.) :: FieldType a => Field a -> a -> SearchExpression+(.==.) = (Term .) . BinaryOp "equals"+infix 4 .==.++(./=.) :: FieldType a => Field a -> a -> SearchExpression+(./=.) = (Term .) . BinaryOp "notequals"+infix 4 ./=.++(.<.) :: FieldType a => Field a -> a -> SearchExpression+(.<.) = (Term .) . BinaryOp "lessthan"+infix 4 .<.++(.<=.) :: FieldType a => Field a -> a -> SearchExpression+(.<=.) = (Term .) . BinaryOp "lessthaneq"+infix 4 .<=.++(.>.) :: FieldType a => Field a -> a -> SearchExpression+(.>.) = (Term .) . BinaryOp "greaterthan"+infix 4 .>.++(.>=.) :: FieldType a => Field a -> a -> SearchExpression+(.>=.) = (Term .) . BinaryOp "greaterthaneq"+infix 4 .>=.++(.=~.) :: FieldType a => Field a -> a -> SearchExpression+(.=~.) = (Term .) . BinaryOp "regexp"++(./=~.) :: FieldType a => Field a -> a -> SearchExpression+(./=~.) = (Term .) . BinaryOp "notregexp"++equalsAny :: FieldType a => Field a -> [a] -> SearchExpression+equalsAny = (Term .) . BinaryOp "anyexact"++contains :: Field T.Text -> T.Text -> SearchExpression+contains = (Term .) . BinaryOp "substring"++containsCase :: Field T.Text -> T.Text -> SearchExpression+containsCase = (Term .) . BinaryOp "casesubstring"++containsAny :: Field T.Text -> [T.Text] -> SearchExpression+containsAny = (Term .) . BinaryOp "anywordssubstr"++containsAll :: Field T.Text -> [T.Text] -> SearchExpression+containsAll = (Term .) . BinaryOp "allwordssubstr"++changedBefore :: FieldType a => Field a -> UTCTime -> SearchExpression+changedBefore = (Term .) . BinaryOp "changedbefore"++changedAfter :: FieldType a => Field a -> UTCTime -> SearchExpression+changedAfter = (Term .) . BinaryOp "changedafter"++changedFrom :: FieldType a => Field a -> a -> SearchExpression+changedFrom = (Term .) . BinaryOp "changedfrom"++changedTo :: FieldType a => Field a -> a -> SearchExpression+changedTo = (Term .) . BinaryOp "changedto"++changedBy :: FieldType a => Field a -> UserEmail -> SearchExpression+changedBy = (Term .) . BinaryOp "changedby"++contentMatches :: T.Text -> SearchExpression+contentMatches = Term . BinaryOp "matches" ContentField++isEmpty :: FieldType a => Field a -> SearchExpression+isEmpty = Term . UnaryOp "isempty"++(.&&.) :: SearchExpression -> SearchExpression -> SearchExpression+(.&&.) a (And as) = And (a:as)+(.&&.) a b = And [a, b]+infixr 3 .&&.++(.||.) :: SearchExpression -> SearchExpression -> SearchExpression+(.||.) a (Or as) = Or (a:as)+(.||.) a b = Or [a, b]+infixr 2 .||.++not' :: SearchExpression -> SearchExpression+not' (Not a) = a+not' a = Not a