diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +The MIT License (MIT) + +Copyright (c) 2014 Charles St-Pierre + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Redmine.cabal b/Redmine.cabal new file mode 100644 --- /dev/null +++ b/Redmine.cabal @@ -0,0 +1,38 @@ +name: Redmine +version: 0.0.1 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: "LICENSE" +maintainer: charles.stpierre@gmail.com +synopsis: Library to access Redmine's REST services +description: Library to access Redmine's REST services +author: Charles St-Pierre +category: Network, Web +homepage: https://github.com/lookunder/RedmineHs +data-dir: "" + +source-repository head + type: git + location: https://github.com/lookunder/RedmineHs.git + +Library + default-language: Haskell2010 + build-depends: base >=2 && <5, old-locale -any, + time -any, old-time -any, bytestring -any, http-conduit >= 2.1.0, + aeson -any, HTTP -any, network -any, text, + transformers, containers, http-client-tls, + resourcet, connection, MissingH + exposed-modules: Redmine.Types, Redmine.Manager, Redmine.Get + buildable: True + hs-source-dirs: src + +test-suite test-Redmine + default-language: Haskell2010 + build-depends: base >=2 && <5, HUnit, text, MissingH, resourcet, transformers, old-locale, time, + http-conduit >= 2.1.0, http-client-tls, connection, network, bytestring, aeson, containers + type: exitcode-stdio-1.0 + main-is: testGet.hs + buildable: True + cpp-options: -DMAIN_FUNCTION=main + hs-source-dirs: testsuite, src diff --git a/Setup.lhs b/Setup.lhs new file mode 100644 --- /dev/null +++ b/Setup.lhs @@ -0,0 +1,6 @@ +#!/usr/bin/runhaskell +> module Main where +> import Distribution.Simple +> main :: IO () +> main = defaultMain + diff --git a/src/Redmine/Get.hs b/src/Redmine/Get.hs new file mode 100644 --- /dev/null +++ b/src/Redmine/Get.hs @@ -0,0 +1,383 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Redmine.Get ( getTimeEntries + , getTimeEntriesForIssue + , getIssue + , getIssues + , getProjects + , getProjectForId + , getProject + , getVersions + , getUser + , expandOptions + , increaseQueryRange + ) where + +import Data.Aeson +import Data.Maybe +import Data.Monoid +import qualified Data.Map as Map +import Data.Tuple +import Redmine.Types +import Redmine.Manager +import Control.Applicative ((<$>), (<*>), pure) +import qualified Data.ByteString as S +import qualified Data.ByteString.Char8 as S8 +import qualified Data.ByteString.Lazy as L +import Network +import Network.Connection (TLSSettings (..)) +import Network.HTTP.Conduit +import Network.HTTP.Client.TLS +import Network.HTTP.Client.Conduit (defaultManagerSettings) +import Data.Time.Format (parseTime) +import Data.Time.Clock (UTCTime) +import Data.Time.Calendar (Day) +import System.Locale (defaultTimeLocale) +import Control.Monad (liftM) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Maybe +import Control.Monad.Trans.Resource +import Data.String.Utils +import Debug.Trace +import qualified Data.Text as T + +parseRHTime :: String -> Maybe UTCTime +parseRHTime = parseTime defaultTimeLocale "%FT%X%QZ" + +parseShortTime :: String -> Maybe Day +parseShortTime = parseTime defaultTimeLocale "%F" + +queryRedmine :: RedmineMng -> S.ByteString -> IO L.ByteString +queryRedmine mng req = do + request <- creerRqt mng req + let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing + response <- withManagerSettings settings $ httpLbs request + return $ responseBody response + +creerRqt :: RedmineMng -> S.ByteString -> IO Request +creerRqt (RedmineMng h) r = parseUrl $ S8.unpack (h <> r) +creerRqt (RedmineMngWithProxy h u p) r = fmap (addProxy u p) (creerRqt (RedmineMng h) r) +creerRqt (RedmineMngWithAuth h l pass) r = fmap (applyBasicAuth l pass) (creerRqt (RedmineMng h) r) +creerRqt (RedmineMngWithAuthAndProxy h l pass u p) r = fmap (applyBasicAuth l pass) (creerRqt (RedmineMngWithProxy h u p) r) + +type ParamRest = Map.Map S.ByteString S.ByteString + +-- Remplace par urlEncodedBody +expandOptions :: ParamRest -> S.ByteString +expandOptions = Map.foldrWithKey (\k a res -> res <> k <> "=" <> a <> "&") "?" + +bsAInt :: S.ByteString -> Int +bsAInt = read . S8.unpack + +increaseQueryRange :: ParamRest -> ParamRest +increaseQueryRange param = + let offset = bsAInt $ Map.findWithDefault "0" "offset" param + limit = bsAInt $ Map.findWithDefault "100" "limit" param + nouvelOffset = offset + limit + in Map.insert "offset" (S8.pack $ show nouvelOffset) param + +-- Réécrire avec les autres modes +queryRedmineAvecOptions :: (FromJSON a, Monoid a, Collection a) => + RedmineMng -> S.ByteString -> ParamRest -> Manager -> IO( Maybe a) +queryRedmineAvecOptions redmineMng req param mng = -- MaybeT IO $ withSocketsDo $ + do + request <- creerRqt redmineMng (req <> expandOptions param) + --traceM (S8.unpack $ (req <> (expandOptions param))) + let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing + response <- withManagerSettings settings $ httpLbs request + parsedRes <- debugResult . eitherDecode . responseBody $ response + --putStrLn $ show parsedRes + case parsedRes of + Just a | 0 == longueur a -> return Nothing + | otherwise -> + do let hausse = increaseQueryRange param + --traceM . show $ hausse + reste <- queryRedmineAvecOptions redmineMng req hausse mng + case reste of + Just b -> return . Just $ mappend a b + Nothing -> return $ Just a + --return (reste >>= (\b -> Just $ mappend a b )) + + Nothing -> return Nothing + +-- |The function 'debugResult' is used to print the parsing error statement +-- and continue the processing. +debugResult :: Either String a -> IO(Maybe a) +debugResult res = case res of + Left msg -> putStrLn msg >> return Nothing + Right v -> return (Just v) + +runQuery :: FromJSON a => RedmineMng -> S.ByteString -> IO( Maybe a) +runQuery mng requete = do -- withSocketsDo $ do + toto <- queryRedmine mng requete + (debugResult . eitherDecode) toto + +initOpt = Map.fromList [("offset","0"), ("limit","100")] + +-- |The function 'getTimeEntries' fetches all the time entries. +-- They can be filtered by spenton date using spent_on=%3E%3C2013-05-01|2013-05-31 +getTimeEntries :: RedmineMng -> ParamRest -> MaybeT IO [TimeEntry] +getTimeEntries mng param = MaybeT $ do + mngConn <- newManager tlsManagerSettings + res <- queryRedmineAvecOptions mng requete ( Map.union param initOpt) mngConn + return $ fmap time_entries res + where requete = "/time_entries.json" + +getTimeEntriesForIssue :: RedmineMng -> Integer-> MaybeT IO [TimeEntry] +getTimeEntriesForIssue mng issueid = MaybeT $ do + mngConn <- newManager tlsManagerSettings + res <- queryRedmineAvecOptions mng requete initOpt mngConn + return $ fmap time_entries res + where requete = "/time_entries/" <> S8.pack (show issueid) <> ".json" + +getIssues :: RedmineMng -> ParamRest -> MaybeT IO [Issue] +getIssues mng param = MaybeT $ do + mngConn <- liftIO $ newManager tlsManagerSettings + res <- queryRedmineAvecOptions mng requete ( Map.union param initOpt) mngConn + return $ fmap issues res + where requete = "/issues.json" + +getIssue :: RedmineMng -> Integer -> ParamRest -> MaybeT IO Issue +getIssue mng elemId param = + fmap issue (MaybeT $ runQuery mng requete) + where requete = "/issues/" <> S8.pack (show elemId) <> ".json" <> expandOptions param + +getProjects :: RedmineMng -> MaybeT IO [Project] +getProjects mng = MaybeT $ do + mngConn <- newManager tlsManagerSettings + res <- queryRedmineAvecOptions mng requete initOpt mngConn + return $ fmap projects res + where requete = "/projects.json" + +getProjectForId :: RedmineMng -> Integer -> MaybeT IO Project +getProjectForId mng elemId = + MaybeT $ runQuery mng requete + where requete = rmhost mng <> "/projects/" <> S8.pack (show elemId) <> ".json" + +getProject :: RedmineMng -> S.ByteString -> MaybeT IO Project +getProject mng projId = + MaybeT $ runQuery mng requete + where requete = "/projects/" <> projId <> ".json" + +--Get all the versions associated to a project +getVersions :: RedmineMng --The connection manager + -> S.ByteString --The project + -> MaybeT IO [Version] +getVersions mng proj = + fmap versions (MaybeT $ runQuery mng requete) + where requete = "/projects/" <> proj <> "/versions.json" + +getVersion:: RedmineMng -> Integer -> ParamRest -> MaybeT IO Version +getVersion mng elemId param = + fmap version (MaybeT $ runQuery mng requete) + where requete = "/versions/" <> S8.pack (show elemId) <> ".json" <> expandOptions param + +getUser :: RedmineMng -> Integer -> MaybeT IO User +getUser mng elemId = + do let requete = "/users/" <> S8.pack (show elemId) <> ".json" + MaybeT $ runQuery mng requete + +instance FromJSON ObjRef where + parseJSON (Object v) = + ObjRef <$> (v .: "id") + <*> (v .: "name") + +instance FromJSON ObjID where + parseJSON (Object v) = + ObjID <$> (v .: "id") + +instance FromJSON IssuesRsp where + parseJSON (Object v) = IssuesRsp <$> (v .: "issues") + +instance FromJSON IssueRsp where + parseJSON (Object v) = IssueRsp <$> (v .: "issue") + +instance FromJSON Issue where + parseJSON (Object v) = + Issue <$> (v .: "id") + <*> (v .: "project") + <*> (v .:? "parent") + <*> (v .: "tracker") + <*> (v .: "status") + <*> (v .: "priority") + <*> (v .: "author") + <*> (v .:? "assigned_to") + <*> (v .:? "category") + <*> (v .: "fixed_version") + <*> (v .: "subject") + <*> (v .: "description") + <*> liftM (parseShortTime . fromMaybe "") (v .:? "start_date") + <*> liftM (parseShortTime . fromMaybe "") (v .:? "due_date") + <*> (v .: "done_ratio") + <*> (v .:? "estimated_hours") + <*> (v .:? "spent_hours") + <*> (v .:? "custom_fields") + <*> liftM parseRHTime (v .: "created_on") + <*> liftM parseRHTime (v .: "updated_on") + <*> (v .:? "journals") + <*> (v .:? "attachements") + <*> (v .:? "changesets") + <*> (v .:? "watchers") + <*> (v .:? "relations") + <*> (v .:? "children") + + +instance FromJSON Child where + parseJSON (Object v) = + Child <$> (v .: "id") + <*> (v .: "tracker") + <*> (v .: "subject") + +instance FromJSON Attachement where + parseJSON (Object v) = + Attachement <$> (v .: "id") + <*> (v .: "filename") + <*> (v .: "filesize") + <*> (v .: "content_type") + <*> (v .: "description") + <*> (v .: "content_url") + <*> (v .: "author_name") + <*> liftM (fromJust.parseRHTime) (v .: "created_on") + +instance FromJSON ChangeSet where + parseJSON (Object v) = + ChangeSet <$> (v .: "revision") + <*> (v .: "user") + <*> (v .: "comments") + <*> liftM (fromJust.parseRHTime) (v .: "committed_on") + +instance FromJSON Watcher where + parseJSON (Object v) = + Watcher <$> (v .: "id") + <*> (v .: "name") + +instance FromJSON CustomField where + parseJSON (Object v) = + CustomField <$> (v .: "id") <*> (v .: "name") <*> (v .: "value") + +instance FromJSON Journal where + parseJSON (Object v) = + Journal <$> (v .: "id") + <*> (v .: "user") + <*> (v .:? "notes" .!= "") + <*> liftM parseRHTime (v .: "created_on") + <*> (v .: "details") + +instance FromJSON Detail where + parseJSON (Object v) = + Detail <$> (v .: "property") + <*> (v .: "name") + <*> (v .:? "old_value") + <*> (v .: "new_value") + +instance FromJSON ProjectsRsp where + parseJSON (Object v) = ProjectsRsp <$> (v .: "projects") + +instance FromJSON Project where + parseJSON (Object v) = + Project <$> (v .: "id") + <*> (v .: "name") + <*> (v .: "identifier") + <*> (v .: "description") + <*> (v .:? "custom_fields") + <*> liftM parseRHTime (v .: "created_on") + <*> liftM parseRHTime (v .: "updated_on") + +instance FromJSON TimeEntriesRsp where + parseJSON (Object v) = TimeEntriesRsp <$> (v .: "time_entries") + +instance FromJSON TimeEntry where + parseJSON (Object v) = + TimeEntry <$> (v .: "id") + <*> (v .: "project") + <*> (v .: "issue") + <*> (v .: "user") + <*> (v .:? "activity") + <*> (v .:? "hours") + <*> (v .: "comments") + <*> liftM parseRHTime (v .: "created_on") + <*> liftM parseRHTime (v .: "updated_on") + <*> liftM (parseShortTime . fromMaybe "") (v .:? "spent_on") + +instance FromJSON VersionsRsp where + parseJSON (Object v) = VersionsRsp <$> (v .: "versions") + +instance FromJSON VersionRsp where + parseJSON (Object v) = VersionRsp <$> (v .: "version") + +instance FromJSON Day where + parseJSON = withText "Day" $ \t -> + case parseTime defaultTimeLocale "%F" (T.unpack t) of + Just d -> pure d + _ -> fail "could not parse ISO-8601 date" + +instance FromJSON Version where + parseJSON (Object v) = + Version <$> (v .: "id") + <*> (v .: "name") + <*> (v .: "project") + <*> (v .: "description") + <*> (v .: "status") + <*> (v .: "sharing") + --FIXME avoid parsing an empty string + <*> liftM (parseShortTime . fromMaybe "") (v .:? "due_date") + <*> liftM parseRHTime (v .: "created_on") + <*> liftM parseRHTime (v .: "updated_on") + +instance FromJSON Relations where + parseJSON (Object v) = Relations <$> (v .: "relations") + +instance FromJSON Relation where + parseJSON (Object v) = + Relation <$> (v .: "id") + <*> (v .: "issue_id") + <*> (v .: "issue_to_id") + <*> (v .: "relation_type") + <*> (v .:? "delay") + +instance FromJSON Roles where + parseJSON (Object v) = Roles <$> (v .: "roles") + +instance FromJSON Role where + parseJSON (Object v) = + Role <$> (v .: "id") <*> (v .: "name") + +instance FromJSON Memberships where + parseJSON (Object v) = Memberships <$> (v .: "memberships") + +instance FromJSON Membership where + parseJSON (Object v) = + Membership <$> (v .: "id") + <*> (v .: "project") + <*> (v .: "user") + <*> (v .: "roles") + +instance FromJSON UsersRsp where + parseJSON (Object v) = UsersRsp <$> (v .: "users") + +instance FromJSON User where + parseJSON (Object v) = + User <$> (v .: "lastname") + <*> liftM parseRHTime (v .: "created_on") + <*> (v .: "mail") + <*> liftM parseRHTime (v .: "last_login_on") + <*> (v .: "firstname") + <*> (v .: "id") + +instance FromJSON Trackers where + parseJSON (Object v) = Trackers <$> (v .: "trackers") + +instance FromJSON Tracker where + parseJSON (Object v) = + Tracker <$> (v .: "id") <*> (v .: "name") + +instance FromJSON IssueStatuses where + parseJSON (Object v) = IssueStatuses <$> (v .: "issue_statuses") + +instance FromJSON IssueStatus where + parseJSON (Object v) = + IssueStatus <$> (v .: "id") + <*> (v .: "name") + <*> (v .: "is_default") + <*> (v .: "is_closed") + diff --git a/src/Redmine/Manager.hs b/src/Redmine/Manager.hs new file mode 100644 --- /dev/null +++ b/src/Redmine/Manager.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Redmine.Manager where + +import Data.ByteString + +-- Ajt Gestionaire de connection +data RedmineMng + + -- |Constructor to create an anonymous connection. + = RedmineMng {rmhost::ByteString} + + -- |Constructor to create a connection throught a proxy + | RedmineMngWithProxy { rmhost::ByteString + , rmurlProxy::ByteString + , rmportProxy::Int } + + -- |Constructor to create a connection with authentification + | RedmineMngWithAuth { rmhost::ByteString + , login::ByteString + , passwd::ByteString } + + -- |Constructor to create a connection throught a proxy with authentification + | RedmineMngWithAuthAndProxy { rmhost::ByteString + , login::ByteString + , passwd::ByteString + , rmurlProxy::ByteString + , rmportProxy::Int } diff --git a/src/Redmine/Types.hs b/src/Redmine/Types.hs new file mode 100644 --- /dev/null +++ b/src/Redmine/Types.hs @@ -0,0 +1,230 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Redmine.Types where + +import Data.Time.Clock (UTCTime) +import Data.Time.Calendar (Day) +import Network.HTTP.Conduit +import Data.Monoid +import Data.Typeable +import Data.Data +import Data.Aeson +import qualified Data.Text as T + +data Status = Closed | Open deriving (Eq, Show) + +data VersionsRsp = VersionsRsp { versions :: [Version] } deriving (Eq,Show) + +data VersionRsp = VersionRsp { version :: Version } deriving (Eq,Show) + +data Version = Version { id_Version :: Integer + , name_Version :: T.Text + , project_Version :: ObjRef + , desc_Version :: T.Text + , status_Version :: T.Text + , sharing_Version :: T.Text + , dueDate_Version :: Maybe Day + , createdOn_Version :: Maybe UTCTime + , updatedOn_Version :: Maybe UTCTime + } deriving (Eq, Show) +--ajouter offset total_cout et limit +data IssuesRsp = IssuesRsp { issues :: [Issue] } deriving (Eq,Show) + +--data Parent = Parent { parent :: ObjID } deriving (Eq,Show) + +data IssueRsp = IssueRsp { issue :: Issue } deriving (Eq,Show) + +data Issue = Issue { id_Issue :: Integer + , project_Issue :: ObjRef + , parent_Issue :: Maybe ObjID --Single issue only + , tracker_Issue :: ObjRef + , status_Issue :: ObjRef + , priority_Issue :: ObjRef + , author_Issue :: ObjRef + , assignedTo_Issue :: Maybe ObjRef + , category_Issue :: Maybe ObjRef + , fixedVersion_Issue :: ObjRef + , subject_Issue :: T.Text + , description_Issue :: T.Text + , startDate_Issue :: Maybe Day + , dueDate_Issue :: Maybe Day + , doneRatio_Issue :: Int + , estimatedHours_Issue :: Maybe Float + , spentHours_Issue :: Maybe Float --Single issue only + , customFields_Issue :: Maybe [CustomField] + , createdOn_Issue :: Maybe UTCTime + , updatedOn_Issue :: Maybe UTCTime + , journals_Issue :: Maybe [Journal] -- Single issue only + , attachements_Issue :: Maybe [Attachement] + , changeSets_Issue :: Maybe [ChangeSet] + , watchers_Issue :: Maybe [Watcher] + , relations_Issue :: Maybe [Relation] + , children_Issue :: Maybe [Child] + } deriving (Eq, Show) + +data ChangeSet = ChangeSet { revision_ChangeSet :: T.Text + , user_ChangeSet :: ObjRef + , comments_ChangeSet :: T.Text + , committedOn_ChangeSet :: UTCTime + } deriving (Eq, Show) + +data Watcher = Watcher { id_Watcher :: Integer + , name_Watcher :: T.Text + } deriving (Eq, Show) + +data Child = Child { id_Child :: Integer + , tracker_Child :: ObjRef + , subject_Tracker :: T.Text + } deriving (Eq, Show) + +data CustomField = CustomField { id_CF :: Integer + , name_CF :: T.Text + , value_CF :: T.Text + } deriving (Eq,Show) + +data ObjRef = ObjRef { id_ObjRef:: Integer, name_ObjRef:: T.Text } deriving (Eq, Show) + +data ObjID = ObjID { id_ObjID:: Integer } deriving (Eq, Show) + +data IssueStatuses = IssueStatuses { issue_statuses :: [IssueStatus] } + deriving (Eq,Show) + +data IssueStatus = IssueStatus { id_IssueStatus:: Integer + , name_IssueStatus:: T.Text + , isDefault_IssueStatus:: Bool + , isClosed_IssueStatus:: Bool + } deriving (Eq, Show) + +data ProjectsRsp = ProjectsRsp { projects :: [Project] } deriving (Eq,Show) + +data ProjectRsp = ProjectRsp { project :: Project } deriving (Eq,Show) + +data Project = Project { id_Project:: Integer + , name_Project:: T.Text + , identifier_Project:: T.Text + , desc_Project:: T.Text + , customFields_Project :: Maybe [CustomField] + , createdOn_Project :: Maybe UTCTime + , updatedOn_Project :: Maybe UTCTime + } deriving (Eq, Show) + + +data UsersRsp = UsersRsp { users :: [User] } deriving (Eq,Show) + +data UserRsp = UserRsp { user :: User } deriving (Eq,Show) + +data User = User { lastname:: T.Text + , createdOn_User:: Maybe UTCTime + , mail:: T.Text + , r :: Maybe UTCTime + , firstname:: T.Text + , id_User:: Integer + } deriving (Eq, Show) + +data Trackers = Trackers { trackers :: [Tracker] } deriving (Eq,Show) + +data Tracker = Tracker { id_Tracker :: Integer + , name_Tracker :: T.Text + } deriving (Eq, Show) + + +data Detail = Detail { property :: T.Text + , name_Detail :: T.Text + , old_value_Detail :: Maybe T.Text + , new_value_Detail :: T.Text + } deriving (Eq,Show) + + +data Journal = Journal { id_Journal :: Integer + , user_Journal :: ObjRef + , notes_Journal :: T.Text + , createdOn_Journal :: Maybe UTCTime + , details_Journal :: Maybe [Detail] + } deriving (Eq, Show) + + +data Attachement = Attachement { id_Attachement :: Integer + , filename_Attachement :: T.Text + , filesize_Attachement :: Integer + , contentType_Attachement :: T.Text + , description_Attachement :: T.Text + , contentUrl_Attachement :: T.Text + , authorName_Attachement :: ObjRef + , createdOn_Attachement :: UTCTime + } deriving (Eq, Show) + + +data TimeEntriesRsp = TimeEntriesRsp { time_entries :: [TimeEntry] } deriving (Eq,Show) + +data TimeEntryRsp = TimeEntryRsp { time_entry :: TimeEntry } deriving (Eq,Show) + +data TimeEntry = TimeEntry { id_TE :: Integer + , project_TE :: ObjRef + , issue_TE :: ObjID + , user_TE :: ObjRef + , activity_TE :: Maybe ObjRef + , hours_TE :: Maybe Float + , comments_TE :: T.Text + , createdOn_TE :: Maybe UTCTime + , updatedOn_TE :: Maybe UTCTime + , spentOn_TE :: Maybe Day + } deriving (Eq, Show) + +data Memberships = Memberships { memberships :: [Membership] + } deriving (Eq,Show) + +data Membership = Membership { id_Membership :: Integer + , project_Membership :: ObjRef + , user_Membership :: ObjRef + , roles_Membership :: [Role] + } deriving (Eq, Show) + +data Roles = Roles { roles :: [Role] } deriving (Eq,Show) + +data Role = Role { id_Role :: Integer + , name_Role :: T.Text + } deriving (Eq, Show) + +data RelationType = Relates | Duplicates | Duplicated | Blocks | Blocked + | Precedes | Follows deriving (Eq, Show) + +data Relations = Relations { relations :: [Relation] } deriving (Eq,Show) + +data Relation = Relation { id_Relation :: Integer + , issueId_Relation:: Integer + , issueToId_Relation:: Integer + , relationType_Relation:: T.Text + , delay_Relation:: Maybe Integer + } deriving (Eq, Show) + +instance Monoid TimeEntriesRsp where + mappend a b = TimeEntriesRsp (time_entries a++time_entries b) + mempty = TimeEntriesRsp [] + +instance Monoid IssuesRsp where + mappend a b = IssuesRsp (issues a++issues b) + mempty = IssuesRsp [] + +instance Monoid ProjectsRsp where + mappend a b = ProjectsRsp (projects a++projects b) + mempty = ProjectsRsp [] + +instance Monoid VersionsRsp where + mappend a b = VersionsRsp (versions a++versions b) + mempty = VersionsRsp [] + +class Collection a where + longueur :: a -> Int + +instance Collection TimeEntriesRsp where + longueur (TimeEntriesRsp a) = length a + +instance Collection IssuesRsp where + longueur (IssuesRsp a) = length a + +instance Collection ProjectsRsp where + longueur (ProjectsRsp a) = length a + +instance Collection VersionsRsp where + longueur (VersionsRsp a) = length a + diff --git a/testsuite/testGet.hs b/testsuite/testGet.hs new file mode 100644 --- /dev/null +++ b/testsuite/testGet.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +import Test.HUnit +import Data.Map +import Redmine.Get + +test1 = TestCase (do let m = fromList [("toto","a"),("offset","20"), ("limit","100")] + ref = "?toto=a&offset=20&limit=100&" + assertEqual "Option expansion failed" ref (expandOptions m)) + +test2 = TestCase (do let m = fromList [("offset","20"), ("limit","100")] + ref = fromList [("offset","120"), ("limit","100")] + assertEqual "increaseQueryRange a échouée" ref (increaseQueryRange m)) + + +--decodeIssue + +main = runTestTT test2 --[test1,test2]