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
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
queryRedmineAvecOptions :: (FromJSON a, Monoid a, Collection a) =>
RedmineMng -> S.ByteString -> ParamRest -> Manager -> IO( Maybe a)
queryRedmineAvecOptions redmineMng req param mng =
do
request <- creerRqt redmineMng (req <> expandOptions param)
let settings = mkManagerSettings (TLSSettingsSimple True False False) Nothing
response <- withManagerSettings settings $ httpLbs request
parsedRes <- debugResult . eitherDecode . responseBody $ response
case parsedRes of
Just a | 0 == longueur a -> return $ Just a
| otherwise ->
do let hausse = increaseQueryRange param
reste <- queryRedmineAvecOptions redmineMng req hausse mng
case reste of
Just b -> return . Just $ mappend a b
Nothing -> return $ Just a
Nothing -> return Nothing
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
toto <- queryRedmine mng requete
(debugResult . eitherDecode) toto
initOpt = Map.fromList [("offset","0"), ("limit","100")]
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"
getVersions :: RedmineMng
-> S.ByteString
-> 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")
<*> 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")