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.2.0.0 +version: 0.3.0.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 @@ -18,7 +18,7 @@ of the following modules: . * A client library for the , - including the 'Line' monad, which manages the channel credentials. + including the 'Line' monad, which manages the channel credentials. . * A servant combinator to write safe Line webhooks. . @@ -33,6 +33,7 @@ , Line.Bot.Types other-modules: Line.Bot.Endpoints + , Line.Bot.Client.Auth build-depends: base >= 4.7 && < 5 , aeson >= 1.4.2 && < 1.5 @@ -46,6 +47,7 @@ , errors >= 2.3.0 && < 2.4 , http-client >= 0.5.14 && < 0.7 , http-types >= 0.12.2 && < 0.13 + , http-api-data >= 0.4 && < 0.5 , http-client-tls >= 0.3.5 && < 0.4 , servant >= 0.15 && < 0.16 , string-conversions >= 0.4.0 && < 0.5 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 @@ -4,7 +4,6 @@ {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ScopedTypeVariables #-} -{-# LANGUAGE TypeFamilies #-} {-# LANGUAGE TypeOperators #-} {-# LANGUAGE UndecidableInstances #-} -- | @@ -33,31 +32,26 @@ , getContent -- ** Account Link , issueLinkToken + -- ** OAuth + , issueChannelToken + , revokeChannelToken ) where -import Control.Monad.Trans.Class (lift) -import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) -import Data.ByteString.Lazy (ByteString) -import Data.Monoid ((<>)) +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.ByteString.Lazy (ByteString) import Data.Proxy import Data.String -import Data.Text as T +import Data.Text as T +import Line.Bot.Client.Auth import Line.Bot.Endpoints import Line.Bot.Types -import Network.HTTP.Client (newManager) -import Network.HTTP.Client.TLS (tlsManagerSettings) -import Servant.API hiding (addHeader) +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Servant.API hiding (addHeader) import Servant.Client -import Servant.Client.Core.Internal.Auth (AuthClientData, - AuthenticatedRequest, - mkAuthenticatedRequest) -import Servant.Client.Core.Internal.Request (Request, addHeader) -import Servant.Server.Experimental.Auth (AuthHandler, - AuthServerData, - mkAuthHandler) - host :: BaseUrl host = BaseUrl Https "api.line.me" 443 "" @@ -65,11 +59,7 @@ -- OAuth access token for a channel type Line = ReaderT ChannelToken ClientM -type Auth = AuthenticatedRequest (AuthProtect ChannelAuth) - -type instance AuthClientData (AuthProtect ChannelAuth) = ChannelToken - -defaultClient:: ClientM a -> IO (Either ServantError a) +defaultClient :: ClientM a -> IO (Either ServantError a) defaultClient comp = do manager <- newManager tlsManagerSettings runClientM comp (mkClientEnv manager host) @@ -86,12 +76,6 @@ -> IO (Either ServantError a) runLineWith f comp token = f $ runReaderT comp token -mkAuth :: ChannelToken -> Auth -mkAuth token = mkAuthenticatedRequest token addAuthHeader - where - addAuthHeader :: ChannelToken -> Request -> Request - addAuthHeader = addHeader "Authorization" - getProfile' :: Auth -> Id User -> ClientM Profile getGroupMemberProfile' :: Auth -> Id Group -> Id User -> ClientM Profile @@ -108,10 +92,14 @@ multicastMessage' :: Auth -> MulticastMessageBody -> ClientM NoContent -getContent' :: Auth -> String -> ClientM ByteString +getContent' :: Auth -> MessageId -> ClientM ByteString issueLinkToken' :: Auth -> Id User -> ClientM LinkToken +issueChannelToken :: ClientCredentials -> ClientM ShortLivedChannelToken + +revokeChannelToken :: ChannelToken -> ClientM NoContent + getProfile' :<|> getGroupMemberProfile' :<|> leaveGroup' @@ -121,7 +109,9 @@ :<|> pushMessage' :<|> multicastMessage' :<|> getContent' - :<|> issueLinkToken' = client (Proxy :: Proxy Endpoints) + :<|> issueLinkToken' + :<|> issueChannelToken + :<|> revokeChannelToken = client (Proxy :: Proxy Endpoints) getProfile :: Id User -> Line Profile getProfile a = ask >>= \token -> lift $ getProfile' (mkAuth token) a @@ -153,7 +143,7 @@ >>= \token -> lift $ multicastMessage' (mkAuth token) body where body = MulticastMessageBody a ms -getContent :: String -> Line ByteString +getContent :: MessageId -> Line ByteString getContent a = ask >>= \token -> lift $ getContent' (mkAuth token) a issueLinkToken :: Id User -> Line LinkToken diff --git a/src/Line/Bot/Client/Auth.hs b/src/Line/Bot/Client/Auth.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Client/Auth.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE TypeFamilies #-} +-- | +-- Module : Line.Bot.Client.Auth +-- Copyright : (c) Alexandre Moreno, 2019 +-- License : BSD3 +-- Maintainer : alexmorenocano@gmail.com +-- Stability : experimental + +module Line.Bot.Client.Auth where + +import Line.Bot.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) + +type Auth = AuthenticatedRequest (AuthProtect ChannelAuth) + +type instance AuthClientData (AuthProtect ChannelAuth) = ChannelToken + +mkAuth :: ChannelToken -> Auth +mkAuth token = mkAuthenticatedRequest token addAuthorizationHeader + where + addAuthorizationHeader :: ChannelToken -> Request -> Request + addAuthorizationHeader = addHeader hAuthorization diff --git a/src/Line/Bot/Endpoints.hs b/src/Line/Bot/Endpoints.hs --- a/src/Line/Bot/Endpoints.hs +++ b/src/Line/Bot/Endpoints.hs @@ -74,7 +74,7 @@ type GetContent = AuthProtect ChannelAuth :> "message" - :> Capture "messageId" String + :> Capture "messageId" MessageId :> "content" :> Get '[OctetStream] ByteString @@ -84,6 +84,18 @@ :> "linkToken" :> Get '[JSON] LinkToken +type IssueChannelToken = + ReqBody '[FormUrlEncoded] ClientCredentials + :> "oauth" + :> "accessToken" + :> Post '[JSON] ShortLivedChannelToken + +type RevokeChannelToken = + ReqBody '[FormUrlEncoded] ChannelToken + :> "oauth" + :> "revoke" + :> PostNoContent '[JSON] NoContent + type Endpoints = "v2" :> "bot" :> ( GetProfile :<|> GetGroupMemberProfile @@ -95,4 +107,6 @@ :<|> MulticastMessage :<|> GetContent :<|> IssueLinkToken + :<|> IssueChannelToken + :<|> RevokeChannelToken ) 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 @@ -8,6 +8,7 @@ {-# LANGUAGE KindSignatures #-} {-# LANGUAGE LambdaCase #-} {-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedLists #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RecordWildCards #-} {-# LANGUAGE StandaloneDeriving #-} @@ -23,6 +24,7 @@ , ChannelSecret(..) , ChatType(..) , Id(..) + , MessageId , URL(..) , Message(..) , ReplyToken(..) @@ -34,6 +36,8 @@ , QuickReply(..) , QuickReplyButton(..) , Action(..) + , ClientCredentials(..) + , ShortLivedChannelToken(..) ) where @@ -43,27 +47,38 @@ 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.Encoding import GHC.Generics hiding (to) import Servant.API import Text.Show +import Web.FormUrlEncoded (ToForm (..)) newtype ChannelToken = ChannelToken Text - deriving (Eq) + deriving (Eq, Show, Generic) +instance FromJSON ChannelToken + instance IsString ChannelToken where fromString s = ChannelToken (fromString s) instance ToHttpApiData ChannelToken where toQueryParam (ChannelToken t) = "Bearer " <> t +instance ToForm ChannelToken where + toForm (ChannelToken t) = [ ("access_token", t) ] + newtype ChannelSecret = ChannelSecret { unChannelSecret :: B.ByteString } instance IsString ChannelSecret where fromString s = ChannelSecret (B.pack s) +instance ToHttpApiData ChannelSecret where + toQueryParam = decodeUtf8 . unChannelSecret + data ChatType = User | Group | Room -- | ID of a chat user, group or room @@ -93,6 +108,8 @@ instance FromJSON (Id Room) where parseJSON = withText "Id Room" $ return . RoomId +type MessageId = Text + newtype URL = URL Text deriving (Show, Eq, Generic) @@ -252,3 +269,26 @@ Just s -> fmap toLower s Nothing -> orig } + +type ChannelId = Id User + +data ClientCredentials = ClientCredentials + { clientId :: ChannelId + , clientSecret :: ChannelSecret + } + +instance ToForm ClientCredentials where + toForm ClientCredentials{..} = + [ ("grant_type", "client_credentials") + , ("client_id", toQueryParam clientId) + , ("client_secret", toQueryParam clientSecret) + ] + +data ShortLivedChannelToken = ShortLivedChannelToken + { accessToken :: ChannelToken + , expiresIn :: Int + } deriving (Eq, Show, Generic) + +instance FromJSON ShortLivedChannelToken where + parseJSON = genericParseJSON defaultOptions + { fieldLabelModifier = camelTo2 '_' } 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 @@ -46,9 +46,11 @@ import Servant.API.ContentTypes import Servant.Server.Internal - +-- | This type alias just specifies how webhook requests should be handled type Webhook = LineReqBody '[JSON] Events :> Post '[JSON] NoContent +-- | A Servant combinator that extracts the request body as a value of type a +-- and performs signature valiadation data LineReqBody (contentTypes :: [*]) (a :: *) deriving (Typeable) @@ -87,8 +89,8 @@ hSignature = "X-Line-Signature" validateReqBody :: Maybe B.ByteString -> BL.ByteString -> Bool - validateReqBody digest body = maybe False f digest' + validateReqBody digest body = maybe False (== SHA256.hmaclazy secret body) digest' where digest' = Base64.decodeLenient <$> digest - f = (== SHA256.hmaclazy (unChannelSecret channelSecret) body) + secret = unChannelSecret channelSecret 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 @@ -52,13 +52,14 @@ data Events = Events - { destination :: Id User - , events :: [Event] + { destination :: Id User -- ^ User ID of a bot that should receive webhook events + , events :: [Event] -- ^ List of webhook event objects } deriving (Eq, Show, Generic) instance FromJSON Events +-- | Events generated on the LINE Platform. data Event = EventMessage { replyToken :: ReplyToken , message :: Message @@ -119,32 +120,33 @@ , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 5 } + data Message = - Text { messageId :: Text + Text { messageId :: MessageId , text :: Text } - | Image { messageId :: Text + | Image { messageId :: MessageId , contentProvider :: ContentProvider } - | Video { messageId :: Text + | Video { messageId :: MessageId , duration :: Int , contentProvider :: ContentProvider } - | Audio { messageId :: Text + | Audio { messageId :: MessageId , duration :: Int , contentProvider :: ContentProvider } - | File { messageId :: Text + | File { messageId :: MessageId , fileSize :: Int , fileName :: Text } - | Location { messageId :: Text + | Location { messageId :: MessageId , title :: Text , address :: Text , latitude :: Double , longitude :: Double } - | Sticker { messageId :: Text + | Sticker { messageId :: MessageId , packageId :: Text , stickerId :: Text } @@ -190,7 +192,6 @@ . fromRational . toRational . (/ 1000) - data Source = SourceUser (Id User)