diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -6,7 +6,7 @@ * Servant combinator `LineReqBody` for validation of request signatures using the channel secret. This is required to distinguish legitimate requests sent by LINE from malicious requests -* Bindings for (most) of the Messaging APIs +* Bindings for (most of) the Messaging APIs ## Installation @@ -34,9 +34,10 @@ ## Documentation -The documentation for the latest release is available on [Hackage][hackage]. +See the official API documentation for more information. -[hackage]: http://hackage.haskell.org/package/line-bot-sdk "Hackage" +- English: https://developers.line.biz/en/docs/messaging-api/overview/ +- Japanese: https://developers.line.biz/ja/docs/messaging-api/overview/ ## Usage 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.2 +version: 0.6.0 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 @@ -31,16 +31,18 @@ , Line.Bot.Webhook.Events , Line.Bot.Client , Line.Bot.Types - , Line.Bot.Internal.Auth , Line.Bot.Internal.Endpoints + other-modules: Paths_line_bot_sdk + autogen-modules: Paths_line_bot_sdk + build-depends: base >= 4.7 && < 5 , aeson >= 1.4.2 && < 1.5 , bytestring >= 0.10.8 && < 0.11 , scientific >= 0.3.6 && < 0.4 , text >= 1.2.3 && < 1.3 , transformers >= 0.5.5 && < 0.6 - , time >= 1.8.0 && < 1.9 + , time >= 1.9.3 && < 1.10 , base64-bytestring >= 1.0.0 && < 1.1 , cryptohash-sha256 >= 0.11.101 && < 0.12 , http-client >= 0.5.14 && < 0.7 @@ -71,7 +73,7 @@ , transformers >= 0.5.5 && < 0.6 , wai >= 3.2.2 && < 3.3 , wai-extra >= 3.0.25 && < 3.1 - , warp >= 3.2.26 && < 3.3 + , warp >= 3.3.12 && < 3.4 default-language: Haskell2010 @@ -92,6 +94,7 @@ , hspec-expectations , http-types , http-client + , http-client-tls , aeson , transformers , aeson-qq 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 @@ -60,23 +60,22 @@ 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) +import Data.Text (Text, pack) +import GHC.TypeLits (Symbol) import Line.Bot.Internal.Endpoints import Line.Bot.Types import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) import Servant.API import Servant.Client.Streaming +import Paths_line_bot_sdk (version) +import Data.Version (showVersion) defaultEndpoint :: BaseUrl defaultEndpoint = BaseUrl Https "api.line.me" 443 "" @@ -84,6 +83,9 @@ blobEndpoint :: BaseUrl blobEndpoint = BaseUrl Https "api-data.line.me" 443 "" +userAgent :: Text +userAgent = "line-bot-sdk-haskell/" <> pack (showVersion version) + -- | @Line@ is the monad in which bot requests run. Contains the -- OAuth access token for a channel type Line = ReaderT ChannelToken ClientM @@ -110,64 +112,81 @@ 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 }) +withHost :: BaseUrl -> Line a -> Line a +withHost baseUrl = mapReaderT $ local (\env -> env { baseUrl = baseUrl }) -type LineAuth a = Auth -> ClientM a +type family AddHeaders a :: * where + AddHeaders ((sym :: Symbol) :> last) + = (sym :: Symbol) :> AddHeaders last + AddHeaders (first :> last) + = first :> AddHeaders last + AddHeaders last + = Header' '[Required, Strict] "Authorization" ChannelToken + :> Header' '[Required, Strict] "User-Agent" Text + :> last + +type ClientWithHeaders a = ChannelToken -> Text -> ClientM a -type family AddLineAuth a :: * where - AddLineAuth (LineAuth a) = Line a - AddLineAuth (a -> b) = a -> AddLineAuth b +type family EmbedLine a :: * where + EmbedLine (ClientWithHeaders a) = Line a + EmbedLine (a -> b) = a -> EmbedLine b class HasLine a where - addLineAuth :: a -> AddLineAuth a + embedLine :: a -> EmbedLine a -instance HasLine (LineAuth a) where - addLineAuth comp = ask >>= lift . comp . mkAuth +instance HasLine (ClientWithHeaders a) where + embedLine comp = do + token <- ask + lift $ comp token userAgent -instance HasLine (a -> LineAuth b) where - addLineAuth comp = addLineAuth . comp +instance HasLine (a -> ClientWithHeaders b) where + embedLine comp = embedLine . comp -instance HasLine (a -> b -> LineAuth c) where - addLineAuth comp = addLineAuth . comp +instance HasLine (a -> b -> ClientWithHeaders c) where + embedLine comp = embedLine . comp -line :: (HasLine (Client ClientM api), HasClient ClientM api) +line :: (HasLine (Client ClientM (AddHeaders api)), HasClient ClientM (AddHeaders api)) => Proxy api - -> AddLineAuth (Client ClientM api) -line = addLineAuth . client + -> EmbedLine (Client ClientM (AddHeaders api)) +line = embedLine . clientWithHeaders -unfoldMemberUserIds :: (Maybe String -> Line MemberIds) -> Line [Id User] +clientWithHeaders :: (HasClient ClientM (AddHeaders api)) + => Proxy api + -> Client ClientM (AddHeaders api) +clientWithHeaders (Proxy :: Proxy api) = client (Proxy :: Proxy (AddHeaders api)) + +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 :: Id 'User -> Line Profile getProfile = line (Proxy @GetProfile) -getGroupMemberProfile :: Id Group -> Id User -> Line Profile +getGroupMemberProfile :: Id 'Group -> Id 'User -> Line Profile getGroupMemberProfile = line (Proxy @GetGroupMemberProfile) -leaveGroup :: Id Group -> Line NoContent +leaveGroup :: Id 'Group -> Line NoContent leaveGroup = line (Proxy @LeaveGroup) -getGroupMemberUserIds' :: Id Group -> Maybe String -> Line MemberIds +getGroupMemberUserIds' :: Id 'Group -> Maybe String -> Line MemberIds getGroupMemberUserIds' = line (Proxy @GetGroupMemberUserIds) -getGroupMemberUserIds :: Id Group -> Line [Id User] +getGroupMemberUserIds :: Id 'Group -> Line [Id 'User] getGroupMemberUserIds = unfoldMemberUserIds . getGroupMemberUserIds' -getRoomMemberProfile :: Id Room -> Id User -> Line Profile +getRoomMemberProfile :: Id 'Room -> Id 'User -> Line Profile getRoomMemberProfile = line (Proxy @GetRoomMemberProfile) -leaveRoom :: Id Room -> Line NoContent +leaveRoom :: Id 'Room -> Line NoContent leaveRoom = line (Proxy @LeaveRoom) -getRoomMemberUserIds' :: Id Room -> Maybe String -> Line MemberIds +getRoomMemberUserIds' :: Id 'Room -> Maybe String -> Line MemberIds getRoomMemberUserIds' = line (Proxy @GetRoomMemberUserIds) -getRoomMemberUserIds :: Id Room -> Line [Id User] +getRoomMemberUserIds :: Id 'Room -> Line [Id 'User] getRoomMemberUserIds = unfoldMemberUserIds . getRoomMemberUserIds' replyMessage' :: ReplyMessageBody -> Line NoContent @@ -185,7 +204,7 @@ multicastMessage' :: MulticastMessageBody -> Line NoContent multicastMessage' = line (Proxy @MulticastMessage) -multicastMessage :: [Id User] -> [Message] -> Line NoContent +multicastMessage :: [Id 'User] -> [Message] -> Line NoContent multicastMessage a ms = multicastMessage' (MulticastMessageBody a ms) broadcastMessage' :: BroadcastMessageBody -> Line NoContent @@ -194,14 +213,14 @@ 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 @GetContent) getContent :: MessageId -> Line LB.ByteString -getContent a = ask >>= lift . withHost blobEndpoint . getContent' a . mkAuth +getContent = withHost blobEndpoint . getContent' -getContentS' :: MessageId -> Auth -> ClientM (SourceIO ByteString) -getContentS' = client (Proxy @GetContentStream) +getContentS' :: MessageId -> Line (SourceIO ByteString) +getContentS' = line (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 @@ -212,7 +231,7 @@ -- > getContentC :: MessageId -> Line (ConduitT () ByteString IO ()) -- > getContentC = fmap fromSourceIO . getContentS getContentS :: MessageId -> Line (SourceIO ByteString) -getContentS a = ask >>= lift . withHost blobEndpoint . getContentS' a . mkAuth +getContentS = withHost blobEndpoint . getContentS' getPushMessageCount' :: LineDate -> Line MessageCount getPushMessageCount' = line (Proxy @GetPushMessageCount) @@ -244,7 +263,7 @@ getMessageQuota :: Line Int getMessageQuota = fmap totalUsage getMessageQuota' -issueLinkToken :: Id User -> Line LinkToken +issueLinkToken :: Id 'User -> Line LinkToken issueLinkToken = line (Proxy @IssueLinkToken) issueChannelToken' :: ClientCredentials -> ClientM ShortLivedChannelToken @@ -265,11 +284,11 @@ getRichMenu :: RichMenuId -> Line RichMenu getRichMenu = fmap richMenu . getRichMenu' -uploadRichMenuImageJpg' :: RichMenuId -> ByteString -> Auth -> ClientM NoContent -uploadRichMenuImageJpg' = client (Proxy @UploadRichMenuImageJpg) +uploadRichMenuImageJpg' :: RichMenuId -> ByteString -> Line NoContent +uploadRichMenuImageJpg' = line (Proxy @UploadRichMenuImageJpg) uploadRichMenuImageJpg :: RichMenuId -> ByteString -> Line NoContent -uploadRichMenuImageJpg a b = ask >>= lift . withHost blobEndpoint . uploadRichMenuImageJpg' a b . mkAuth +uploadRichMenuImageJpg a = withHost blobEndpoint . uploadRichMenuImageJpg' a deleteRichMenu :: RichMenuId -> Line NoContent deleteRichMenu = line (Proxy @DeleteRichMenu) diff --git a/src/Line/Bot/Internal/Auth.hs b/src/Line/Bot/Internal/Auth.hs deleted file mode 100644 --- a/src/Line/Bot/Internal/Auth.hs +++ /dev/null @@ -1,25 +0,0 @@ -{-# LANGUAGE TypeFamilies #-} --- | --- Module : Line.Bot.Internal.Auth --- Copyright : (c) Alexandre Moreno, 2019 --- License : BSD3 --- Maintainer : alexmorenocano@gmail.com --- Stability : experimental - -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.Auth (AuthClientData, - AuthenticatedRequest, - mkAuthenticatedRequest) -import Servant.Client.Core.Request (Request, addHeader) - -type instance AuthClientData ChannelAuth = ChannelToken - -type Auth = AuthenticatedRequest ChannelAuth - -mkAuth :: ChannelToken -> Auth -mkAuth token = mkAuthenticatedRequest token (addHeader hAuthorization) 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 @@ -19,71 +19,61 @@ import qualified Data.ByteString.Lazy as LB (ByteString) import Line.Bot.Types import Servant.API -import Servant.Client -- | Combinator for authenticating with the channel access token -type ChannelAuth = AuthProtect "channel-access-token" - type GetProfile' a = "v2":> "bot" :> "profile" - :> Capture "userId" (Id User) - :> ChannelAuth + :> Capture "userId" (Id 'User) :> Get '[JSON] a type GetProfile = GetProfile' Profile type GetGroupMemberProfile' a = "v2":> "bot" :> "group" - :> Capture "groupId" (Id Group) + :> Capture "groupId" (Id 'Group) :> "member" - :> Capture "userId" (Id User) - :> ChannelAuth + :> Capture "userId" (Id 'User) :> Get '[JSON] a type GetGroupMemberProfile = GetGroupMemberProfile' Profile type LeaveGroup = "v2":> "bot" :> "group" - :> Capture "groupId" (Id Group) + :> Capture "groupId" (Id 'Group) :> "leave" - :> ChannelAuth :> PostNoContent '[JSON] NoContent type GetGroupMemberUserIds' a = "v2":> "bot" :> "group" - :> Capture "groupId" (Id Group) + :> Capture "groupId" (Id 'Group) :> "members" :> "ids" :> QueryParam "start" String - :> ChannelAuth :> Get '[JSON] a type GetGroupMemberUserIds = GetGroupMemberUserIds' MemberIds type GetRoomMemberProfile' a = "v2":> "bot" :> "room" - :> Capture "roomId" (Id Room) + :> Capture "roomId" (Id 'Room) :> "member" - :> Capture "userId" (Id User) - :> ChannelAuth + :> Capture "userId" (Id 'User) :> Get '[JSON] a type GetRoomMemberProfile = GetRoomMemberProfile' Profile type LeaveRoom = "v2":> "bot" :> "room" - :> Capture "roomId" (Id Room) + :> Capture "roomId" (Id 'Room) :> "leave" - :> ChannelAuth :> PostNoContent '[JSON] NoContent type GetRoomMemberUserIds' a = "v2":> "bot" :> "room" - :> Capture "roomId" (Id Room) + :> Capture "roomId" (Id 'Room) :> "members" :> "ids" :> QueryParam "start" String - :> ChannelAuth :> Get '[JSON] a type GetRoomMemberUserIds = GetRoomMemberUserIds' MemberIds @@ -92,7 +82,6 @@ "v2":> "bot" :> "message" :> "reply" :> ReqBody '[JSON] a - :> ChannelAuth :> PostNoContent '[JSON] NoContent type ReplyMessage = ReplyMessage' ReplyMessageBody @@ -101,7 +90,6 @@ "v2":> "bot" :> "message" :> "push" :> ReqBody '[JSON] a - :> ChannelAuth :> PostNoContent '[JSON] NoContent type PushMessage = PushMessage' PushMessageBody @@ -110,7 +98,6 @@ "v2":> "bot" :> "message" :> "multicast" :> ReqBody '[JSON] a - :> ChannelAuth :> PostNoContent '[JSON] NoContent type MulticastMessage = MulticastMessage' MulticastMessageBody @@ -119,7 +106,6 @@ "v2":> "bot" :> "message" :> "broadcast" :> ReqBody '[JSON] a - :> ChannelAuth :> PostNoContent '[JSON] NoContent type BroadcastMessage = BroadcastMessage' BroadcastMessageBody @@ -128,21 +114,18 @@ "v2":> "bot" :> "message" :> Capture "messageId" MessageId :> "content" - :> ChannelAuth :> Get '[OctetStream] LB.ByteString type GetContentStream = "v2":> "bot" :> "message" :> Capture "messageId" MessageId :> "content" - :> ChannelAuth :> StreamGet NoFraming OctetStream (SourceIO ByteString) type GetReplyMessageCount' a b = "v2":> "bot" :> "message" :> "delivery" :> "reply" :> QueryParam' '[Required, Strict] "date" a - :> ChannelAuth :> Get '[JSON] b type GetReplyMessageCount = GetReplyMessageCount' LineDate MessageCount @@ -151,7 +134,6 @@ "v2":> "bot" :> "message" :> "delivery" :> "push" :> QueryParam' '[Required, Strict] "date" a - :> ChannelAuth :> Get '[JSON] b type GetPushMessageCount = GetPushMessageCount' LineDate MessageCount @@ -160,7 +142,6 @@ "v2" :> "bot" :> "message" :> "delivery" :> "multicast" :> QueryParam' '[Required, Strict] "date" a - :> ChannelAuth :> Get '[JSON] b type GetMulticastMessageCount = GetMulticastMessageCount' LineDate MessageCount @@ -169,7 +150,6 @@ "v2" :> "bot" :> "message" :> "delivery" :> "broadcast" :> QueryParam' '[Required, Strict] "date" a - :> ChannelAuth :> Get '[JSON] b type GetBroadcastMessageCount = GetBroadcastMessageCount' LineDate MessageCount @@ -177,16 +157,14 @@ type GetMessageQuota' a = "v2":> "bot" :> "message" :> "quota" :> "consumption" - :> ChannelAuth :> Get '[JSON] a type GetMessageQuota = GetMessageQuota' MessageQuota type IssueLinkToken' a = "v2":> "bot" :> "user" - :> Capture "userId" (Id User) + :> Capture "userId" (Id 'User) :> "linkToken" - :> ChannelAuth :> Get '[JSON] a type IssueLinkToken = IssueLinkToken' LinkToken @@ -210,7 +188,6 @@ type CreateRichMenu' a b = "v2" :> "bot" :> "richmenu" :> ReqBody '[JSON] a - :> ChannelAuth :> PostNoContent '[JSON] b type CreateRichMenu = CreateRichMenu' RichMenu RichMenuId @@ -218,7 +195,6 @@ type DeleteRichMenu' a = "v2" :> "bot" :> "richmenu" :> Capture "richMenuId" a - :> ChannelAuth :> Delete '[JSON] NoContent type DeleteRichMenu = DeleteRichMenu' RichMenuId @@ -226,7 +202,6 @@ type GetRichMenu' a b = "v2" :> "bot" :> "richmenu" :> Capture "richMenuId" a - :> ChannelAuth :> Get '[JSON] b type GetRichMenu = GetRichMenu' RichMenuId RichMenuResponse @@ -236,7 +211,6 @@ :> Capture "richMenuId" a :> "content" :> ReqBody '[JPEG] b - :> ChannelAuth :> Post '[JSON] NoContent type UploadRichMenuImageJpg = UploadRichMenuImageJpg' RichMenuId ByteString @@ -244,7 +218,6 @@ type GetRichMenuList' a = "v2" :> "bot" :> "richmenu" :> "list" - :> ChannelAuth :> Get '[JSON] a type GetRichMenuList = GetRichMenuList' RichMenuResponseList @@ -252,7 +225,6 @@ 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 @@ -62,28 +62,22 @@ import Control.Arrow ((>>>)) import Control.DeepSeq import Data.Aeson -import Data.Aeson.Types 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) -import Data.Monoid ((<>)) import Data.String -import Data.Text as T hiding (drop, toLower) +import Data.Text as T hiding (count, drop, toLower) 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 Network.HTTP.Media ((//)) import Servant.API -import Text.Show import Web.FormUrlEncoded (ToForm (..)) - - newtype ChannelToken = ChannelToken { unChannelToken :: Text } deriving (Eq, Show, Generic, NFData) @@ -121,9 +115,9 @@ -- | ID of a chat user, group or room data Id :: ChatType -> * where - UserId :: Text -> Id User - GroupId :: Text -> Id Group - RoomId :: Text -> Id Room + UserId :: Text -> Id 'User + GroupId :: Text -> Id 'Group + RoomId :: Text -> Id 'Room deriving instance Eq (Id a) deriving instance Show (Id a) @@ -142,32 +136,32 @@ instance ToJSON (Id a) where toJSON = String . toQueryParam -instance FromHttpApiData (Id User) where +instance FromHttpApiData (Id 'User) where parseUrlPiece = pure . UserId -instance FromHttpApiData (Id Group) where +instance FromHttpApiData (Id 'Group) where parseUrlPiece = pure . GroupId -instance FromHttpApiData (Id Room) where +instance FromHttpApiData (Id 'Room) where parseUrlPiece = pure . RoomId -instance IsString (Id User) where +instance IsString (Id 'User) where fromString s = UserId (fromString s) -instance IsString (Id Group) where +instance IsString (Id 'Group) where fromString s = GroupId (fromString s) -instance IsString (Id Room) where +instance IsString (Id 'Room) where fromString s = RoomId (fromString s) -instance FromJSON (Id User) where - parseJSON = withText "Id User" $ return . UserId +instance FromJSON (Id 'User) where + parseJSON = withText "Id 'User" $ return . UserId -instance FromJSON (Id Group) where - parseJSON = withText "Id Group" $ return . GroupId +instance FromJSON (Id 'Group) where + parseJSON = withText "Id 'Group" $ return . GroupId -instance FromJSON (Id Room) where - parseJSON = withText "Id Room" $ return . RoomId +instance FromJSON (Id 'Room) where + parseJSON = withText "Id 'Room" $ return . RoomId type MessageId = Text @@ -265,7 +259,7 @@ ] data MulticastMessageBody = MulticastMessageBody - { to :: [Id User] + { to :: [Id 'User] , messages :: [Message] } deriving (Show, Generic, NFData) @@ -379,7 +373,7 @@ instance FromJSON MessageQuota data MemberIds = MemberIds - { memberIds :: [Id User] + { memberIds :: [Id 'User] , next :: Maybe String } deriving (Eq, Show, Generic, NFData) @@ -459,13 +453,13 @@ data RichMenuBulkLinkBody = RichMenuBulkLinkBody { richMenuId :: Text - , userIds :: [Id User] + , userIds :: [Id 'User] } deriving (Show, Eq, Generic, NFData) instance ToJSON RichMenuBulkLinkBody newtype RichMenuBulkUnlinkBody = RichMenuBulkUnlinkBody - { userIds :: [Id User] } + { 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 @@ -28,11 +28,9 @@ ) where -import Control.Monad (forM_, (>>)) +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 import qualified Data.ByteString as B import qualified Data.ByteString.Base64 as Base64 import qualified Data.ByteString.Lazy as BL @@ -43,7 +41,7 @@ import Line.Bot.Types (ChannelSecret (..)) import Line.Bot.Webhook.Events as Events import Network.HTTP.Types (HeaderName, hContentType) -import Network.Wai (Request, lazyRequestBody, +import Network.Wai (lazyRequestBody, requestHeaders) import Servant import Servant.API.ContentTypes 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 @@ -37,26 +37,21 @@ import Control.Arrow ((>>>)) import Data.Aeson -import Data.Aeson.Types import Data.Char import Data.Foldable import Data.List as L (stripPrefix) -import Data.Maybe -import Data.Scientific -import Data.String import Data.Text as T hiding (drop, toLower) -import Data.Time (LocalTime, UTCTime) +import Data.Time (UTCTime) import Data.Time.Calendar (Day) import Data.Time.Clock.POSIX import Data.Time.Format import Data.Time.LocalTime import Data.Typeable (Typeable) import GHC.Generics (Generic) -import Line.Bot.Types hiding (Message, Text) - +import Line.Bot.Types hiding (Message) data Events = Events - { destination :: Id User -- ^ User ID of a bot that should receive webhook events + { destination :: Id 'User -- ^ 'User ID of a bot that should receive webhook events , events :: [Event] -- ^ List of webhook event objects } deriving (Show, Generic) @@ -207,9 +202,9 @@ _ -> 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] + toJSON (Source (UserId a)) = object ["type" .= String "user", "userId" .= a] + toJSON (Source (GroupId a)) = object ["type" .= String "group", "groupId" .= a] + toJSON (Source (RoomId a)) = object ["type" .= String "room", "roomId" .= a] newtype Members = Members { members :: [Source] } deriving (Show, Generic) @@ -230,13 +225,13 @@ , PostbackTimeOfDay <$> o .: "time" ] -data Postback = Postback Text PostbackDateTime +data Postback = Postback Text (Maybe PostbackDateTime) deriving (Eq, Show) instance FromJSON Postback where parseJSON = withObject "Postback" $ \o -> do postbackData <- o .: "data" - params <- o .: "params" + params <- o .:? "params" return $ Postback postbackData params data BeaconEvent = Enter | Leave | Banner 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 @@ -5,10 +5,10 @@ {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} +{-# LANGUAGE TypeApplications #-} module Line.Bot.ClientSpec (spec) where -import Control.Arrow (left) import Control.DeepSeq (NFData) import Control.Monad ((>=>)) import Control.Monad.Free @@ -17,15 +17,13 @@ import Data.Aeson.QQ import Data.ByteString as B (stripPrefix) import Data.Foldable (toList) -import Data.Text import Data.Text.Encoding import Data.Time.Calendar (fromGregorian) import Line.Bot.Client hiding (runLine) -import Line.Bot.Internal.Auth import Line.Bot.Internal.Endpoints import Line.Bot.Types -import Network.HTTP.Client (defaultManagerSettings, - newManager) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) import Network.HTTP.Types (hAuthorization) import Network.Wai as Wai (Request, requestHeaders) @@ -34,13 +32,12 @@ 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) import Test.Hspec import Test.Hspec.Expectations.Contrib -import Test.Hspec.Wai +type ChannelAuth = AuthProtect "channel-token" type instance AuthServerData ChannelAuth = ChannelToken -- a dummy auth handler that returns the channel access token @@ -57,14 +54,14 @@ :<|> GetGroupMemberProfile' Value :<|> GetRoomMemberProfile' Value -getReplyMessageCountF :: LineDate -> Auth -> Free ClientF MessageCount -getReplyMessageCountF = F.client (Proxy :: Proxy GetReplyMessageCount) +getReplyMessageCountF :: LineDate -> Free ClientF MessageCount +getReplyMessageCountF = F.client (Proxy @GetReplyMessageCount) -getPushMessageCountF :: LineDate -> Auth -> Free ClientF MessageCount -getPushMessageCountF = F.client (Proxy :: Proxy GetPushMessageCount) +getPushMessageCountF :: LineDate -> Free ClientF MessageCount +getPushMessageCountF = F.client (Proxy @GetPushMessageCount) -getMulticastMessageCountF :: LineDate -> Auth -> Free ClientF MessageCount -getMulticastMessageCountF = F.client (Proxy :: Proxy GetMulticastMessageCount) +getMulticastMessageCountF :: LineDate -> Free ClientF MessageCount +getMulticastMessageCountF = F.client (Proxy @GetMulticastMessageCount) testProfile :: Value testProfile = [aesonQQ| @@ -78,20 +75,20 @@ withPort :: Port -> (ClientEnv -> IO a) -> IO a withPort port app = do - manager <- newManager defaultManagerSettings + manager <- newManager tlsManagerSettings app $ mkClientEnv manager $ BaseUrl Http "localhost" port "" token :: ChannelToken token = "fake" runLine :: NFData a => Line a -> Port -> IO (Either ClientError a) -runLine comp port = withPort port $ runClientM $ runReaderT comp token +runLine comp port = withPort port $ \env -> runClientM (runReaderT comp token) env app :: Application app = serveWithContext (Proxy :: Proxy API) serverContext $ - (\_ _ -> return testProfile) - :<|> (\_ _ _ -> return testProfile) - :<|> (\_ _ _ -> return testProfile) + (\_ -> return testProfile) + :<|> (\_ _ -> return testProfile) + :<|> (\_ _ -> return testProfile) spec :: Spec spec = describe "Line client" $ do @@ -108,15 +105,15 @@ runLine (getRoomMemberProfile "1" "1") >=> (`shouldSatisfy` isRight) it "should send `date` query param for push message count" $ do - let Free (RunRequest Request{..} _) = getPushMessageCountF date (mkAuth token) + let Free (RunRequest Request{..} _) = getPushMessageCountF date toList requestQueryString `shouldBe` [("date", Just "20190407")] it "should send `date` query param for reply message count" $ do - let Free (RunRequest Request{..} _) = getReplyMessageCountF date (mkAuth token) + let Free (RunRequest Request{..} _) = getReplyMessageCountF date toList requestQueryString `shouldBe` [("date", Just "20190407")] it "should send `date` query param for multicast message count" $ do - let Free (RunRequest Request{..} _) = getMulticastMessageCountF date (mkAuth token) + let Free (RunRequest Request{..} _) = getMulticastMessageCountF date toList requestQueryString `shouldBe` [("date", Just "20190407")] where date = LineDate $ fromGregorian 2019 4 7