diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -41,21 +41,24 @@ ## Usage ```haskell +{-# LANGUAGE DataKinds #-} {-# LANGUAGE OverloadedStrings #-} -import Data.String (fromString) -import Line.Bot.Client (Line, getProfile, runLine) -import Line.Bot.Types (Profile) -import System.Environment (getEnv) +import Data.String (fromString) +import Line.Bot.Client +import Line.Bot.Types +import System.Environment (getEnv) -profile :: Line Profile -profile = getProfile "U4af4980629..." +getProfiles :: Id Room -> Line [Profile] +getProfiles roomId = do + userIds <- getRoomMemberUserIds roomId + sequence $ getRoomMemberProfile roomId <$> userIds main = do - token <- fromString <$> getEnv "CHANNEL_TOKEN" - result <- runLine profile token + token <- fromString <$> getEnv "CHANNEL_TOKEN" + result <- runLine (getProfiles "U4af4980629...") token case result of - Left err -> print err + Left err -> print err Right profile -> print profile ``` diff --git a/line-bot-sdk.cabal b/line-bot-sdk.cabal --- a/line-bot-sdk.cabal +++ b/line-bot-sdk.cabal @@ -1,5 +1,5 @@ name: line-bot-sdk -version: 0.5.1.0 +version: 0.5.2 synopsis: Haskell SDK for LINE Messaging API homepage: https://github.com/moleike/line-bot-sdk#readme bug-reports: https://github.com/moleike/line-bot-sdk/issues @@ -43,24 +43,21 @@ , time >= 1.8.0 && < 1.9 , base64-bytestring >= 1.0.0 && < 1.1 , cryptohash-sha256 >= 0.11.101 && < 0.12 - , errors >= 2.3.0 && < 2.4 , http-client >= 0.5.14 && < 0.7 , http-types >= 0.12.2 && < 0.13 + , http-media , http-api-data >= 0.4 && < 0.5 , http-client-tls >= 0.3.5 && < 0.4 - , servant >= 0.15 && < 0.16 + , servant >= 0.16.2 && < 0.17 , string-conversions >= 0.4.0 && < 0.5 - , servant-client >= 0.15 && < 0.16 - , servant-client-core >= 0.15 && < 0.16 - , servant-server >= 0.15 && < 0.16 + , servant-client >= 0.16.0.1 && < 0.17 + , servant-client-core >= 0.16 && < 0.17 + , servant-server >= 0.16.2 && < 0.17 , wai >= 3.2.2 && < 3.3 - , wai-extra >= 3.0.25 && < 3.1 - , exceptions >= 0.10 && < 0.11 - , transformers-base >= 0.4 && < 0.5 , mtl >= 2.2.2 && < 2.3 - , monad-control >= 1.0 && < 1.1 - , streaming >= 0.2 && < 0.3 + , deepseq >= 1.4.2.0 && < 1.5 + default-language: Haskell2010 executable echo-server @@ -69,11 +66,9 @@ ghc-options: -threaded -rtsopts -with-rtsopts=-N build-depends: base >= 4.7 && < 5 , line-bot-sdk - , servant >= 0.15 && < 0.16 - , servant-server >= 0.15 && < 0.16 - , servant-client >= 0.15 && < 0.16 + , servant >= 0.16.2 && < 0.17 + , servant-server >= 0.16.2 && < 0.17 , transformers >= 0.5.5 && < 0.6 - , time >= 1.8.0 && < 1.9 , wai >= 3.2.2 && < 3.3 , wai-extra >= 3.0.25 && < 3.1 , warp >= 3.2.26 && < 3.3 @@ -108,6 +103,7 @@ , warp , free , time + , deepseq ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Line/Bot/Client.hs b/src/Line/Bot/Client.hs --- a/src/Line/Bot/Client.hs +++ b/src/Line/Bot/Client.hs @@ -2,9 +2,11 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE FlexibleInstances #-} {-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeApplications #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} @@ -18,7 +20,7 @@ module Line.Bot.Client ( Line , runLine - , runLine' + , withLine , withLineEnv -- ** Profile , getProfile @@ -26,33 +28,46 @@ , getGroupMemberProfile , leaveGroup , getGroupMemberUserIds - , getGroupMemberUserIdsS -- ** Room , getRoomMemberProfile , leaveRoom , getRoomMemberUserIds - , getRoomMemberUserIdsS -- ** Message , replyMessage , pushMessage , multicastMessage + , broadcastMessage , getContent + , getContentS , getPushMessageCount , getReplyMessageCount , getMulticastMessageCount + , getBroadcastMessageCount , getMessageQuota -- ** Account Link , issueLinkToken -- ** OAuth , issueChannelToken , revokeChannelToken + -- ** Rich menus + , createRichMenu + , deleteRichMenu + , getRichMenu + , uploadRichMenuImageJpg + , getRichMenuList + , setDefaultRichMenu ) where +import Control.DeepSeq (NFData) import Control.Monad.IO.Class import Control.Monad.Reader import Control.Monad.Trans.Class (lift) +import Data.ByteString (ByteString) import qualified Data.ByteString.Lazy as LB +import Data.Functor +import Data.Maybe +import Data.Monoid import Data.Proxy import Data.Time.Calendar (Day) import Line.Bot.Internal.Auth (Auth, mkAuth) @@ -60,31 +75,44 @@ import Line.Bot.Types import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import Servant.API hiding (Stream) -import Servant.Client -import Streaming -import qualified Streaming.Prelude as S +import Servant.API +import Servant.Client.Streaming -host :: BaseUrl -host = BaseUrl Https "api.line.me" 443 "" +defaultEndpoint :: BaseUrl +defaultEndpoint = BaseUrl Https "api.line.me" 443 "" +blobEndpoint :: BaseUrl +blobEndpoint = BaseUrl Https "api-data.line.me" 443 "" + -- | @Line@ is the monad in which bot requests run. Contains the -- OAuth access token for a channel type Line = ReaderT ChannelToken ClientM +-- | Perform a request using LINE 'ClientEnv' +-- +-- > withLineEnv $ \env -> runClientM comp env withLineEnv :: (ClientEnv -> IO a) -> IO a withLineEnv app = do manager <- newManager tlsManagerSettings - app $ mkClientEnv manager host + app $ mkClientEnv manager defaultEndpoint --- | Executes a request in the LINE plaform (default) -runLine' :: ClientM a -> IO (Either ServantError a) +runLine' :: NFData a => ClientM a -> IO (Either ClientError a) runLine' comp = withLineEnv $ \env -> runClientM comp env --- | Runs a @Line@ computation with the given channel access token -runLine :: Line a -> ChannelToken -> IO (Either ServantError a) +-- | Executes a request in the LINE plaform with the given 'ChannelToken' +runLine :: NFData a => Line a -> ChannelToken -> IO (Either ClientError a) runLine comp = runLine' . runReaderT comp +withLine' :: ClientM a -> (Either ClientError a -> IO b) -> IO b +withLine' comp k = withLineEnv $ \env -> withClientM comp env k + +-- | Execute a request with a streaming response in the LINE platform +withLine :: Line a -> ChannelToken -> (Either ClientError a -> IO b) -> IO b +withLine comp = withLine' . runReaderT comp + +withHost :: MonadReader ClientEnv m => BaseUrl -> m a -> m a +withHost baseUrl = local (\env -> env { baseUrl = baseUrl }) + type LineAuth a = Auth -> ClientM a type family AddLineAuth a :: * where @@ -95,118 +123,163 @@ addLineAuth :: a -> AddLineAuth a instance HasLine (LineAuth a) where - addLineAuth comp = ask >>= \token -> lift $ comp (mkAuth token) + addLineAuth comp = ask >>= lift . comp . mkAuth instance HasLine (a -> LineAuth b) where - addLineAuth comp a = addLineAuth (comp a) + addLineAuth comp = addLineAuth . comp instance HasLine (a -> b -> LineAuth c) where - addLineAuth comp a = addLineAuth (comp a) + addLineAuth comp = addLineAuth . comp line :: (HasLine (Client ClientM api), HasClient ClientM api) - => Proxy api -> AddLineAuth (Client ClientM api) -line api = addLineAuth (client api) + => Proxy api + -> AddLineAuth (Client ClientM api) +line = addLineAuth . client +unfoldMemberUserIds :: (Maybe String -> Line MemberIds) -> Line [Id User] +unfoldMemberUserIds k = go Nothing where + go tok = do + MemberIds{next, memberIds = a} <- k tok + as <- maybe (return []) (\_ -> go next) next + return $ a ++ as + getProfile :: Id User -> Line Profile -getProfile = line (Proxy :: Proxy GetProfile) +getProfile = line (Proxy @GetProfile) getGroupMemberProfile :: Id Group -> Id User -> Line Profile -getGroupMemberProfile = line (Proxy :: Proxy GetGroupMemberProfile) +getGroupMemberProfile = line (Proxy @GetGroupMemberProfile) leaveGroup :: Id Group -> Line NoContent -leaveGroup = line (Proxy :: Proxy LeaveGroup) +leaveGroup = line (Proxy @LeaveGroup) getGroupMemberUserIds' :: Id Group -> Maybe String -> Line MemberIds -getGroupMemberUserIds' = line (Proxy :: Proxy GetGroupMemberUserIds) - -getGroupMemberUserIdsS :: Id Group -> Stream (Of (Id User)) Line () -getGroupMemberUserIdsS gid = go gid Nothing - where - go gid token = do - MemberIds{..} <- lift $ getGroupMemberUserIds' gid token - S.each memberIds - case next of - Nothing -> return () - token' -> go gid token' +getGroupMemberUserIds' = line (Proxy @GetGroupMemberUserIds) getGroupMemberUserIds :: Id Group -> Line [Id User] -getGroupMemberUserIds = S.toList_ . getGroupMemberUserIdsS +getGroupMemberUserIds = unfoldMemberUserIds . getGroupMemberUserIds' getRoomMemberProfile :: Id Room -> Id User -> Line Profile -getRoomMemberProfile = line (Proxy :: Proxy GetRoomMemberProfile) +getRoomMemberProfile = line (Proxy @GetRoomMemberProfile) leaveRoom :: Id Room -> Line NoContent -leaveRoom = line (Proxy :: Proxy LeaveRoom) +leaveRoom = line (Proxy @LeaveRoom) getRoomMemberUserIds' :: Id Room -> Maybe String -> Line MemberIds -getRoomMemberUserIds' = line (Proxy :: Proxy GetRoomMemberUserIds) - -getRoomMemberUserIdsS :: Id Room -> Stream (Of (Id User)) Line () -getRoomMemberUserIdsS gid = go gid Nothing - where - go gid token = do - MemberIds{..} <- lift $ getRoomMemberUserIds' gid token - S.each memberIds - case next of - Nothing -> return () - token' -> go gid token' +getRoomMemberUserIds' = line (Proxy @GetRoomMemberUserIds) getRoomMemberUserIds :: Id Room -> Line [Id User] -getRoomMemberUserIds = S.toList_ . getRoomMemberUserIdsS +getRoomMemberUserIds = unfoldMemberUserIds . getRoomMemberUserIds' replyMessage' :: ReplyMessageBody -> Line NoContent -replyMessage' = line (Proxy :: Proxy ReplyMessage) +replyMessage' = line (Proxy @ReplyMessage) replyMessage :: ReplyToken -> [Message] -> Line NoContent replyMessage a ms = replyMessage' (ReplyMessageBody a ms) pushMessage' :: PushMessageBody -> Line NoContent -pushMessage' = line (Proxy :: Proxy PushMessage) +pushMessage' = line (Proxy @PushMessage) pushMessage :: Id a -> [Message] -> Line NoContent pushMessage a ms = pushMessage' (PushMessageBody a ms) multicastMessage' :: MulticastMessageBody -> Line NoContent -multicastMessage' = line (Proxy :: Proxy MulticastMessage) +multicastMessage' = line (Proxy @MulticastMessage) multicastMessage :: [Id User] -> [Message] -> Line NoContent multicastMessage a ms = multicastMessage' (MulticastMessageBody a ms) +broadcastMessage' :: BroadcastMessageBody -> Line NoContent +broadcastMessage' = line (Proxy @BroadcastMessage) + +broadcastMessage :: [Message] -> Line NoContent +broadcastMessage = broadcastMessage' . BroadcastMessageBody + +getContent' :: MessageId -> Auth -> ClientM LB.ByteString +getContent' = client (Proxy @GetContent) + getContent :: MessageId -> Line LB.ByteString -getContent = line (Proxy :: Proxy GetContent) +getContent a = ask >>= lift . withHost blobEndpoint . getContent' a . mkAuth +getContentS' :: MessageId -> Auth -> ClientM (SourceIO ByteString) +getContentS' = client (Proxy @GetContentStream) + +-- | This is an streaming version of 'getContent' meant to be used with coroutine +-- libraries like @pipes@, @conduits@, @streaming@, etc. You need and instance +-- of 'FromSourceIO', see e.g. @servant-conduit@. +-- +-- Example: +-- +-- > getContentC :: MessageId -> Line (ConduitT () ByteString IO ()) +-- > getContentC = fmap fromSourceIO . getContentS +getContentS :: MessageId -> Line (SourceIO ByteString) +getContentS a = ask >>= lift . withHost blobEndpoint . getContentS' a . mkAuth + getPushMessageCount' :: LineDate -> Line MessageCount -getPushMessageCount' = line (Proxy :: Proxy GetPushMessageCount) +getPushMessageCount' = line (Proxy @GetPushMessageCount) getPushMessageCount :: Day -> Line (Maybe Int) getPushMessageCount = fmap count . getPushMessageCount' . LineDate getReplyMessageCount' :: LineDate -> Line MessageCount -getReplyMessageCount' = line (Proxy :: Proxy GetReplyMessageCount) +getReplyMessageCount' = line (Proxy @GetReplyMessageCount) getReplyMessageCount :: Day -> Line (Maybe Int) getReplyMessageCount = fmap count . getReplyMessageCount' . LineDate getMulticastMessageCount' :: LineDate -> Line MessageCount -getMulticastMessageCount' = line (Proxy :: Proxy GetMulticastMessageCount) +getMulticastMessageCount' = line (Proxy @GetMulticastMessageCount) getMulticastMessageCount :: Day -> Line (Maybe Int) getMulticastMessageCount = fmap count . getMulticastMessageCount' . LineDate +getBroadcastMessageCount' :: LineDate -> Line MessageCount +getBroadcastMessageCount' = line (Proxy @GetBroadcastMessageCount) + +getBroadcastMessageCount :: Day -> Line (Maybe Int) +getBroadcastMessageCount = fmap count . getBroadcastMessageCount' . LineDate + getMessageQuota' :: Line MessageQuota -getMessageQuota' = line (Proxy :: Proxy GetMessageQuota) +getMessageQuota' = line (Proxy @GetMessageQuota) getMessageQuota :: Line Int getMessageQuota = fmap totalUsage getMessageQuota' issueLinkToken :: Id User -> Line LinkToken -issueLinkToken = line (Proxy :: Proxy IssueLinkToken) +issueLinkToken = line (Proxy @IssueLinkToken) issueChannelToken' :: ClientCredentials -> ClientM ShortLivedChannelToken -issueChannelToken' = client (Proxy :: Proxy IssueChannelToken) +issueChannelToken' = client (Proxy @IssueChannelToken) issueChannelToken :: ChannelId -> ChannelSecret -> ClientM ShortLivedChannelToken issueChannelToken a b = issueChannelToken' $ ClientCredentials a b revokeChannelToken :: ChannelToken -> ClientM NoContent -revokeChannelToken = client (Proxy :: Proxy RevokeChannelToken) +revokeChannelToken = client (Proxy @RevokeChannelToken) + +createRichMenu :: RichMenu -> Line RichMenuId +createRichMenu = line (Proxy @CreateRichMenu) + +getRichMenu' :: RichMenuId -> Line RichMenuResponse +getRichMenu' = line (Proxy @GetRichMenu) + +getRichMenu :: RichMenuId -> Line RichMenu +getRichMenu = fmap richMenu . getRichMenu' + +uploadRichMenuImageJpg' :: RichMenuId -> ByteString -> Auth -> ClientM NoContent +uploadRichMenuImageJpg' = client (Proxy @UploadRichMenuImageJpg) + +uploadRichMenuImageJpg :: RichMenuId -> ByteString -> Line NoContent +uploadRichMenuImageJpg a b = ask >>= lift . withHost blobEndpoint . uploadRichMenuImageJpg' a b . mkAuth + +deleteRichMenu :: RichMenuId -> Line NoContent +deleteRichMenu = line (Proxy @DeleteRichMenu) + +getRichMenuList' :: Line RichMenuResponseList +getRichMenuList' = line (Proxy @GetRichMenuList) + +getRichMenuList :: Line [(RichMenuId, RichMenu)] +getRichMenuList = richmenus <$> getRichMenuList' <&> fmap f where + f RichMenuResponse{..} = (RichMenuId richMenuId, richMenu) + +setDefaultRichMenu :: RichMenuId -> Line NoContent +setDefaultRichMenu = line (Proxy @SetDefaultRichMenu) diff --git a/src/Line/Bot/Internal/Auth.hs b/src/Line/Bot/Internal/Auth.hs --- a/src/Line/Bot/Internal/Auth.hs +++ b/src/Line/Bot/Internal/Auth.hs @@ -8,14 +8,14 @@ module Line.Bot.Internal.Auth where -import Line.Bot.Internal.Endpoints (ChannelAuth) -import Line.Bot.Types (ChannelToken) -import Network.HTTP.Types (hAuthorization) -import Servant.API (AuthProtect) -import Servant.Client.Core.Internal.Auth (AuthClientData, - AuthenticatedRequest, - mkAuthenticatedRequest) -import Servant.Client.Core.Internal.Request (Request, addHeader) +import Line.Bot.Internal.Endpoints (ChannelAuth) +import Line.Bot.Types (ChannelToken) +import Network.HTTP.Types (hAuthorization) +import Servant.API (AuthProtect) +import Servant.Client.Core.Auth (AuthClientData, + AuthenticatedRequest, + mkAuthenticatedRequest) +import Servant.Client.Core.Request (Request, addHeader) type instance AuthClientData ChannelAuth = ChannelToken diff --git a/src/Line/Bot/Internal/Endpoints.hs b/src/Line/Bot/Internal/Endpoints.hs --- a/src/Line/Bot/Internal/Endpoints.hs +++ b/src/Line/Bot/Internal/Endpoints.hs @@ -15,7 +15,8 @@ module Line.Bot.Internal.Endpoints where -import Data.ByteString.Lazy (ByteString) +import Data.ByteString (ByteString) +import qualified Data.ByteString.Lazy as LB (ByteString) import Line.Bot.Types import Servant.API import Servant.Client @@ -88,7 +89,8 @@ type GetRoomMemberUserIds = GetRoomMemberUserIds' MemberIds type ReplyMessage' a = - "v2":> "bot" :> "message" :> "reply" + "v2":> "bot" :> "message" + :> "reply" :> ReqBody '[JSON] a :> ChannelAuth :> PostNoContent '[JSON] NoContent @@ -113,12 +115,21 @@ type MulticastMessage = MulticastMessage' MulticastMessageBody +type BroadcastMessage' a = + "v2":> "bot" :> "message" + :> "broadcast" + :> ReqBody '[JSON] a + :> ChannelAuth + :> PostNoContent '[JSON] NoContent + +type BroadcastMessage = BroadcastMessage' BroadcastMessageBody + type GetContent = "v2":> "bot" :> "message" :> Capture "messageId" MessageId :> "content" :> ChannelAuth - :> Get '[OctetStream] ByteString + :> Get '[OctetStream] LB.ByteString type GetContentStream = "v2":> "bot" :> "message" @@ -154,6 +165,15 @@ type GetMulticastMessageCount = GetMulticastMessageCount' LineDate MessageCount +type GetBroadcastMessageCount' a b = + "v2" :> "bot" :> "message" :> "delivery" + :> "broadcast" + :> QueryParam' '[Required, Strict] "date" a + :> ChannelAuth + :> Get '[JSON] b + +type GetBroadcastMessageCount = GetBroadcastMessageCount' LineDate MessageCount + type GetMessageQuota' a = "v2":> "bot" :> "message" :> "quota" :> "consumption" @@ -183,6 +203,56 @@ "v2" :> "oauth" :> "revoke" :> ReqBody '[FormUrlEncoded] a - :> PostNoContent '[JSON] NoContent + :> Post '[JSON] NoContent type RevokeChannelToken = RevokeChannelToken' ChannelToken + +type CreateRichMenu' a b = + "v2" :> "bot" :> "richmenu" + :> ReqBody '[JSON] a + :> ChannelAuth + :> PostNoContent '[JSON] b + +type CreateRichMenu = CreateRichMenu' RichMenu RichMenuId + +type DeleteRichMenu' a = + "v2" :> "bot" :> "richmenu" + :> Capture "richMenuId" a + :> ChannelAuth + :> Delete '[JSON] NoContent + +type DeleteRichMenu = DeleteRichMenu' RichMenuId + +type GetRichMenu' a b = + "v2" :> "bot" :> "richmenu" + :> Capture "richMenuId" a + :> ChannelAuth + :> Get '[JSON] b + +type GetRichMenu = GetRichMenu' RichMenuId RichMenuResponse + +type UploadRichMenuImageJpg' a b = + "v2" :> "bot" :> "richmenu" + :> Capture "richMenuId" a + :> "content" + :> ReqBody '[JPEG] b + :> ChannelAuth + :> Post '[JSON] NoContent + +type UploadRichMenuImageJpg = UploadRichMenuImageJpg' RichMenuId ByteString + +type GetRichMenuList' a = + "v2" :> "bot" :> "richmenu" + :> "list" + :> ChannelAuth + :> Get '[JSON] a + +type GetRichMenuList = GetRichMenuList' RichMenuResponseList + +type SetDefaultRichMenu' a = + "v2":> "bot" :> "user" :> "all" :> "richmenu" + :> Capture "richMenuId" a + :> ChannelAuth + :> PostNoContent '[JSON] NoContent + +type SetDefaultRichMenu = SetDefaultRichMenu' RichMenuId diff --git a/src/Line/Bot/Types.hs b/src/Line/Bot/Types.hs --- a/src/Line/Bot/Types.hs +++ b/src/Line/Bot/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DataKinds #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE ExistentialQuantification #-} {-# LANGUAGE FlexibleContexts #-} @@ -7,6 +8,7 @@ {-# LANGUAGE GADTs #-} {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE NamedFieldPuns #-} {-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} @@ -33,6 +35,7 @@ , ReplyMessageBody(ReplyMessageBody) , PushMessageBody(PushMessageBody) , MulticastMessageBody(MulticastMessageBody) + , BroadcastMessageBody(BroadcastMessageBody) , Profile(..) , QuickReply(..) , QuickReplyButton(..) @@ -43,13 +46,26 @@ , MessageCount(..) , MessageQuota(..) , MemberIds(..) + , JPEG + , RichMenuSize(..) + , RichMenuBounds(..) + , RichMenuArea(..) + , RichMenu(..) + , RichMenuResponse(..) + , RichMenuId(..) + , RichMenuResponseList(..) + , RichMenuBulkLinkBody(..) + , RichMenuBulkUnlinkBody(..) ) where import Control.Arrow ((>>>)) +import Control.DeepSeq import Data.Aeson import Data.Aeson.Types -import qualified Data.ByteString.Char8 as B +import Data.ByteString (ByteString) +import qualified Data.ByteString.Char8 as C8 +import qualified Data.ByteString.Lazy as LB import Data.Char (toLower) import Data.List as L (stripPrefix) import Data.Maybe (fromJust) @@ -59,14 +75,17 @@ import Data.Text.Encoding import Data.Time.Calendar (Day) import Data.Time.Format +import Data.Typeable import GHC.Generics hiding (to) +import Network.HTTP.Media (MediaType, (//)) import Servant.API import Text.Show import Web.FormUrlEncoded (ToForm (..)) + newtype ChannelToken = ChannelToken { unChannelToken :: Text } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance FromJSON ChannelToken where parseJSON = withText "ChannelToken" $ return . ChannelToken @@ -81,16 +100,16 @@ instance ToForm ChannelToken where toForm (ChannelToken t) = [ ("access_token", t) ] -newtype ChannelSecret = ChannelSecret { unChannelSecret :: B.ByteString } +newtype ChannelSecret = ChannelSecret { unChannelSecret :: C8.ByteString } instance IsString ChannelSecret where - fromString s = ChannelSecret (B.pack s) + fromString s = ChannelSecret (C8.pack s) instance ToHttpApiData ChannelSecret where toQueryParam = decodeUtf8 . unChannelSecret newtype ChannelId = ChannelId { unChannelId :: Text } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance IsString ChannelId where fromString s = ChannelId (fromString s) @@ -109,6 +128,11 @@ deriving instance Eq (Id a) deriving instance Show (Id a) +instance NFData (Id a) where + rnf (UserId a) = rnf a + rnf (GroupId a) = rnf a + rnf (RoomId a) = rnf a + instance ToHttpApiData (Id a) where toQueryParam = \case UserId a -> a @@ -148,7 +172,7 @@ type MessageId = Text newtype URL = URL Text - deriving (Show, Eq, Generic) + deriving (Show, Eq, Generic, NFData) instance ToJSON URL instance FromJSON URL @@ -183,7 +207,7 @@ , contents :: Value , quickReply :: Maybe QuickReply } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance ToJSON Message where toJSON = genericToJSON messageJSONOptions @@ -200,22 +224,22 @@ data Profile = Profile { displayName :: Text - , userId :: Id User + , userId :: Text , pictureUrl :: URL , statusMessage :: Maybe Text } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance FromJSON Profile newtype ReplyToken = ReplyToken Text - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance ToJSON ReplyToken instance FromJSON ReplyToken newtype LinkToken = LinkToken { linkToken :: Text } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance FromJSON LinkToken @@ -223,7 +247,7 @@ { replyToken :: ReplyToken , messages :: [Message] } - deriving (Show, Generic) + deriving (Show, Generic, NFData) instance ToJSON ReplyMessageBody @@ -244,13 +268,19 @@ { to :: [Id User] , messages :: [Message] } - deriving (Show, Generic) + deriving (Show, Generic, NFData) instance ToJSON MulticastMessageBody +newtype BroadcastMessageBody = BroadcastMessageBody + { messages :: [Message] } + deriving (Show, Generic, NFData) + +instance ToJSON BroadcastMessageBody + newtype QuickReply = QuickReply { items :: [QuickReplyButton] } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance ToJSON QuickReply @@ -258,7 +288,7 @@ { imageUrl :: Maybe URL , action :: Action } - deriving (Eq, Show) + deriving (Eq, Show, Generic, NFData) instance ToJSON QuickReplyButton where toJSON QuickReplyButton{..} = object @@ -284,11 +314,14 @@ } | ActionLocation { label :: Text } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance ToJSON Action where toJSON = genericToJSON actionJSONOptions +instance FromJSON Action where + parseJSON = genericParseJSON actionJSONOptions + actionJSONOptions :: Options actionJSONOptions = defaultOptions { sumEncoding = TaggedObject @@ -315,7 +348,7 @@ data ShortLivedChannelToken = ShortLivedChannelToken { accessToken :: ChannelToken , expiresIn :: Int - } deriving (Eq, Show, Generic) + } deriving (Eq, Show, Generic, NFData) instance FromJSON ShortLivedChannelToken where parseJSON = genericParseJSON defaultOptions @@ -341,13 +374,98 @@ return MessageCount{..} newtype MessageQuota = MessageQuota { totalUsage :: Int } - deriving (Eq, Show, Generic) + deriving (Eq, Show, Generic, NFData) instance FromJSON MessageQuota data MemberIds = MemberIds { memberIds :: [Id User] - , next :: Maybe String - } deriving (Eq, Show, Generic) + , next :: Maybe String + } deriving (Eq, Show, Generic, NFData) instance FromJSON MemberIds + +data JPEG deriving Typeable + +instance Accept JPEG where + contentType _ = "image" // "jpeg" + +instance MimeRender JPEG ByteString where + mimeRender _ = LB.fromStrict + +data RichMenuSize = RichMenuSize + { width :: Int + , height :: Int + } deriving (Eq, Show, Generic, NFData) + +instance FromJSON RichMenuSize +instance ToJSON RichMenuSize + +data RichMenuBounds = RichMenuBounds + { x :: Int + , y :: Int + , width :: Int + , height :: Int + } deriving (Eq, Show, Generic, NFData) + +instance FromJSON RichMenuBounds +instance ToJSON RichMenuBounds + +data RichMenuArea = RichMenuArea + { bounds :: RichMenuBounds + , action :: Action + } deriving (Eq, Show, Generic, NFData) + +instance FromJSON RichMenuArea +instance ToJSON RichMenuArea + +data RichMenu = RichMenu + { size :: RichMenuSize + , selected :: Bool + , name :: Text + , chatBarText :: Text + , areas :: [RichMenuArea] + } deriving (Eq, Show, Generic, NFData) + +instance FromJSON RichMenu +instance ToJSON RichMenu + +data RichMenuResponse = RichMenuResponse + { richMenuId :: Text + , richMenu :: RichMenu + } + deriving (Show, Eq, Generic, NFData) + +instance FromJSON RichMenuResponse where + parseJSON = withObject "RichMenuResponse" $ \o -> do + richMenuId <- o .: "richMenuId" + richMenu <- parseJSON (Object o) + return RichMenuResponse{..} + +newtype RichMenuId = RichMenuId + { richMenuId :: Text } + deriving (Show, Eq, Generic, NFData) + +instance FromJSON RichMenuId + +instance ToHttpApiData RichMenuId where + toQueryParam (RichMenuId a) = a + +newtype RichMenuResponseList = RichMenuResponseList + { richmenus :: [RichMenuResponse] } + deriving (Show, Eq, Generic, NFData) + +instance FromJSON RichMenuResponseList + +data RichMenuBulkLinkBody = RichMenuBulkLinkBody + { richMenuId :: Text + , userIds :: [Id User] + } deriving (Show, Eq, Generic, NFData) + +instance ToJSON RichMenuBulkLinkBody + +newtype RichMenuBulkUnlinkBody = RichMenuBulkUnlinkBody + { userIds :: [Id User] } + deriving (Show, Eq, Generic, NFData) + +instance ToJSON RichMenuBulkUnlinkBody diff --git a/src/Line/Bot/Webhook.hs b/src/Line/Bot/Webhook.hs --- a/src/Line/Bot/Webhook.hs +++ b/src/Line/Bot/Webhook.hs @@ -7,10 +7,12 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE PolyKinds #-} {-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} {-# LANGUAGE ScopedTypeVariables #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} + -- | -- Module : Line.Bot.Webhook -- Copyright : (c) Alexandre Moreno, 2019 @@ -20,12 +22,14 @@ module Line.Bot.Webhook ( Webhook + , webhook , LineReqBody , module Events ) where -import Control.Monad.IO.Class (liftIO) +import Control.Monad (forM_, (>>)) +import Control.Monad.IO.Class (MonadIO, liftIO) import qualified Crypto.Hash.SHA256 as SHA256 import Data.Aeson import Data.Aeson.Types @@ -47,6 +51,15 @@ -- | This type alias just specifies how webhook requests should be handled type Webhook = LineReqBody '[JSON] Events :> Post '[JSON] NoContent + +-- | Helper function that takes a handler to process 'Webhook' events: +-- +-- > server :: Server Webhook +-- > server = webhook $ \case +-- > EventMessage { message, replyToken } = handleMessage message replyToken +-- > _ = return () +webhook :: MonadIO m => (Event -> m a) -> Events -> m NoContent +webhook k Events{..} = forM_ events k >> return NoContent -- | A Servant combinator that extracts the request body as a value of type a -- and performs signature valiadation diff --git a/src/Line/Bot/Webhook/Events.hs b/src/Line/Bot/Webhook/Events.hs --- a/src/Line/Bot/Webhook/Events.hs +++ b/src/Line/Bot/Webhook/Events.hs @@ -6,7 +6,6 @@ {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE GADTs #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} -{-# LANGUAGE KindSignatures #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -60,7 +59,7 @@ { destination :: Id User -- ^ User ID of a bot that should receive webhook events , events :: [Event] -- ^ List of webhook event objects } - deriving (Eq, Show, Generic) + deriving (Show, Generic) instance FromJSON Events @@ -114,7 +113,7 @@ , timestamp :: EpochMilli , things :: Things } - deriving (Eq, Show, Generic) + deriving (Show, Generic) instance FromJSON Event where parseJSON = genericParseJSON defaultOptions @@ -196,24 +195,24 @@ data Source = forall a. Source (Id a) deriving instance Show Source - -instance Eq Source where - Source (UserId a) == Source (UserId b) = a == b - Source (GroupId a) == Source (GroupId b) = a == b - Source (RoomId a) == Source (RoomId b) = a == b - _ == _ = False +deriving instance Typeable Source instance FromJSON Source where parseJSON = withObject "Source" $ \o -> do messageType <- o .: "type" case messageType of - "user" -> (Source . UserId) <$> o .: "userId" - "group" -> (Source . GroupId) <$> o .: "groupId" - "room" -> (Source . RoomId) <$> o .: "roomId" + "user" -> Source . UserId <$> o .: "userId" + "group" -> Source . GroupId <$> o .: "groupId" + "room" -> Source . RoomId <$> o .: "roomId" _ -> fail ("unknown source: " ++ messageType) +instance ToJSON Source where + toJSON (Source (UserId a)) = object ["type" .= "user", "userId" .= a] + toJSON (Source (GroupId a)) = object ["type" .= "group", "groupId" .= a] + toJSON (Source (RoomId a)) = object ["type" .= "room", "roomId" .= a] + newtype Members = Members { members :: [Source] } - deriving (Eq, Show, Generic) + deriving (Show, Generic) instance FromJSON Members diff --git a/test/Line/Bot/ClientSpec.hs b/test/Line/Bot/ClientSpec.hs --- a/test/Line/Bot/ClientSpec.hs +++ b/test/Line/Bot/ClientSpec.hs @@ -9,6 +9,7 @@ module Line.Bot.ClientSpec (spec) where import Control.Arrow (left) +import Control.DeepSeq (NFData) import Control.Monad ((>=>)) import Control.Monad.Free import Control.Monad.Trans.Reader (runReaderT) @@ -30,9 +31,9 @@ requestHeaders) import Network.Wai.Handler.Warp (Port, withApplication) import Servant -import Servant.Client import Servant.Client.Core import Servant.Client.Free as F +import Servant.Client.Streaming import Servant.Server (Context (..)) import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, mkAuthHandler) @@ -83,7 +84,7 @@ token :: ChannelToken token = "fake" -runLine :: Line a -> Port -> IO (Either ServantError a) +runLine :: NFData a => Line a -> Port -> IO (Either ClientError a) runLine comp port = withPort port $ runClientM $ runReaderT comp token app :: Application