diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -1,5 +1,17 @@ # bugzilla-redhat version history +## 1.0.0 (2022-02-20) +- rename Web.Bugzilla.RedHat to Web.RedHatBugzilla +- use Network.HTTP.Simple global session Manager +- from 28 Feb 2022 Red Hat Bugzilla only allows API key authentication: +- remove newBugzillaContext and BugzillaContext +- drop loginSession and also BugzillaToken +- bzServer replaces bzContext +- newBzRequest now puts API key in Authorization header +- sendBzRequest no longer takes a session argument +- rename BugzillaApikey to BugzillaApiKey +- rename ApikeySession to ApiKeySession + ## 0.3.3 (2021-10-14) - support building with aeson-2.0 diff --git a/TODO b/TODO --- a/TODO +++ b/TODO @@ -2,6 +2,4 @@ - instance Monoid SearchExpression? -- rename Bugzilla.Redhat to RedHatBugzilla for 0.4 - -- use http-query (http-conduit Simple) +* use http-query diff --git a/bugzilla-redhat.cabal b/bugzilla-redhat.cabal --- a/bugzilla-redhat.cabal +++ b/bugzilla-redhat.cabal @@ -1,11 +1,11 @@ name: bugzilla-redhat -version: 0.3.3 +version: 1.0.0 synopsis: A Haskell interface to the Bugzilla native REST API description: This package is designed to provide an easy-to-use, type-safe interface to querying Bugzilla from Haskell. . This is a friendly fork of Seth Fowler's library, - with minor updates and API tweaks needed for + with updates and API tweaks needed for bugzilla.redhat.com. homepage: https://github.com/juhp/hsbugzilla license: BSD3 @@ -13,7 +13,7 @@ author: Seth Fowler maintainer: Jens Petersen copyright: 2014 Seth Fowler, - 2020-2021 Jens Petersen + 2020-2022 Jens Petersen category: Web build-type: Simple extra-source-files: README.md @@ -31,11 +31,11 @@ library ghc-options: -Wall - exposed-modules: Web.Bugzilla.RedHat, - Web.Bugzilla.RedHat.Search - other-modules: Web.Bugzilla.RedHat.Internal.Network, - Web.Bugzilla.RedHat.Internal.Search, - Web.Bugzilla.RedHat.Internal.Types + exposed-modules: Web.RedHatBugzilla, + Web.RedHatBugzilla.Search + other-modules: Web.RedHatBugzilla.Internal.Network, + Web.RedHatBugzilla.Internal.Search, + Web.RedHatBugzilla.Internal.Types build-depends: base >=4.6 && <5, aeson >=0.7 && <2.1, blaze-builder >=0.3 && <0.5, diff --git a/demo/BugzillaDemo.hs b/demo/BugzillaDemo.hs --- a/demo/BugzillaDemo.hs +++ b/demo/BugzillaDemo.hs @@ -1,7 +1,6 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} -import Control.Exception (bracket) import Control.Monad import Data.Maybe import qualified Data.Text as T @@ -9,25 +8,23 @@ import System.Environment (getArgs) import System.IO -import Web.Bugzilla.RedHat -import Web.Bugzilla.RedHat.Search +import Web.RedHatBugzilla +import Web.RedHatBugzilla.Search main :: IO () -main = dispatch Nothing Nothing =<< getArgs +main = dispatch 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 ["--assigned-to-brief", user] = withBz l s $ doAssignedToBrief (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 +dispatch :: Maybe BugzillaServer -> [String] -> IO () +dispatch Nothing ("--server" : server : as) = dispatch (Just $ T.pack server) as +dispatch s ["--assigned-to", user] = withBz s $ doAssignedTo (T.pack user) +dispatch s ["--assigned-to-brief", user] = withBz s $ doAssignedToBrief (T.pack user) +dispatch s ["--requests", user] = withBz s $ doRequests (T.pack user) +dispatch s ["--history", bug, n] = withBz 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." @@ -35,22 +32,13 @@ >> 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 +withBz :: Maybe BugzillaServer -> (BugzillaSession -> IO ()) + -> IO () +withBz mServer f = do let server = case mServer of Just s -> s Nothing -> error "Please specify a server with '--server'" - ctx <- newBugzillaContext server - 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 + f $ anonymousSession server doAssignedTo :: UserEmail -> BugzillaSession -> IO () @@ -158,9 +146,3 @@ 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/RedHat.hs b/src/Web/Bugzilla/RedHat.hs deleted file mode 100644 --- a/src/Web/Bugzilla/RedHat.hs +++ /dev/null @@ -1,283 +0,0 @@ -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE MultiParamTypeClasses #-} -{-# LANGUAGE OverloadedStrings #-} - --- | This package is designed to provide an easy-to-use, typesafe --- interface to querying Bugzilla from Haskell. --- --- A modified version of Web.Bugzilla to support --- the list fields in Red Hat's modified bugzilla API. --- --- A very simple program using this package might look like this: --- --- > ctx <- newBugzillaContext "https://bugzilla.redhat.com" --- > 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.RedHat -( -- * Connecting to Bugzilla - newBugzillaContext -, loginSession -, apikeySession -, anonymousSession - -, BugzillaServer -, BugzillaContext -, BugzillaSession (..) -, BugzillaToken (..) -, BugzillaApikey (..) - - -- * Querying Bugzilla -, searchBugs -, searchBugsAll -, searchBugs' -, searchBugsWithLimit -, searchBugsAllWithLimit -, searchBugsWithLimit' -, getBug -, getBugAll -, getAttachment -, getAttachments -, getComments -, getHistory -, searchUsers -, getUser -, getUserById -, newBzRequest -, sendBzRequest -, intAsText - -, Request -, BugId -, AttachmentId -, CommentId -, UserId -, EventId -, FlagId -, FlagType -, UserEmail -, Field (..) -, User (..) -, Flag (..) -, Bug (..) -, ExternalBug (..) -, ExternalType (..) -, Attachment (..) -, Comment (..) -, History (..) -, HistoryEvent (..) -, Change (..) -, Modification (..) -, fieldName - -, BugzillaException (..) -) where - -import Control.Exception (throw, try) -import Control.Monad.IO.Class (liftIO) -import Data.Aeson (FromJSON) -import qualified Data.Text as T -import Network.Connection (TLSSettings(..)) -import Network.HTTP.Conduit (mkManagerSettings, newManager) - -import Web.Bugzilla.RedHat.Internal.Network -import Web.Bugzilla.RedHat.Internal.Search -import Web.Bugzilla.RedHat.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 - --- | 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 a 'BugzillaSession' using the provided api key. -apikeySession :: BugzillaContext -> BugzillaApikey -> BugzillaSession -apikeySession = ApikeySession - --- | Creates an anonymous 'BugzillaSession'. Note that some content --- will be hidden by Bugzilla when you make queries in this state. -anonymousSession :: BugzillaContext -> BugzillaSession -anonymousSession = AnonymousSession - -intAsText :: Int -> T.Text -intAsText = T.pack . show - --- | Searches 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 - BugList bugs <- doSearchBugs session search Nothing Nothing - return bugs - --- | Similar to 'searchBugs', but return _all fields. -searchBugsAll :: BugzillaSession -> SearchExpression -> IO [Bug] -searchBugsAll session search = do - BugList bugs <- doSearchBugs session search (Just "_all") Nothing - return bugs - --- | Like 'searchBugs', but returns a list of 'BugId's. You can --- retrieve the 'Bug' for each 'BugId' using 'getBug'. The combination --- of 'searchBugs'' and 'getBug' is much less efficient than --- 'searchBugs'. 'searchBugs'' is suitable for cases where you won't need to call --- 'getBug' most of the time - for example, polling to determine whether the --- set of bugs returned by a query has changed. -searchBugs' :: BugzillaSession -> SearchExpression -> IO [BugId] -searchBugs' session search = do - BugIdList bugs <- doSearchBugs session search (Just "id") Nothing - return bugs - -doSearchBugs :: FromJSON a => BugzillaSession -> SearchExpression -> Maybe T.Text -> Maybe (Int, Int) -> IO a -doSearchBugs session search includeField limits = do - let fieldsQuery = case includeField of - Nothing -> [] - Just field -> [("include_fields", Just field)] - limitQuery = case limits of - Nothing -> [] - Just (limit, offset) -> [("limit", Just $ intAsText limit), - ("offset", Just $ intAsText offset)] - searchQuery = evalSearchExpr search - req = newBzRequest session ["bug"] (limitQuery ++ fieldsQuery ++ searchQuery) - sendBzRequest session req - --- | 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 - BugList bugs <- doSearchBugs session search Nothing (Just (limit, offset)) - return bugs - --- | Similar to 'searchBugsWithLimit', but return _all fields. -searchBugsAllWithLimit :: BugzillaSession - -> Int -- ^ The maximum number of results to return. - -> Int -- ^ The offset from the first result to start from. - -> SearchExpression - -> IO [Bug] -searchBugsAllWithLimit session limit offset search = do - BugList bugs <- doSearchBugs session search (Just "_all") (Just (limit, offset)) - return bugs - --- | Like 'searchBugsWithLimit', but returns a list of 'BugId's. See --- 'searchBugs'' for more discussion. -searchBugsWithLimit' :: BugzillaSession - -> Int -- ^ The maximum number of results to return. - -> Int -- ^ The offset from the first result to start from. - -> SearchExpression - -> IO [BugId] -searchBugsWithLimit' session limit offset search = do - BugIdList bugs <- doSearchBugs session search (Just "id") (Just (limit, offset)) - return bugs - --- | Retrieve a bug by bug number. -getBug :: BugzillaSession -> BugId -> IO (Maybe Bug) -getBug session bid = getBugIncludeFields session bid [] - --- | Retrieve all bug field by bug number -getBugAll :: BugzillaSession -> BugId -> IO (Maybe Bug) -getBugAll session bid = getBugIncludeFields session bid ["_all"] - --- | Retrieve a bug by bug number with fields -getBugIncludeFields :: BugzillaSession -> BugId -> [T.Text] -> IO (Maybe Bug) -getBugIncludeFields session bid includeFields = do - let req = newBzRequest session ["bug", intAsText bid] query - (BugList bugs) <- sendBzRequest session req - case bugs of - [bug] -> return $ Just bug - [] -> return Nothing - _ -> throw $ BugzillaUnexpectedValue - "Request for a single bug returned multiple bugs" - where - query = map (\f -> ("include_fields", Just f)) includeFields - --- | 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/RedHat/Internal/Network.hs b/src/Web/Bugzilla/RedHat/Internal/Network.hs deleted file mode 100644 --- a/src/Web/Bugzilla/RedHat/Internal/Network.hs +++ /dev/null @@ -1,127 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} - -module Web.Bugzilla.RedHat.Internal.Network -( BugzillaServer -, BugzillaContext (..) -, BugzillaApikey (..) -, BugzillaToken (..) -, BugzillaSession (..) -, BugzillaException (..) -, QueryPart -, Request -, requestUrl -, newBzRequest -, sendBzRequest -) where - -import Blaze.ByteString.Builder (toByteString) -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative ((<$>), (<*>)) -#endif -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 Data.Maybe (fromMaybe) -import qualified Data.ByteString as B -import qualified Data.ByteString.Lazy as BL -#if !MIN_VERSION_base(4,11,0) -import Data.Monoid ((<>)) -#endif -import qualified Data.Text as T -import qualified Data.Text.Encoding as TE -import Data.Typeable -import Network.HTTP.Conduit (Manager, Request(..), Response(..), defaultRequest, host, httpLbs, path, queryString, secure, parseRequest) -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' to create one. -data BugzillaContext = BugzillaContext - { bzServer :: BugzillaServer - , bzManager :: Manager - } - -newtype BugzillaToken = BugzillaToken T.Text - -newtype BugzillaApikey = BugzillaApikey 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 - | ApikeySession BugzillaContext BugzillaApikey - -bzContext :: BugzillaSession -> BugzillaContext -bzContext (AnonymousSession ctx) = ctx -bzContext (LoginSession ctx _) = ctx -bzContext (ApikeySession 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 = - defaultRequest { - secure = True, - port = 443 - } - -newBzRequest :: BugzillaSession -> [T.Text] -> QueryText -> Request -newBzRequest session methodParts query = - baseRequest { - path = toByteString $ encodePathSegments $ "rest" : methodParts, - queryString = toByteString $ renderQueryText True queryWithToken - } - where - -- Try to parse the bzServer first, if it has a scheme then use it as the base request, - -- otherwise force a secure ssl request. - baseRequest :: Request - baseRequest = fromMaybe (sslRequest { host = serverBytes }) (parseRequest serverStr) - serverBytes = TE.encodeUtf8 serverTxt - serverStr = T.unpack serverTxt - serverTxt = bzServer . bzContext $ session - queryWithToken = case session of - AnonymousSession _ -> query - LoginSession _ (BugzillaToken token) -> ("token", Just token) : query - ApikeySession _ (BugzillaApikey token) -> ("api_key", 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/RedHat/Internal/Search.hs b/src/Web/Bugzilla/RedHat/Internal/Search.hs deleted file mode 100644 --- a/src/Web/Bugzilla/RedHat/Internal/Search.hs +++ /dev/null @@ -1,90 +0,0 @@ -{-# 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.RedHat.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.RedHat.Internal.Network -import Web.Bugzilla.RedHat.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 - EqTerm :: (FieldType a, FieldType b) => 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 -evalSearchTerm _ (EqTerm field val) = [(searchFieldName field, Just . fvAsText $ 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/RedHat/Internal/Types.hs b/src/Web/Bugzilla/RedHat/Internal/Types.hs deleted file mode 100644 --- a/src/Web/Bugzilla/RedHat/Internal/Types.hs +++ /dev/null @@ -1,747 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE FunctionalDependencies #-} -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} - -module Web.Bugzilla.RedHat.Internal.Types -( BugId -, AttachmentId -, CommentId -, UserId -, EventId -, FlagId -, FlagType -, UserEmail -, Field (..) -, User (..) -, UserList (..) -, Flag (..) -, ExternalType (..) -, ExternalBug (..) -, Bug (..) -, BugList (..) -, BugIdList (..) -, Attachment (..) -, AttachmentList (..) -, Comment (..) -, CommentList (..) -, History (..) -, HistoryEvent (..) -, Change (..) -, Modification (..) -, fieldName -, searchFieldName -) where - -#if !MIN_VERSION_base(4,8,0) -import Control.Applicative (pure, (<$>), (<*>)) -#endif -import Control.Monad (mzero) -import Data.Aeson -#if MIN_VERSION_aeson(1,0,0) -import Data.Aeson.Text -#else -import Data.Aeson.Encode -#endif -import Data.Aeson.Types -#if MIN_VERSION_aeson(2,0,0) -import Data.Aeson.Key -import qualified Data.Aeson.KeyMap as M -#else -import qualified Data.HashMap.Strict as M -#endif -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 EventId = 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 :: Maybe UserEmail - , 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 - -newtype 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 - --- | An external bug type -data ExternalType = ExternalType - { externalTypeDescription :: T.Text - , externalTypeUrl :: T.Text - , externalTypeId :: Int - , externalTypeType :: T.Text - , externalTypeFullUrl :: T.Text - } deriving (Eq, Ord, Show) - -instance FromJSON ExternalType where - parseJSON (Object v) = - ExternalType <$> v .: "description" - <*> v .: "url" - <*> v .: "id" - <*> v .: "type" - <*> v .: "full_url" - parseJSON _ = mzero - --- | An external bug. -data ExternalBug = ExternalBug - { externalDescription :: T.Text - , externalBzId :: Int - , externalPriority :: T.Text - , externalBugId :: T.Text - , externalStatus :: T.Text - , externalId :: Int - , externalType :: ExternalType - } deriving (Eq, Ord, Show) - -instance FromJSON ExternalBug where - parseJSON (Object v) = - ExternalBug <$> v .: "ext_description" - <*> v .: "ext_bz_id" - <*> v .: "ext_priority" - <*> v .: "ext_bz_bug_id" - <*> v .: "ext_status" - <*> v .: "id" - <*> v .: "type" - 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 :: Maybe [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 :: -#if MIN_VERSION_aeson(2,0,0) - M.KeyMap T.Text -#else - M.HashMap T.Text T.Text -#endif -, bugExternalBugs :: Maybe [ExternalBug] - } 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) - <*> v .:? "external_bugs" - parseJSON _ = mzero - -customFields :: Object -> -#if MIN_VERSION_aeson(2,0,0) - M.KeyMap T.Text -#else - M.HashMap T.Text T.Text -#endif -customFields = M.map stringifyCustomFields - . M.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` toText k -#if !MIN_VERSION_aeson(2,0,0) - where toText = id -#endif - -newtype BugList = BugList [Bug] - deriving (Eq, Show) - -instance FromJSON BugList where - parseJSON (Object v) = BugList <$> v .: "bugs" - parseJSON _ = mzero - -newtype BugIdList = BugIdList [BugId] - deriving (Eq, Show) - -instance FromJSON BugIdList where - parseJSON (Object v) = do - bugs <- v .: "bugs" - bugIds <- mapM (.: "id") bugs - return $ BugIdList bugIds - 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) = - 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 - -newtype 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 (M.toList -> [(_, as)]), _) -> AttachmentList . (:[]) <$> parseJSON as - (_, Object (M.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) = - Comment <$> v .: "id" - <*> v .: "bug_id" - <*> v .: "attachment_id" - <*> v .: "count" - <*> v .: "text" - <*> v .: "creator" - <*> v .: "creation_time" - <*> v .: "is_private" - parseJSON _ = mzero - -newtype CommentList = CommentList [Comment] - deriving (Eq, Show) - -instance FromJSON CommentList where - parseJSON (Object v) = do - bugsVal <- v .: "bugs" - case bugsVal of - Object (M.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 $ M.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" - <*> parseHistoryEvents h) - history - _ -> mzero - parseJSON _ = mzero - -parseHistoryEvents :: Object -> Parser [HistoryEvent] -parseHistoryEvents h = do - events <- h .: "history" - withArray "event list" (parseJSON . addCount) events - --- | An event in a bug's history. -data HistoryEvent = HistoryEvent - { historyEventId :: EventId -- ^ A sequential event id. - , 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 .: "count" - <*> 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" -> ListFieldChange 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" -> ListFieldChange 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/RedHat/Search.hs b/src/Web/Bugzilla/RedHat/Search.hs deleted file mode 100644 --- a/src/Web/Bugzilla/RedHat/Search.hs +++ /dev/null @@ -1,147 +0,0 @@ -{-# LANGUAGE GADTs #-} -{-# LANGUAGE OverloadedStrings #-} - --- | A modified version of Web.Bugzilla.Search to support --- the list fields in Red Hat's modified bugzilla API. - -module Web.Bugzilla.RedHat.Search -( - -- * Search operators - (.==.) -, (./=.) -, (.<.) -, (.<=.) -, (.>.) -, (.>=.) -, (.=~.) -, (./=~.) -, equalsAny -, contains -, containsCase -, containsAny -, containsAll -, changedBefore -, changedAfter -, changedSince -, changedUntil -, changedRange -, changedFrom -, changedTo -, changedBy -, contentMatches -, isEmpty -, isNotEmpty -, (.&&.) -, (.||.) -, not' - - -- * Search expressions -, Field (..) -, SearchExpression -, evalSearchExpr -) where - -import qualified Data.Text as T -import Data.Time.Clock (UTCTime(..)) - -import Web.Bugzilla.RedHat.Internal.Search -import Web.Bugzilla.RedHat.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" - --- | Filter bug changed since UTCTime -changedSince :: UTCTime -> SearchExpression -changedSince ts = Term $ EqTerm (CustomField "chfieldfrom") ts - --- | Filter bug changed until UTCTime -changedUntil :: UTCTime -> SearchExpression -changedUntil ts = Term $ EqTerm (CustomField "chfieldto") ts - --- | Filter bug changed in range -changedRange :: UTCTime -> UTCTime -> SearchExpression -changedRange from to = changedSince from .&&. changedUntil to - -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" - -isNotEmpty :: FieldType a => Field a -> SearchExpression -isNotEmpty = Term . UnaryOp "isnotempty" - -(.&&.) :: SearchExpression -> SearchExpression -> SearchExpression -(.&&.) (And as) (And bs) = And (as ++ bs) -(.&&.) (And as) a = And (as ++ [a]) -(.&&.) a (And as) = And (a:as) -(.&&.) a b = And [a, b] -infixr 3 .&&. - -(.||.) :: SearchExpression -> SearchExpression -> SearchExpression -(.||.) (Or as) (Or bs) = Or (as ++ bs) -(.||.) a (Or as) = Or (a:as) -(.||.) (Or as) a = Or (as ++ [a]) -(.||.) a b = Or [a, b] -infixr 2 .||. - -not' :: SearchExpression -> SearchExpression -not' (Not a) = a -not' a = Not a diff --git a/src/Web/RedHatBugzilla.hs b/src/Web/RedHatBugzilla.hs new file mode 100644 --- /dev/null +++ b/src/Web/RedHatBugzilla.hs @@ -0,0 +1,249 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | This package is designed to provide an easy-to-use, typesafe +-- interface to querying Bugzilla from Haskell. +-- +-- A modified version of Web.Bugzilla to support +-- the list fields in Red Hat's modified bugzilla API. +-- +-- A very simple program using this package might look like this: +-- +-- > let session = anonymousSession "https://bugzilla.redhat.com" +-- > 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 more in-depth demo program included with the +-- source code to this package. + +module Web.RedHatBugzilla +( -- * Connecting to Bugzilla + apikeySession +, anonymousSession + +, BugzillaServer +, BugzillaSession (..) +, BugzillaApiKey (..) + + -- * Querying Bugzilla +, searchBugs +, searchBugsAll +, searchBugs' +, searchBugsWithLimit +, searchBugsAllWithLimit +, searchBugsWithLimit' +, getBug +, getBugAll +, getAttachment +, getAttachments +, getComments +, getHistory +, searchUsers +, getUser +, getUserById +, newBzRequest +, sendBzRequest +, intAsText + +, Request +, BugId +, AttachmentId +, CommentId +, UserId +, EventId +, FlagId +, FlagType +, UserEmail +, Field (..) +, User (..) +, Flag (..) +, Bug (..) +, ExternalBug (..) +, ExternalType (..) +, Attachment (..) +, Comment (..) +, History (..) +, HistoryEvent (..) +, Change (..) +, Modification (..) +, fieldName + +, BugzillaException (..) +) where + +import Control.Exception (throw) +import Data.Aeson (FromJSON) +import qualified Data.Text as T + +import Web.RedHatBugzilla.Internal.Network +import Web.RedHatBugzilla.Internal.Search +import Web.RedHatBugzilla.Internal.Types + +-- | Creates a 'BugzillaSession' using the provided api key. +apikeySession :: BugzillaServer -> BugzillaApiKey -> BugzillaSession +apikeySession = ApiKeySession + +-- | Creates an anonymous 'BugzillaSession'. Note that some content +-- will be hidden by Bugzilla when you make queries in this state. +anonymousSession :: BugzillaServer -> BugzillaSession +anonymousSession = AnonymousSession + +intAsText :: Int -> T.Text +intAsText = T.pack . show + +-- | Searches 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 + BugList bugs <- doSearchBugs session search Nothing Nothing + return bugs + +-- | Similar to 'searchBugs', but return _all fields. +searchBugsAll :: BugzillaSession -> SearchExpression -> IO [Bug] +searchBugsAll session search = do + BugList bugs <- doSearchBugs session search (Just "_all") Nothing + return bugs + +-- | Like 'searchBugs', but returns a list of 'BugId's. You can +-- retrieve the 'Bug' for each 'BugId' using 'getBug'. The combination +-- of 'searchBugs'' and 'getBug' is much less efficient than +-- 'searchBugs'. 'searchBugs'' is suitable for cases where you won't need to call +-- 'getBug' most of the time - for example, polling to determine whether the +-- set of bugs returned by a query has changed. +searchBugs' :: BugzillaSession -> SearchExpression -> IO [BugId] +searchBugs' session search = do + BugIdList bugs <- doSearchBugs session search (Just "id") Nothing + return bugs + +doSearchBugs :: FromJSON a => BugzillaSession -> SearchExpression -> Maybe T.Text -> Maybe (Int, Int) -> IO a +doSearchBugs session search includeField limits = do + let fieldsQuery = case includeField of + Nothing -> [] + Just field -> [("include_fields", Just field)] + limitQuery = case limits of + Nothing -> [] + Just (limit, offset) -> [("limit", Just $ intAsText limit), + ("offset", Just $ intAsText offset)] + searchQuery = evalSearchExpr search + req = newBzRequest session ["bug"] (limitQuery ++ fieldsQuery ++ searchQuery) + sendBzRequest req + +-- | 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 + BugList bugs <- doSearchBugs session search Nothing (Just (limit, offset)) + return bugs + +-- | Similar to 'searchBugsWithLimit', but return _all fields. +searchBugsAllWithLimit :: BugzillaSession + -> Int -- ^ The maximum number of results to return. + -> Int -- ^ The offset from the first result to start from. + -> SearchExpression + -> IO [Bug] +searchBugsAllWithLimit session limit offset search = do + BugList bugs <- doSearchBugs session search (Just "_all") (Just (limit, offset)) + return bugs + +-- | Like 'searchBugsWithLimit', but returns a list of 'BugId's. See +-- 'searchBugs'' for more discussion. +searchBugsWithLimit' :: BugzillaSession + -> Int -- ^ The maximum number of results to return. + -> Int -- ^ The offset from the first result to start from. + -> SearchExpression + -> IO [BugId] +searchBugsWithLimit' session limit offset search = do + BugIdList bugs <- doSearchBugs session search (Just "id") (Just (limit, offset)) + return bugs + +-- | Retrieve a bug by bug number. +getBug :: BugzillaSession -> BugId -> IO (Maybe Bug) +getBug session bid = getBugIncludeFields session bid [] + +-- | Retrieve all bug field by bug number +getBugAll :: BugzillaSession -> BugId -> IO (Maybe Bug) +getBugAll session bid = getBugIncludeFields session bid ["_all"] + +-- | Retrieve a bug by bug number with fields +getBugIncludeFields :: BugzillaSession -> BugId -> [T.Text] -> IO (Maybe Bug) +getBugIncludeFields session bid includeFields = do + let req = newBzRequest session ["bug", intAsText bid] query + (BugList bugs) <- sendBzRequest req + case bugs of + [bug] -> return $ Just bug + [] -> return Nothing + _ -> throw $ BugzillaUnexpectedValue + "Request for a single bug returned multiple bugs" + where + query = map (\f -> ("include_fields", Just f)) includeFields + +-- | 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 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 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 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 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 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 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 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/RedHatBugzilla/Internal/Network.hs b/src/Web/RedHatBugzilla/Internal/Network.hs new file mode 100644 --- /dev/null +++ b/src/Web/RedHatBugzilla/Internal/Network.hs @@ -0,0 +1,114 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE OverloadedStrings #-} + +module Web.RedHatBugzilla.Internal.Network +( BugzillaServer +, BugzillaApiKey (..) +, BugzillaSession (..) +, BugzillaException (..) +, QueryPart +, Request +, requestUrl +, newBzRequest +, sendBzRequest +) where + +import Blaze.ByteString.Builder (toByteString) +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative ((<$>), (<*>)) +#endif +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 Data.Maybe (fromMaybe) +import qualified Data.ByteString as B +import qualified Data.ByteString.Lazy as BL +#if !MIN_VERSION_base(4,11,0) +import Data.Monoid ((<>)) +#endif +import qualified Data.Text as T +import qualified Data.Text.Encoding as TE +import Data.Typeable +import Network.HTTP.Simple (defaultRequest, httpLBS, parseRequest) +import Network.HTTP.Conduit (Request(..), Response(..), host, path, port, + queryString, requestHeaders, secure) +import Network.HTTP.Types.URI (QueryText, encodePathSegments, renderQueryText) + +type BugzillaServer = T.Text + +newtype BugzillaApiKey = BugzillaApiKey T.Text + +-- | A session for Bugzilla queries. Use 'anonymousSession' and +-- 'loginSession', as appropriate, to create one. +data BugzillaSession = AnonymousSession BugzillaServer + | ApiKeySession BugzillaServer BugzillaApiKey + +bzServer :: BugzillaSession -> BugzillaServer +bzServer (AnonymousSession svr) = svr +bzServer (ApiKeySession svr _) = svr + +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 = + defaultRequest { + secure = True, + port = 443 + } + +newBzRequest :: BugzillaSession -> [T.Text] -> QueryText -> Request +newBzRequest session methodParts query = + let req = + baseRequest { + path = toByteString $ encodePathSegments $ "rest" : methodParts, + queryString = toByteString $ renderQueryText True query + } + in case session of + ApiKeySession _ (BugzillaApiKey key) -> + req { requestHeaders = [("Authorization", + "Bearer " <> TE.encodeUtf8 key)] } + _ -> req + where + -- Try to parse the bzServer first, if it has a scheme then use it as the base request, + -- otherwise force a secure ssl request. + baseRequest :: Request + baseRequest = fromMaybe (sslRequest { host = serverBytes }) (parseRequest serverStr) + serverBytes = TE.encodeUtf8 serverTxt + serverStr = T.unpack serverTxt + serverTxt = bzServer session + +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 => Request -> IO a +sendBzRequest req = runResourceT $ do + response <- liftIO $ httpLBS req + let mResult = eitherDecode $ responseBody response + case mResult of + Left msg -> liftIO $ handleError msg (responseBody response) + Right decoded -> return decoded diff --git a/src/Web/RedHatBugzilla/Internal/Search.hs b/src/Web/RedHatBugzilla/Internal/Search.hs new file mode 100644 --- /dev/null +++ b/src/Web/RedHatBugzilla/Internal/Search.hs @@ -0,0 +1,90 @@ +{-# 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.RedHatBugzilla.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.RedHatBugzilla.Internal.Network +import Web.RedHatBugzilla.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 + EqTerm :: (FieldType a, FieldType b) => 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 +evalSearchTerm _ (EqTerm field val) = [(searchFieldName field, Just . fvAsText $ 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/RedHatBugzilla/Internal/Types.hs b/src/Web/RedHatBugzilla/Internal/Types.hs new file mode 100644 --- /dev/null +++ b/src/Web/RedHatBugzilla/Internal/Types.hs @@ -0,0 +1,747 @@ +{-# LANGUAGE CPP #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE FunctionalDependencies #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ViewPatterns #-} + +module Web.RedHatBugzilla.Internal.Types +( BugId +, AttachmentId +, CommentId +, UserId +, EventId +, FlagId +, FlagType +, UserEmail +, Field (..) +, User (..) +, UserList (..) +, Flag (..) +, ExternalType (..) +, ExternalBug (..) +, Bug (..) +, BugList (..) +, BugIdList (..) +, Attachment (..) +, AttachmentList (..) +, Comment (..) +, CommentList (..) +, History (..) +, HistoryEvent (..) +, Change (..) +, Modification (..) +, fieldName +, searchFieldName +) where + +#if !MIN_VERSION_base(4,8,0) +import Control.Applicative (pure, (<$>), (<*>)) +#endif +import Control.Monad (mzero) +import Data.Aeson +#if MIN_VERSION_aeson(1,0,0) +import Data.Aeson.Text +#else +import Data.Aeson.Encode +#endif +import Data.Aeson.Types +#if MIN_VERSION_aeson(2,0,0) +import Data.Aeson.Key +import qualified Data.Aeson.KeyMap as M +#else +import qualified Data.HashMap.Strict as M +#endif +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 EventId = 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 :: Maybe UserEmail + , 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 + +newtype 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 + +-- | An external bug type +data ExternalType = ExternalType + { externalTypeDescription :: T.Text + , externalTypeUrl :: T.Text + , externalTypeId :: Int + , externalTypeType :: T.Text + , externalTypeFullUrl :: T.Text + } deriving (Eq, Ord, Show) + +instance FromJSON ExternalType where + parseJSON (Object v) = + ExternalType <$> v .: "description" + <*> v .: "url" + <*> v .: "id" + <*> v .: "type" + <*> v .: "full_url" + parseJSON _ = mzero + +-- | An external bug. +data ExternalBug = ExternalBug + { externalDescription :: T.Text + , externalBzId :: Int + , externalPriority :: T.Text + , externalBugId :: T.Text + , externalStatus :: T.Text + , externalId :: Int + , externalType :: ExternalType + } deriving (Eq, Ord, Show) + +instance FromJSON ExternalBug where + parseJSON (Object v) = + ExternalBug <$> v .: "ext_description" + <*> v .: "ext_bz_id" + <*> v .: "ext_priority" + <*> v .: "ext_bz_bug_id" + <*> v .: "ext_status" + <*> v .: "id" + <*> v .: "type" + 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 :: Maybe [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 :: +#if MIN_VERSION_aeson(2,0,0) + M.KeyMap T.Text +#else + M.HashMap T.Text T.Text +#endif +, bugExternalBugs :: Maybe [ExternalBug] + } 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) + <*> v .:? "external_bugs" + parseJSON _ = mzero + +customFields :: Object -> +#if MIN_VERSION_aeson(2,0,0) + M.KeyMap T.Text +#else + M.HashMap T.Text T.Text +#endif +customFields = M.map stringifyCustomFields + . M.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` toText k +#if !MIN_VERSION_aeson(2,0,0) + where toText = id +#endif + +newtype BugList = BugList [Bug] + deriving (Eq, Show) + +instance FromJSON BugList where + parseJSON (Object v) = BugList <$> v .: "bugs" + parseJSON _ = mzero + +newtype BugIdList = BugIdList [BugId] + deriving (Eq, Show) + +instance FromJSON BugIdList where + parseJSON (Object v) = do + bugs <- v .: "bugs" + bugIds <- mapM (.: "id") bugs + return $ BugIdList bugIds + 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) = + 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 + +newtype 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 (M.toList -> [(_, as)]), _) -> AttachmentList . (:[]) <$> parseJSON as + (_, Object (M.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) = + Comment <$> v .: "id" + <*> v .: "bug_id" + <*> v .: "attachment_id" + <*> v .: "count" + <*> v .: "text" + <*> v .: "creator" + <*> v .: "creation_time" + <*> v .: "is_private" + parseJSON _ = mzero + +newtype CommentList = CommentList [Comment] + deriving (Eq, Show) + +instance FromJSON CommentList where + parseJSON (Object v) = do + bugsVal <- v .: "bugs" + case bugsVal of + Object (M.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 $ M.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" + <*> parseHistoryEvents h) + history + _ -> mzero + parseJSON _ = mzero + +parseHistoryEvents :: Object -> Parser [HistoryEvent] +parseHistoryEvents h = do + events <- h .: "history" + withArray "event list" (parseJSON . addCount) events + +-- | An event in a bug's history. +data HistoryEvent = HistoryEvent + { historyEventId :: EventId -- ^ A sequential event id. + , 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 .: "count" + <*> 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" -> ListFieldChange 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" -> ListFieldChange 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/RedHatBugzilla/Search.hs b/src/Web/RedHatBugzilla/Search.hs new file mode 100644 --- /dev/null +++ b/src/Web/RedHatBugzilla/Search.hs @@ -0,0 +1,146 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | A modified version of Web.Bugzilla.Search to support +-- the list fields in Red Hat's modified bugzilla API. + +module Web.RedHatBugzilla.Search +( + -- * Search operators + (.==.) +, (./=.) +, (.<.) +, (.<=.) +, (.>.) +, (.>=.) +, (.=~.) +, (./=~.) +, equalsAny +, contains +, containsCase +, containsAny +, containsAll +, changedBefore +, changedAfter +, changedSince +, changedUntil +, changedRange +, changedFrom +, changedTo +, changedBy +, contentMatches +, isEmpty +, isNotEmpty +, (.&&.) +, (.||.) +, not' + + -- * Search expressions +, Field (..) +, SearchExpression +, evalSearchExpr +) where + +import qualified Data.Text as T +import Data.Time.Clock (UTCTime(..)) + +import Web.RedHatBugzilla.Internal.Search +import Web.RedHatBugzilla.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" + +-- | Filter bug changed since UTCTime +changedSince :: UTCTime -> SearchExpression +changedSince ts = Term $ EqTerm (CustomField "chfieldfrom") ts + +-- | Filter bug changed until UTCTime +changedUntil :: UTCTime -> SearchExpression +changedUntil ts = Term $ EqTerm (CustomField "chfieldto") ts + +-- | Filter bug changed in range +changedRange :: UTCTime -> UTCTime -> SearchExpression +changedRange from to = changedSince from .&&. changedUntil to + +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" + +isNotEmpty :: FieldType a => Field a -> SearchExpression +isNotEmpty = Term . UnaryOp "isnotempty" + +(.&&.) :: SearchExpression -> SearchExpression -> SearchExpression +(.&&.) (And as) (And bs) = And (as ++ bs) +(.&&.) (And as) a = And (as ++ [a]) +(.&&.) a (And as) = And (a:as) +(.&&.) a b = And [a, b] +infixr 3 .&&. + +(.||.) :: SearchExpression -> SearchExpression -> SearchExpression +(.||.) (Or as) (Or bs) = Or (as ++ bs) +(.||.) a (Or as) = Or (a:as) +(.||.) (Or as) a = Or (as ++ [a]) +(.||.) a b = Or [a, b] +infixr 2 .||. + +not' :: SearchExpression -> SearchExpression +not' (Not a) = a +not' a = Not a diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -4,7 +4,7 @@ module Main (main) where import Test.Hspec -import Web.Bugzilla.RedHat.Search +import Web.RedHatBugzilla.Search main :: IO () main = hspec spec