line-bot-sdk (empty) → 0.1.0.0
raw patch · 11 files changed
+1032/−0 lines, 11 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, bytestring, cryptohash-sha256, errors, hspec, hspec-wai, hspec-wai-json, http-client, http-client-tls, http-types, line-bot-sdk, scientific, servant, servant-client, servant-client-core, servant-server, string-conversions, text, time, transformers, wai, wai-extra, warp
Files
- LICENSE +30/−0
- README.md +1/−0
- Setup.hs +2/−0
- examples/Echo.hs +53/−0
- line-bot-sdk.cabal +92/−0
- src/Line/Bot/Client.hs +137/−0
- src/Line/Bot/Endpoints.hs +85/−0
- src/Line/Bot/Types.hs +223/−0
- src/Line/Bot/Webhook.hs +88/−0
- src/Line/Bot/Webhook/Types.hs +301/−0
- test/Spec.hs +20/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -0,0 +1,1 @@+# line-bot-sdk
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ examples/Echo.hs view
@@ -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
+ line-bot-sdk.cabal view
@@ -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 <alexmorenocano@gmail.com>+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 <https://developers.line.biz/en/docs/messaging-api/ LINE Messaging API>,+ 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
+ src/Line/Bot/Client.hs view
@@ -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
+ src/Line/Bot/Endpoints.hs view
@@ -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+ )
+ src/Line/Bot/Types.hs view
@@ -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+ }
+ src/Line/Bot/Webhook.hs view
@@ -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)+
+ src/Line/Bot/Webhook/Types.hs view
@@ -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{..}
+ test/Spec.hs view
@@ -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