diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/bugzilla.cabal b/bugzilla.cabal new file mode 100644 --- /dev/null +++ b/bugzilla.cabal @@ -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 diff --git a/demo/BugzillaDemo.hs b/demo/BugzillaDemo.hs new file mode 100644 --- /dev/null +++ b/demo/BugzillaDemo.hs @@ -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) diff --git a/src/Web/Bugzilla.hs b/src/Web/Bugzilla.hs new file mode 100644 --- /dev/null +++ b/src/Web/Bugzilla.hs @@ -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" diff --git a/src/Web/Bugzilla/Internal/Network.hs b/src/Web/Bugzilla/Internal/Network.hs new file mode 100644 --- /dev/null +++ b/src/Web/Bugzilla/Internal/Network.hs @@ -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 diff --git a/src/Web/Bugzilla/Internal/Search.hs b/src/Web/Bugzilla/Internal/Search.hs new file mode 100644 --- /dev/null +++ b/src/Web/Bugzilla/Internal/Search.hs @@ -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) diff --git a/src/Web/Bugzilla/Internal/Types.hs b/src/Web/Bugzilla/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/Bugzilla/Internal/Types.hs @@ -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 diff --git a/src/Web/Bugzilla/Search.hs b/src/Web/Bugzilla/Search.hs new file mode 100644 --- /dev/null +++ b/src/Web/Bugzilla/Search.hs @@ -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