MockServer.hs

{-# 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