Redmine 0.0.5 → 0.0.6
raw patch · 5 files changed
+498/−3 lines, 5 files
Files
- Redmine.cabal +3/−3
- src/Redmine/JSON.hs +358/−0
- src/Redmine/Post.hs +29/−0
- src/Redmine/Put.hs +3/−0
- src/Redmine/Rest.hs +105/−0
Redmine.cabal view
@@ -1,5 +1,5 @@ name: Redmine-version: 0.0.5+version: 0.0.6 cabal-version: >=1.10 build-type: Simple license: MIT@@ -19,11 +19,11 @@ Library default-language: Haskell2010 build-depends: base >=2 && <5, old-locale -any,- time -any, old-time -any, bytestring -any, http-conduit >= 2.1.0, http-types, + 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- exposed-modules: Redmine.Types, Redmine.Manager, Redmine.Get+ exposed-modules: Redmine.Types, Redmine.Manager, Redmine.Get, Redmine.JSON, Redmine.Rest, Redmine.Post, Redmine.Put buildable: True hs-source-dirs: src
+ src/Redmine/JSON.hs view
@@ -0,0 +1,358 @@+{-# LANGUAGE OverloadedStrings #-}++module Redmine.JSON+( parseJSON+, toJSON+) where++import Data.Aeson+import Data.Maybe+import Data.Time.Clock (UTCTime)+import Data.Time.Format (parseTime)+import Redmine.Types+import Control.Applicative ((<$>), (<*>), pure)+import Control.Monad (liftM)+import Data.Time.Calendar (Day, showGregorian)+import System.Locale (defaultTimeLocale)++import qualified Data.Text as T (pack, unpack)++parseRHTime :: String -> Maybe UTCTime+parseRHTime = parseTime defaultTimeLocale "%FT%X%QZ"++parseShortTime :: String -> Maybe Day+parseShortTime = parseTime defaultTimeLocale "%F"++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")+ <*> liftM (fromMaybe "") (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 TimeEntryRsp where+ parseJSON (Object v) = TimeEntryRsp <$> (v .: "time_entry")++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 UserRsp where+ parseJSON (Object v) = UserRsp <$> (v .: "user")++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")++instance ToJSON Day where+ toJSON = String . T.pack . showGregorian++instance ToJSON ObjRef where+ toJSON (ObjRef id name) = object [ "id" .= id, "name" .= name]++instance ToJSON ObjID where+ toJSON (ObjID id) = object ["id" .= id]++instance ToJSON Issue where+ toJSON (Issue _id'+ project+ _parent+ _tracker+ _status+ _priority+ _author+ _assigned_to+ _category+ _fixed_version+ subject+ description+ _start_date+ _due_date+ _done_ratio+ _estimated_hours+ _spent_hours+ _custom_fields+ _created_on+ _updated_on+ _journals+ _attachements+ _changesets+ _watchers+ _relations+ _children+ ) = object [ "issue" .=+ object [ -- "id" .= id',+ "project_id" .= id_ObjRef project+-- , "tracker" .= tracker+-- , "status" .= status+-- , "priority" .= priority+-- , "author" .= author+-- , "assigned_to" .= assigned_to+-- , "category" .= category+-- , "fixed_version" .= fixed_version+ , "subject" .= subject+ , "description" .= description+-- , "start_date" .= start_date+-- , "due_date" .= due_date+-- , "done_ratio" .= done_ratio+-- , "estimated_hours" .= estimated_hours+-- , "spent_hours" .= spent_hours+-- , "custom_fields" .= custom_fields+-- , "created_on" .= created_on+-- , "updated_on" .= updated_on+-- , "journals" .= journals+-- , "attachements" .= attachements+-- , "changesets" .= changesets+-- , "watchers" .= watchers+-- , "relations" .= relations+-- , "children" .= children+ ]]++instance ToJSON Child where+ toJSON (Child id' tracker subject) =+ object [ "id" .= id'+ , "tracker" .= tracker+ , "subject" .= subject]++instance ToJSON Attachement where+ toJSON (Attachement id' filename filesize content_type description content_url author_name created_on) =+ object [ "id" .= id'+ , "filename" .= filename+ , "filesize" .= filesize+ , "content_type" .= content_type+ , "description" .= description+ , "content_url" .= content_url+ , "author_name" .= author_name+ , "created_on" .= created_on]++instance ToJSON ChangeSet where+ toJSON (ChangeSet revision user comments committed_on) =+ object [ "revision" .= revision+ , "user" .= user+ , "comments" .= comments+ , "commited_on" .= committed_on]+++instance ToJSON CustomField where+ toJSON (CustomField id' name value) =+ object ["id" .= id'+ , "name" .= name+ , "value" .= value]++instance ToJSON Journal where+ toJSON (Journal id' user notes created_on details) =+ object ["id" .= id'+ , "user" .= user+ , "notes" .= notes+ , "created_on" .= created_on+ , "details" .= details]++instance ToJSON Detail where+ toJSON (Detail property name old_value new_value) =+ object [ "property" .= property+ , "name" .= name+ , "old_value" .= old_value+ , "new_value" .= new_value]++instance ToJSON Watcher where+ toJSON (Watcher id' name) =+ object [ "id" .= id'+ , "name" .= name]++instance ToJSON Relation where+ toJSON (Relation id' issue_id issue_to_id relation_type delay) =+ object [ "id" .= id'+ , "issue_id" .= issue_id+ , "issue_to_id" .= issue_to_id+ , "relation_type" .= relation_type+ , "delay" .= delay]+
+ src/Redmine/Post.hs view
@@ -0,0 +1,29 @@+{-# LANGUAGE OverloadedStrings #-}+module Redmine.Post (postIssue) where++import Data.Aeson+import Data.Monoid+import qualified Data.Map as Map+import Redmine.JSON+import Redmine.Types+import Redmine.Manager+import Redmine.Rest+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.HTTP.Conduit+import Network.HTTP.Base (RequestMethod(..))+import Network.HTTP.Client.TLS+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Maybe+import Debug.Trace+++postIssue :: RedmineMng -> Issue -> MaybeT IO Issue+postIssue mng iss =+ fmap issue (MaybeT $ runQuery mng POST requete (toJsonBody iss))+ where requete = "issues.json" ++++
+ src/Redmine/Put.hs view
@@ -0,0 +1,3 @@+{-# LANGUAGE OverloadedStrings #-}++module Redmine.Put where
+ src/Redmine/Rest.hs view
@@ -0,0 +1,105 @@+{-# LANGUAGE OverloadedStrings #-}+module Redmine.Rest(expandOptions+ , increaseQueryRange+ , initOpt+ , toJsonBody+ , queryRedmineAvecOptions+ , runQuery++ , ParamRest+ ) where++import Data.Aeson+import Data.Monoid+import qualified Data.Map as Map+import Redmine.Types+import Redmine.Manager+import qualified Data.ByteString as S+import qualified Data.ByteString.Char8 as S8+import qualified Data.ByteString.Lazy as L+import qualified Data.ByteString.Lazy.Char8 as L8+import Network.Connection (TLSSettings (..))+import Network.HTTP.Conduit+import Network.HTTP.Base (RequestMethod(..))+import Network.HTTP.Types.Header (Header, hContentType)+import qualified Data.Text as T++import Debug.Trace++queryRedmine :: RedmineMng -> RequestMethod -> S.ByteString -> (Maybe S.ByteString) -> IO L.ByteString+queryRedmine mng m req b = do+ request <- creerRqt mng m req b+ let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing+ response <- withManagerSettings settings $ httpLbs request+ return $ responseBody response++creerRqt :: RedmineMng -> RequestMethod -> S.ByteString -> Maybe S.ByteString -> IO Request+creerRqt (RedmineMng h) m r body = fmap (f body) $ parseUrl $ S8.unpack (h <> r)+ where+ ct = (hContentType, "application/json") :: Header+ f (Just b) req = trace (S8.unpack b) req'+ where req' = req{method = S8.pack . show $ m, requestHeaders = ct : requestHeaders req, requestBody = RequestBodyBS b}+ f Nothing req = req{method = S8.pack . show $ m, requestHeaders = ct : requestHeaders req}++creerRqt (RedmineMngWithProxy h u p) m r b = fmap (addProxy u p) (creerRqt (RedmineMng h) m r b)+creerRqt (RedmineMngWithAuth h l pass) m r b = fmap (applyBasicAuth l pass) (creerRqt (RedmineMng h) m r b)+creerRqt (RedmineMngWithAuthAndProxy h l pass u p) m r b = fmap (applyBasicAuth l pass) (creerRqt (RedmineMngWithProxy h u p) m r b)++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 -> RequestMethod -> S.ByteString -> ParamRest -> Maybe S.ByteString -> Manager -> IO( Maybe a)+queryRedmineAvecOptions redmineMng m req param body mng = -- MaybeT IO $ withSocketsDo $+ do+ request <- creerRqt redmineMng m (req <> expandOptions param) body+ --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 m req hausse body 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)++--contentType = mkHeader HdrContentType "application/json"++runQuery :: FromJSON a => RedmineMng -> RequestMethod -> S.ByteString -> Maybe S.ByteString -> IO( Maybe a)+runQuery mng m requete body = do -- withSocketsDo $ do+ toto <- queryRedmine mng m requete body+ (debugResult . eitherDecode) toto++toJsonBody :: ToJSON a => a -> Maybe S8.ByteString+toJsonBody = Just . L8.toStrict . encode . toJSON++initOpt = Map.fromList [("offset","0"), ("limit","100")] :: Map.Map S8.ByteString S8.ByteString