diff --git a/Redmine.cabal b/Redmine.cabal --- a/Redmine.cabal +++ b/Redmine.cabal @@ -1,5 +1,5 @@ name: Redmine -version: 0.0.3 +version: 0.0.5 cabal-version: >=1.10 build-type: Simple license: MIT @@ -19,7 +19,7 @@ Library default-language: Haskell2010 build-depends: base >=2 && <5, old-locale -any, - time -any, old-time -any, bytestring -any, http-conduit >= 2.1.0, + time -any, old-time -any, bytestring -any, http-conduit >= 2.1.0, http-types, aeson -any, HTTP -any, network -any, text, transformers, containers, http-client-tls, resourcet, connection, MissingH diff --git a/src/Redmine/Get.hs b/src/Redmine/Get.hs --- a/src/Redmine/Get.hs +++ b/src/Redmine/Get.hs @@ -1,6 +1,7 @@ {-# LANGUAGE OverloadedStrings #-} module Redmine.Get ( getTimeEntries + , getTimeEntry , getTimeEntriesForIssue , getIssue , getIssues @@ -13,150 +14,71 @@ , increaseQueryRange ) where -import Data.Aeson -import Data.Maybe import Data.Monoid import qualified Data.Map as Map -import Data.Tuple +import Redmine.JSON import Redmine.Types import Redmine.Manager -import Control.Applicative ((<$>), (<*>), pure) +import Redmine.Rest 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.Base (RequestMethod(..)) 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 $ Just a - | 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 + res <- queryRedmineAvecOptions mng GET requete ( Map.union param initOpt) Nothing mngConn return $ fmap time_entries res where requete = "/time_entries.json" +getTimeEntry :: RedmineMng -> Integer -> MaybeT IO TimeEntry +getTimeEntry mng elemId = + fmap time_entry (MaybeT $ runQuery mng GET requete Nothing) + where requete = "/time_entries/" <> S8.pack (show elemId) <> ".json" + getTimeEntriesForIssue :: RedmineMng -> Integer-> MaybeT IO [TimeEntry] getTimeEntriesForIssue mng issueid = MaybeT $ do mngConn <- newManager tlsManagerSettings - res <- queryRedmineAvecOptions mng requete initOpt mngConn + res <- queryRedmineAvecOptions mng GET requete initOpt Nothing 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 + res <- queryRedmineAvecOptions mng GET requete ( Map.union param initOpt) Nothing 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) + fmap issue (MaybeT $ runQuery mng GET requete Nothing) 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 + res <- queryRedmineAvecOptions mng GET requete initOpt Nothing mngConn return $ fmap projects res where requete = "/projects.json" getProjectForId :: RedmineMng -> Integer -> MaybeT IO Project getProjectForId mng elemId = - MaybeT $ runQuery mng requete + MaybeT $ runQuery mng GET requete Nothing where requete = rmhost mng <> "/projects/" <> S8.pack (show elemId) <> ".json" getProject :: RedmineMng -> S.ByteString -> MaybeT IO Project getProject mng projId = - MaybeT $ runQuery mng requete + MaybeT $ runQuery mng GET requete Nothing where requete = "/projects/" <> projId <> ".json" --Get all the versions associated to a project @@ -164,220 +86,15 @@ -> S.ByteString --The project -> MaybeT IO [Version] getVersions mng proj = - fmap versions (MaybeT $ runQuery mng requete) + fmap versions (MaybeT $ runQuery mng GET requete Nothing) where requete = "/projects/" <> proj <> "/versions.json" getVersion:: RedmineMng -> Integer -> ParamRest -> MaybeT IO Version getVersion mng elemId param = - fmap version (MaybeT $ runQuery mng requete) + fmap version (MaybeT $ runQuery mng GET requete Nothing) 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") - + fmap user (MaybeT $ runQuery mng GET requete Nothing) + where requete = "/users/" <> S8.pack (show elemId) <> ".json"