diff --git a/chatwork.cabal b/chatwork.cabal --- a/chatwork.cabal +++ b/chatwork.cabal @@ -1,57 +1,121 @@ -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 +-- This file has been generated from package.yaml by hpack version 0.17.0. +-- +-- see: https://github.com/sol/hpack +name: chatwork +version: 0.1.1.0 +synopsis: The ChatWork API in Haskell +description: See README at +homepage: https://github.com/matsubara0507/chatwork#readme +bug-reports: https://github.com/matsubara0507/chatwork/issues +author: MATSUBARA Nobutada +maintainer: MATSUBARA Nobutada +copyright: 2017 MATSUBARA Nobutada +license: MIT +license-file: LICENSE +category: Web +build-type: Simple +cabal-version: >= 1.10 + source-repository head - type: git - location: https://github.com/matsubara0507/chatwork + 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 + hs-source-dirs: + src + ghc-options: -Wall + exposed-modules: + ChatWork + ChatWork.Client + 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 + other-modules: + ChatWork.Internal + build-depends: + base >=4.7 && <5 + , aeson >=1.0.2.1 && <1.2 + , aeson-casing >=0.1.0.5 && <0.2 + , bytestring >=0.10.8.1 && <0.11 + , connection >=0.2.7 && <0.3 + , data-default-class >=0.1.2.0 && <0.2 + , http-api-data >=0.3.5 && <0.3.8 + , http-client >=0.5.5.0 && <0.6 + , http-client-tls >=0.3.3.1 && <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 +test-suite spec + type: exitcode-stdio-1.0 + main-is: Spec.hs + hs-source-dirs: + test + src + ghc-options: -Wall + build-depends: + base >=4.7 && <5 + , aeson >=1.0.2.1 && <1.2 + , aeson-casing >=0.1.0.5 && <0.2 + , bytestring >=0.10.8.1 && <0.11 + , connection >=0.2.7 && <0.3 + , data-default-class >=0.1.2.0 && <0.2 + , http-api-data >=0.3.5 && <0.3.8 + , http-client >=0.5.5.0 && <0.6 + , http-client-tls >=0.3.3.1 && <0.4 + , http-types >=0.9.1 && <0.10 + , req >=0.3.0 && <0.4 + , text >=1.2.2.1 && <1.3 + , servant-server >=0.9.1.1 && <0.12 + , warp >=3.2.11 && <3.3 + , hspec >=2.4.1 && <2.5 + other-modules: + ChatWork.Endpoints.ContactsSpec + ChatWork.Endpoints.IncomingRequestsSpec + ChatWork.Endpoints.MeSpec + ChatWork.Endpoints.MySpec + ChatWork.Endpoints.RoomsSpec + ChatWork.Test.Client + ChatWork.Test.MockServer + ChatWork.Test.Types + ChatWork.Test.Values + ChatWork.Test.Values.Contacts + ChatWork.Test.Values.IncomingRequests + ChatWork.Test.Values.Me + ChatWork.Test.Values.My + ChatWork.Test.Values.Rooms + ChatWork + ChatWork.Client + ChatWork.Endpoints + ChatWork.Endpoints.Contacts + ChatWork.Endpoints.IncomingRequests + ChatWork.Endpoints.Me + ChatWork.Endpoints.My + ChatWork.Endpoints.Rooms + ChatWork.Internal + ChatWork.MonadHttpIO + ChatWork.Types + ChatWork.Types.Base + ChatWork.Types.Contacts + ChatWork.Types.Error + ChatWork.Types.IncomingRequests + ChatWork.Types.Me + ChatWork.Types.My + ChatWork.Types.Rooms + ChatWork.Utils + default-language: Haskell2010 diff --git a/src/ChatWork.hs b/src/ChatWork.hs --- a/src/ChatWork.hs +++ b/src/ChatWork.hs @@ -3,14 +3,17 @@ -- module ChatWork ( - -- * Emdpoint function definitions - module ChatWork.Endpoints + -- * Define about ChatWork Client + module ChatWork.Client + -- * Endpoint 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.Client import ChatWork.Endpoints import ChatWork.MonadHttpIO () import ChatWork.Types diff --git a/src/ChatWork/Client.hs b/src/ChatWork/Client.hs new file mode 100644 --- /dev/null +++ b/src/ChatWork/Client.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TypeFamilies #-} + +module ChatWork.Client ( + Token + , ChatWorkClient(..) + , Client(..) + ) where + +import Data.ByteString (ByteString) +import Network.HTTP.Req (Option, Scheme (Https), Url, header, https, + (/:)) + + +type Token = ByteString + +newtype ChatWorkClient = ChatWorkClient Token + +-- | +-- By using type class, the same functions can be used for mock servers and local hosts. +class Client a where + type ClientScheme a :: Scheme + baseUrl :: a -> Url (ClientScheme a) + mkHeader :: a -> Option scheme + +instance Client ChatWorkClient where + type ClientScheme ChatWorkClient = 'Https + baseUrl = const (https "api.chatwork.com" /: "v2") + mkHeader (ChatWorkClient token) = header "X-ChatWorkToken" token diff --git a/src/ChatWork/Endpoints/Contacts.hs b/src/ChatWork/Endpoints/Contacts.hs --- a/src/ChatWork/Endpoints/Contacts.hs +++ b/src/ChatWork/Endpoints/Contacts.hs @@ -7,11 +7,11 @@ ( getContacts ) where +import ChatWork.Client (Client (..)) import ChatWork.Internal (req) import ChatWork.Types (ChatWorkResponse, Contacts) -import ChatWork.Utils (Token, baseUrl, mkTokenHeader) -import Network.HTTP.Req (GET (..), JsonResponse, MonadHttp, - NoReqBody (..), jsonResponse, (/:)) +import Network.HTTP.Req (GET (..), MonadHttp, NoReqBody (..), + jsonResponse, (/:)) -getContacts :: (MonadHttp m) => Token -> m (ChatWorkResponse Contacts) -getContacts = req GET (baseUrl /: "contacts") NoReqBody jsonResponse . mkTokenHeader +getContacts :: (MonadHttp m, Client c) => c -> m (ChatWorkResponse Contacts) +getContacts c = req GET (baseUrl c /: "contacts") NoReqBody jsonResponse $ mkHeader c diff --git a/src/ChatWork/Endpoints/IncomingRequests.hs b/src/ChatWork/Endpoints/IncomingRequests.hs --- a/src/ChatWork/Endpoints/IncomingRequests.hs +++ b/src/ChatWork/Endpoints/IncomingRequests.hs @@ -5,23 +5,27 @@ module ChatWork.Endpoints.IncomingRequests ( getIncomingRequests - , acceptIncomingRequests - , rejectIncomingRequests + , acceptIncomingRequest + , rejectIncomingRequest ) where +import ChatWork.Client (Client (..)) 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, (/:), (/~)) +import Network.HTTP.Req (DELETE (..), GET (..), MonadHttp, + NoReqBody (..), PUT (..), jsonResponse, + (/:), (/~)) -getIncomingRequests :: (MonadHttp m) => Token -> m (ChatWorkResponse IncomingRequests) -getIncomingRequests = req GET (baseUrl /: "incoming_requests") NoReqBody jsonResponse . mkTokenHeader +getIncomingRequests :: (MonadHttp m, Client c) => c -> m (ChatWorkResponse IncomingRequests) +getIncomingRequests c = req GET (baseUrl c /: "incoming_requests") NoReqBody jsonResponse $ mkHeader c -acceptIncomingRequests :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse AcceptedIncomingRequest) -acceptIncomingRequests t n = req PUT (baseUrl /: "incoming_requests" /~ n ) NoReqBody jsonResponse $ mkTokenHeader t +-- | +-- argument 'Int' is `request_id` +acceptIncomingRequest :: (MonadHttp m, Client c) => c -> Int -> m (ChatWorkResponse AcceptedIncomingRequest) +acceptIncomingRequest c n = req PUT (baseUrl c /: "incoming_requests" /~ n ) NoReqBody jsonResponse $ mkHeader c -rejectIncomingRequests :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse ()) -rejectIncomingRequests t n = req DELETE (baseUrl /: "incoming_requests" /~ n) NoReqBody jsonResponse $ mkTokenHeader t +-- | +-- argument 'Int' is `request_id` +rejectIncomingRequest :: (MonadHttp m, Client c) => c -> Int -> m (ChatWorkResponse ()) +rejectIncomingRequest c n = req DELETE (baseUrl c /: "incoming_requests" /~ n) NoReqBody jsonResponse $ mkHeader c diff --git a/src/ChatWork/Endpoints/Me.hs b/src/ChatWork/Endpoints/Me.hs --- a/src/ChatWork/Endpoints/Me.hs +++ b/src/ChatWork/Endpoints/Me.hs @@ -7,11 +7,11 @@ ( getMe ) where +import ChatWork.Client (Client (..)) import ChatWork.Internal (req) import ChatWork.Types (ChatWorkResponse, Me) -import ChatWork.Utils (Token, baseUrl, mkTokenHeader) -import Network.HTTP.Req (GET (..), JsonResponse, MonadHttp, - NoReqBody (..), jsonResponse, (/:)) +import Network.HTTP.Req (GET (..), MonadHttp, NoReqBody (..), + jsonResponse, (/:)) -getMe :: (MonadHttp m) => Token -> m (ChatWorkResponse Me) -getMe = req GET (baseUrl /: "me") NoReqBody jsonResponse . mkTokenHeader +getMe :: (MonadHttp m, Client c) => c -> m (ChatWorkResponse Me) +getMe c = req GET (baseUrl c /: "me") NoReqBody jsonResponse $ mkHeader c diff --git a/src/ChatWork/Endpoints/My.hs b/src/ChatWork/Endpoints/My.hs --- a/src/ChatWork/Endpoints/My.hs +++ b/src/ChatWork/Endpoints/My.hs @@ -8,14 +8,19 @@ , getMyTasks ) where +import ChatWork.Client (Client (..)) 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, (/:)) +import ChatWork.Types (ChatWorkResponse, GetMyTasksParams (..), + MyStatus, MyTasks, ToReqParam (..)) +import Data.Monoid ((<>)) +import Network.HTTP.Req (GET (..), MonadHttp, NoReqBody (..), + jsonResponse, (/:)) -getMyStatus :: (MonadHttp m) => Token -> m (ChatWorkResponse MyStatus) -getMyStatus = req GET (baseUrl /: "my" /: "status") NoReqBody jsonResponse . mkTokenHeader +getMyStatus :: (MonadHttp m, Client c) => c -> m (ChatWorkResponse MyStatus) +getMyStatus c = req GET (baseUrl c /: "my" /: "status") NoReqBody jsonResponse $ mkHeader c -getMyTasks :: (MonadHttp m) => Token -> m (ChatWorkResponse MyTasks) -getMyTasks = req GET (baseUrl /: "my" /: "tasks") NoReqBody jsonResponse . mkTokenHeader +getMyTasks :: (MonadHttp m, Client c) => c -> GetMyTasksParams -> m (ChatWorkResponse MyTasks) +getMyTasks c params = req GET (baseUrl c /: "my" /: "tasks") NoReqBody jsonResponse $ mkHeader c <> params' + where + params' = toReqParam "assigned_by_account_id" (getMyTasksAssignedByAccountId params) + <> toReqParam "status" (getMyTasksStatus params) diff --git a/src/ChatWork/Endpoints/Rooms.hs b/src/ChatWork/Endpoints/Rooms.hs --- a/src/ChatWork/Endpoints/Rooms.hs +++ b/src/ChatWork/Endpoints/Rooms.hs @@ -28,6 +28,7 @@ , getFile ) where +import ChatWork.Client (Client (..)) import ChatWork.Internal (req) import ChatWork.Types (AccountId, ChatWorkResponse, CreateRoomParams (..), @@ -39,20 +40,19 @@ RoomIdWrap, RoomMembersParams (..), RoomTask, RoomTasks, Rooms, TaskIdsWrap, ToReqParam (..), UpdateRoomParams (..)) -import ChatWork.Utils (DELETE2 (..), Token, baseUrl, mkTokenHeader) +import ChatWork.Utils (DELETE2 (..)) import Data.Bool (bool) import Data.Monoid ((<>)) import Data.Text (Text) -import Network.HTTP.Req (DELETE (..), GET (..), JsonResponse, - MonadHttp, NoReqBody (..), POST (..), - PUT (..), ReqBodyUrlEnc (..), jsonResponse, - (/:), (/~), (=:)) +import Network.HTTP.Req (GET (..), MonadHttp, NoReqBody (..), + POST (..), PUT (..), ReqBodyUrlEnc (..), + jsonResponse, (/:), (/~), (=:)) -getRooms :: (MonadHttp m) => Token -> m (ChatWorkResponse Rooms) -getRooms = req GET (baseUrl /: "rooms") NoReqBody jsonResponse . mkTokenHeader +getRooms :: (MonadHttp m, Client c) => c -> m (ChatWorkResponse Rooms) +getRooms c = req GET (baseUrl c /: "rooms") NoReqBody jsonResponse $ mkHeader c -createRoom :: (MonadHttp m) => Token -> CreateRoomParams -> m (ChatWorkResponse RoomIdWrap) -createRoom t params = req POST (baseUrl /: "rooms") (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t +createRoom :: (MonadHttp m, Client c) => c -> CreateRoomParams -> m (ChatWorkResponse RoomIdWrap) +createRoom c params = req POST (baseUrl c /: "rooms") (ReqBodyUrlEnc params') jsonResponse $ mkHeader c where params' = toReqParam "description" (cRoomDescription params) <> toReqParam "icon_preset" (cIconPreset params) @@ -61,73 +61,107 @@ <> 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 +-- | +-- argumrnt 'Int' is `room_id`. +getRoom :: (MonadHttp m, Client c) => c -> Int -> m (ChatWorkResponse RoomDetail) +getRoom c n = req GET (baseUrl c /: "rooms" /~ n) NoReqBody jsonResponse $ mkHeader c -updateRoom :: (MonadHttp m) => Token -> Int -> UpdateRoomParams -> m (ChatWorkResponse RoomIdWrap) -updateRoom t n params = req PUT (baseUrl /: "rooms" /~ n) (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t +-- | +-- argumrnt 'Int' is `room_id`. +updateRoom :: (MonadHttp m, Client c) => c -> Int -> UpdateRoomParams -> m (ChatWorkResponse RoomIdWrap) +updateRoom c n params = req PUT (baseUrl c /: "rooms" /~ n) (ReqBodyUrlEnc params') jsonResponse $ mkHeader c 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 +-- | +-- wrap `deleteRoom'` function, using 'DeleteRoom'. +-- argumrnt 'Int' is `room_id`. +deleteRoom :: (MonadHttp m, Client c) => c -> Int -> m (ChatWorkResponse ()) +deleteRoom c n = deleteRoom' c n DeleteRoom -leaveRoom :: (MonadHttp m) => Token -> Int -> m (ChatWorkResponse ()) -leaveRoom t n = deleteRoom' t n LeaveRoom +-- | +-- wrap `deleteRoom'` function, using 'LeaveRoom'. +-- argumrnt 'Int' is `room_id`. +leaveRoom :: (MonadHttp m, Client c) => c -> Int -> m (ChatWorkResponse ()) +leaveRoom c n = deleteRoom' c n LeaveRoom -deleteRoom' :: (MonadHttp m) => Token -> Int -> DeleteRoomActionType -> m (ChatWorkResponse ()) -deleteRoom' t n action = req DELETE2 (baseUrl /: "rooms" /~ n) (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t +-- | +-- argumrnt 'Int' is `room_id`. +deleteRoom' :: (MonadHttp m, Client c) => c -> Int -> DeleteRoomActionType -> m (ChatWorkResponse ()) +deleteRoom' c n action = req DELETE2 (baseUrl c /: "rooms" /~ n) (ReqBodyUrlEnc params') jsonResponse $ mkHeader c 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 +-- | +-- argumrnt 'Int' is `room_id`. +getMembers :: (MonadHttp m, Client c) => c -> Int -> m (ChatWorkResponse Members) +getMembers c n = req GET (baseUrl c /: "rooms" /~ n /: "members") NoReqBody jsonResponse $ mkHeader c -updateMembersPermission :: (MonadHttp m) => Token -> Int -> RoomMembersParams -> m (ChatWorkResponse MembersPermission) -updateMembersPermission t n params = req PUT (baseUrl /: "rooms" /~ n /: "members") (ReqBodyUrlEnc params') jsonResponse $ mkTokenHeader t +-- | +-- argumrnt 'Int' is `room_id`. +updateMembersPermission :: (MonadHttp m, Client c) => c -> Int -> RoomMembersParams -> m (ChatWorkResponse MembersPermission) +updateMembersPermission c n params = req PUT (baseUrl c /: "rooms" /~ n /: "members") (ReqBodyUrlEnc params') jsonResponse $ mkHeader c 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' +-- | +-- argumrnt 'Int' is `room_id`. +getMessages :: (MonadHttp m, Client c) => c -> Int -> Maybe Force -> m (ChatWorkResponse Messages) +getMessages c n force = req GET (baseUrl c /: "rooms" /~ n /: "messages") NoReqBody jsonResponse $ mkHeader c <> 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 +-- | +-- argumrnt 'Int' is `room_id`. +postMessage :: (MonadHttp m, Client c) => c -> Int -> MessageBody -> m (ChatWorkResponse MessageIdWrap) +postMessage c n body = req POST (baseUrl c /: "rooms" /~ n /: "messages") (ReqBodyUrlEnc params') jsonResponse $ mkHeader c 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 +-- | +-- argumrnt 'Int' is `room_id`. +-- argumrnt 'Text' is `message_id`. +getMessage :: (MonadHttp m, Client c) => c -> Int -> Text -> m (ChatWorkResponse Message) +getMessage c rid mid = req GET (baseUrl c /: "rooms" /~ rid /: "messages" /~ mid) NoReqBody jsonResponse $ mkHeader c -getRoomTasks :: (MonadHttp m) => Token -> Int -> GetTasksParams -> m (ChatWorkResponse RoomTasks) -getRoomTasks t n params = req GET (baseUrl /: "rooms" /~ n /: "tasks") NoReqBody jsonResponse $ mkTokenHeader t <> params' +-- | +-- argumrnt 'Int' is `room_id`. +getRoomTasks :: (MonadHttp m, Client c) => c -> Int -> GetTasksParams -> m (ChatWorkResponse RoomTasks) +getRoomTasks c n params = req GET (baseUrl c /: "rooms" /~ n /: "tasks") NoReqBody jsonResponse $ mkHeader c <> 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 +-- | +-- argumrnt 'Int' is `room_id`. +createTask :: (MonadHttp m, Client c) => c -> Int -> CreateTaskParams -> m (ChatWorkResponse TaskIdsWrap) +createTask c n params = req POST (baseUrl c /: "rooms" /~ n /: "tasks") (ReqBodyUrlEnc params') jsonResponse $ mkHeader c 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 +-- | +-- argumrnt first 'Int' is `room_id`. +-- argumrnt second 'Int' is `task_id`. +getRoomTask :: (MonadHttp m, Client c) => c -> Int -> Int -> m (ChatWorkResponse RoomTask) +getRoomTask c rid tid = req GET (baseUrl c /: "rooms" /~ rid /: "tasks" /~ tid) NoReqBody jsonResponse $ mkHeader c -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' +-- | +-- argumrnt 'Int' is `room_id`. +getFiles :: (MonadHttp m, Client c) => c -> Int -> Maybe AccountId -> m (ChatWorkResponse Files) +getFiles c rid aid = req GET (baseUrl c /: "rooms" /~ rid /: "files") NoReqBody jsonResponse $ mkHeader c <> 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' +-- | +-- argumrnt first 'Int' is `room_id`. +-- argumrnt second 'Int' is `file_id`. +getFile :: (MonadHttp m, Client c) => c -> Int -> Int -> Maybe CreateUrlFlag -> m (ChatWorkResponse File) +getFile c rid fid flag = req GET (baseUrl c /: "rooms" /~ rid /: "files" /~ fid) NoReqBody jsonResponse $ mkHeader c <> params' where params' = toReqParam "create_download_url" (bool 0 (1 :: Int) <$> flag) diff --git a/src/ChatWork/Types.hs b/src/ChatWork/Types.hs --- a/src/ChatWork/Types.hs +++ b/src/ChatWork/Types.hs @@ -1,4 +1,3 @@ -{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeSynonymInstances #-} @@ -6,7 +5,7 @@ module ChatWork.Types ( -- * type synonym of Response Json - ChatWorkResponse(..) + ChatWorkResponse -- * Helper type class for constructing Request paramater , ToReqParam(..) @@ -25,10 +24,9 @@ import ChatWork.Types.Error (ChatWorkErrors) import Control.Applicative ((<|>)) -import Data.Aeson (FromJSON (..), Value (..)) +import Data.Aeson (FromJSON (..)) import Data.Monoid (Monoid) import Data.Text (Text, pack) -import GHC.Generics import Network.HTTP.Req (JsonResponse, QueryParam, (=:)) @@ -56,7 +54,7 @@ toReqParam = maybe mempty . toReqParam instance Show a => ToReqParam [a] where - toReqParam name = toReqParam name . foldl (\acc a -> mconcat [acc, ",", pack $ show a]) "" + toReqParam name = toReqParam name . foldl1 (\acc txt -> mconcat [acc, ",", txt]) . fmap (pack . show) instance ToReqParam IconPreset where toReqParam name = toReqParam name . pack . show diff --git a/src/ChatWork/Types/Base.hs b/src/ChatWork/Types/Base.hs --- a/src/ChatWork/Types/Base.hs +++ b/src/ChatWork/Types/Base.hs @@ -1,10 +1,13 @@ {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE TypeSynonymInstances #-} module ChatWork.Types.Base ( Room(..) , Account(..) , IconPreset(..) - , TaskStatus + , TaskStatus (..) , AccountId ) where @@ -12,14 +15,16 @@ import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) import Data.Aeson.Casing (aesonDrop, snakeCase) -import Data.Text (Text) +import Data.Either (partitionEithers) +import Data.Text (Text, pack, split) import GHC.Generics (Generic) +import Web.HttpApiData data Room = Room { roomToRoomId :: Int , roomToName :: Text , roomToIconPath :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON Room where toJSON = genericToJSON $ aesonDrop (strLength "roomTo") snakeCase @@ -30,7 +35,7 @@ { accountToAccountId :: Int , accountToName :: Text , accountToAvatarImageUrl :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON Account where toJSON = genericToJSON $ aesonDrop (strLength "accountTo") snakeCase @@ -57,7 +62,7 @@ | Music | Sports | Travel - deriving (Eq) + deriving (Bounded, Enum, Eq) instance Show IconPreset where show Group = "group" @@ -78,10 +83,33 @@ show Sports = "sports" show Travel = "travel" -data TaskStatus = Open | Done +instance ToHttpApiData IconPreset where + toUrlPiece = pack . show +instance FromHttpApiData IconPreset where + parseUrlPiece = parseBoundedUrlPiece + +-- | +-- use get tasks on room +-- see: +data TaskStatus = Open | Done deriving (Bounded, Enum, Eq) + instance Show TaskStatus where show Open = "open" show Done = "done" +instance ToHttpApiData TaskStatus where + toUrlPiece = pack . show + +instance FromHttpApiData TaskStatus where + parseUrlPiece = parseBoundedUrlPiece + +-- | +-- use get files on room +-- see: type AccountId = Int + +instance (FromHttpApiData a) => FromHttpApiData [a] where + parseUrlPiece txt = if null es then Right xs else Left "abc" + where + (es, xs) = partitionEithers . fmap parseUrlPiece $ split (== ',') txt diff --git a/src/ChatWork/Types/Contacts.hs b/src/ChatWork/Types/Contacts.hs --- a/src/ChatWork/Types/Contacts.hs +++ b/src/ChatWork/Types/Contacts.hs @@ -23,7 +23,7 @@ , contactToOrganizationName :: Text , contactToDepartment :: Text , contactToAvatarImageUrl :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON Contact where toJSON = genericToJSON $ aesonDrop (strLength "contactTo") snakeCase diff --git a/src/ChatWork/Types/Error.hs b/src/ChatWork/Types/Error.hs --- a/src/ChatWork/Types/Error.hs +++ b/src/ChatWork/Types/Error.hs @@ -1,7 +1,7 @@ {-# LANGUAGE DeriveGeneric #-} module ChatWork.Types.Error - ( ChatWorkErrors + ( ChatWorkErrors(..) ) where import ChatWork.Utils (strLength) @@ -17,7 +17,7 @@ -- -- see : http://developer.chatwork.com/ja/endpoints.html -newtype ChatWorkErrors = ChatWorkErrors { getErrors :: [Text] } deriving (Show, Generic) +newtype ChatWorkErrors = ChatWorkErrors { getErrors :: [Text] } deriving (Eq, Show, Generic) instance ToJSON ChatWorkErrors where toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase diff --git a/src/ChatWork/Types/IncomingRequests.hs b/src/ChatWork/Types/IncomingRequests.hs --- a/src/ChatWork/Types/IncomingRequests.hs +++ b/src/ChatWork/Types/IncomingRequests.hs @@ -25,7 +25,7 @@ , incomingRequestToOrganizationName :: Text , incomingRequestToDepartment :: Text , incomingRequestToAvatarImageUrl :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON IncomingRequest where toJSON = genericToJSON $ aesonDrop (strLength "incomingRequestTo") snakeCase @@ -41,7 +41,7 @@ , acceptedIncomingRequestToOrganizationName :: Text , acceptedIncomingRequestToDepartment :: Text , acceptedIncomingRequestToAvatarImageUrl :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON AcceptedIncomingRequest where toJSON = genericToJSON $ aesonDrop (strLength "acceptedIncomingRequestTo") snakeCase diff --git a/src/ChatWork/Types/Me.hs b/src/ChatWork/Types/Me.hs --- a/src/ChatWork/Types/Me.hs +++ b/src/ChatWork/Types/Me.hs @@ -30,7 +30,7 @@ , meToFacebook :: Text , meToTwitter :: Text , meToAvatarImageUrl :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON Me where toJSON = genericToJSON $ aesonDrop (strLength "meTo") snakeCase diff --git a/src/ChatWork/Types/My.hs b/src/ChatWork/Types/My.hs --- a/src/ChatWork/Types/My.hs +++ b/src/ChatWork/Types/My.hs @@ -4,9 +4,10 @@ ( MyStatus(..) , MyTasks , MyTask(..) + , GetMyTasksParams(..) ) where -import ChatWork.Types.Base (Account, Room) +import ChatWork.Types.Base (Account, AccountId, Room, TaskStatus) import ChatWork.Utils (strLength) import Data.Aeson (FromJSON (..), ToJSON (..), genericParseJSON, genericToJSON) @@ -21,7 +22,7 @@ , myStatusToUnreadNum :: Int , myStatusToMentionNum :: Int , myStatusToMytaskNum :: Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON MyStatus where toJSON = genericToJSON $ aesonDrop (strLength "myStatusTo") snakeCase @@ -38,9 +39,16 @@ , myTaskToBody :: Text , myTaskToLimitTime :: Int , myTaskToStatus :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON MyTask where toJSON = genericToJSON $ aesonDrop (strLength "myTaskTo") snakeCase instance FromJSON MyTask where parseJSON = genericParseJSON $ aesonDrop (strLength "myTaskTo") snakeCase + +-- | +-- see: +data GetMyTasksParams = GetMyTasksParams + { getMyTasksAssignedByAccountId :: Maybe AccountId + , getMyTasksStatus :: Maybe TaskStatus + } deriving (Show) diff --git a/src/ChatWork/Types/Rooms.hs b/src/ChatWork/Types/Rooms.hs --- a/src/ChatWork/Types/Rooms.hs +++ b/src/ChatWork/Types/Rooms.hs @@ -1,7 +1,9 @@ -{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE OverloadedStrings #-} -module ChatWork.Types.Rooms - ( Rooms +module ChatWork.Types.Rooms ( + -- Response Types + Rooms , RoomDetail(..) , RoomIdWrap(..) , Members @@ -11,11 +13,11 @@ , Message(..) , MessageIdWrap(..) , RoomTasks - , RoomTask + , RoomTask(..) , TaskIdsWrap(..) , Files , File(..) - + -- Request Parameter Types , CreateRoomParams(..) , UpdateRoomParams(..) , RoomMembersParams(..) @@ -27,13 +29,15 @@ , 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) +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, pack) +import GHC.Generics (Generic) +import Web.FormUrlEncoded +import Web.HttpApiData type Rooms = [RoomDetail] @@ -52,14 +56,14 @@ , roomDetailToIconPath :: Text , roomDetailToLastUpdateTime :: Int , roomDetailToDescription :: Maybe Text - } deriving (Show, Generic) + } deriving (Eq, 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) +newtype RoomIdWrap = RoomIdWrap { getRoomId :: Int } deriving (Eq, Show, Generic) instance ToJSON RoomIdWrap where toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase @@ -77,7 +81,7 @@ , memberToOrganizationName :: Text , memberToDepartment :: Text , memberToAvatarImageUrl :: Text - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON Member where toJSON = genericToJSON $ aesonDrop (strLength "memberTo") snakeCase @@ -88,7 +92,7 @@ { membersPermissionToAdmin :: [Int] , membersPermissionToMember :: [Int] , membersPermissionToReadonly :: [Int] - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON MembersPermission where toJSON = genericToJSON $ aesonDrop (strLength "membersPermissionTo") snakeCase @@ -103,14 +107,14 @@ , messageToBody :: Text , messageToSendTime :: Int , messageToUpdateTime :: Int - } deriving (Show, Generic) + } deriving (Eq, 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) +newtype MessageIdWrap = MessageIdWrap { getMessageId :: Text } deriving (Eq, Show, Generic) instance ToJSON MessageIdWrap where toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase @@ -127,14 +131,14 @@ , roomTaskToBody :: Text , roomTaskToLimitTime :: Int , roomTaskToStatus :: Text - } deriving (Show, Generic) + } deriving (Eq, 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) +newtype TaskIdsWrap = TaskIdsWrap { getTaskIds :: [Int] } deriving (Eq, Show, Generic) instance ToJSON TaskIdsWrap where toJSON = genericToJSON $ aesonDrop (strLength "get") snakeCase @@ -150,13 +154,15 @@ , fileToFilename :: Text , fileToFilesize :: Int , fileToUploadTime :: Int - } deriving (Show, Generic) + } deriving (Eq, Show, Generic) instance ToJSON File where toJSON = genericToJSON $ aesonDrop (strLength "fileTo") snakeCase instance FromJSON File where parseJSON = genericParseJSON $ aesonDrop (strLength "fileTo") snakeCase +-- | +-- see: data CreateRoomParams = CreateRoomParams { cRoomDescription :: Maybe Text , cIconPreset :: Maybe IconPreset @@ -166,40 +172,92 @@ , cRoomName :: Text } deriving (Show) +instance FromForm CreateRoomParams where + fromForm f = CreateRoomParams + <$> parseMaybe "description" f + <*> parseMaybe "icon_preset" f + <*> parseUnique "members_admin_ids" f + <*> parseMaybe "members_member_ids" f + <*> parseMaybe "members_readonly_ids" f + <*> parseUnique "name" f + +-- | +-- see: data UpdateRoomParams = UpdateRoomParams { uRoomDescription :: Maybe Text , uIconPreset :: Maybe IconPreset , uRoomName :: Maybe Text } deriving (Show) +instance FromForm UpdateRoomParams where + fromForm f = UpdateRoomParams + <$> parseMaybe "description" f + <*> parseMaybe "icon_preset" f + <*> parseMaybe "name" f + +-- | +-- see: data RoomMembersParams = RoomMembersParams { getAdminIds :: [Int] , getMemberIds :: Maybe [Int] , getReadonlyIds :: Maybe [Int] } deriving (Show) +instance FromForm RoomMembersParams where + fromForm f = RoomMembersParams + <$> parseUnique "members_admin_ids" f + <*> parseMaybe "members_member_ids" f + <*> parseMaybe "members_readonly_ids" f + +-- | +-- see: data GetTasksParams = GetTasksParams { getTaskAccountId :: Maybe Int , getTaskAssignedByAccountId :: Maybe Int , getTaskStatus :: Maybe TaskStatus } deriving (Show) +-- | +-- see: data CreateTaskParams = CreateTaskParams { getTaskBody :: Text , getTaskLimit :: Maybe Int , getTaskToIds :: [Int] } deriving (Show) +instance FromForm CreateTaskParams where + fromForm f = CreateTaskParams + <$> parseUnique "body" f + <*> parseMaybe "limit" f + <*> parseUnique "to_ids" f + +-- | +-- see: data DeleteRoomActionType = LeaveRoom | DeleteRoom - deriving (Eq) + deriving (Bounded, Enum, Eq) instance Show DeleteRoomActionType where show LeaveRoom = "leave" show DeleteRoom = "delete" +instance FromForm DeleteRoomActionType where + fromForm f = parseUnique "action_type" f + +instance ToHttpApiData DeleteRoomActionType where + toUrlPiece = pack . show + +instance FromHttpApiData DeleteRoomActionType where + parseUrlPiece = parseBoundedUrlPiece + +-- | +-- see: type Force = Bool +-- | +-- see: type MessageBody = Text +-- | +-- see: type CreateUrlFlag = Bool diff --git a/src/ChatWork/Utils.hs b/src/ChatWork/Utils.hs --- a/src/ChatWork/Utils.hs +++ b/src/ChatWork/Utils.hs @@ -3,12 +3,8 @@ {-# LANGUAGE TypeFamilies #-} module ChatWork.Utils ( - -- * help to construct endpoint - Token - , baseUrl - , mkTokenHeader -- * Custamize Managaer - , getHttpResponse' + getHttpResponse' , fixEmptyStringManager , fixEmptyString -- * DELETE HTTP method with paramater @@ -18,7 +14,6 @@ ) where import Control.Monad.IO.Class (MonadIO (..)) -import Data.ByteString (ByteString) import Data.Default.Class (def) import Data.List (lookup) import Data.Maybe (fromMaybe) @@ -32,32 +27,14 @@ import Network.HTTP.Req (AllowsBody (..), CanHaveBody (..), HttpMethod (..), - HttpResponse (..), MonadHttp, - Option, Scheme (Https), Url, - header, https, (/:)) + HttpResponse (..), MonadHttp) 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 +getHttpResponse' Proxy r _ = liftIO $ getHttpResponse r =<< fixEmptyStringManager fixEmptyStringManager :: IO Manager fixEmptyStringManager = do diff --git a/test/ChatWork/Endpoints/ContactsSpec.hs b/test/ChatWork/Endpoints/ContactsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Endpoints/ContactsSpec.hs @@ -0,0 +1,24 @@ +module ChatWork.Endpoints.ContactsSpec + ( main + , spec + ) where + +import ChatWork.Endpoints.Contacts (getContacts) +import ChatWork.MonadHttpIO () +import ChatWork.Test.Client (TestClient (..)) +import ChatWork.Test.MockServer (runMockServer) +import ChatWork.Test.Values.Contacts (contacts) +import Network.HTTP.Req (responseBody) +import Test.Hspec (Spec, around_, context, + describe, hspec, it, + shouldReturn) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = around_ runMockServer $ do + describe "getContacts: endpoint GET /contacts" $ do + context "correct responce" $ do + it "should return Right contacts response body" $ do + (responseBody <$> getContacts TestClient) `shouldReturn` Right contacts diff --git a/test/ChatWork/Endpoints/IncomingRequestsSpec.hs b/test/ChatWork/Endpoints/IncomingRequestsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Endpoints/IncomingRequestsSpec.hs @@ -0,0 +1,35 @@ +module ChatWork.Endpoints.IncomingRequestsSpec + ( main + , spec + ) where + +import ChatWork.Endpoints.IncomingRequests (acceptIncomingRequest, + getIncomingRequests, + rejectIncomingRequest) +import ChatWork.MonadHttpIO () +import ChatWork.Test.Client (TestClient (..)) +import ChatWork.Test.MockServer (runMockServer) +import ChatWork.Test.Values.IncomingRequests (acceptedIncomingRequest, + incomingRequests) +import Network.HTTP.Req (responseBody) +import Test.Hspec (Spec, around_, context, + describe, hspec, it, + shouldReturn) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = around_ runMockServer $ do + describe "getIncomingRequests: endpoint GET /incoming_requests" $ do + context"correct responce" $ do + it "should return Right myStatus response body" $ do + (responseBody <$> getIncomingRequests TestClient) `shouldReturn` Right incomingRequests + describe "acceptIncomingRequest: endpoint GET /incoming_requests/{request_id}" $ do + context"correct responce" $ do + it "should return Right acceptedIncomingRequest response body" $ do + (responseBody <$> acceptIncomingRequest TestClient 123) `shouldReturn` Right acceptedIncomingRequest + describe "rejectIncomingRequest: endpoint DELETE /incoming_requests/{request_id}" $ do + context"correct responce" $ do + it "should return Right () response body" $ do + (responseBody <$> rejectIncomingRequest TestClient 123) `shouldReturn` Right () diff --git a/test/ChatWork/Endpoints/MeSpec.hs b/test/ChatWork/Endpoints/MeSpec.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Endpoints/MeSpec.hs @@ -0,0 +1,23 @@ +module ChatWork.Endpoints.MeSpec + ( main + , spec + ) where + +import ChatWork.Endpoints.Me (getMe) +import ChatWork.MonadHttpIO () +import ChatWork.Test.Client (TestClient (..)) +import ChatWork.Test.MockServer (runMockServer) +import ChatWork.Test.Values.Me (me) +import Network.HTTP.Req (responseBody) +import Test.Hspec (Spec, around_, context, describe, + hspec, it, shouldReturn) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = around_ runMockServer $ do + describe "getMe: endpoint GET /me" $ do + context "correct responce" $ do + it "should return Right me response body" $ do + (responseBody <$> getMe TestClient) `shouldReturn` Right me diff --git a/test/ChatWork/Endpoints/MySpec.hs b/test/ChatWork/Endpoints/MySpec.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Endpoints/MySpec.hs @@ -0,0 +1,27 @@ +module ChatWork.Endpoints.MySpec + ( main + , spec + ) where + +import ChatWork.Endpoints.My (getMyStatus, getMyTasks) +import ChatWork.MonadHttpIO () +import ChatWork.Test.Client (TestClient (..)) +import ChatWork.Test.MockServer (runMockServer) +import ChatWork.Test.Values.My (getMyTasksParams, myStatus, myTasks) +import Network.HTTP.Req (responseBody) +import Test.Hspec (Spec, around_, context, describe, + hspec, it, shouldReturn) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = around_ runMockServer $ do + describe "getMyStatus: endpoint GET /my/status" $ do + context "correct responce" $ do + it "should return Right myStatus response body" $ do + (responseBody <$> getMyStatus TestClient) `shouldReturn` Right myStatus + describe "getMyTasks: endpoint GET /my/tasks" $ do + context "correct responce" $ do + it "should return Right myTasks response body" $ do + (responseBody <$> getMyTasks TestClient getMyTasksParams) `shouldReturn` Right myTasks diff --git a/test/ChatWork/Endpoints/RoomsSpec.hs b/test/ChatWork/Endpoints/RoomsSpec.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Endpoints/RoomsSpec.hs @@ -0,0 +1,95 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Endpoints.RoomsSpec + ( main + , spec + ) where + +import ChatWork.Endpoints.Rooms (createRoom, createTask, deleteRoom, + getFile, getFiles, getMembers, + getMessage, getMessages, getRoom, + getRoomTask, getRoomTasks, + getRooms, leaveRoom, postMessage, + updateMembersPermission, + updateRoom) +import ChatWork.MonadHttpIO () +import ChatWork.Test.Client (TestClient (..)) +import ChatWork.Test.MockServer (runMockServer) +import ChatWork.Test.Values.Rooms (file, files, members, + membersPermission, message, + messageId, messages, roomDetail, + roomId, roomTask, roomTasks, rooms, + taskIds, createRoomParams, updateRoomParams, createTaskParams, roomMembersParams, getTasksParams) +import Network.HTTP.Req (responseBody) +import Test.Hspec (Spec, around_, context, describe, + hspec, it, shouldReturn) + +main :: IO () +main = hspec spec + +spec :: Spec +spec = around_ runMockServer $ do + describe "getRooms: endpoint GET /rooms" $ do + context "correct responce" $ do + it "should return Right rooms response body" $ do + (responseBody <$> getRooms TestClient) `shouldReturn` Right rooms + describe "createRoom: endpoint POST /rooms" $ do + context "correct responce" $ do + it "should return Right room response body" $ do + (responseBody <$> createRoom TestClient createRoomParams) `shouldReturn` Right roomId + describe "getRoom: endpoint GET /rooms/{room_id}" $ do + context "correct responce" $ do + it "should return Right roomDetail response body" $ do + (responseBody <$> getRoom TestClient 123) `shouldReturn` Right roomDetail + describe "updateRoom: endpoint PUT /rooms/{room_id}" $ do + context "correct responce" $ do + it "should return Right roomId response body" $ do + (responseBody <$> updateRoom TestClient 123 updateRoomParams) `shouldReturn` Right roomId + describe "deleteRoom: endpoint DELETE /rooms/{room_id}" $ do + context "correct responce" $ do + it "should return Right () response body" $ do + (responseBody <$> deleteRoom TestClient 123) `shouldReturn` Right () + describe "leaveRoom: endpoint DELETE /rooms/{room_id}" $ do + context "correct responce" $ do + it "should return Right () response body" $ do + (responseBody <$> leaveRoom TestClient 123) `shouldReturn` Right () + describe "getMembers: endpoint GET /rooms/{room_id}/members" $ do + context "correct responce" $ do + it "should return Right members response body" $ do + (responseBody <$> getMembers TestClient 123) `shouldReturn` Right members + describe "updateMembersPermission: endpoint PUT /rooms/{room_id}/members" $ do + context "correct responce" $ do + it "should return Right membersPermission response body" $ do + (responseBody <$> updateMembersPermission TestClient 123 roomMembersParams) `shouldReturn` Right membersPermission + describe "getMessages: endpoint GET /rooms/{room_id}/messages?force=0" $ do + context "correct responce" $ do + it "should return Right messages response body" $ do + (responseBody <$> getMessages TestClient 123 (Just False)) `shouldReturn` Right messages + describe "postMessage: ndpoint POST /rooms/{room_id}/messages" $ do + context "correct responce" $ do + it "should return Right messageId response body" $ do + (responseBody <$> postMessage TestClient 123 "Hello ChatWork!") `shouldReturn` Right messageId + describe "getMessage: ndpoint GET /rooms/{room_id}/messages/{message_id}" $ do + context "correct responce" $ do + it "should return Right message response body" $ do + (responseBody <$> getMessage TestClient 123 "5") `shouldReturn` Right message + describe "getRoomTasks: endpoint GET /rooms/{room_id}/tasks?..." $ do + context "correct responce" $ do + it "should return Right roomTasks response body" $ do + (responseBody <$> getRoomTasks TestClient 123 getTasksParams) `shouldReturn` Right roomTasks + describe "createTask: endpoint POST /rooms/{room_id}/tasks" $ do + context "correct responce" $ do + it "should return Right taskIds response body" $ do + (responseBody <$> createTask TestClient 123 createTaskParams) `shouldReturn` Right taskIds + describe "getRoomTask: endpoint GET /rooms/{room_id}/tasks/{tasks_id}" $ do + context "correct responce" $ do + it "should return Right roomTask response body" $ do + (responseBody <$> getRoomTask TestClient 123 3) `shouldReturn` Right roomTask + describe "getFiles: endpoint GET /rooms/{room_id}/files?..." $ do + context "correct responce" $ do + it "should return Right files response body" $ do + (responseBody <$> getFiles TestClient 123 (Just 101)) `shouldReturn` Right files + describe "getFile: endpoint GET /rooms/{room_id}/files/{files_id}?..." $ do + context "correct responce" $ do + it "should return Right file response body" $ do + (responseBody <$> getFile TestClient 123 3 (Just True)) `shouldReturn` Right file diff --git a/test/ChatWork/Test/Client.hs b/test/ChatWork/Test/Client.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Client.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} + +module ChatWork.Test.Client ( + TestClient(..) + ) where + +import ChatWork.Client (Client(..)) +import Network.HTTP.Req (http, Scheme(Http), port) + + +data TestClient = TestClient + +instance Client TestClient where + type ClientScheme TestClient = 'Http + baseUrl = const (http "localhost") + mkHeader = const (port 8000) diff --git a/test/ChatWork/Test/MockServer.hs b/test/ChatWork/Test/MockServer.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/MockServer.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +{-# OPTIONS_GHC -fno-warn-unused-binds #-} + +module ChatWork.Test.MockServer + ( mockServer + , runMockServer + ) where + +import ChatWork.Test.Types +import ChatWork.Test.Values +import ChatWork.Types +import Control.Concurrent +import Control.Exception +import Data.Aeson +import qualified Data.ByteString.Lazy as LBS (length) +import Data.Int (Int64) +import Network.Wai.Handler.Warp +import Servant + +type ChatWorkHeader a = Headers '[Header "Content-Length" Int64] a + +type API = "me" :> Get '[JSON] (ChatWorkHeader Me) + :<|> "my" :> "status" :> Get '[JSON] (ChatWorkHeader MyStatus) + :<|> "my" :> "tasks" + :> QueryParam "assigned_by_account_id" AccountId + :> QueryParam "status" TaskStatus + :> Get '[JSON] (ChatWorkHeader MyTasks) + :<|> "contacts" :> Get '[JSON] (ChatWorkHeader Contacts) + :<|> "incoming_requests" :> Get '[JSON] (ChatWorkHeader IncomingRequests) + :<|> "incoming_requests" :> Capture "request_id" Int + :> Put '[JSON] (ChatWorkHeader AcceptedIncomingRequest) + :<|> "incoming_requests" :> Capture "request_id" Int + :> Delete '[JSON] (ChatWorkHeader ()) + :<|> "rooms" :> Get '[JSON] (ChatWorkHeader Rooms) + :<|> "rooms" :> ReqBody '[FormUrlEncoded] CreateRoomParams + :> Post '[JSON] (ChatWorkHeader RoomIdWrap) + :<|> "rooms" :> Capture "room_id" Int + :> Get '[JSON] (ChatWorkHeader RoomDetail) + :<|> "rooms" :> Capture "room_id" Int + :> ReqBody '[FormUrlEncoded] UpdateRoomParams + :> Put '[JSON] (ChatWorkHeader RoomIdWrap) + :<|> "rooms" :> Capture "room_id" Int + :> ReqBody '[FormUrlEncoded] DeleteRoomActionType + :> Delete '[JSON] (ChatWorkHeader ()) + :<|> "rooms" :> Capture "room_id" Int :> "members" + :> Get '[JSON] (ChatWorkHeader Members) + :<|> "rooms" :> Capture "room_id" Int :> "members" + :> ReqBody '[FormUrlEncoded] RoomMembersParams + :> Put '[JSON] (ChatWorkHeader MembersPermission) + :<|> "rooms" :> Capture "room_id" Int :> "messages" + :> QueryParam "force" Int + :> Get '[JSON] (ChatWorkHeader Messages) + :<|> "rooms" :> Capture "room_id" Int :> "messages" + :> ReqBody '[FormUrlEncoded] MessageParams + :> Post '[JSON] (ChatWorkHeader MessageIdWrap) + :<|> "rooms" :> Capture "room_id" Int :> "messages" + :> Capture "message_id" Int + :> Get '[JSON] (ChatWorkHeader Message) + :<|> "rooms" :> Capture "room_id" Int :> "tasks" + :> QueryParam "account_id" AccountId + :> QueryParam "assigned_by_account_id" AccountId + :> QueryParam "status" TaskStatus + :> Get '[JSON] (ChatWorkHeader RoomTasks) + :<|> "rooms" :> Capture "room_id" Int :> "tasks" + :> ReqBody '[FormUrlEncoded] CreateTaskParams + :> Post '[JSON] (ChatWorkHeader TaskIdsWrap) + :<|> "rooms" :> Capture "room_id" Int :> "tasks" + :> Capture "task_id" Int + :> Get '[JSON] (ChatWorkHeader RoomTask) + :<|> "rooms" :> Capture "room_id" Int :> "files" + :> QueryParam "account_id" AccountId + :> Get '[JSON] (ChatWorkHeader Files) + :<|> "rooms" :> Capture "room_id" Int :> "files" + :> Capture "file_id" Int + :> QueryParam "create_download_url" Int + :> Get '[JSON] (ChatWorkHeader File) + +api :: Proxy API +api = Proxy + +server :: Server API +server = getMe :<|> getMyStatus :<|> getMyTasks :<|> getContacts + :<|> getIncomingRequests :<|> acceptIncomingRequest :<|> rejectIncomingRequest + :<|> getRooms :<|> createRoom :<|> getRoom :<|> updateRoom :<|> deleteRoom + :<|> getMembers :<|> updateMembersPermission + :<|> getMessages :<|> postMessage :<|> getMessage + :<|> getRoomTasks :<|> createTask :<|> getRoomTask :<|> getFiles :<|> getFile + where + getMe = return $ addHeader (LBS.length $ encode me) me + getMyStatus = return $ addHeader (LBS.length $ encode myStatus) myStatus + getMyTasks _ _ = return $ addHeader (LBS.length $ encode myTasks) myTasks + getContacts = return $ addHeader (LBS.length $ encode contacts) contacts + getIncomingRequests = return $ addHeader (LBS.length $ encode incomingRequests) incomingRequests + acceptIncomingRequest _ = return $ addHeader (LBS.length $ encode acceptedIncomingRequest) acceptedIncomingRequest + rejectIncomingRequest _ = return $ addHeader (LBS.length $ encode ()) () + getRooms = return $ addHeader (LBS.length $ encode rooms) rooms + createRoom _ = return $ addHeader (LBS.length $ encode roomId) roomId + getRoom _ = return $ addHeader (LBS.length $ encode roomDetail) roomDetail + updateRoom _ _ = return $ addHeader (LBS.length $ encode roomId) roomId + deleteRoom _ _ = return $ addHeader (LBS.length $ encode ()) () + getMembers _ = return $ addHeader (LBS.length $ encode members) members + updateMembersPermission _ _ = return $ addHeader (LBS.length $ encode membersPermission) membersPermission + getMessages _ _ = return $ addHeader (LBS.length $ encode messages) messages + postMessage _ _ = return $ addHeader (LBS.length $ encode messageId) messageId + getMessage _ _ = return $ addHeader (LBS.length $ encode message) message + getRoomTasks _ _ _ _ = return $ addHeader (LBS.length $ encode roomTasks) roomTasks + createTask _ _ = return $ addHeader (LBS.length $ encode taskIds) taskIds + getRoomTask _ _ = return $ addHeader (LBS.length $ encode roomTask) roomTask + getFiles _ _ = return $ addHeader (LBS.length $ encode files) files + getFile _ _ _ = return $ addHeader (LBS.length $ encode file) file + +mockServer :: IO () +mockServer = run 8000 (serve api server) + +runMockServer :: IO () -> IO () +runMockServer action = do + tid <- forkIO mockServer + action `finally` killThread tid diff --git a/test/ChatWork/Test/Types.hs b/test/ChatWork/Test/Types.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Types.hs @@ -0,0 +1,13 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Test.Types + ( MessageParams (..) + ) where + +import ChatWork.Types +import Web.FormUrlEncoded + +newtype MessageParams = MessageParams MessageBody deriving (Show) + +instance FromForm MessageParams where + fromForm f = MessageParams <$> parseUnique "body" f diff --git a/test/ChatWork/Test/Values.hs b/test/ChatWork/Test/Values.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Values.hs @@ -0,0 +1,9 @@ +module ChatWork.Test.Values + ( module Values + ) where + +import ChatWork.Test.Values.Me as Values +import ChatWork.Test.Values.My as Values +import ChatWork.Test.Values.Contacts as Values +import ChatWork.Test.Values.IncomingRequests as Values +import ChatWork.Test.Values.Rooms as Values diff --git a/test/ChatWork/Test/Values/Contacts.hs b/test/ChatWork/Test/Values/Contacts.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Values/Contacts.hs @@ -0,0 +1,18 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Test.Values.Contacts + ( contacts + ) where + +import ChatWork.Types (Contact (..), Contacts) + +contacts :: Contacts +contacts = [ Contact 123 + 322 + "John Smith" + "tarochatworkid" + 101 + "Hello Company" + "Marketing" + "https://example.com/abc.png" + ] diff --git a/test/ChatWork/Test/Values/IncomingRequests.hs b/test/ChatWork/Test/Values/IncomingRequests.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Values/IncomingRequests.hs @@ -0,0 +1,31 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Test.Values.IncomingRequests + ( incomingRequests + , acceptedIncomingRequest + ) where + +import ChatWork.Types (AcceptedIncomingRequest (..), + IncomingRequest (..), IncomingRequests) + +incomingRequests :: IncomingRequests +incomingRequests = [ IncomingRequest 123 + 363 + "hogehoge" + "John Smith" + "tarochatworkid" + 101 + "Hello Company" + "Marketing" + "https://example.com/abc.png" + ] + +acceptedIncomingRequest :: AcceptedIncomingRequest +acceptedIncomingRequest = AcceptedIncomingRequest 363 + 1234 + "John Smith" + "tarochatworkid" + 101 + "Hello Company" + "Marketing" + "https://example.com/abc.png" diff --git a/test/ChatWork/Test/Values/Me.hs b/test/ChatWork/Test/Values/Me.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Values/Me.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Test.Values.Me + ( me + ) where + +import ChatWork.Types (Me (..)) + +me :: Me +me = Me 123 + 322 + "John Smith" + "tarochatworkid" + 101 + "Hello Company" + "Marketing" + "CMO" + "http://mycompany.com" + "Self Introduction" + "taro@example.com" + "XXX-XXXX-XXXX" + "YYY-YYYY-YYYY" + "ZZZ-ZZZZ-ZZZZ" + "myskype_id" + "myfacebook_id" + "mytwitter_id" + "https://example.com/abc.png" diff --git a/test/ChatWork/Test/Values/My.hs b/test/ChatWork/Test/Values/My.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Values/My.hs @@ -0,0 +1,27 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Test.Values.My + ( myStatus + , myTasks + , getMyTasksParams + ) where + +import ChatWork.Types (Account (..), GetMyTasksParams (..), + MyStatus (..), MyTask (..), MyTasks, Room (..), + TaskStatus (..)) + +myStatus :: MyStatus +myStatus = MyStatus 2 1 3 12 1 8 + +myTasks :: MyTasks +myTasks = [ MyTask 3 + (Room 5 "Group Chat Name" "https://example.com/ico_group.png") + (Account 456 "Anna" "https://example.com/def.png") + "13" + "buy milk" + 1384354799 + "open" + ] + +getMyTasksParams :: GetMyTasksParams +getMyTasksParams = GetMyTasksParams (Just 78) (Just Done) diff --git a/test/ChatWork/Test/Values/Rooms.hs b/test/ChatWork/Test/Values/Rooms.hs new file mode 100644 --- /dev/null +++ b/test/ChatWork/Test/Values/Rooms.hs @@ -0,0 +1,157 @@ +{-# LANGUAGE OverloadedStrings #-} + +module ChatWork.Test.Values.Rooms ( + -- * Room + rooms + , roomId + , roomDetail + -- * Room Member + , members + , membersPermission + -- * Room Message + , messages + , messageId + , message + -- * Room Task + , roomTasks + , taskIds + , roomTask + -- * Room File + , files + , file + -- * request params + , createRoomParams + , updateRoomParams + , roomMembersParams + , getTasksParams + , createTaskParams + ) where + +import ChatWork.Types (Account (..), CreateRoomParams (..), + CreateTaskParams (..), File (..), Files, + GetTasksParams (..), IconPreset (..), + Member (..), Members, MembersPermission (..), + Message (..), MessageIdWrap (..), Messages, + RoomDetail (..), RoomIdWrap (..), + RoomMembersParams (..), RoomTask (..), + RoomTasks, Rooms, TaskIdsWrap (..), + TaskStatus (..), UpdateRoomParams (..)) + +rooms :: Rooms +rooms = [ RoomDetail 123 + "Group Chat Name" + "group" + "admin" + False + 10 + 1 + 0 + 122 + 10 + 17 + "https://example.com/ico_group.png" + 1298905200 + Nothing + ] + +roomId :: RoomIdWrap +roomId = RoomIdWrap 1234 + +roomDetail :: RoomDetail +roomDetail = RoomDetail 123 + "Group Chat Name" + "group" + "admin" + False + 10 + 1 + 0 + 122 + 10 + 17 + "https://example.com/ico_group.png" + 1298905200 + (Just "room description text") +members :: Members +members = [ Member 123 + "member" + "John Smith" + "tarochatworkid" + 101 + "Hello Company" + "Marketing" + "https://example.com/abc.png" + ] + +membersPermission :: MembersPermission +membersPermission = MembersPermission [123, 542, 1001] + [10, 103] + [6, 11] + +messages :: Messages +messages = [ Message "5" + (Account 123 "Bob" "https://example.com/ico_avatar.png") + "Hello Chatwork!" + 1384242850 + 0 + ] + +messageId :: MessageIdWrap +messageId = MessageIdWrap "1234" + +message :: Message +message = head messages + +roomTasks :: RoomTasks +roomTasks = [ RoomTask 3 + (Account 123 "Bob" "https://example.com/abc.png") + (Account 456 "Anna" "https://example.com/def.png") + "13" + "buy milk" + 1384354799 + "open" + ] + +taskIds :: TaskIdsWrap +taskIds = TaskIdsWrap [123, 124] + +roomTask :: RoomTask +roomTask = head roomTasks + +files :: Files +files = [ File 3 + (Account 123 "Bob" "https://example.com/ico_avatar.png") + "22" + "README.md" + 2232 + 1384414750 + ] + +file :: File +file = head files + +createRoomParams :: CreateRoomParams +createRoomParams = CreateRoomParams (Just "group chat description") + (Just Meeting) + [123, 542, 1001] + (Just [21, 344]) + (Just [15, 103]) + "Website renewal project" + +updateRoomParams :: UpdateRoomParams +updateRoomParams = UpdateRoomParams (Just "group chat description") + (Just Meeting) + (Just "Website renewal project") + +roomMembersParams :: RoomMembersParams +roomMembersParams = RoomMembersParams [123, 542, 1001] + (Just [21, 344]) + (Just [15, 103]) + +getTasksParams :: GetTasksParams +getTasksParams = GetTasksParams (Just 101) (Just 78) (Just Done) + +createTaskParams :: CreateTaskParams +createTaskParams = CreateTaskParams "Buy milk" + (Just 1385996399) + [1, 3, 6] diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,1 @@ +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}