diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 MATSUBARA Nobutada + +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/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/chatwork.cabal b/chatwork.cabal new file mode 100644 --- /dev/null +++ b/chatwork.cabal @@ -0,0 +1,57 @@ +name: chatwork +version: 0.1.0.0 +cabal-version: >=1.10 +build-type: Simple +license: MIT +license-file: LICENSE +copyright: 2017 MATSUBARA Nobutada +maintainer: MATSUBARA Nobutada +homepage: https://github.com/matsubara0507/chatwork#readme +bug-reports: https://github.com/matsubara0507/chatwork/issues +synopsis: The ChatWork API in Haskell +description: + See README at +category: Web +author: MATSUBARA Nobutada + +source-repository head + type: git + location: https://github.com/matsubara0507/chatwork + +library + exposed-modules: + ChatWork + ChatWork.Endpoints + ChatWork.Endpoints.Me + ChatWork.Endpoints.My + ChatWork.Endpoints.Contacts + ChatWork.Endpoints.Rooms + ChatWork.Endpoints.IncomingRequests + ChatWork.MonadHttpIO + ChatWork.Types + ChatWork.Types.Base + ChatWork.Types.Error + ChatWork.Types.Me + ChatWork.Types.My + ChatWork.Types.Contacts + ChatWork.Types.Rooms + ChatWork.Types.IncomingRequests + ChatWork.Utils + build-depends: + base >=4.7 && <5, + aeson >=1.0.2.1 && <1.1, + aeson-casing >=0.1.0.5 && <0.2, + bytestring >=0.10.8.1 && <0.11, + connection >=0.2.8 && <0.3, + data-default-class >=0.1.2.0 && <0.2, + http-client >=0.5.7.0 && <0.6, + http-client-tls >=0.3.5 && <0.4, + http-types >=0.9.1 && <0.10, + req >=0.3.0 && <0.4, + text >=1.2.2.1 && <1.3 + default-language: Haskell2010 + hs-source-dirs: src + other-modules: + ChatWork.Internal + ghc-options: -Wall + diff --git a/src/ChatWork.hs b/src/ChatWork.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork.hs @@ -0,0 +1,16 @@ +-- | +-- This module is re-export all endpoint functions and types from this package. +-- + +module ChatWork ( + -- * Emdpoint function definitions + module ChatWork.Endpoints + -- * Response and request param type definitions + , module ChatWork.Types + -- * Define MonadHttp type class instance of IO + , module ChatWork.MonadHttpIO + ) where + +import ChatWork.Endpoints +import ChatWork.MonadHttpIO () +import ChatWork.Types diff --git a/src/ChatWork/Endpoints.hs b/src/ChatWork/Endpoints.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Endpoints.hs @@ -0,0 +1,18 @@ +module ChatWork.Endpoints ( + -- * /me + module ChatWork.Endpoints.Me + -- * /my + , module ChatWork.Endpoints.My + -- * /contacts + , module ChatWork.Endpoints.Contacts + -- * /rooms + , module ChatWork.Endpoints.Rooms + -- * /incoming_requests + , module ChatWork.Endpoints.IncomingRequests + ) where + +import ChatWork.Endpoints.Contacts +import ChatWork.Endpoints.IncomingRequests +import ChatWork.Endpoints.Me +import ChatWork.Endpoints.My +import ChatWork.Endpoints.Rooms diff --git a/src/ChatWork/Endpoints/Contacts.hs b/src/ChatWork/Endpoints/Contacts.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Endpoints/Contacts.hs @@ -0,0 +1,17 @@ +-- | +-- see : + +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Endpoints.Contacts + ( getContacts + ) where + +import ChatWork.Internal (req) +import ChatWork.Types (ChatWorkResponse, Contacts) +import ChatWork.Utils (Token, baseUrl, mkTokenHeader) +import Network.HTTP.Req (GET (..), JsonResponse, MonadHttp, + NoReqBody (..), jsonResponse, (/:)) + +getContacts :: (MonadHttp m) => Token -> m (ChatWorkResponse Contacts) +getContacts = req GET (baseUrl /: "contacts") NoReqBody jsonResponse . mkTokenHeader diff --git a/src/ChatWork/Endpoints/IncomingRequests.hs b/src/ChatWork/Endpoints/IncomingRequests.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Endpoints/IncomingRequests.hs @@ -0,0 +1,27 @@ +-- | +-- see : + +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Endpoints.IncomingRequests + ( getIncomingRequests + , acceptIncomingRequests + , rejectIncomingRequests + ) where + +import ChatWork.Internal (req) +import ChatWork.Types (AcceptedIncomingRequest, ChatWorkResponse, + IncomingRequests) +import ChatWork.Utils (Token, baseUrl, mkTokenHeader) +import Network.HTTP.Req (DELETE (..), GET (..), JsonResponse, + MonadHttp, NoReqBody (..), PUT (..), + jsonResponse, (/:), (/~)) + +getIncomingRequests :: (MonadHttp m) => Token -> m (ChatWorkResponse IncomingRequests) +getIncomingRequests = req GET (baseUrl /: "incoming_requests") NoReqBody jsonResponse . mkTokenHeader + +acceptIncomingRequests :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse AcceptedIncomingRequest) +acceptIncomingRequests t n = req PUT (baseUrl /: "incoming_requests" /~ n ) NoReqBody jsonResponse $ mkTokenHeader t + +rejectIncomingRequests :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse ()) +rejectIncomingRequests t n = req DELETE (baseUrl /: "incoming_requests" /~ n) NoReqBody jsonResponse $ mkTokenHeader t diff --git a/src/ChatWork/Endpoints/Me.hs b/src/ChatWork/Endpoints/Me.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Endpoints/Me.hs @@ -0,0 +1,17 @@ +-- | +-- see : +-- +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Endpoints.Me + ( getMe + ) where + +import ChatWork.Internal (req) +import ChatWork.Types (ChatWorkResponse, Me) +import ChatWork.Utils (Token, baseUrl, mkTokenHeader) +import Network.HTTP.Req (GET (..), JsonResponse, MonadHttp, + NoReqBody (..), jsonResponse, (/:)) + +getMe :: (MonadHttp m) => Token -> m (ChatWorkResponse Me) +getMe = req GET (baseUrl /: "me") NoReqBody jsonResponse . mkTokenHeader diff --git a/src/ChatWork/Endpoints/My.hs b/src/ChatWork/Endpoints/My.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Endpoints/My.hs @@ -0,0 +1,21 @@ +-- | +-- see : + +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Endpoints.My + ( getMyStatus + , getMyTasks + ) where + +import ChatWork.Internal (req) +import ChatWork.Types (ChatWorkResponse, MyStatus, MyTasks) +import ChatWork.Utils (Token, baseUrl, mkTokenHeader) +import Network.HTTP.Req (GET (..), JsonResponse, MonadHttp, + NoReqBody (..), jsonResponse, (/:)) + +getMyStatus :: (MonadHttp m) => Token -> m (ChatWorkResponse MyStatus) +getMyStatus = req GET (baseUrl /: "my" /: "status") NoReqBody jsonResponse . mkTokenHeader + +getMyTasks :: (MonadHttp m) => Token -> m (ChatWorkResponse MyTasks) +getMyTasks = req GET (baseUrl /: "my" /: "tasks") NoReqBody jsonResponse . mkTokenHeader diff --git a/src/ChatWork/Endpoints/Rooms.hs b/src/ChatWork/Endpoints/Rooms.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Endpoints/Rooms.hs @@ -0,0 +1,133 @@ +-- | +-- see : + +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Endpoints.Rooms ( + -- * Room + getRooms + , createRoom + , getRoom + , updateRoom + , deleteRoom + , leaveRoom + , deleteRoom' + -- * Room Member + , getMembers + , updateMembersPermission + -- * Room Message + , getMessages + , postMessage + , getMessage + -- * Room Task + , getRoomTasks + , createTask + , getRoomTask + -- * Room File + , getFiles + , getFile + ) where + +import ChatWork.Internal (req) +import ChatWork.Types (AccountId, ChatWorkResponse, + CreateRoomParams (..), + CreateTaskParams (..), CreateUrlFlag, + DeleteRoomActionType (..), File, Files, + Force, GetTasksParams (..), Members, + MembersPermission, Message, MessageBody, + MessageIdWrap, Messages, RoomDetail, + RoomIdWrap, RoomMembersParams (..), + RoomTask, RoomTasks, Rooms, TaskIdsWrap, + ToReqParam (..), UpdateRoomParams (..)) +import ChatWork.Utils (DELETE2 (..), Token, baseUrl, mkTokenHeader) +import Data.Bool (bool) +import Data.Monoid ((<>)) +import Data.Text (Text) +import Network.HTTP.Req (DELETE (..), GET (..), JsonResponse, + MonadHttp, NoReqBody (..), POST (..), + PUT (..), ReqBodyUrlEnc (..), jsonResponse, + (/:), (/~), (=:)) + +getRooms :: (MonadHttp m) => Token -> m (ChatWorkResponse Rooms) +getRooms = req GET (baseUrl /: "rooms") NoReqBody jsonResponse . mkTokenHeader + +createRoom :: (MonadHttp m) => Token -> CreateRoomParams -> m (ChatWorkResponse RoomIdWrap) +createRoom t params = req POST (baseUrl /: "rooms") (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t + where + params' = toReqParam "description" (cRoomDescription params) + <> toReqParam "icon_preset" (cIconPreset params) + <> toReqParam "members_admin_ids" (cMembersAdminIds params) + <> toReqParam "members_member_ids" (cMembersMemberIds params) + <> toReqParam "members_readonly_ids" (cMembersReadonlyIds params) + <> toReqParam "name" (cRoomName params) + +getRoom :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse RoomDetail) +getRoom t n = req GET (baseUrl /: "rooms" /~ n) NoReqBody jsonResponse $ mkTokenHeader t + +updateRoom :: (MonadHttp m) => Token -> Int -> UpdateRoomParams -> m (ChatWorkResponse RoomIdWrap) +updateRoom t n params = req PUT (baseUrl /: "rooms" /~ n) (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t + where + params' = toReqParam "description" (uRoomDescription params) + <> toReqParam "icon_preset" (uIconPreset params) + <> toReqParam "name" (uRoomName params) + +deleteRoom :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse ()) +deleteRoom t n = deleteRoom' t n DeleteRoom + +leaveRoom :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse ()) +leaveRoom t n = deleteRoom' t n LeaveRoom + +deleteRoom' :: (MonadHttp m) => Token -> Int -> DeleteRoomActionType -> m (ChatWorkResponse ()) +deleteRoom' t n action = req DELETE2 (baseUrl /: "rooms" /~ n) (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t + where + params' = "action_type" =: show action + +getMembers :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse Members) +getMembers t n = req GET (baseUrl /: "rooms" /~ n /: "members") NoReqBody jsonResponse $ mkTokenHeader t + +updateMembersPermission :: (MonadHttp m) => Token -> Int -> RoomMembersParams -> m (ChatWorkResponse MembersPermission) +updateMembersPermission t n params = req PUT (baseUrl /: "rooms" /~ n /: "members") (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t + where + params' = toReqParam "members_admin_ids" (getAdminIds params) + <> toReqParam "members_member_ids" (getMemberIds params) + <> toReqParam "members_readonly_ids" (getReadonlyIds params) + +getMessages :: (MonadHttp m) => Token -> Int -> Maybe Force -> m (ChatWorkResponse Messages) +getMessages t n force = req GET (baseUrl /: "rooms" /~ n /: "messages") NoReqBody jsonResponse $ mkTokenHeader t <> params' + where + params' = toReqParam "force" (bool 0 (1 :: Int) <$> force) + +postMessage :: (MonadHttp m) => Token -> Int -> MessageBody -> m (ChatWorkResponse MessageIdWrap) +postMessage t n body = req POST (baseUrl /: "rooms" /~ n /: "messages") (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t + where + params' = toReqParam "body" body + +getMessage :: (MonadHttp m) => Token -> Int -> Text -> m (ChatWorkResponse Message) +getMessage t rid mid = req GET (baseUrl /: "rooms" /~ rid /: "messages" /~ mid) NoReqBody jsonResponse $ mkTokenHeader t + +getRoomTasks :: (MonadHttp m) => Token -> Int -> GetTasksParams -> m (ChatWorkResponse RoomTasks) +getRoomTasks t n params = req GET (baseUrl /: "rooms" /~ n /: "tasks") NoReqBody jsonResponse $ mkTokenHeader t <> params' + where + params' = toReqParam "account_id" (getTaskAccountId params) + <> toReqParam "assigned_by_account_id" (getTaskAssignedByAccountId params) + <> toReqParam "status" (getTaskStatus params) + +createTask :: (MonadHttp m) => Token -> Int -> CreateTaskParams -> m (ChatWorkResponse TaskIdsWrap) +createTask t n params = req POST (baseUrl /: "rooms" /~ n /: "tasks") (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t + where + params' = toReqParam "body" (getTaskBody params) + <> toReqParam "limit" (getTaskLimit params) + <> toReqParam "to_ids" (getTaskToIds params) + +getRoomTask :: (MonadHttp m) => Token -> Int -> Int -> m (ChatWorkResponse RoomTask) +getRoomTask t rid tid = req GET (baseUrl /: "rooms" /~ rid /: "tasks" /~ tid) NoReqBody jsonResponse $ mkTokenHeader t + +getFiles :: (MonadHttp m) => Token -> Int -> Maybe AccountId -> m (ChatWorkResponse Files) +getFiles t rid aid = req GET (baseUrl /: "rooms" /~ rid /: "files") NoReqBody jsonResponse $ mkTokenHeader t <> params' + where + params' = toReqParam "account_id" aid + +getFile :: (MonadHttp m) => Token -> Int -> Int -> Maybe CreateUrlFlag -> m (ChatWorkResponse File) +getFile t rid fid flag = req GET (baseUrl /: "rooms" /~ rid /: "files" /~ fid) NoReqBody jsonResponse $ mkTokenHeader t <> params' + where + params' = toReqParam "create_download_url" (bool 0 (1 :: Int) <$> flag) diff --git a/src/ChatWork/Internal.hs b/src/ChatWork/Internal.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Internal.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +module ChatWork.Internal + ( req + ) where + +import ChatWork.Utils (getHttpResponse') + +import Data.Proxy (Proxy) +import Network.HTTP.Req (AllowsBody, HttpBody, HttpBodyAllowed, + HttpMethod, HttpResponse, MonadHttp, Option, + ProvidesBody, Url, req') + +-- | +-- Helper function for req' +-- getHttpResponse' is used my custamize Manager + +req :: + ( MonadHttp m, HttpMethod method, HttpBody body, HttpResponse response + , HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) + => method + -> Url scheme + -> body + -> Proxy response + -> Option scheme + -> m response +req method url body = flip (req' method url body) . getHttpResponse' diff --git a/src/ChatWork/MonadHttpIO.hs b/src/ChatWork/MonadHttpIO.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/MonadHttpIO.hs @@ -0,0 +1,11 @@ +-- | +-- This module is that define MonadHttp type class instance of IO. +-- if you want other definition, don't import this module. + +module ChatWork.MonadHttpIO where + +import Control.Exception (throwIO) +import Network.HTTP.Req + +instance MonadHttp IO where + handleHttpException = throwIO diff --git a/src/ChatWork/Types.hs b/src/ChatWork/Types.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types.hs @@ -0,0 +1,65 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeSynonymInstances #-} +-- {-# LANGUAGE OverlappingInstances #-} + +module ChatWork.Types ( + -- * type synonym of Response Json + ChatWorkResponse(..) + -- * Helper type class for constructing Request paramater + , ToReqParam(..) + + , module Types + ) where + +import ChatWork.Types.Base as Types +import ChatWork.Types.Contacts as Types +import ChatWork.Types.Error as Types +import ChatWork.Types.IncomingRequests as Types +import ChatWork.Types.Me as Types +import ChatWork.Types.My as Types +import ChatWork.Types.Rooms as Types + +import ChatWork.Types.Base (IconPreset, TaskStatus) +import ChatWork.Types.Error (ChatWorkErrors) + +import Control.Applicative ((<|>)) +import Data.Aeson (FromJSON (..), Value (..)) +import Data.Monoid (Monoid) +import Data.Text (Text, pack) +import GHC.Generics +import Network.HTTP.Req (JsonResponse, QueryParam, + (=:)) + +-- | +-- Wrapper type synonym of 'JsonResponse' and 'ChatWorkErrors' +type ChatWorkResponse a = JsonResponse (Either ChatWorkErrors a) + +instance {-# OVERLAPS #-} (FromJSON a) => FromJSON (Either ChatWorkErrors a) where + parseJSON v = ((Left <$> parseJSON v) <|> (Right <$> parseJSON v)) + +-- | +-- Helper Type Class of 'QueryParam' +-- use to construct request parameter from param type, e.g. 'CreateRoomParams' + +class ToReqParam a where + toReqParam :: (QueryParam param, Monoid param) => Text -> a -> param + +instance ToReqParam Int where + toReqParam = (=:) + +instance ToReqParam Text where + toReqParam = (=:) + +instance ToReqParam a => ToReqParam (Maybe a) where + toReqParam = maybe mempty . toReqParam + +instance Show a => ToReqParam [a] where + toReqParam name = toReqParam name . foldl (\acc a -> mconcat [acc, ",", pack $ show a]) "" + +instance ToReqParam IconPreset where + toReqParam name = toReqParam name . pack . show + +instance ToReqParam TaskStatus where + toReqParam name = toReqParam name . pack . show diff --git a/src/ChatWork/Types/Base.hs b/src/ChatWork/Types/Base.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/Base.hs @@ -0,0 +1,87 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.Base + ( Room(..) + , Account(..) + , IconPreset(..) + , TaskStatus + , AccountId + ) where + +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +data Room = Room + { roomToRoomId :: Int + , roomToName :: Text + , roomToIconPath :: Text + } deriving (Show, Generic) + +instance ToJSON Room where + toJSON = genericToJSON $ aesonDrop (strLength "roomTo") snakeCase +instance FromJSON Room where + parseJSON = genericParseJSON $ aesonDrop (strLength "roomTo") snakeCase + +data Account = Account + { accountToAccountId :: Int + , accountToName :: Text + , accountToAvatarImageUrl :: Text + } deriving (Show, Generic) + +instance ToJSON Account where + toJSON = genericToJSON $ aesonDrop (strLength "accountTo") snakeCase +instance FromJSON Account where + parseJSON = genericParseJSON $ aesonDrop (strLength "accountTo") snakeCase + +-- | +-- use create new room +-- see : +data IconPreset = Group + | Check + | Document + | Meeting + | Event + | Project + | Business + | Study + | Security + | Star + | Idea + | Heart + | Magcup + | Beer + | Music + | Sports + | Travel + deriving (Eq) + +instance Show IconPreset where + show Group = "group" + show Check = "check" + show Document = "document" + show Meeting = "meeting" + show Event = "event" + show Project = "project" + show Business = "business" + show Study = "study" + show Security = "security" + show Star = "star" + show Idea = "idea" + show Heart = "heart" + show Magcup = "magcup" + show Beer = "beer" + show Music = "music" + show Sports = "sports" + show Travel = "travel" + +data TaskStatus = Open | Done + +instance Show TaskStatus where + show Open = "open" + show Done = "done" + +type AccountId = Int diff --git a/src/ChatWork/Types/Contacts.hs b/src/ChatWork/Types/Contacts.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/Contacts.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.Contacts + ( Contacts + , Contact(..) + ) where + +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +type Contacts = [Contact] + +data Contact = Contact + { contactToAccountId :: Int + , contactToRoomId :: Int + , contactToName :: Text + , contactToChatworkId :: Text + , contactToOrganizationId :: Int + , contactToOrganizationName :: Text + , contactToDepartment :: Text + , contactToAvatarImageUrl :: Text + } deriving (Show, Generic) + +instance ToJSON Contact where + toJSON = genericToJSON $ aesonDrop (strLength "contactTo") snakeCase +instance FromJSON Contact where + parseJSON = genericParseJSON $ aesonDrop (strLength "contactTo") snakeCase diff --git a/src/ChatWork/Types/Error.hs b/src/ChatWork/Types/Error.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/Error.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.Error + ( ChatWorkErrors + ) where + +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +-- | +-- when error, chatwork is response: +-- { "errors": ["Invalid API token"] } +-- +-- see : http://developer.chatwork.com/ja/endpoints.html + +newtype ChatWorkErrors = ChatWorkErrors { getErrors :: [Text] } deriving (Show, Generic) + +instance ToJSON ChatWorkErrors where + toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase +instance FromJSON ChatWorkErrors where + parseJSON = genericParseJSON $ aesonDrop (strLength "get") snakeCase diff --git a/src/ChatWork/Types/IncomingRequests.hs b/src/ChatWork/Types/IncomingRequests.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/IncomingRequests.hs @@ -0,0 +1,49 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.IncomingRequests + ( IncomingRequests + , IncomingRequest(..) + , AcceptedIncomingRequest(..) + ) where + +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +type IncomingRequests = [IncomingRequest] + +data IncomingRequest = IncomingRequest + { incomingRequestToRequestId :: Int + , incomingRequestToAccountId :: Int + , incomingRequestToMessage :: Text + , incomingRequestToName :: Text + , incomingRequestToChatworkId :: Text + , incomingRequestToOrganizationId :: Int + , incomingRequestToOrganizationName :: Text + , incomingRequestToDepartment :: Text + , incomingRequestToAvatarImageUrl :: Text + } deriving (Show, Generic) + +instance ToJSON IncomingRequest where + toJSON = genericToJSON $ aesonDrop (strLength "incomingRequestTo") snakeCase +instance FromJSON IncomingRequest where + parseJSON = genericParseJSON $ aesonDrop (strLength "incomingRequestTo") snakeCase + +data AcceptedIncomingRequest = AcceptedIncomingRequest + { acceptedIncomingRequestToAccountId :: Int + , acceptedIncomingRequestToRoomId :: Int + , acceptedIncomingRequestToName :: Text + , acceptedIncomingRequestToChatworkId :: Text + , acceptedIncomingRequestToOrganizationId :: Int + , acceptedIncomingRequestToOrganizationName :: Text + , acceptedIncomingRequestToDepartment :: Text + , acceptedIncomingRequestToAvatarImageUrl :: Text + } deriving (Show, Generic) + +instance ToJSON AcceptedIncomingRequest where + toJSON = genericToJSON $ aesonDrop (strLength "acceptedIncomingRequestTo") snakeCase +instance FromJSON AcceptedIncomingRequest where + parseJSON = genericParseJSON $ aesonDrop (strLength "acceptedIncomingRequestTo") snakeCase diff --git a/src/ChatWork/Types/Me.hs b/src/ChatWork/Types/Me.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/Me.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.Me + ( Me(..) + ) where + +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +data Me = Me + { meToAccountId :: Int + , meToRoomId :: Int + , meToName :: Text + , meToChatworkId :: Text + , meToOrganizationId :: Int + , meToOrganizationName :: Text + , meToDepartment :: Text + , meToTitle :: Text + , meToUrl :: Text + , meToIntroduction :: Text + , meToMail :: Text + , meToTelOrganization :: Text + , meToTelExtension :: Text + , meToTelMobile :: Text + , meToSkype :: Text + , meToFacebook :: Text + , meToTwitter :: Text + , meToAvatarImageUrl :: Text + } deriving (Show, Generic) + +instance ToJSON Me where + toJSON = genericToJSON $ aesonDrop (strLength "meTo") snakeCase +instance FromJSON Me where + parseJSON = genericParseJSON $ aesonDrop (strLength "meTo") snakeCase diff --git a/src/ChatWork/Types/My.hs b/src/ChatWork/Types/My.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/My.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.My + ( MyStatus(..) + , MyTasks + , MyTask(..) + ) where + +import ChatWork.Types.Base (Account, Room) +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +data MyStatus = MyStatus + { myStatusToUnreadRoomNum :: Int + , myStatusToMentionRoomNum :: Int + , myStatusToMytaskRoomNum :: Int + , myStatusToUnreadNum :: Int + , myStatusToMentionNum :: Int + , myStatusToMytaskNum :: Int + } deriving (Show, Generic) + +instance ToJSON MyStatus where + toJSON = genericToJSON $ aesonDrop (strLength "myStatusTo") snakeCase +instance FromJSON MyStatus where + parseJSON = genericParseJSON $ aesonDrop (strLength "myStatusTo") snakeCase + +type MyTasks = [MyTask] + +data MyTask = MyTask + { myTaskToTaskId :: Int + , myTaskToRoom :: Room + , myTaskToAssignedByAccount :: Account + , myTaskToMessageId :: Text + , myTaskToBody :: Text + , myTaskToLimitTime :: Int + , myTaskToStatus :: Text + } deriving (Show, Generic) + +instance ToJSON MyTask where + toJSON = genericToJSON $ aesonDrop (strLength "myTaskTo") snakeCase +instance FromJSON MyTask where + parseJSON = genericParseJSON $ aesonDrop (strLength "myTaskTo") snakeCase diff --git a/src/ChatWork/Types/Rooms.hs b/src/ChatWork/Types/Rooms.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Types/Rooms.hs @@ -0,0 +1,205 @@ +{-# LANGUAGE DeriveGeneric #-} + +module ChatWork.Types.Rooms + ( Rooms + , RoomDetail(..) + , RoomIdWrap(..) + , Members + , Member(..) + , MembersPermission(..) + , Messages + , Message(..) + , MessageIdWrap(..) + , RoomTasks + , RoomTask + , TaskIdsWrap(..) + , Files + , File(..) + + , CreateRoomParams(..) + , UpdateRoomParams(..) + , RoomMembersParams(..) + , GetTasksParams(..) + , CreateTaskParams(..) + , DeleteRoomActionType(..) + , Force + , MessageBody + , CreateUrlFlag + ) where + +import ChatWork.Types.Base (Account, IconPreset, TaskStatus) +import ChatWork.Utils (strLength) +import Data.Aeson (FromJSON (..), ToJSON (..), + genericParseJSON, genericToJSON) +import Data.Aeson.Casing (aesonDrop, snakeCase) +import Data.Text (Text) +import GHC.Generics (Generic) + +type Rooms = [RoomDetail] + +data RoomDetail = RoomDetail + { roomDetailToRoomId :: Int + , roomDetailToName :: Text + , roomDetailToType :: Text + , roomDetailToRole :: Text + , roomDetailToSticky :: Bool + , roomDetailToUnreadNum :: Int + , roomDetailToMentionNum :: Int + , roomDetailToMytaskNum :: Int + , roomDetailToMessageNum :: Int + , roomDetailToFileNum :: Int + , roomDetailToTaskNum :: Int + , roomDetailToIconPath :: Text + , roomDetailToLastUpdateTime :: Int + , roomDetailToDescription :: Maybe Text + } deriving (Show, Generic) + +instance ToJSON RoomDetail where + toJSON = genericToJSON $ aesonDrop (strLength "roomDetailTo") snakeCase +instance FromJSON RoomDetail where + parseJSON = genericParseJSON $ aesonDrop (strLength "roomDetailTo") snakeCase + +newtype RoomIdWrap = RoomIdWrap { getRoomId :: Int } deriving (Show, Generic) + +instance ToJSON RoomIdWrap where + toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase +instance FromJSON RoomIdWrap where + parseJSON = genericParseJSON $ aesonDrop (strLength "get") snakeCase + +type Members = [Member] + +data Member = Member + { memberToAccountId :: Int + , memberToRole :: Text + , memberToName :: Text + , memberToChatworkId :: Text + , memberToOrganizationId :: Int + , memberToOrganizationName :: Text + , memberToDepartment :: Text + , memberToAvatarImageUrl :: Text + } deriving (Show, Generic) + +instance ToJSON Member where + toJSON = genericToJSON $ aesonDrop (strLength "memberTo") snakeCase +instance FromJSON Member where + parseJSON = genericParseJSON $ aesonDrop (strLength "memberTo") snakeCase + +data MembersPermission = MembersPermission + { membersPermissionToAdmin :: [Int] + , membersPermissionToMember :: [Int] + , membersPermissionToReadonly :: [Int] + } deriving (Show, Generic) + +instance ToJSON MembersPermission where + toJSON = genericToJSON $ aesonDrop (strLength "membersPermissionTo") snakeCase +instance FromJSON MembersPermission where + parseJSON = genericParseJSON $ aesonDrop (strLength "membersPermissionTo") snakeCase + +type Messages = [Message] + +data Message = Message + { messageToMessageId :: Text + , messageToAccount :: Account + , messageToBody :: Text + , messageToSendTime :: Int + , messageToUpdateTime :: Int + } deriving (Show, Generic) + +instance ToJSON Message where + toJSON = genericToJSON $ aesonDrop (strLength "messageTo") snakeCase +instance FromJSON Message where + parseJSON = genericParseJSON $ aesonDrop (strLength "messageTo") snakeCase + +newtype MessageIdWrap = MessageIdWrap { getMessageId :: Text } deriving (Show, Generic) + +instance ToJSON MessageIdWrap where + toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase +instance FromJSON MessageIdWrap where + parseJSON = genericParseJSON $ aesonDrop (strLength "get") snakeCase + +type RoomTasks = [RoomTask] + +data RoomTask = RoomTask + { roomTaskToTaskId :: Int + , roomTaskToAccount :: Account + , roomTaskToAssignedByAccount :: Account + , roomTaskToMessageId :: Text + , roomTaskToBody :: Text + , roomTaskToLimitTime :: Int + , roomTaskToStatus :: Text + } deriving (Show, Generic) + +instance ToJSON RoomTask where + toJSON = genericToJSON $ aesonDrop (strLength "roomTaskTo") snakeCase +instance FromJSON RoomTask where + parseJSON = genericParseJSON $ aesonDrop (strLength "roomTaskTo") snakeCase + +newtype TaskIdsWrap = TaskIdsWrap { getTaskIds :: [Int] } deriving (Show, Generic) + +instance ToJSON TaskIdsWrap where + toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase +instance FromJSON TaskIdsWrap where + parseJSON = genericParseJSON $ aesonDrop (strLength "get") snakeCase + +type Files = [File] + +data File = File + { fileToFileId :: Int + , fileToAccount :: Account + , fileToMessageId :: Text + , fileToFilename :: Text + , fileToFilesize :: Int + , fileToUploadTime :: Int + } deriving (Show, Generic) + +instance ToJSON File where + toJSON = genericToJSON $ aesonDrop (strLength "fileTo") snakeCase +instance FromJSON File where + parseJSON = genericParseJSON $ aesonDrop (strLength "fileTo") snakeCase + +data CreateRoomParams = CreateRoomParams + { cRoomDescription :: Maybe Text + , cIconPreset :: Maybe IconPreset + , cMembersAdminIds :: [Int] + , cMembersMemberIds :: Maybe [Int] + , cMembersReadonlyIds :: Maybe [Int] + , cRoomName :: Text + } deriving (Show) + +data UpdateRoomParams = UpdateRoomParams + { uRoomDescription :: Maybe Text + , uIconPreset :: Maybe IconPreset + , uRoomName :: Maybe Text + } deriving (Show) + +data RoomMembersParams = RoomMembersParams + { getAdminIds :: [Int] + , getMemberIds :: Maybe [Int] + , getReadonlyIds :: Maybe [Int] + } deriving (Show) + +data GetTasksParams = GetTasksParams + { getTaskAccountId :: Maybe Int + , getTaskAssignedByAccountId :: Maybe Int + , getTaskStatus :: Maybe TaskStatus + } deriving (Show) + +data CreateTaskParams = CreateTaskParams + { getTaskBody :: Text + , getTaskLimit :: Maybe Int + , getTaskToIds :: [Int] + } deriving (Show) + +data DeleteRoomActionType = LeaveRoom + | DeleteRoom + deriving (Eq) + +instance Show DeleteRoomActionType where + show LeaveRoom = "leave" + show DeleteRoom = "delete" + +type Force = Bool + +type MessageBody = Text + +type CreateUrlFlag = Bool diff --git a/src/ChatWork/Utils.hs b/src/ChatWork/Utils.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Utils.hs @@ -0,0 +1,90 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module ChatWork.Utils ( + -- * help to construct endpoint + Token + , baseUrl + , mkTokenHeader + -- * Custamize Managaer + , getHttpResponse' + , fixEmptyStringManager + , fixEmptyString + -- * DELETE HTTP method with paramater + , DELETE2(..) + -- * help to make 'FromJSON' instance + , strLength + ) where + +import Control.Monad.IO.Class (MonadIO (..)) +import Data.ByteString (ByteString) +import Data.Default.Class (def) +import Data.List (lookup) +import Data.Maybe (fromMaybe) +import Data.Proxy (Proxy (..)) +import Network.Connection (initConnectionContext) +import Network.HTTP.Client (BodyReader, Manager, + ManagerSettings (..), Request, + Response (..), newManager) +import Network.HTTP.Client.Internal (constBodyReader) +import Network.HTTP.Client.TLS (mkManagerSettingsContext) +import Network.HTTP.Req (AllowsBody (..), + CanHaveBody (..), + HttpMethod (..), + HttpResponse (..), MonadHttp, + Option, Scheme (Https), Url, + header, https, (/:)) +import Network.HTTP.Types (methodDelete) +import Network.HTTP.Types.Header (hContentLength) + +-- | +-- ChatWork API Token +-- detail is +type Token = ByteString + +-- | +-- Base URL for endpoints +-- TODO : change type class function +baseUrl :: Url 'Https +baseUrl = https "api.chatwork.com" /: "v2" + +-- | +-- Make HTTP Header to authenticate API Token of ChatWork +mkTokenHeader :: Token -> Option 'Https +mkTokenHeader token = header "X-ChatWorkToken" token + +-- | +-- Helper function that use custamized Manager +getHttpResponse' :: (HttpResponse a, MonadHttp m) => Proxy a -> Request -> Manager -> m a +getHttpResponse' Proxy r m = liftIO $ getHttpResponse r =<< fixEmptyStringManager + +fixEmptyStringManager :: IO Manager +fixEmptyStringManager = do + context <- initConnectionContext + let settings = mkManagerSettingsContext (Just context) def Nothing + newManager $ settings { managerModifyResponse = fixEmptyString } + +-- | +-- if response is no contents, replace "[]". +-- aeson return parse error when response is no content response +fixEmptyString :: Response BodyReader -> IO (Response BodyReader) +fixEmptyString res = do + reader <- constBodyReader ["[]"] + let + contentLength = fromMaybe "0" $ lookup hContentLength (responseHeaders res) + return $ if contentLength /= "0" then res else res { responseBody = reader } + +-- | +-- if want to use Delete HTTP methos with request param, use this type. +-- ref : +data DELETE2 = DELETE2 + +instance HttpMethod DELETE2 where + type AllowsBody DELETE2 = 'CanHaveBody + httpMethodName Proxy = methodDelete + +-- | +-- for resolve ambiguous type +strLength :: String -> Int +strLength = length