chatwork (empty) → 0.1.0.0

raw patch · 21 files changed

+1004/−0 lines, 21 filesdep +aesondep +aeson-casingdep +basesetup-changed

Dependencies added: aeson, aeson-casing, base, bytestring, connection, data-default-class, http-client, http-client-tls, http-types, req, text

Files

LICENSE +21/−0
Setup.hs +2/−0
chatwork.cabal +57/−0
src/ChatWork.hs +16/−0
src/ChatWork/Endpoints.hs +18/−0
src/ChatWork/Endpoints/Contacts.hs +17/−0
src/ChatWork/Endpoints/IncomingRequests.hs +27/−0
src/ChatWork/Endpoints/Me.hs +17/−0
src/ChatWork/Endpoints/My.hs +21/−0
src/ChatWork/Endpoints/Rooms.hs +133/−0
src/ChatWork/Internal.hs +28/−0
src/ChatWork/MonadHttpIO.hs +11/−0
src/ChatWork/Types.hs +65/−0
src/ChatWork/Types/Base.hs +87/−0
src/ChatWork/Types/Contacts.hs +31/−0
src/ChatWork/Types/Error.hs +25/−0
src/ChatWork/Types/IncomingRequests.hs +49/−0
src/ChatWork/Types/Me.hs +38/−0
src/ChatWork/Types/My.hs +46/−0
src/ChatWork/Types/Rooms.hs +205/−0
src/ChatWork/Utils.hs +90/−0

+ LICENSE view

@@ -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.

+ Setup.hs view

@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain

+ chatwork.cabal view

@@ -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 <https://github.com/matsubara0507/chatwork#readme>+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+

+ src/ChatWork.hs view

@@ -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

+ src/ChatWork/Endpoints.hs view

@@ -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

+ src/ChatWork/Endpoints/Contacts.hs view

@@ -0,0 +1,17 @@+-- |
+-- see : <http://developer.chatwork.com/ja/endpoint_contacts.html>
+
+{-# 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

+ src/ChatWork/Endpoints/IncomingRequests.hs view

@@ -0,0 +1,27 @@+-- |
+-- see : <http://developer.chatwork.com/ja/endpoint_incoming_requests.html>
+
+{-# 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

+ src/ChatWork/Endpoints/Me.hs view

@@ -0,0 +1,17 @@+-- |
+-- see : <http://developer.chatwork.com/ja/endpoint_me.html>
+--
+{-# 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

+ src/ChatWork/Endpoints/My.hs view

@@ -0,0 +1,21 @@+-- |
+-- see : <http://developer.chatwork.com/ja/endpoint_my.html>
+
+{-# 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

+ src/ChatWork/Endpoints/Rooms.hs view

@@ -0,0 +1,133 @@+-- |
+-- see : <http://developer.chatwork.com/ja/endpoint_rooms.html>
+
+{-# 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)

+ src/ChatWork/Internal.hs view

@@ -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'

+ src/ChatWork/MonadHttpIO.hs view

@@ -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

+ src/ChatWork/Types.hs view

@@ -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

+ src/ChatWork/Types/Base.hs view

@@ -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 : <http://developer.chatwork.com/ja/endpoint_rooms.html#POST-rooms>
+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

+ src/ChatWork/Types/Contacts.hs view

@@ -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

+ src/ChatWork/Types/Error.hs view

@@ -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

+ src/ChatWork/Types/IncomingRequests.hs view

@@ -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

+ src/ChatWork/Types/Me.hs view

@@ -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

+ src/ChatWork/Types/My.hs view

@@ -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

+ src/ChatWork/Types/Rooms.hs view

@@ -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

+ src/ChatWork/Utils.hs view

@@ -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 <http://developer.chatwork.com/ja/authenticate.html>
+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 : <https://hackage.haskell.org/package/req-0.3.0/docs/Network-HTTP-Req.html#t:DELETE>
+data DELETE2 = DELETE2
+
+instance HttpMethod DELETE2 where
+  type AllowsBody DELETE2 = 'CanHaveBody
+  httpMethodName Proxy = methodDelete
+
+-- |
+-- for resolve ambiguous type
+strLength :: String -> Int
+strLength = length