diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2018 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,1 @@ +# line-bot-sdk diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/examples/Echo.hs b/examples/Echo.hs new file mode 100644 --- /dev/null +++ b/examples/Echo.hs @@ -0,0 +1,53 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE TypeOperators #-} + +module Main (main) where + +import Control.Monad (mapM_) +import Control.Monad.IO.Class (liftIO) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.String (fromString) +import Line.Bot.Client as B +import Line.Bot.Webhook as W +import Network.Wai.Handler.Warp (run) +import Network.Wai.Middleware.RequestLogger (logStdout) +import Servant +import Servant.Server (Context ((:.), EmptyContext)) +import System.Environment (getEnv) + +type WebM = ReaderT ChannelToken Handler + +type API = "webhook" :> Webhook + +echo :: Event -> Line NoContent +echo EventMessage { message = W.Text { text }, replyToken } = + replyMessage replyToken [B.Text text Nothing] +echo _ = return NoContent + +handleEvents :: Events -> WebM NoContent +handleEvents Events { events } = do + token <- ask + _ <- liftIO $ mapM_ (runLine token . echo) events + return NoContent + +echoServer :: ServerT API WebM +echoServer = handleEvents + +app :: ChannelToken -> ChannelSecret -> Application +app token secret = serveWithContext api context server + where + api = Proxy :: Proxy API + server = hoistServerWithContext api pc nt echoServer + nt = flip runReaderT token + pc = Proxy :: Proxy '[ChannelSecret] + context = secret :. EmptyContext + +main :: IO () +main = do + token <- fromString <$> getEnv "CHANNEL_TOKEN" + secret <- fromString <$> getEnv "CHANNEL_SECRET" + port <- read <$> getEnv "PORT" + run port $ logStdout $ app token secret diff --git a/line-bot-sdk.cabal b/line-bot-sdk.cabal new file mode 100644 --- /dev/null +++ b/line-bot-sdk.cabal @@ -0,0 +1,92 @@ +name: line-bot-sdk +version: 0.1.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 +license: BSD3 +license-file: LICENSE +author: Alexandre Moreno +maintainer: Alexandre Moreno +stability: experimental +copyright: (c) 2018 Alexandre Moreno +category: Network, Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 +description: + A Servant library for building LINE chatbots. This package is composed + of the following modules: + . + * A client library for the , + including the 'Line' monad, which manages the channel credentials. + . + * A servant combinator to write safe Line webhooks. + . + To get started, see the documentation for the @Line.Bot.Client@ + and @Line.Bot.Webhook@ modules below. + +library + hs-source-dirs: src + exposed-modules: Line.Bot.Webhook + , Line.Bot.Client + + other-modules: Line.Bot.Endpoints + , Line.Bot.Types + , Line.Bot.Webhook.Types + + 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 + , 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-client-tls >= 0.3.5 && < 0.4 + , servant >= 0.15 && < 0.16 + , 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 + , wai >= 3.2.2 && < 3.3 + , wai-extra >= 3.0.25 && < 3.1 + + default-language: Haskell2010 + +executable echo-server + hs-source-dirs: examples + main-is: Echo.hs + 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 + , 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 + + default-language: Haskell2010 + +test-suite line-bot-sdk-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , line-bot-sdk + , hspec + , hspec-wai + , hspec-wai-json + , aeson + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/moleike/line-bot-sdk diff --git a/src/Line/Bot/Client.hs b/src/Line/Bot/Client.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Client.hs @@ -0,0 +1,137 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Line.Bot.Client + ( module Line.Bot.Types + , runLine + , Line + , ChannelToken(..) + , getProfile + , getGroupMemberProfile + , leaveGroup + , getRoomMemberProfile + , leaveRoom + , replyMessage + , pushMessage + , multicastMessage + ) +where + +import Control.Monad.Trans.Class (lift) +import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) +import Data.ByteString.Lazy (ByteString) +import Data.Monoid ((<>)) +import Data.Proxy +import Data.String +import Data.Text as T +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 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 "" + +newtype ChannelToken = ChannelToken Text + deriving (Eq) + +instance IsString ChannelToken where + fromString s = ChannelToken (fromString s) + +instance ToHttpApiData ChannelToken where + toQueryParam (ChannelToken t) = "Bearer " <> t + +type Line = ReaderT ChannelToken ClientM + +type Auth = AuthenticatedRequest (AuthProtect ChannelAuth) + +type instance AuthClientData (AuthProtect ChannelAuth) = ChannelToken + +runLine' :: ClientM a -> IO (Either ServantError a) +runLine' comp = do + manager <- newManager tlsManagerSettings + runClientM comp (mkClientEnv manager host) + +runLine :: ChannelToken -> Line a -> IO (Either ServantError a) +runLine token comp = runLine' $ 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 + +leaveGroup' :: Auth -> Id Group -> ClientM NoContent + +getRoomMemberProfile' :: Auth -> Id Room -> Id User -> ClientM Profile + +leaveRoom' :: Auth -> Id Room -> ClientM NoContent + +replyMessage' :: Auth -> ReplyMessageBody -> ClientM NoContent + +pushMessage' :: Auth -> PushMessageBody -> ClientM NoContent + +multicastMessage' :: Auth -> MulticastMessageBody -> ClientM NoContent + +getContent' :: Auth -> String -> ClientM ByteString + +getProfile' + :<|> getGroupMemberProfile' + :<|> leaveGroup' + :<|> getRoomMemberProfile' + :<|> leaveRoom' + :<|> replyMessage' + :<|> pushMessage' + :<|> multicastMessage' + :<|> getContent' = client (Proxy :: Proxy Endpoints) + +getProfile :: Id User -> Line Profile +getProfile a = ask >>= \token -> lift $ getProfile' (mkAuth token) a + +getGroupMemberProfile :: Id Group -> Id User -> Line Profile +getGroupMemberProfile a b = + ask >>= \token -> lift $ getGroupMemberProfile' (mkAuth token) a b + +leaveGroup :: Id Group -> Line NoContent +leaveGroup a = ask >>= \token -> lift $ leaveGroup' (mkAuth token) a + +getRoomMemberProfile :: Id Room -> Id User -> Line Profile +getRoomMemberProfile a b = + ask >>= \token -> lift $ getRoomMemberProfile' (mkAuth token) a b + +leaveRoom :: Id Room -> Line NoContent +leaveRoom a = ask >>= \token -> lift $ leaveRoom' (mkAuth token) a + +replyMessage :: ReplyToken -> [Message] -> Line NoContent +replyMessage a ms = ask >>= \token -> lift $ replyMessage' (mkAuth token) body + where body = ReplyMessageBody a ms + +pushMessage :: Id a -> [Message] -> Line NoContent +pushMessage a ms = ask >>= \token -> lift $ pushMessage' (mkAuth token) body + where body = PushMessageBody a ms + +multicastMessage :: [Id User] -> [Message] -> Line NoContent +multicastMessage a ms = ask + >>= \token -> lift $ multicastMessage' (mkAuth token) body + where body = MulticastMessageBody a ms diff --git a/src/Line/Bot/Endpoints.hs b/src/Line/Bot/Endpoints.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Endpoints.hs @@ -0,0 +1,85 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +module Line.Bot.Endpoints where + +import Data.ByteString.Lazy (ByteString) +import Line.Bot.Types +import Servant.API +import Servant.Client + +data ChannelAuth + +type GetProfile = AuthProtect ChannelAuth + :> "profile" + :> Capture "userId" (Id User) + :> Get '[JSON] Profile + +type GetGroupMemberProfile = AuthProtect ChannelAuth + :> "group" + :> Capture "groupId" (Id Group) + :> "member" + :> Capture "userId" (Id User) + :> Get '[JSON] Profile + +type LeaveGroup = AuthProtect ChannelAuth + :> "group" + :> Capture "groupId" (Id Group) + :> "leave" + :> PostNoContent '[JSON] NoContent + +type GetRoomMemberProfile = AuthProtect ChannelAuth + :> "room" + :> Capture "roomId" (Id Room) + :> "member" + :> Capture "userId" (Id User) + :> Get '[JSON] Profile + +type LeaveRoom = AuthProtect ChannelAuth + :> "room" + :> Capture "roomId" (Id Room) + :> "leave" + :> PostNoContent '[JSON] NoContent + +type ReplyMessage = AuthProtect ChannelAuth + :> ReqBody '[JSON] ReplyMessageBody + :> "message" + :> "reply" + :> PostNoContent '[JSON] NoContent + +type PushMessage = AuthProtect ChannelAuth + :> ReqBody '[JSON] PushMessageBody + :> "message" + :> "push" + :> PostNoContent '[JSON] NoContent + +type MulticastMessage = AuthProtect ChannelAuth + :> ReqBody '[JSON] MulticastMessageBody + :> "message" + :> "multicast" + :> PostNoContent '[JSON] NoContent + +type GetContent = AuthProtect ChannelAuth + :> "message" + :> Capture "messageId" String + :> "content" + :> Get '[OctetStream] ByteString + +type Endpoints = "v2" :> "bot" :> + ( GetProfile + :<|> GetGroupMemberProfile + :<|> LeaveGroup + :<|> GetRoomMemberProfile + :<|> LeaveRoom + :<|> ReplyMessage + :<|> PushMessage + :<|> MulticastMessage + :<|> GetContent + ) diff --git a/src/Line/Bot/Types.hs b/src/Line/Bot/Types.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Types.hs @@ -0,0 +1,223 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE KindSignatures #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE NamedFieldPuns #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Line.Bot.Types + ( ChatType(..) + , Id(..) + , URL(..) + , Message(..) + , ReplyToken(..) + , ReplyMessageBody(ReplyMessageBody) + , PushMessageBody(PushMessageBody) + , MulticastMessageBody(MulticastMessageBody) + , Profile(..) + , QuickReply(..) + , QuickReplyButton(..) + , Action(..) + ) +where + +import Data.Aeson +import Data.Aeson.Types +import Data.Char (toLower) +import Data.List as L (stripPrefix) +import Data.Maybe (fromJust) +import Data.String +import Data.Text as T hiding (drop, toLower) +import GHC.Generics hiding (to) +import Servant.API +import Text.Show + +data ChatType = User | Group | Room + +data Id :: ChatType -> * where + UserId :: Text -> Id User + GroupId :: Text -> Id Group + RoomId :: Text -> Id Room + +deriving instance Eq (Id a) +deriving instance Show (Id a) + +instance ToHttpApiData (Id a) where + toQueryParam = \case + UserId a -> a + GroupId a -> a + RoomId a -> a + +instance ToJSON (Id a) where + toJSON = String . toQueryParam + +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 Room) where + parseJSON = withText "Id Room" $ return . RoomId + +newtype URL = URL Text + deriving (Show, Eq, Generic) + +instance ToJSON URL +instance FromJSON URL + +data Message = + Text { text :: Text + , quickReply :: Maybe QuickReply + } + | Sticker { packageId :: Text + , stickerId :: Text + , quickReply :: Maybe QuickReply + } + | Image { originalContentUrl :: URL + , previewImageUrl :: URL + , quickReply :: Maybe QuickReply + } + | Video { originalContentUrl :: URL + , previewImageUrl :: URL + , quickReply :: Maybe QuickReply + } + | Audio { originalContentUrl :: URL + , duration :: Int + , quickReply :: Maybe QuickReply + } + | Location { title :: Text + , address :: Text + , latitude :: Double + , longitude :: Double + , quickReply :: Maybe QuickReply + } + deriving (Eq, Show, Generic) + +instance ToJSON Message where + toJSON = genericToJSON messageJSONOptions + +messageJSONOptions :: Options +messageJSONOptions = defaultOptions + { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = fmap toLower + , omitNothingFields = True + } + +data Profile = Profile + { displayName :: Text + , userId :: Id User + , pictureUrl :: URL + , statusMessage :: Maybe Text + } + deriving (Show, Generic) + +instance FromJSON Profile + +newtype ReplyToken = ReplyToken Text + deriving (Eq, Show, Generic) + +instance ToJSON ReplyToken +instance FromJSON ReplyToken + +data ReplyMessageBody = ReplyMessageBody + { replyToken :: ReplyToken + , messages :: [Message] + } + deriving (Show, Generic) + +instance ToJSON ReplyMessageBody + +data PushMessageBody = forall a. PushMessageBody + { to :: Id a + , messages :: [Message] + } + +deriving instance Show (PushMessageBody) + +instance ToJSON PushMessageBody where + toJSON (PushMessageBody {..}) = object + [ "to" .= to + , "messages" .= messages + ] + +data MulticastMessageBody = MulticastMessageBody + { to :: [Id User] + , messages :: [Message] + } + deriving (Show, Generic) + +instance ToJSON MulticastMessageBody + +data QuickReply = QuickReply + { items :: [QuickReplyButton] } + deriving (Eq, Show, Generic) + +instance ToJSON QuickReply + +data QuickReplyButton = + Action { imageUrl :: Maybe URL + , action :: Action + } + deriving (Eq, Show, Generic) + +quickReplyButtonJSONOptions :: Options +quickReplyButtonJSONOptions = defaultOptions + { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = fmap toLower + , omitNothingFields = True + , tagSingleConstructors = True + } + +instance ToJSON QuickReplyButton where + toJSON = genericToJSON quickReplyButtonJSONOptions + + +data Action = + ActionPostback { label :: Text + , postbackData :: Text + , displayText :: Text + } + | ActionMessage { label :: Text + , text :: Text + } + | ActionURI { label :: Text + , uri :: Text + } + | ActionCamera { label :: Text + } + | ActionCameraRoll { label :: Text + } + | ActionLocation { label :: Text + } + deriving (Eq, Show, Generic) + +instance ToJSON Action where + toJSON = genericToJSON actionJSONOptions + +actionJSONOptions :: Options +actionJSONOptions = defaultOptions + { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 6 + , omitNothingFields = True + , fieldLabelModifier = \orig -> + case L.stripPrefix "postback" orig of + Just s -> fmap toLower s + Nothing -> orig + } diff --git a/src/Line/Bot/Webhook.hs b/src/Line/Bot/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Webhook.hs @@ -0,0 +1,88 @@ +{-# LANGUAGE ConstraintKinds #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PolyKinds #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TupleSections #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + + +module Line.Bot.Webhook + ( module Line.Bot.Webhook.Types + , Webhook + , LineReqBody + ) + where + +import Control.Monad.IO.Class (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 +import Data.Maybe (fromMaybe) +import Data.Proxy +import Data.String.Conversions (cs) +import Data.Typeable (Typeable) +import Line.Bot.Webhook.Types +import Network.HTTP.Types (HeaderName, hContentType) +import Network.Wai (Request, lazyRequestBody, + requestHeaders) +import Servant +import Servant.API.ContentTypes +import Servant.Server.Internal + + +type Webhook = LineReqBody '[JSON] Events :> Post '[JSON] NoContent + +data LineReqBody (contentTypes :: [*]) (a :: *) + deriving (Typeable) + +instance (AllCTUnrender list a, HasServer api context, HasContextEntry context ChannelSecret) + => HasServer (LineReqBody list a :> api) context where + + type ServerT (LineReqBody list a :> api) m = a -> ServerT api m + + hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s + + route Proxy context subserver + = route (Proxy :: Proxy api) context $ + addBodyCheck subserver ctCheck bodyCheck + where + ctCheck = withRequest $ \request -> do + let contentTypeH = fromMaybe "application/octet-stream" + $ lookup hContentType $ requestHeaders request + case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of + Nothing -> delayedFail err415 + Just f -> return f + + bodyCheck f = withRequest $ \ request -> do + rawBody <- liftIO $ lazyRequestBody request + let signatureH = lookup hSignature $ requestHeaders request + + if validateReqBody signatureH rawBody + then case (f rawBody) of + Left e -> delayedFailFatal err400 { errBody = cs e } + Right v -> return v + else delayedFailFatal err401 + + channelSecret :: ChannelSecret + channelSecret = getContextEntry context + + hSignature :: HeaderName + hSignature = "X-Line-Signature" + + validateReqBody :: Maybe B.ByteString -> BL.ByteString -> Bool + validateReqBody digest body = maybe False f digest' + where + digest' = Base64.decodeLenient <$> digest + f = (== SHA256.hmaclazy (unChannelSecret channelSecret) body) + diff --git a/src/Line/Bot/Webhook/Types.hs b/src/Line/Bot/Webhook/Types.hs new file mode 100644 --- /dev/null +++ b/src/Line/Bot/Webhook/Types.hs @@ -0,0 +1,301 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE ExtendedDefaultRules #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE StandaloneDeriving #-} + +module Line.Bot.Webhook.Types + ( ChannelSecret(..) + , Events(..) + , Event(..) + , Message(..) + , EpochMilli(..) + , Source(..) + , Members(..) + , Postback(..) + , Beacon(..) + , BeaconEvent(..) + , Things(..) + , ThingsEvent(..) + , AccountLink(..) + , AccountLinkResult(..) + ) +where + +import Data.Aeson +import Data.Aeson.Types +import qualified Data.ByteString.Char8 as B +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, stripPrefix, toLower) +import Data.Time (LocalTime, 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) + + +newtype ChannelSecret = ChannelSecret + { unChannelSecret :: B.ByteString } + +instance IsString ChannelSecret where + fromString s = ChannelSecret (B.pack s) + +data Events = Events + { destination :: Id User + , events :: [Event] + } + deriving (Eq, Show, Generic) + +instance FromJSON Events + +data Event = + EventMessage { replyToken :: ReplyToken + , message :: Message + , source :: Source + , timestamp :: EpochMilli + } + | EventFollow { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + } + | EventUnfollow { source :: Source + , timestamp :: EpochMilli + } + | EventJoin { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + } + | EventLeave { source :: Source + , timestamp :: EpochMilli + } + | EventMemberJoined { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , joined :: Members + } + | EventMemberLeft { source :: Source + , timestamp :: EpochMilli + , left :: Members + } + | EventPostback { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , postback :: Postback + } + | EventBeacon { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , beacon :: Beacon + } + | EventAccountLink { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , link :: AccountLink + } + | EventThings { replyToken :: ReplyToken + , source :: Source + , timestamp :: EpochMilli + , things :: Things + } + deriving (Eq, Show, Generic) + +instance FromJSON Event where + parseJSON = genericParseJSON $ + defaultOptions { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 5 + } + +data Message = + Text { messageId :: Text + , text :: Text + } + | Image { messageId :: Text + , contentProvider :: ContentProvider + } + | Video { messageId :: Text + , duration :: Int + , contentProvider :: ContentProvider + } + | Audio { messageId :: Text + , duration :: Int + , contentProvider :: ContentProvider + } + | File { messageId :: Text + , fileSize :: Int + , fileName :: Text + } + | Location { messageId :: Text + , title :: Text + , address :: Text + , latitude :: Double + , longitude :: Double + } + | Sticker { messageId :: Text + , packageId :: Text + , stickerId :: Text + } + deriving (Eq, Show, Generic) + +messageJSONOptions :: Options +messageJSONOptions = defaultOptions + { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = fmap toLower + , fieldLabelModifier = \orig -> + case L.stripPrefix "message" orig of + Just s -> fmap toLower s + Nothing -> orig + , omitNothingFields = True + } + +instance FromJSON Message where + parseJSON = genericParseJSON messageJSONOptions + + +data ContentProvider = ContentProvider + { originalContentUrl :: Maybe URL + , previewImageUrl :: Maybe URL + } + deriving (Eq, Show, Generic) + +instance FromJSON ContentProvider + +newtype EpochMilli = EpochMilli { + fromEpochMilli :: UTCTime + -- ^ Acquire the underlying value. +} deriving (Eq, Ord, Read, Show, FormatTime) + +instance FromJSON EpochMilli where + parseJSON = withScientific "EpochMilli" $ \t -> + pure $ millis t + where + millis = EpochMilli + . posixSecondsToUTCTime + . fromRational + . toRational + . (/ 1000) + + +data Source = + SourceUser (Id User) + | SourceGroup (Id Group) (Maybe (Id User)) + | SourceRoom (Id Room) (Maybe (Id User)) + deriving (Eq, Show) + +instance FromJSON Source where + parseJSON = withObject "Source" $ \o -> do + messageType <- o .: "type" + case messageType of + "user" -> SourceUser <$> o .: "userId" + "group" -> SourceGroup <$> o .: "groupId" <*> o .:? "userId" + "room" -> SourceRoom <$> o .: "roomId" <*> o .:? "userId" + _ -> fail ("unknown source: " ++ messageType) + + +data Members = Members { members :: [Source] } + deriving (Eq, Show, Generic) + +instance FromJSON Members + +data PostbackDateTime = + PostbackDay Day + | PostbackLocalTime LocalTime + | PostbackTimeOfDay TimeOfDay + deriving (Eq, Show) + +instance FromJSON PostbackDateTime where + parseJSON = withObject "PostbackDateTime" $ \o -> do + dateTime <- asum + [ PostbackDay <$> o .: "date" + , PostbackLocalTime <$> o .: "datetime" + , PostbackTimeOfDay <$> o .: "time" + ] + return dateTime + +data Postback = Postback Text PostbackDateTime + deriving (Eq, Show) + +instance FromJSON Postback where + parseJSON = withObject "Postback" $ \o -> do + postbackData <- o .: "data" + params <- o .: "params" + return $ Postback postbackData params + +data BeaconEvent = Enter | Leave | Banner + deriving (Show, Read, Eq, Ord, Generic) + +instance FromJSON BeaconEvent where + parseJSON = genericParseJSON $ + defaultOptions { constructorTagModifier = fmap toLower + , allNullaryToStringTag = True + } + +data Beacon = Beacon + { hwid :: Text + , eventType :: BeaconEvent + , dm :: Maybe Text + } + deriving (Eq, Show, Generic) + +instance FromJSON Beacon where + parseJSON = withObject "Beacon" $ \o -> do + hwid <- o .: "hwid" + eventType <- o .: "type" + dm <- o .:? "dm" + return $ Beacon{..} + +data AccountLinkResult = Ok | Failed + deriving (Eq, Show, Generic) + +instance FromJSON AccountLinkResult where + parseJSON = genericParseJSON $ + defaultOptions { constructorTagModifier = fmap toLower + , allNullaryToStringTag = True + } + +data AccountLink = AccountLink + { nonce :: Text + , result :: AccountLinkResult + } + deriving (Eq, Show, Generic) + +instance FromJSON AccountLink + +data ThingsEvent = Link | Unlink + deriving (Show, Read, Eq, Ord, Generic) + +instance FromJSON ThingsEvent where + parseJSON = genericParseJSON $ + defaultOptions { constructorTagModifier = fmap toLower + , allNullaryToStringTag = True + } + +data Things = Things + { deviceId :: Text + , eventType :: ThingsEvent + } + deriving (Eq, Show, Generic) + +instance FromJSON Things where + parseJSON = withObject "Things" $ \o -> do + deviceId <- o .: "deviceId" + eventType <- o .: "type" + return $ Things{..} diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,20 @@ +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE OverloadedStrings #-} +module Main (main) where + +import Lib (app) +import Test.Hspec +import Test.Hspec.Wai +import Test.Hspec.Wai.JSON + +main :: IO () +main = hspec spec + +spec :: Spec +spec = with (return app) $ do + describe "GET /users" $ do + it "responds with 200" $ do + get "/users" `shouldRespondWith` 200 + it "responds with [User]" $ do + let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]" + get "/users" `shouldRespondWith` users