├── .github └── workflows │ └── haskell.yml ├── .gitignore ├── .hlint.yaml ├── .stylish-haskell.yaml ├── CODE_OF_CONDUCT.md ├── LICENSE ├── README.md ├── Setup.hs ├── examples ├── Echo.hs └── examples.cabal ├── line-bot-sdk.cabal ├── src └── Line │ └── Bot │ ├── Client.hs │ ├── Internal │ └── Endpoints.hs │ ├── Types.hs │ ├── Webhook.hs │ └── Webhook │ └── Events.hs ├── stack.yaml └── test ├── Line └── Bot │ ├── ClientSpec.hs │ └── WebhookSpec.hs └── Spec.hs /.github/workflows/haskell.yml: -------------------------------------------------------------------------------- 1 | name: build 2 | 3 | on: 4 | push: 5 | branches: [ master ] 6 | pull_request: 7 | branches: [ master ] 8 | 9 | jobs: 10 | build: 11 | 12 | runs-on: ubuntu-latest 13 | 14 | steps: 15 | - uses: actions/checkout@v2 16 | - uses: haskell/actions/setup@v1 17 | with: 18 | ghc-version: '8.10.3' 19 | cabal-version: '3.4.0.0' 20 | 21 | - name: Cache 22 | uses: actions/cache@v1 23 | env: 24 | cache-name: cache-cabal 25 | with: 26 | path: ~/.cabal 27 | key: ${{ runner.os }}-build-${{ env.cache-name }}-${{ hashFiles('**/*.cabal') }}-${{ hashFiles('**/cabal.project') }} 28 | restore-keys: | 29 | ${{ runner.os }}-build-${{ env.cache-name }}- 30 | ${{ runner.os }}-build- 31 | ${{ runner.os }}- 32 | - name: Install dependencies 33 | run: | 34 | cabal update 35 | cabal build --only-dependencies --enable-tests --enable-benchmarks 36 | - name: Build 37 | run: cabal build --enable-tests --enable-benchmarks all 38 | - name: Run tests 39 | run: cabal test all 40 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | dist 2 | dist-* 3 | cabal-dev 4 | *.o 5 | *.hi 6 | *.chi 7 | *.chs.h 8 | *.dyn_o 9 | *.dyn_hi 10 | .hpc 11 | .hsenv 12 | .cabal-sandbox/ 13 | cabal.sandbox.config 14 | *.prof 15 | *.aux 16 | *.hp 17 | *.eventlog 18 | .stack-work/ 19 | cabal.project.local 20 | cabal.project.local~ 21 | .HTF/ 22 | .ghc.environment.* 23 | -------------------------------------------------------------------------------- /.hlint.yaml: -------------------------------------------------------------------------------- 1 | # HLint configuration file 2 | # https://github.com/ndmitchell/hlint 3 | ########################## 4 | 5 | # This file contains a template configuration file, which is typically 6 | # placed as .hlint.yaml in the root of your project 7 | 8 | 9 | # Specify additional command line arguments 10 | # 11 | # - arguments: [--color, --cpp-simple, -XQuasiQuotes] 12 | 13 | 14 | # Control which extensions/flags/modules/functions can be used 15 | # 16 | # - extensions: 17 | # - default: false # all extension are banned by default 18 | # - name: [PatternGuards, ViewPatterns] # only these listed extensions can be used 19 | # - {name: CPP, within: CrossPlatform} # CPP can only be used in a given module 20 | # 21 | # - flags: 22 | # - {name: -w, within: []} # -w is allowed nowhere 23 | # 24 | # - modules: 25 | # - {name: [Data.Set, Data.HashSet], as: Set} # if you import Data.Set qualified, it must be as 'Set' 26 | # - {name: Control.Arrow, within: []} # Certain modules are banned entirely 27 | # 28 | # - functions: 29 | # - {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules 30 | 31 | 32 | # Add custom hints for this project 33 | # 34 | # Will suggest replacing "wibbleMany [myvar]" with "wibbleOne myvar" 35 | # - error: {lhs: "wibbleMany [x]", rhs: wibbleOne x} 36 | 37 | 38 | # Turn on hints that are off by default 39 | # 40 | # Ban "module X(module X) where", to require a real export list 41 | # - warn: {name: Use explicit module export list} 42 | # 43 | # Replace a $ b $ c with a . b $ c 44 | # - group: {name: dollar, enabled: true} 45 | # 46 | # Generalise map to fmap, ++ to <> 47 | # - group: {name: generalise, enabled: true} 48 | 49 | 50 | # Ignore some builtin hints 51 | # - ignore: {name: Use let} 52 | # - ignore: {name: Use const, within: SpecialModule} # Only within certain modules 53 | 54 | 55 | # Define some custom infix operators 56 | # - fixity: infixr 3 ~^#^~ 57 | 58 | 59 | # To generate a suitable file for HLint do: 60 | # $ hlint --default > .hlint.yaml 61 | -------------------------------------------------------------------------------- /.stylish-haskell.yaml: -------------------------------------------------------------------------------- 1 | # stylish-haskell configuration file 2 | # ================================== 3 | 4 | # The stylish-haskell tool is mainly configured by specifying steps. These steps 5 | # are a list, so they have an order, and one specific step may appear more than 6 | # once (if needed). Each file is processed by these steps in the given order. 7 | steps: 8 | # Convert some ASCII sequences to their Unicode equivalents. This is disabled 9 | # by default. 10 | # - unicode_syntax: 11 | # # In order to make this work, we also need to insert the UnicodeSyntax 12 | # # language pragma. If this flag is set to true, we insert it when it's 13 | # # not already present. You may want to disable it if you configure 14 | # # language extensions using some other method than pragmas. Default: 15 | # # true. 16 | # add_language_pragma: true 17 | 18 | # Align the right hand side of some elements. This is quite conservative 19 | # and only applies to statements where each element occupies a single 20 | # line. 21 | - simple_align: 22 | cases: true 23 | top_level_patterns: true 24 | records: true 25 | 26 | # Import cleanup 27 | - imports: 28 | # There are different ways we can align names and lists. 29 | # 30 | # - global: Align the import names and import list throughout the entire 31 | # file. 32 | # 33 | # - file: Like global, but don't add padding when there are no qualified 34 | # imports in the file. 35 | # 36 | # - group: Only align the imports per group (a group is formed by adjacent 37 | # import lines). 38 | # 39 | # - none: Do not perform any alignment. 40 | # 41 | # Default: global. 42 | align: global 43 | 44 | # The following options affect only import list alignment. 45 | # 46 | # List align has following options: 47 | # 48 | # - after_alias: Import list is aligned with end of import including 49 | # 'as' and 'hiding' keywords. 50 | # 51 | # > import qualified Data.List as List (concat, foldl, foldr, head, 52 | # > init, last, length) 53 | # 54 | # - with_alias: Import list is aligned with start of alias or hiding. 55 | # 56 | # > import qualified Data.List as List (concat, foldl, foldr, head, 57 | # > init, last, length) 58 | # 59 | # - new_line: Import list starts always on new line. 60 | # 61 | # > import qualified Data.List as List 62 | # > (concat, foldl, foldr, head, init, last, length) 63 | # 64 | # Default: after_alias 65 | list_align: after_alias 66 | 67 | # Right-pad the module names to align imports in a group: 68 | # 69 | # - true: a little more readable 70 | # 71 | # > import qualified Data.List as List (concat, foldl, foldr, 72 | # > init, last, length) 73 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 74 | # > init, last, length) 75 | # 76 | # - false: diff-safe 77 | # 78 | # > import qualified Data.List as List (concat, foldl, foldr, init, 79 | # > last, length) 80 | # > import qualified Data.List.Extra as List (concat, foldl, foldr, 81 | # > init, last, length) 82 | # 83 | # Default: true 84 | pad_module_names: true 85 | 86 | # Long list align style takes effect when import is too long. This is 87 | # determined by 'columns' setting. 88 | # 89 | # - inline: This option will put as much specs on same line as possible. 90 | # 91 | # - new_line: Import list will start on new line. 92 | # 93 | # - new_line_multiline: Import list will start on new line when it's 94 | # short enough to fit to single line. Otherwise it'll be multiline. 95 | # 96 | # - multiline: One line per import list entry. 97 | # Type with constructor list acts like single import. 98 | # 99 | # > import qualified Data.Map as M 100 | # > ( empty 101 | # > , singleton 102 | # > , ... 103 | # > , delete 104 | # > ) 105 | # 106 | # Default: inline 107 | long_list_align: inline 108 | 109 | # Align empty list (importing instances) 110 | # 111 | # Empty list align has following options 112 | # 113 | # - inherit: inherit list_align setting 114 | # 115 | # - right_after: () is right after the module name: 116 | # 117 | # > import Vector.Instances () 118 | # 119 | # Default: inherit 120 | empty_list_align: inherit 121 | 122 | # List padding determines indentation of import list on lines after import. 123 | # This option affects 'long_list_align'. 124 | # 125 | # - : constant value 126 | # 127 | # - module_name: align under start of module name. 128 | # Useful for 'file' and 'group' align settings. 129 | list_padding: 4 130 | 131 | # Separate lists option affects formatting of import list for type 132 | # or class. The only difference is single space between type and list 133 | # of constructors, selectors and class functions. 134 | # 135 | # - true: There is single space between Foldable type and list of it's 136 | # functions. 137 | # 138 | # > import Data.Foldable (Foldable (fold, foldl, foldMap)) 139 | # 140 | # - false: There is no space between Foldable type and list of it's 141 | # functions. 142 | # 143 | # > import Data.Foldable (Foldable(fold, foldl, foldMap)) 144 | # 145 | # Default: true 146 | separate_lists: true 147 | 148 | # Space surround option affects formatting of import lists on a single 149 | # line. The only difference is single space after the initial 150 | # parenthesis and a single space before the terminal parenthesis. 151 | # 152 | # - true: There is single space associated with the enclosing 153 | # parenthesis. 154 | # 155 | # > import Data.Foo ( foo ) 156 | # 157 | # - false: There is no space associated with the enclosing parenthesis 158 | # 159 | # > import Data.Foo (foo) 160 | # 161 | # Default: false 162 | space_surround: false 163 | 164 | # Language pragmas 165 | - language_pragmas: 166 | # We can generate different styles of language pragma lists. 167 | # 168 | # - vertical: Vertical-spaced language pragmas, one per line. 169 | # 170 | # - compact: A more compact style. 171 | # 172 | # - compact_line: Similar to compact, but wrap each line with 173 | # `{-#LANGUAGE #-}'. 174 | # 175 | # Default: vertical. 176 | style: vertical 177 | 178 | # Align affects alignment of closing pragma brackets. 179 | # 180 | # - true: Brackets are aligned in same column. 181 | # 182 | # - false: Brackets are not aligned together. There is only one space 183 | # between actual import and closing bracket. 184 | # 185 | # Default: true 186 | align: true 187 | 188 | # stylish-haskell can detect redundancy of some language pragmas. If this 189 | # is set to true, it will remove those redundant pragmas. Default: true. 190 | remove_redundant: true 191 | 192 | # Replace tabs by spaces. This is disabled by default. 193 | # - tabs: 194 | # # Number of spaces to use for each tab. Default: 8, as specified by the 195 | # # Haskell report. 196 | # spaces: 8 197 | 198 | # Remove trailing whitespace 199 | - trailing_whitespace: {} 200 | 201 | # Squash multiple spaces between the left and right hand sides of some 202 | # elements into single spaces. Basically, this undoes the effect of 203 | # simple_align but is a bit less conservative. 204 | # - squash: {} 205 | 206 | # A common setting is the number of columns (parts of) code will be wrapped 207 | # to. Different steps take this into account. Default: 80. 208 | columns: 80 209 | 210 | # By default, line endings are converted according to the OS. You can override 211 | # preferred format here. 212 | # 213 | # - native: Native newline format. CRLF on Windows, LF on other OSes. 214 | # 215 | # - lf: Convert to LF ("\n"). 216 | # 217 | # - crlf: Convert to CRLF ("\r\n"). 218 | # 219 | # Default: native. 220 | newline: native 221 | 222 | # Sometimes, language extensions are specified in a cabal file or from the 223 | # command line instead of using language pragmas in the file. stylish-haskell 224 | # needs to be aware of these, so it can parse the file correctly. 225 | # 226 | # No language extensions are enabled by default. 227 | # language_extensions: 228 | # - TemplateHaskell 229 | # - QuasiQuotes 230 | -------------------------------------------------------------------------------- /CODE_OF_CONDUCT.md: -------------------------------------------------------------------------------- 1 | Contributor Code of Conduct 2 | =========================== 3 | 4 | As contributors and maintainers of this project, we pledge to respect all 5 | people who contribute through reporting issues, posting feature requests, 6 | updating documentation, submitting pull requests or patches, and other 7 | activities. 8 | 9 | We are committed to making participation in this project a harassment-free 10 | experience for everyone, regardless of level of experience, gender, gender 11 | identity and expression, sexual orientation, disability, personal appearance, 12 | body size, race, ethnicity, age, or religion. 13 | 14 | Examples of unacceptable behavior by participants include the use of sexual 15 | language or imagery, derogatory comments or personal attacks, trolling, public 16 | or private harassment, insults, or other unprofessional conduct. 17 | 18 | Project maintainers have the right and responsibility to remove, edit, or 19 | reject comments, commits, code, wiki edits, issues, and other contributions 20 | that are not aligned to this Code of Conduct. Project maintainers who do not 21 | follow the Code of Conduct may be removed from the project team. 22 | 23 | This code of conduct applies both within project spaces and in public spaces 24 | when an individual is representing the project or its community. 25 | 26 | Instances of abusive, harassing, or otherwise unacceptable behavior may be 27 | reported by opening an issue or contacting one or more of the project 28 | maintainers. 29 | 30 | This Code of Conduct is adapted from the [Contributor 31 | Covenant](https://contributor-covenant.org/), version 1.1.0, available at 32 | [https://contributor-covenant.org/version/1/1/0/](https://contributor-covenant.org/version/1/1/0/) 33 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright Alexandre Moreno (c) 2019-2021 2 | 3 | All rights reserved. 4 | 5 | Redistribution and use in source and binary forms, with or without 6 | modification, are permitted provided that the following conditions are met: 7 | 8 | * Redistributions of source code must retain the above copyright 9 | notice, this list of conditions and the following disclaimer. 10 | 11 | * Redistributions in binary form must reproduce the above 12 | copyright notice, this list of conditions and the following 13 | disclaimer in the documentation and/or other materials provided 14 | with the distribution. 15 | 16 | * Neither the name of Author name here nor the names of other 17 | contributors may be used to endorse or promote products derived 18 | from this software without specific prior written permission. 19 | 20 | THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS 21 | "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT 22 | LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR 23 | A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT 24 | OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, 25 | SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT 26 | LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, 27 | DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY 28 | THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT 29 | (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE 30 | OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. 31 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # line-bot-sdk [![Build Actions](https://github.com/moleike/line-bot-sdk/workflows/build/badge.svg)](https://github.com/moleike/line-bot-sdk/actions) 2 | 3 | 4 | Servant library for building LINE chatbots. 5 | 6 | Features: 7 | 8 | * 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 9 | 10 | * Bindings for (most of) the Messaging APIs 11 | 12 | ## Installation 13 | 14 | ### From Hackage 15 | 16 | `line-bot-sdk` is available on [Hackage](https://hackage.haskell.org). Using the [`cabal-install`][cabal] tool: 17 | 18 | ```bash 19 | cabal update 20 | cabal install line-bot-sdk 21 | ``` 22 | 23 | ### From source 24 | 25 | Building from source can be done using [stack][stack] or [cabal][cabal]: 26 | 27 | ```bash 28 | git clone github.com/moleike/line-bot-sdk.git 29 | cd line-bot-sdk 30 | stack install # Alternatively, `cabal install` 31 | ``` 32 | 33 | [cabal]: https://www.haskell.org/cabal 34 | [stack]: https://docs.haskellstack.org/en/stable/README 35 | 36 | ## Documentation 37 | 38 | See the official API documentation for more information. 39 | 40 | - English: https://developers.line.biz/en/docs/messaging-api/overview/ 41 | - Japanese: https://developers.line.biz/ja/docs/messaging-api/overview/ 42 | 43 | ## Usage 44 | 45 | ```haskell 46 | {-# LANGUAGE DataKinds #-} 47 | {-# LANGUAGE OverloadedStrings #-} 48 | 49 | import Data.String (fromString) 50 | import Line.Bot.Client 51 | import Line.Bot.Types 52 | import System.Environment (getEnv) 53 | 54 | getProfiles :: Id Room -> Line [Profile] 55 | getProfiles roomId = do 56 | userIds <- getRoomMemberUserIds roomId 57 | sequence $ getRoomMemberProfile roomId <$> userIds 58 | 59 | main = do 60 | token <- fromString <$> getEnv "CHANNEL_TOKEN" 61 | result <- runLine (getProfiles "U4af4980629...") token 62 | case result of 63 | Left err -> print err 64 | Right profile -> print profile 65 | ``` 66 | 67 | See the 68 | [examples/](https://github.com/moleike/line-bot-sdk/tree/master/examples) directory for more comprehensive examples. 69 | 70 | ## Contribute 71 | 72 | Please report bugs via the 73 | [github issue tracker](https://github.com/moleike/line-bot-sdk/issues). 74 | 75 | ## Acknowledgments 76 | 77 | Thanks to the authors of [servant-github](https://hackage.haskell.org/package/servant-github), for inspiration. 78 | 79 | ## License 80 | 81 | See [LICENSE][license]. 82 | 83 | Copyright © 2019–present Alexandre Moreno 84 | 85 | [license]: https://github.com/moleike/line-bot-sdk/blob/master/LICENSE 86 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /examples/Echo.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DisambiguateRecordFields #-} 3 | {-# LANGUAGE NamedFieldPuns #-} 4 | {-# LANGUAGE OverloadedStrings #-} 5 | {-# LANGUAGE TypeOperators #-} 6 | 7 | module Main (main) where 8 | 9 | import Control.Monad (forM_) 10 | import Control.Monad.IO.Class (liftIO) 11 | import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) 12 | import Data.Maybe (fromMaybe) 13 | import Data.String (fromString) 14 | import Line.Bot.Client (Line, replyMessage, 15 | runLine) 16 | import Line.Bot.Types as B 17 | import Line.Bot.Webhook as W 18 | import Network.Wai.Handler.Warp (run) 19 | import Network.Wai.Middleware.RequestLogger (logStdout) 20 | import Servant 21 | import Servant.Server (Context ((:.), EmptyContext)) 22 | import System.Environment (getEnv, lookupEnv) 23 | 24 | type WebM = ReaderT ChannelToken Handler 25 | 26 | type API = "webhook" :> Webhook 27 | 28 | echo :: Event -> Line NoContent 29 | echo EventMessage { message = W.MessageText { text }, replyToken } = 30 | replyMessage replyToken [B.MessageText text Nothing] 31 | echo _ = return NoContent 32 | 33 | handleEvents :: [Event] -> WebM NoContent 34 | handleEvents events = do 35 | token <- ask 36 | _ <- liftIO $ forM_ events $ flip runLine token . echo 37 | return NoContent 38 | 39 | echoServer :: ServerT API WebM 40 | echoServer = handleEvents . events 41 | 42 | app :: ChannelToken -> ChannelSecret -> Application 43 | app token secret = serveWithContext api context server 44 | where 45 | api = Proxy :: Proxy API 46 | pc = Proxy :: Proxy '[ChannelSecret] 47 | server = hoistServerWithContext api pc (`runReaderT` token) echoServer 48 | context = secret :. EmptyContext 49 | 50 | main :: IO () 51 | main = do 52 | token <- fromString <$> getEnv "CHANNEL_TOKEN" 53 | secret <- fromString <$> getEnv "CHANNEL_SECRET" 54 | port <- fmap read <$> lookupEnv "PORT" 55 | run (fromMaybe 8000 port) $ logStdout $ app token secret 56 | -------------------------------------------------------------------------------- /examples/examples.cabal: -------------------------------------------------------------------------------- 1 | name: examples 2 | version: 0.1 3 | cabal-version: >=1.18 4 | build-type: Simple 5 | description: minimal examples 6 | 7 | executable echo-server 8 | hs-source-dirs: . 9 | main-is: Echo.hs 10 | default-language: Haskell2010 11 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 12 | build-depends: 13 | line-bot-sdk, 14 | base, 15 | servant-server, 16 | transformers, 17 | wai-extra, 18 | warp 19 | 20 | default-language: Haskell2010 21 | -------------------------------------------------------------------------------- /line-bot-sdk.cabal: -------------------------------------------------------------------------------- 1 | name: line-bot-sdk 2 | version: 0.7.2 3 | synopsis: Haskell SDK for LINE Messaging API 4 | homepage: https://github.com/moleike/line-bot-sdk#readme 5 | bug-reports: https://github.com/moleike/line-bot-sdk/issues 6 | license: BSD3 7 | x-license: BSD-3-Clause 8 | license-file: LICENSE 9 | author: Alexandre Moreno 10 | maintainer: Alexandre Moreno 11 | copyright: (c) Alexandre Moreno, 2019-2021 12 | category: Network, Web 13 | build-type: Simple 14 | extra-doc-files: README.md 15 | cabal-version: >=1.18 16 | description: 17 | A Servant library for building LINE chatbots. This package is composed 18 | of the following modules: 19 | . 20 | * A client library for the , 21 | including the 'Line' monad, which manages the channel credentials. 22 | . 23 | * A servant combinator to write safe Line webhooks. 24 | . 25 | To get started, see the documentation for the @Line.Bot.Client@ 26 | and @Line.Bot.Webhook@ modules below. 27 | 28 | library 29 | hs-source-dirs: src 30 | exposed-modules: Line.Bot.Webhook 31 | , Line.Bot.Webhook.Events 32 | , Line.Bot.Client 33 | , Line.Bot.Types 34 | , Line.Bot.Internal.Endpoints 35 | 36 | other-modules: Paths_line_bot_sdk 37 | autogen-modules: Paths_line_bot_sdk 38 | 39 | build-depends: 40 | aeson >= 1.5.6 && < 1.6, 41 | base >= 4.14.1 && < 4.15, 42 | bytestring >= 0.10.12 && < 0.11, 43 | deepseq >= 1.4.4 && < 1.5, 44 | text >= 1.2.4 && < 1.3, 45 | time >= 1.9.3 && < 1.10, 46 | mtl >= 2.2.2 && < 2.3, 47 | base64-bytestring >= 1.1.0 && < 1.2, 48 | cryptohash-sha256 >= 0.11.102 && < 0.12, 49 | http-api-data >= 0.4.1.1 && < 0.5, 50 | http-types >= 0.12.3 && < 0.13, 51 | http-client >= 0.6.4 && < 0.7, 52 | http-client-tls >= 0.3.5 && < 0.4, 53 | http-media >= 0.8.0 && < 0.9, 54 | servant >= 0.18.2 && < 0.19, 55 | string-conversions >= 0.4.0 && < 0.5, 56 | servant-client >= 0.18.2 && < 0.19, 57 | servant-client-core >= 0.18.2 && < 0.19, 58 | servant-server >= 0.18.2 && < 0.19, 59 | wai >= 3.2.3 && < 3.3 60 | 61 | default-language: Haskell2010 62 | 63 | test-suite line-bot-sdk-test 64 | type: exitcode-stdio-1.0 65 | hs-source-dirs: test 66 | other-modules: Line.Bot.WebhookSpec 67 | , Line.Bot.ClientSpec 68 | main-is: Spec.hs 69 | build-depends: 70 | base, 71 | line-bot-sdk, 72 | base64-bytestring, 73 | cryptohash-sha256, 74 | text, 75 | bytestring, 76 | hspec, 77 | hspec-wai, 78 | hspec-expectations, 79 | http-types, 80 | http-client, 81 | http-client-tls, 82 | aeson, 83 | transformers, 84 | aeson-qq, 85 | servant, 86 | servant-server, 87 | servant-client, 88 | servant-client-core, 89 | wai, 90 | warp, 91 | free, 92 | time , 93 | deepseq 94 | ghc-options: -threaded -rtsopts -with-rtsopts=-N 95 | default-language: Haskell2010 96 | build-tool-depends: hspec-discover:hspec-discover 97 | 98 | 99 | source-repository head 100 | type: git 101 | location: https://github.com/moleike/line-bot-sdk 102 | -------------------------------------------------------------------------------- /src/Line/Bot/Client.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE NamedFieldPuns #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE RecordWildCards #-} 8 | {-# LANGUAGE ScopedTypeVariables #-} 9 | {-# LANGUAGE TypeApplications #-} 10 | {-# LANGUAGE TypeFamilies #-} 11 | {-# LANGUAGE TypeOperators #-} 12 | 13 | -- | 14 | -- Module : Line.Bot.Client 15 | -- Copyright : (c) Alexandre Moreno, 2019-2021 16 | -- License : BSD-3-Clause 17 | -- Maintainer : alexmorenocano@gmail.com 18 | -- Stability : experimental 19 | 20 | module Line.Bot.Client 21 | ( Line 22 | , runLine 23 | , withLine 24 | , withLineEnv 25 | -- ** Profile 26 | , getProfile 27 | -- ** Group 28 | , getGroupMemberProfile 29 | , leaveGroup 30 | , getGroupMemberUserIds 31 | -- ** Room 32 | , getRoomMemberProfile 33 | , leaveRoom 34 | , getRoomMemberUserIds 35 | -- ** Message 36 | , replyMessage 37 | , pushMessage 38 | , multicastMessage 39 | , broadcastMessage 40 | , getContent 41 | , getContentS 42 | , getPushMessageCount 43 | , getReplyMessageCount 44 | , getMulticastMessageCount 45 | , getBroadcastMessageCount 46 | , getMessageQuota 47 | -- ** Account Link 48 | , issueLinkToken 49 | -- ** OAuth 50 | , issueChannelToken 51 | , revokeChannelToken 52 | -- ** Rich menus 53 | , createRichMenu 54 | , deleteRichMenu 55 | , getRichMenu 56 | , uploadRichMenuImageJpg 57 | , getRichMenuList 58 | , setDefaultRichMenu 59 | ) 60 | where 61 | 62 | import Control.DeepSeq (NFData) 63 | import Control.Monad.Reader 64 | import Data.ByteString (ByteString) 65 | import qualified Data.ByteString.Lazy as LB 66 | import Data.Functor 67 | import Data.Proxy 68 | import Data.Time.Calendar (Day) 69 | import Data.Text (Text, pack) 70 | import GHC.TypeLits (Symbol) 71 | import Line.Bot.Internal.Endpoints 72 | import Line.Bot.Types 73 | import Network.HTTP.Client (newManager) 74 | import Network.HTTP.Client.TLS (tlsManagerSettings) 75 | import Servant.API 76 | import Servant.Client.Streaming 77 | import Paths_line_bot_sdk (version) 78 | import Data.Version (showVersion) 79 | 80 | defaultEndpoint :: BaseUrl 81 | defaultEndpoint = BaseUrl Https "api.line.me" 443 "" 82 | 83 | blobEndpoint :: BaseUrl 84 | blobEndpoint = BaseUrl Https "api-data.line.me" 443 "" 85 | 86 | userAgent :: Text 87 | userAgent = "line-bot-sdk-haskell/" <> pack (showVersion version) 88 | 89 | -- | @Line@ is the monad in which bot requests run. Contains the 90 | -- OAuth access token for a channel 91 | type Line = ReaderT ChannelToken ClientM 92 | 93 | -- | Perform a request using LINE 'ClientEnv' 94 | -- 95 | -- > withLineEnv $ \env -> runClientM comp env 96 | withLineEnv :: (ClientEnv -> IO a) -> IO a 97 | withLineEnv app = do 98 | manager <- newManager tlsManagerSettings 99 | app $ mkClientEnv manager defaultEndpoint 100 | 101 | runLine' :: NFData a => ClientM a -> IO (Either ClientError a) 102 | runLine' comp = withLineEnv $ \env -> runClientM comp env 103 | 104 | -- | Executes a request in the LINE plaform with the given 'ChannelToken' 105 | runLine :: NFData a => Line a -> ChannelToken -> IO (Either ClientError a) 106 | runLine comp = runLine' . runReaderT comp 107 | 108 | withLine' :: ClientM a -> (Either ClientError a -> IO b) -> IO b 109 | withLine' comp k = withLineEnv $ \env -> withClientM comp env k 110 | 111 | -- | Execute a request with a streaming response in the LINE platform 112 | withLine :: Line a -> ChannelToken -> (Either ClientError a -> IO b) -> IO b 113 | withLine comp = withLine' . runReaderT comp 114 | 115 | withHost :: BaseUrl -> Line a -> Line a 116 | withHost baseUrl = mapReaderT $ local (\env -> env { baseUrl = baseUrl }) 117 | 118 | type family AddHeaders a :: * where 119 | AddHeaders ((sym :: Symbol) :> last) 120 | = (sym :: Symbol) :> AddHeaders last 121 | AddHeaders (first :> last) 122 | = first :> AddHeaders last 123 | AddHeaders last 124 | = Header' '[Required, Strict] "Authorization" ChannelToken 125 | :> Header' '[Required, Strict] "User-Agent" Text 126 | :> last 127 | 128 | type ClientWithHeaders a = ChannelToken -> Text -> ClientM a 129 | 130 | type family EmbedLine a :: * where 131 | EmbedLine (ClientWithHeaders a) = Line a 132 | EmbedLine (a -> b) = a -> EmbedLine b 133 | 134 | class HasLine a where 135 | embedLine :: a -> EmbedLine a 136 | 137 | instance HasLine (ClientWithHeaders a) where 138 | embedLine comp = do 139 | token <- ask 140 | lift $ comp token userAgent 141 | 142 | instance HasLine (a -> ClientWithHeaders b) where 143 | embedLine comp = embedLine . comp 144 | 145 | instance HasLine (a -> b -> ClientWithHeaders c) where 146 | embedLine comp = embedLine . comp 147 | 148 | line :: (HasLine (Client ClientM (AddHeaders api)), HasClient ClientM (AddHeaders api)) 149 | => Proxy api 150 | -> EmbedLine (Client ClientM (AddHeaders api)) 151 | line = embedLine . clientWithHeaders 152 | 153 | clientWithHeaders :: (HasClient ClientM (AddHeaders api)) 154 | => Proxy api 155 | -> Client ClientM (AddHeaders api) 156 | clientWithHeaders (Proxy :: Proxy api) = client (Proxy :: Proxy (AddHeaders api)) 157 | 158 | unfoldMemberUserIds :: (Maybe String -> Line MemberIds) -> Line [Id 'User] 159 | unfoldMemberUserIds k = go Nothing where 160 | go tok = do 161 | MemberIds{next, memberIds = a} <- k tok 162 | as <- maybe (return []) (\_ -> go next) next 163 | return $ a ++ as 164 | 165 | getProfile :: Id 'User -> Line Profile 166 | getProfile = line (Proxy @GetProfile) 167 | 168 | getGroupMemberProfile :: Id 'Group -> Id 'User -> Line Profile 169 | getGroupMemberProfile = line (Proxy @GetGroupMemberProfile) 170 | 171 | leaveGroup :: Id 'Group -> Line NoContent 172 | leaveGroup = line (Proxy @LeaveGroup) 173 | 174 | getGroupMemberUserIds' :: Id 'Group -> Maybe String -> Line MemberIds 175 | getGroupMemberUserIds' = line (Proxy @GetGroupMemberUserIds) 176 | 177 | getGroupMemberUserIds :: Id 'Group -> Line [Id 'User] 178 | getGroupMemberUserIds = unfoldMemberUserIds . getGroupMemberUserIds' 179 | 180 | getRoomMemberProfile :: Id 'Room -> Id 'User -> Line Profile 181 | getRoomMemberProfile = line (Proxy @GetRoomMemberProfile) 182 | 183 | leaveRoom :: Id 'Room -> Line NoContent 184 | leaveRoom = line (Proxy @LeaveRoom) 185 | 186 | getRoomMemberUserIds' :: Id 'Room -> Maybe String -> Line MemberIds 187 | getRoomMemberUserIds' = line (Proxy @GetRoomMemberUserIds) 188 | 189 | getRoomMemberUserIds :: Id 'Room -> Line [Id 'User] 190 | getRoomMemberUserIds = unfoldMemberUserIds . getRoomMemberUserIds' 191 | 192 | replyMessage' :: ReplyMessageBody -> Line NoContent 193 | replyMessage' = line (Proxy @ReplyMessage) 194 | 195 | replyMessage :: ReplyToken -> [Message] -> Line NoContent 196 | replyMessage a ms = replyMessage' (ReplyMessageBody a ms) 197 | 198 | pushMessage' :: PushMessageBody -> Line NoContent 199 | pushMessage' = line (Proxy @PushMessage) 200 | 201 | pushMessage :: Id a -> [Message] -> Line NoContent 202 | pushMessage a ms = pushMessage' (PushMessageBody a ms) 203 | 204 | multicastMessage' :: MulticastMessageBody -> Line NoContent 205 | multicastMessage' = line (Proxy @MulticastMessage) 206 | 207 | multicastMessage :: [Id 'User] -> [Message] -> Line NoContent 208 | multicastMessage a ms = multicastMessage' (MulticastMessageBody a ms) 209 | 210 | broadcastMessage' :: BroadcastMessageBody -> Line NoContent 211 | broadcastMessage' = line (Proxy @BroadcastMessage) 212 | 213 | broadcastMessage :: [Message] -> Line NoContent 214 | broadcastMessage = broadcastMessage' . BroadcastMessageBody 215 | 216 | getContent' :: MessageId -> Line LB.ByteString 217 | getContent' = line (Proxy @GetContent) 218 | 219 | getContent :: MessageId -> Line LB.ByteString 220 | getContent = withHost blobEndpoint . getContent' 221 | 222 | getContentS' :: MessageId -> Line (SourceIO ByteString) 223 | getContentS' = line (Proxy @GetContentStream) 224 | 225 | -- | This is an streaming version of 'getContent' meant to be used with coroutine 226 | -- libraries like @pipes@, @conduits@, @streaming@, etc. You need and instance 227 | -- of 'FromSourceIO', see e.g. @servant-conduit@. 228 | -- 229 | -- Example: 230 | -- 231 | -- > getContentC :: MessageId -> Line (ConduitT () ByteString IO ()) 232 | -- > getContentC = fmap fromSourceIO . getContentS 233 | getContentS :: MessageId -> Line (SourceIO ByteString) 234 | getContentS = withHost blobEndpoint . getContentS' 235 | 236 | getPushMessageCount' :: LineDate -> Line MessageCount 237 | getPushMessageCount' = line (Proxy @GetPushMessageCount) 238 | 239 | getPushMessageCount :: Day -> Line (Maybe Int) 240 | getPushMessageCount = fmap count . getPushMessageCount' . LineDate 241 | 242 | getReplyMessageCount' :: LineDate -> Line MessageCount 243 | getReplyMessageCount' = line (Proxy @GetReplyMessageCount) 244 | 245 | getReplyMessageCount :: Day -> Line (Maybe Int) 246 | getReplyMessageCount = fmap count . getReplyMessageCount' . LineDate 247 | 248 | getMulticastMessageCount' :: LineDate -> Line MessageCount 249 | getMulticastMessageCount' = line (Proxy @GetMulticastMessageCount) 250 | 251 | getMulticastMessageCount :: Day -> Line (Maybe Int) 252 | getMulticastMessageCount = fmap count . getMulticastMessageCount' . LineDate 253 | 254 | getBroadcastMessageCount' :: LineDate -> Line MessageCount 255 | getBroadcastMessageCount' = line (Proxy @GetBroadcastMessageCount) 256 | 257 | getBroadcastMessageCount :: Day -> Line (Maybe Int) 258 | getBroadcastMessageCount = fmap count . getBroadcastMessageCount' . LineDate 259 | 260 | getMessageQuota' :: Line MessageQuota 261 | getMessageQuota' = line (Proxy @GetMessageQuota) 262 | 263 | getMessageQuota :: Line Int 264 | getMessageQuota = fmap totalUsage getMessageQuota' 265 | 266 | issueLinkToken :: Id 'User -> Line LinkToken 267 | issueLinkToken = line (Proxy @IssueLinkToken) 268 | 269 | issueChannelToken' :: ClientCredentials -> ClientM ShortLivedChannelToken 270 | issueChannelToken' = client (Proxy @IssueChannelToken) 271 | 272 | issueChannelToken :: ChannelId -> ChannelSecret -> ClientM ShortLivedChannelToken 273 | issueChannelToken a b = issueChannelToken' $ ClientCredentials a b 274 | 275 | revokeChannelToken :: ChannelToken -> ClientM NoContent 276 | revokeChannelToken = client (Proxy @RevokeChannelToken) 277 | 278 | createRichMenu :: RichMenu -> Line RichMenuId 279 | createRichMenu = line (Proxy @CreateRichMenu) 280 | 281 | getRichMenu' :: RichMenuId -> Line RichMenuResponse 282 | getRichMenu' = line (Proxy @GetRichMenu) 283 | 284 | getRichMenu :: RichMenuId -> Line RichMenu 285 | getRichMenu = fmap richMenu . getRichMenu' 286 | 287 | uploadRichMenuImageJpg' :: RichMenuId -> ByteString -> Line NoContent 288 | uploadRichMenuImageJpg' = line (Proxy @UploadRichMenuImageJpg) 289 | 290 | uploadRichMenuImageJpg :: RichMenuId -> ByteString -> Line NoContent 291 | uploadRichMenuImageJpg a = withHost blobEndpoint . uploadRichMenuImageJpg' a 292 | 293 | deleteRichMenu :: RichMenuId -> Line NoContent 294 | deleteRichMenu = line (Proxy @DeleteRichMenu) 295 | 296 | getRichMenuList' :: Line RichMenuResponseList 297 | getRichMenuList' = line (Proxy @GetRichMenuList) 298 | 299 | getRichMenuList :: Line [(RichMenuId, RichMenu)] 300 | getRichMenuList = richmenus <$> getRichMenuList' <&> fmap f where 301 | f RichMenuResponse{..} = (RichMenuId richMenuId, richMenu) 302 | 303 | setDefaultRichMenu :: RichMenuId -> Line NoContent 304 | setDefaultRichMenu = line (Proxy @SetDefaultRichMenu) 305 | -------------------------------------------------------------------------------- /src/Line/Bot/Internal/Endpoints.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE MultiParamTypeClasses #-} 5 | {-# LANGUAGE ScopedTypeVariables #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE UndecidableInstances #-} 9 | 10 | -- | 11 | -- Module : Line.Bot.Internal.Endpoints 12 | -- Copyright : (c) Alexandre Moreno, 2019-2021 13 | -- License : BSD-3-Clause 14 | -- Maintainer : alexmorenocano@gmail.com 15 | -- Stability : experimental 16 | 17 | module Line.Bot.Internal.Endpoints where 18 | 19 | import Data.ByteString (ByteString) 20 | import qualified Data.ByteString.Lazy as LB (ByteString) 21 | import Line.Bot.Types 22 | import Servant.API 23 | 24 | type GetProfile' a = 25 | "v2":> "bot" :> "profile" 26 | :> Capture "userId" (Id 'User) 27 | :> Get '[JSON] a 28 | 29 | type GetProfile = GetProfile' Profile 30 | 31 | type GetGroupMemberProfile' a = 32 | "v2":> "bot" :> "group" 33 | :> Capture "groupId" (Id 'Group) 34 | :> "member" 35 | :> Capture "userId" (Id 'User) 36 | :> Get '[JSON] a 37 | 38 | type GetGroupMemberProfile = GetGroupMemberProfile' Profile 39 | 40 | type LeaveGroup = 41 | "v2":> "bot" :> "group" 42 | :> Capture "groupId" (Id 'Group) 43 | :> "leave" 44 | :> PostNoContent 45 | 46 | type GetGroupMemberUserIds' a = 47 | "v2":> "bot" :> "group" 48 | :> Capture "groupId" (Id 'Group) 49 | :> "members" 50 | :> "ids" 51 | :> QueryParam "start" String 52 | :> Get '[JSON] a 53 | 54 | type GetGroupMemberUserIds = GetGroupMemberUserIds' MemberIds 55 | 56 | type GetRoomMemberProfile' a = 57 | "v2":> "bot" :> "room" 58 | :> Capture "roomId" (Id 'Room) 59 | :> "member" 60 | :> Capture "userId" (Id 'User) 61 | :> Get '[JSON] a 62 | 63 | type GetRoomMemberProfile = GetRoomMemberProfile' Profile 64 | 65 | type LeaveRoom = 66 | "v2":> "bot" :> "room" 67 | :> Capture "roomId" (Id 'Room) 68 | :> "leave" 69 | :> PostNoContent 70 | 71 | type GetRoomMemberUserIds' a = 72 | "v2":> "bot" :> "room" 73 | :> Capture "roomId" (Id 'Room) 74 | :> "members" 75 | :> "ids" 76 | :> QueryParam "start" String 77 | :> Get '[JSON] a 78 | 79 | type GetRoomMemberUserIds = GetRoomMemberUserIds' MemberIds 80 | 81 | type ReplyMessage' a = 82 | "v2":> "bot" :> "message" 83 | :> "reply" 84 | :> ReqBody '[JSON] a 85 | :> PostNoContent 86 | 87 | type ReplyMessage = ReplyMessage' ReplyMessageBody 88 | 89 | type PushMessage' a = 90 | "v2":> "bot" :> "message" 91 | :> "push" 92 | :> ReqBody '[JSON] a 93 | :> PostNoContent 94 | 95 | type PushMessage = PushMessage' PushMessageBody 96 | 97 | type MulticastMessage' a = 98 | "v2":> "bot" :> "message" 99 | :> "multicast" 100 | :> ReqBody '[JSON] a 101 | :> PostNoContent 102 | 103 | type MulticastMessage = MulticastMessage' MulticastMessageBody 104 | 105 | type BroadcastMessage' a = 106 | "v2":> "bot" :> "message" 107 | :> "broadcast" 108 | :> ReqBody '[JSON] a 109 | :> PostNoContent 110 | 111 | type BroadcastMessage = BroadcastMessage' BroadcastMessageBody 112 | 113 | type GetContent = 114 | "v2":> "bot" :> "message" 115 | :> Capture "messageId" MessageId 116 | :> "content" 117 | :> Get '[OctetStream] LB.ByteString 118 | 119 | type GetContentStream = 120 | "v2":> "bot" :> "message" 121 | :> Capture "messageId" MessageId 122 | :> "content" 123 | :> StreamGet NoFraming OctetStream (SourceIO ByteString) 124 | 125 | type GetReplyMessageCount' a b = 126 | "v2":> "bot" :> "message" :> "delivery" 127 | :> "reply" 128 | :> QueryParam' '[Required, Strict] "date" a 129 | :> Get '[JSON] b 130 | 131 | type GetReplyMessageCount = GetReplyMessageCount' LineDate MessageCount 132 | 133 | type GetPushMessageCount' a b = 134 | "v2":> "bot" :> "message" :> "delivery" 135 | :> "push" 136 | :> QueryParam' '[Required, Strict] "date" a 137 | :> Get '[JSON] b 138 | 139 | type GetPushMessageCount = GetPushMessageCount' LineDate MessageCount 140 | 141 | type GetMulticastMessageCount' a b = 142 | "v2" :> "bot" :> "message" :> "delivery" 143 | :> "multicast" 144 | :> QueryParam' '[Required, Strict] "date" a 145 | :> Get '[JSON] b 146 | 147 | type GetMulticastMessageCount = GetMulticastMessageCount' LineDate MessageCount 148 | 149 | type GetBroadcastMessageCount' a b = 150 | "v2" :> "bot" :> "message" :> "delivery" 151 | :> "broadcast" 152 | :> QueryParam' '[Required, Strict] "date" a 153 | :> Get '[JSON] b 154 | 155 | type GetBroadcastMessageCount = GetBroadcastMessageCount' LineDate MessageCount 156 | 157 | type GetMessageQuota' a = 158 | "v2":> "bot" :> "message" :> "quota" 159 | :> "consumption" 160 | :> Get '[JSON] a 161 | 162 | type GetMessageQuota = GetMessageQuota' MessageQuota 163 | 164 | type IssueLinkToken' a = 165 | "v2":> "bot" :> "user" 166 | :> Capture "userId" (Id 'User) 167 | :> "linkToken" 168 | :> Get '[JSON] a 169 | 170 | type IssueLinkToken = IssueLinkToken' LinkToken 171 | 172 | type IssueChannelToken' a b = 173 | "v2" :> "oauth" 174 | :> "accessToken" 175 | :> ReqBody '[FormUrlEncoded] a 176 | :> Post '[JSON] b 177 | 178 | type IssueChannelToken = IssueChannelToken' ClientCredentials ShortLivedChannelToken 179 | 180 | type RevokeChannelToken' a = 181 | "v2" :> "oauth" 182 | :> "revoke" 183 | :> ReqBody '[FormUrlEncoded] a 184 | :> Post '[JSON] NoContent 185 | 186 | type RevokeChannelToken = RevokeChannelToken' ChannelToken 187 | 188 | type CreateRichMenu' a b = 189 | "v2" :> "bot" :> "richmenu" 190 | :> ReqBody '[JSON] a 191 | :> Post '[JSON] b 192 | 193 | type CreateRichMenu = CreateRichMenu' RichMenu RichMenuId 194 | 195 | type DeleteRichMenu' a = 196 | "v2" :> "bot" :> "richmenu" 197 | :> Capture "richMenuId" a 198 | :> Delete '[JSON] NoContent 199 | 200 | type DeleteRichMenu = DeleteRichMenu' RichMenuId 201 | 202 | type GetRichMenu' a b = 203 | "v2" :> "bot" :> "richmenu" 204 | :> Capture "richMenuId" a 205 | :> Get '[JSON] b 206 | 207 | type GetRichMenu = GetRichMenu' RichMenuId RichMenuResponse 208 | 209 | type UploadRichMenuImageJpg' a b = 210 | "v2" :> "bot" :> "richmenu" 211 | :> Capture "richMenuId" a 212 | :> "content" 213 | :> ReqBody '[JPEG] b 214 | :> Post '[JSON] NoContent 215 | 216 | type UploadRichMenuImageJpg = UploadRichMenuImageJpg' RichMenuId ByteString 217 | 218 | type GetRichMenuList' a = 219 | "v2" :> "bot" :> "richmenu" 220 | :> "list" 221 | :> Get '[JSON] a 222 | 223 | type GetRichMenuList = GetRichMenuList' RichMenuResponseList 224 | 225 | type SetDefaultRichMenu' a = 226 | "v2":> "bot" :> "user" :> "all" :> "richmenu" 227 | :> Capture "richMenuId" a 228 | :> PostNoContent 229 | 230 | type SetDefaultRichMenu = SetDefaultRichMenu' RichMenuId 231 | -------------------------------------------------------------------------------- /src/Line/Bot/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DeriveAnyClass #-} 4 | {-# LANGUAGE DuplicateRecordFields #-} 5 | {-# LANGUAGE ExistentialQuantification #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE FlexibleInstances #-} 8 | {-# LANGUAGE GADTs #-} 9 | {-# LANGUAGE KindSignatures #-} 10 | {-# LANGUAGE LambdaCase #-} 11 | {-# LANGUAGE MultiParamTypeClasses #-} 12 | {-# LANGUAGE NamedFieldPuns #-} 13 | {-# LANGUAGE OverloadedLists #-} 14 | {-# LANGUAGE OverloadedStrings #-} 15 | {-# LANGUAGE RecordWildCards #-} 16 | {-# LANGUAGE StandaloneDeriving #-} 17 | 18 | -- | 19 | -- Module : Line.Bot.Types 20 | -- Copyright : (c) Alexandre Moreno, 2019-2021 21 | -- License : BSD-3-Clause 22 | -- Maintainer : alexmorenocano@gmail.com 23 | -- Stability : experimental 24 | 25 | module Line.Bot.Types 26 | ( ChannelToken(..) 27 | , ChannelSecret(..) 28 | , ChannelId(..) 29 | , ChatType(..) 30 | , Id(..) 31 | , MessageId 32 | , URL(..) 33 | , Message(..) 34 | , ReplyToken(..) 35 | , LinkToken(..) 36 | , ReplyMessageBody(ReplyMessageBody) 37 | , PushMessageBody(PushMessageBody) 38 | , MulticastMessageBody(MulticastMessageBody) 39 | , BroadcastMessageBody(BroadcastMessageBody) 40 | , Profile(..) 41 | , QuickReply(..) 42 | , QuickReplyButton(..) 43 | , Action(..) 44 | , ClientCredentials(..) 45 | , ShortLivedChannelToken(..) 46 | , LineDate(..) 47 | , MessageCount(..) 48 | , MessageQuota(..) 49 | , MemberIds(..) 50 | , JPEG 51 | , RichMenuSize(..) 52 | , RichMenuBounds(..) 53 | , RichMenuArea(..) 54 | , RichMenu(..) 55 | , RichMenuResponse(..) 56 | , RichMenuId(..) 57 | , RichMenuResponseList(..) 58 | , RichMenuBulkLinkBody(..) 59 | , RichMenuBulkUnlinkBody(..) 60 | ) 61 | where 62 | 63 | import Control.Arrow ((>>>)) 64 | import Control.DeepSeq 65 | import Data.Aeson 66 | import Data.ByteString (ByteString) 67 | import qualified Data.ByteString.Char8 as C8 68 | import qualified Data.ByteString.Lazy as LB 69 | import Data.Char (toLower) 70 | import Data.List as L (stripPrefix) 71 | import Data.String 72 | import Data.Text as T hiding (count, drop, toLower) 73 | import Data.Text.Encoding 74 | import Data.Time.Calendar (Day) 75 | import Data.Time.Format 76 | import Data.Typeable 77 | import GHC.Generics hiding (to) 78 | import Network.HTTP.Media ((//)) 79 | import Servant.API 80 | import Web.FormUrlEncoded (ToForm (..)) 81 | 82 | newtype ChannelToken = ChannelToken { unChannelToken :: Text } 83 | deriving (Eq, Show, Generic, NFData) 84 | 85 | instance FromJSON ChannelToken where 86 | parseJSON = withText "ChannelToken" $ return . ChannelToken 87 | 88 | instance IsString ChannelToken where 89 | fromString s = ChannelToken (fromString s) 90 | 91 | instance ToHttpApiData ChannelToken where 92 | toHeader (ChannelToken t) = encodeUtf8 $ "Bearer " <> t 93 | toQueryParam (ChannelToken t) = t 94 | 95 | instance ToForm ChannelToken where 96 | toForm (ChannelToken t) = [ ("access_token", t) ] 97 | 98 | newtype ChannelSecret = ChannelSecret { unChannelSecret :: C8.ByteString } 99 | 100 | instance IsString ChannelSecret where 101 | fromString s = ChannelSecret (C8.pack s) 102 | 103 | instance ToHttpApiData ChannelSecret where 104 | toQueryParam = decodeUtf8 . unChannelSecret 105 | 106 | newtype ChannelId = ChannelId { unChannelId :: Text } 107 | deriving (Eq, Show, Generic, NFData) 108 | 109 | instance IsString ChannelId where 110 | fromString s = ChannelId (fromString s) 111 | 112 | instance ToHttpApiData ChannelId where 113 | toQueryParam (ChannelId t) = t 114 | 115 | data ChatType = User | Group | Room 116 | 117 | -- | ID of a chat user, group or room 118 | data Id :: ChatType -> * where 119 | UserId :: Text -> Id 'User 120 | GroupId :: Text -> Id 'Group 121 | RoomId :: Text -> Id 'Room 122 | 123 | deriving instance Eq (Id a) 124 | deriving instance Show (Id a) 125 | 126 | instance NFData (Id a) where 127 | rnf (UserId a) = rnf a 128 | rnf (GroupId a) = rnf a 129 | rnf (RoomId a) = rnf a 130 | 131 | instance ToHttpApiData (Id a) where 132 | toQueryParam = \case 133 | UserId a -> a 134 | GroupId a -> a 135 | RoomId a -> a 136 | 137 | instance ToJSON (Id a) where 138 | toJSON = String . toQueryParam 139 | 140 | instance FromHttpApiData (Id 'User) where 141 | parseUrlPiece = pure . UserId 142 | 143 | instance FromHttpApiData (Id 'Group) where 144 | parseUrlPiece = pure . GroupId 145 | 146 | instance FromHttpApiData (Id 'Room) where 147 | parseUrlPiece = pure . RoomId 148 | 149 | instance IsString (Id 'User) where 150 | fromString s = UserId (fromString s) 151 | 152 | instance IsString (Id 'Group) where 153 | fromString s = GroupId (fromString s) 154 | 155 | instance IsString (Id 'Room) where 156 | fromString s = RoomId (fromString s) 157 | 158 | instance FromJSON (Id 'User) where 159 | parseJSON = withText "Id 'User" $ return . UserId 160 | 161 | instance FromJSON (Id 'Group) where 162 | parseJSON = withText "Id 'Group" $ return . GroupId 163 | 164 | instance FromJSON (Id 'Room) where 165 | parseJSON = withText "Id 'Room" $ return . RoomId 166 | 167 | type MessageId = Text 168 | 169 | newtype URL = URL Text 170 | deriving (Show, Eq, Generic, NFData) 171 | 172 | instance ToJSON URL 173 | instance FromJSON URL 174 | 175 | data Message = 176 | MessageText { text :: Text 177 | , quickReply :: Maybe QuickReply 178 | } 179 | | MessageSticker { packageId :: Text 180 | , stickerId :: Text 181 | , quickReply :: Maybe QuickReply 182 | } 183 | | MessageImage { originalContentUrl :: URL 184 | , previewImageUrl :: URL 185 | , quickReply :: Maybe QuickReply 186 | } 187 | | MessageVideo { originalContentUrl :: URL 188 | , previewImageUrl :: URL 189 | , quickReply :: Maybe QuickReply 190 | } 191 | | MessageAudio { originalContentUrl :: URL 192 | , duration :: Int 193 | , quickReply :: Maybe QuickReply 194 | } 195 | | MessageLocation { title :: Text 196 | , address :: Text 197 | , latitude :: Double 198 | , longitude :: Double 199 | , quickReply :: Maybe QuickReply 200 | } 201 | | MessageFlex { altText :: Text 202 | , contents :: Value 203 | , quickReply :: Maybe QuickReply 204 | } 205 | deriving (Eq, Show, Generic, NFData) 206 | 207 | instance ToJSON Message where 208 | toJSON = genericToJSON messageJSONOptions 209 | 210 | messageJSONOptions :: Options 211 | messageJSONOptions = defaultOptions 212 | { sumEncoding = TaggedObject 213 | { tagFieldName = "type" 214 | , contentsFieldName = undefined 215 | } 216 | , constructorTagModifier = fmap toLower . drop 7 217 | , omitNothingFields = True 218 | } 219 | 220 | data Profile = Profile 221 | { displayName :: Text 222 | , userId :: Text 223 | , pictureUrl :: URL 224 | , statusMessage :: Maybe Text 225 | } 226 | deriving (Eq, Show, Generic, NFData) 227 | 228 | instance FromJSON Profile 229 | 230 | newtype ReplyToken = ReplyToken Text 231 | deriving (Eq, Show, Generic, NFData) 232 | 233 | instance ToJSON ReplyToken 234 | instance FromJSON ReplyToken 235 | 236 | newtype LinkToken = LinkToken { linkToken :: Text } 237 | deriving (Eq, Show, Generic, NFData) 238 | 239 | instance FromJSON LinkToken 240 | 241 | data ReplyMessageBody = ReplyMessageBody 242 | { replyToken :: ReplyToken 243 | , messages :: [Message] 244 | } 245 | deriving (Show, Generic, NFData) 246 | 247 | instance ToJSON ReplyMessageBody 248 | 249 | data PushMessageBody = forall a. PushMessageBody 250 | { to :: Id a 251 | , messages :: [Message] 252 | } 253 | 254 | deriving instance Show PushMessageBody 255 | 256 | instance ToJSON PushMessageBody where 257 | toJSON PushMessageBody {..} = object 258 | [ "to" .= to 259 | , "messages" .= messages 260 | ] 261 | 262 | data MulticastMessageBody = MulticastMessageBody 263 | { to :: [Id 'User] 264 | , messages :: [Message] 265 | } 266 | deriving (Show, Generic, NFData) 267 | 268 | instance ToJSON MulticastMessageBody 269 | 270 | newtype BroadcastMessageBody = BroadcastMessageBody 271 | { messages :: [Message] } 272 | deriving (Show, Generic, NFData) 273 | 274 | instance ToJSON BroadcastMessageBody 275 | 276 | newtype QuickReply = QuickReply 277 | { items :: [QuickReplyButton] } 278 | deriving (Eq, Show, Generic, NFData) 279 | 280 | instance ToJSON QuickReply 281 | 282 | data QuickReplyButton = QuickReplyButton 283 | { imageUrl :: Maybe URL 284 | , action :: Action 285 | } 286 | deriving (Eq, Show, Generic, NFData) 287 | 288 | instance ToJSON QuickReplyButton where 289 | toJSON QuickReplyButton{..} = object 290 | [ "type" .= pack "action" 291 | , "imageUrl" .= imageUrl 292 | , "action" .= action 293 | ] 294 | 295 | data Action = 296 | ActionPostback { label :: Text 297 | , postbackData :: Text 298 | , displayText :: Text 299 | } 300 | | ActionMessage { label :: Text 301 | , text :: Text 302 | } 303 | | ActionUri { label :: Text 304 | , uri :: URL 305 | } 306 | | ActionCamera { label :: Text 307 | } 308 | | ActionCameraRoll { label :: Text 309 | } 310 | | ActionLocation { label :: Text 311 | } 312 | deriving (Eq, Show, Generic, NFData) 313 | 314 | instance ToJSON Action where 315 | toJSON = genericToJSON actionJSONOptions 316 | 317 | instance FromJSON Action where 318 | parseJSON = genericParseJSON actionJSONOptions 319 | 320 | actionJSONOptions :: Options 321 | actionJSONOptions = defaultOptions 322 | { sumEncoding = TaggedObject 323 | { tagFieldName = "type" 324 | , contentsFieldName = undefined 325 | } 326 | , constructorTagModifier = drop 6 >>> \(x:xs) -> toLower x : xs 327 | , omitNothingFields = True 328 | , fieldLabelModifier = \x -> maybe x (fmap toLower) $ L.stripPrefix "postback" x 329 | } 330 | 331 | data ClientCredentials = ClientCredentials 332 | { clientId :: ChannelId 333 | , clientSecret :: ChannelSecret 334 | } 335 | 336 | instance ToForm ClientCredentials where 337 | toForm ClientCredentials{..} = 338 | [ ("grant_type", "client_credentials") 339 | , ("client_id", toQueryParam clientId) 340 | , ("client_secret", toQueryParam clientSecret) 341 | ] 342 | 343 | data ShortLivedChannelToken = ShortLivedChannelToken 344 | { accessToken :: ChannelToken 345 | , expiresIn :: Int 346 | } deriving (Eq, Show, Generic, NFData) 347 | 348 | instance FromJSON ShortLivedChannelToken where 349 | parseJSON = genericParseJSON defaultOptions 350 | { fieldLabelModifier = camelTo2 '_' } 351 | 352 | newtype LineDate = LineDate { unLineDate :: Day } deriving (Eq) 353 | 354 | instance Show LineDate where 355 | show = formatTime defaultTimeLocale "%Y%m%d" . unLineDate 356 | 357 | instance ToHttpApiData LineDate where 358 | toQueryParam = T.pack . show 359 | 360 | data MessageCount = MessageCount 361 | { count :: Maybe Int 362 | , status :: String 363 | } deriving (Eq, Show) 364 | 365 | instance FromJSON MessageCount where 366 | parseJSON = withObject "MessageCount" $ \o -> do 367 | count <- o .:? "success" 368 | status <- o .: "status" 369 | return MessageCount{..} 370 | 371 | newtype MessageQuota = MessageQuota { totalUsage :: Int } 372 | deriving (Eq, Show, Generic, NFData) 373 | 374 | instance FromJSON MessageQuota 375 | 376 | data MemberIds = MemberIds 377 | { memberIds :: [Id 'User] 378 | , next :: Maybe String 379 | } deriving (Eq, Show, Generic, NFData) 380 | 381 | instance FromJSON MemberIds 382 | 383 | data JPEG deriving Typeable 384 | 385 | instance Accept JPEG where 386 | contentType _ = "image" // "jpeg" 387 | 388 | instance MimeRender JPEG ByteString where 389 | mimeRender _ = LB.fromStrict 390 | 391 | data RichMenuSize = RichMenuSize 392 | { width :: Int 393 | , height :: Int 394 | } deriving (Eq, Show, Generic, NFData) 395 | 396 | instance FromJSON RichMenuSize 397 | instance ToJSON RichMenuSize 398 | 399 | data RichMenuBounds = RichMenuBounds 400 | { x :: Int 401 | , y :: Int 402 | , width :: Int 403 | , height :: Int 404 | } deriving (Eq, Show, Generic, NFData) 405 | 406 | instance FromJSON RichMenuBounds 407 | instance ToJSON RichMenuBounds 408 | 409 | data RichMenuArea = RichMenuArea 410 | { bounds :: RichMenuBounds 411 | , action :: Action 412 | } deriving (Eq, Show, Generic, NFData) 413 | 414 | instance FromJSON RichMenuArea 415 | instance ToJSON RichMenuArea 416 | 417 | data RichMenu = RichMenu 418 | { size :: RichMenuSize 419 | , selected :: Bool 420 | , name :: Text 421 | , chatBarText :: Text 422 | , areas :: [RichMenuArea] 423 | } deriving (Eq, Show, Generic, NFData) 424 | 425 | instance FromJSON RichMenu 426 | instance ToJSON RichMenu 427 | 428 | data RichMenuResponse = RichMenuResponse 429 | { richMenuId :: Text 430 | , richMenu :: RichMenu 431 | } 432 | deriving (Show, Eq, Generic, NFData) 433 | 434 | instance FromJSON RichMenuResponse where 435 | parseJSON = withObject "RichMenuResponse" $ \o -> do 436 | richMenuId <- o .: "richMenuId" 437 | richMenu <- parseJSON (Object o) 438 | return RichMenuResponse{..} 439 | 440 | newtype RichMenuId = RichMenuId 441 | { richMenuId :: Text } 442 | deriving (Show, Eq, Generic, NFData) 443 | 444 | instance FromJSON RichMenuId 445 | 446 | instance ToHttpApiData RichMenuId where 447 | toQueryParam (RichMenuId a) = a 448 | 449 | newtype RichMenuResponseList = RichMenuResponseList 450 | { richmenus :: [RichMenuResponse] } 451 | deriving (Show, Eq, Generic, NFData) 452 | 453 | instance FromJSON RichMenuResponseList 454 | 455 | data RichMenuBulkLinkBody = RichMenuBulkLinkBody 456 | { richMenuId :: Text 457 | , userIds :: [Id 'User] 458 | } deriving (Show, Eq, Generic, NFData) 459 | 460 | instance ToJSON RichMenuBulkLinkBody 461 | 462 | newtype RichMenuBulkUnlinkBody = RichMenuBulkUnlinkBody 463 | { userIds :: [Id 'User] } 464 | deriving (Show, Eq, Generic, NFData) 465 | 466 | instance ToJSON RichMenuBulkUnlinkBody 467 | -------------------------------------------------------------------------------- /src/Line/Bot/Webhook.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE ConstraintKinds #-} 2 | {-# LANGUAGE DataKinds #-} 3 | {-# LANGUAGE DeriveDataTypeable #-} 4 | {-# LANGUAGE FlexibleContexts #-} 5 | {-# LANGUAGE FlexibleInstances #-} 6 | {-# LANGUAGE MultiParamTypeClasses #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE PolyKinds #-} 9 | {-# LANGUAGE RankNTypes #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE ScopedTypeVariables #-} 12 | {-# LANGUAGE TypeFamilies #-} 13 | {-# LANGUAGE TypeOperators #-} 14 | {-# LANGUAGE UndecidableInstances #-} 15 | 16 | -- | 17 | -- Module : Line.Bot.Webhook 18 | -- Copyright : (c) Alexandre Moreno, 2019-2021 19 | -- License : BSD-3-Clause 20 | -- Maintainer : alexmorenocano@gmail.com 21 | -- Stability : experimental 22 | 23 | module Line.Bot.Webhook 24 | ( Webhook 25 | , webhook 26 | , LineReqBody 27 | , module Events 28 | ) 29 | where 30 | 31 | import Control.Monad (forM_) 32 | import Control.Monad.IO.Class (MonadIO, liftIO) 33 | import qualified Crypto.Hash.SHA256 as SHA256 34 | import qualified Data.ByteString as B 35 | import qualified Data.ByteString.Base64 as Base64 36 | import qualified Data.ByteString.Lazy as BL 37 | import Data.Maybe (fromMaybe) 38 | import Data.Proxy 39 | import Data.String.Conversions (cs) 40 | import Data.Typeable (Typeable) 41 | import Line.Bot.Types (ChannelSecret (..)) 42 | import Line.Bot.Webhook.Events as Events 43 | import Network.HTTP.Types (HeaderName, hContentType) 44 | import Network.Wai (lazyRequestBody, 45 | requestHeaders) 46 | import Servant 47 | import Servant.API.ContentTypes 48 | import Servant.Server.Internal 49 | 50 | -- | This type alias just specifies how webhook requests should be handled 51 | type Webhook = LineReqBody '[JSON] Events :> Post '[JSON] NoContent 52 | 53 | -- | Helper function that takes a handler to process 'Webhook' events: 54 | -- 55 | -- > server :: Server Webhook 56 | -- > server = webhook $ \case 57 | -- > EventMessage { message, replyToken } = handleMessage message replyToken 58 | -- > _ = return () 59 | webhook :: MonadIO m => (Event -> m a) -> Events -> m NoContent 60 | webhook k Events{..} = forM_ events k >> return NoContent 61 | 62 | -- | A Servant combinator that extracts the request body as a value of type a 63 | -- and performs signature valiadation 64 | data LineReqBody (contentTypes :: [*]) (a :: *) 65 | deriving (Typeable) 66 | 67 | instance (AllCTUnrender list a, HasServer api context, HasContextEntry context ChannelSecret) 68 | => HasServer (LineReqBody list a :> api) context where 69 | 70 | type ServerT (LineReqBody list a :> api) m = a -> ServerT api m 71 | 72 | hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt . s 73 | 74 | route Proxy context subserver 75 | = route (Proxy :: Proxy api) context $ 76 | addBodyCheck subserver ctCheck bodyCheck 77 | where 78 | ctCheck = withRequest $ \request -> do 79 | let contentTypeH = fromMaybe "application/octet-stream" 80 | $ lookup hContentType $ requestHeaders request 81 | case canHandleCTypeH (Proxy :: Proxy list) (cs contentTypeH) :: Maybe (BL.ByteString -> Either String a) of 82 | Nothing -> delayedFail err415 83 | Just f -> return f 84 | 85 | bodyCheck f = withRequest $ \ request -> do 86 | rawBody <- liftIO $ lazyRequestBody request 87 | let signatureH = lookup hSignature $ requestHeaders request 88 | 89 | if validateReqBody signatureH rawBody 90 | then case f rawBody of 91 | Left e -> delayedFailFatal err400 { errBody = cs e } 92 | Right v -> return v 93 | else delayedFailFatal err401 94 | 95 | channelSecret :: ChannelSecret 96 | channelSecret = getContextEntry context 97 | 98 | hSignature :: HeaderName 99 | hSignature = "X-Line-Signature" 100 | 101 | validateReqBody :: Maybe B.ByteString -> BL.ByteString -> Bool 102 | validateReqBody digest body = digest' == Just (SHA256.hmaclazy secret body) 103 | where 104 | digest' = Base64.decodeLenient <$> digest 105 | secret = unChannelSecret channelSecret 106 | 107 | -------------------------------------------------------------------------------- /src/Line/Bot/Webhook/Events.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE DuplicateRecordFields #-} 4 | {-# LANGUAGE ExistentialQuantification #-} 5 | {-# LANGUAGE ExtendedDefaultRules #-} 6 | {-# LANGUAGE FlexibleContexts #-} 7 | {-# LANGUAGE GADTs #-} 8 | {-# LANGUAGE GeneralizedNewtypeDeriving #-} 9 | {-# LANGUAGE OverloadedStrings #-} 10 | {-# LANGUAGE RecordWildCards #-} 11 | {-# LANGUAGE StandaloneDeriving #-} 12 | 13 | -- | 14 | -- Module : Line.Bot.Webhook.Events 15 | -- Copyright : (c) Alexandre Moreno, 2019-2021 16 | -- License : BSD-3-Clause 17 | -- Maintainer : alexmorenocano@gmail.com 18 | -- Stability : experimental 19 | 20 | module Line.Bot.Webhook.Events 21 | ( Events(..) 22 | , Event(..) 23 | , Message(..) 24 | , ContentProvider(..) 25 | , EpochMilli(..) 26 | , Source(..) 27 | , MessageSource(..) 28 | , Members(..) 29 | , Postback(..) 30 | , Beacon(..) 31 | , BeaconEvent(..) 32 | , Things(..) 33 | , ThingsEvent(..) 34 | , AccountLink(..) 35 | , AccountLinkResult(..) 36 | , TrackingId(..) 37 | ) 38 | where 39 | 40 | import Control.Arrow ((>>>)) 41 | import Data.Aeson 42 | import Data.Char 43 | import Data.Foldable 44 | import Data.List as L (stripPrefix) 45 | import Data.Text as T hiding (drop, toLower) 46 | import Data.Time (UTCTime) 47 | import Data.Time.Calendar (Day) 48 | import Data.Time.Clock.POSIX 49 | import Data.Time.Format 50 | import Data.Time.LocalTime 51 | import Data.Typeable (Typeable) 52 | import GHC.Generics (Generic) 53 | import Line.Bot.Types hiding (Message) 54 | 55 | data Events = Events 56 | { destination :: Id 'User -- ^ 'User ID of a bot that should receive webhook events 57 | , events :: [Event] -- ^ List of webhook event objects 58 | } 59 | deriving (Show, Generic) 60 | 61 | instance FromJSON Events 62 | 63 | -- | Events generated on the LINE Platform. 64 | data Event = 65 | EventMessage { replyToken :: ReplyToken 66 | , message :: Message 67 | , messageSource :: MessageSource 68 | , timestamp :: EpochMilli 69 | } 70 | | EventFollow { replyToken :: ReplyToken 71 | , source :: Source 72 | , timestamp :: EpochMilli 73 | } 74 | | EventUnfollow { source :: Source 75 | , timestamp :: EpochMilli 76 | } 77 | | EventJoin { replyToken :: ReplyToken 78 | , source :: Source 79 | , timestamp :: EpochMilli 80 | } 81 | | EventLeave { source :: Source 82 | , timestamp :: EpochMilli 83 | } 84 | | EventMemberJoined { replyToken :: ReplyToken 85 | , source :: Source 86 | , timestamp :: EpochMilli 87 | , joined :: Members 88 | } 89 | | EventMemberLeft { source :: Source 90 | , timestamp :: EpochMilli 91 | , left :: Members 92 | } 93 | | EventPostback { replyToken :: ReplyToken 94 | , source :: Source 95 | , timestamp :: EpochMilli 96 | , postback :: Postback 97 | } 98 | | EventBeacon { replyToken :: ReplyToken 99 | , source :: Source 100 | , timestamp :: EpochMilli 101 | , beacon :: Beacon 102 | } 103 | | EventAccountLink { replyToken :: ReplyToken 104 | , source :: Source 105 | , timestamp :: EpochMilli 106 | , link :: AccountLink 107 | } 108 | | EventThings { replyToken :: ReplyToken 109 | , source :: Source 110 | , timestamp :: EpochMilli 111 | , things :: Things 112 | } 113 | | EventUnsend { source :: Source 114 | , timestamp :: EpochMilli 115 | } 116 | | EventVideoPlayComplete { replyToken :: ReplyToken 117 | , source :: Source 118 | , timestamp :: EpochMilli 119 | , videoPlayComplete :: TrackingId 120 | } 121 | deriving (Show, Generic) 122 | 123 | instance FromJSON Event where 124 | parseJSON = genericParseJSON defaultOptions 125 | { sumEncoding = TaggedObject 126 | { tagFieldName = "type" 127 | , contentsFieldName = undefined 128 | } 129 | , constructorTagModifier = drop 5 >>> \(x:xs) -> toLower x : xs 130 | , fieldLabelModifier = \s -> if s == "messageSource" then "source" else s 131 | } 132 | 133 | data Message = 134 | MessageText { messageId :: MessageId 135 | , text :: Text 136 | } 137 | | MessageImage { messageId :: MessageId 138 | , contentProvider :: ContentProvider 139 | } 140 | | MessageVideo { messageId :: MessageId 141 | , duration :: Int 142 | , contentProvider :: ContentProvider 143 | } 144 | | MessageAudio { messageId :: MessageId 145 | , duration :: Int 146 | , contentProvider :: ContentProvider 147 | } 148 | | MessageFile { messageId :: MessageId 149 | , fileSize :: Int 150 | , fileName :: Text 151 | } 152 | | MessageLocation { messageId :: MessageId 153 | , title :: Maybe Text 154 | , address :: Text 155 | , latitude :: Double 156 | , longitude :: Double 157 | } 158 | | MessageSticker { messageId :: MessageId 159 | , packageId :: Text 160 | , stickerId :: Text 161 | } 162 | deriving (Eq, Show, Generic) 163 | 164 | messageJSONOptions :: Options 165 | messageJSONOptions = defaultOptions 166 | { sumEncoding = TaggedObject 167 | { tagFieldName = "type" 168 | , contentsFieldName = undefined 169 | } 170 | , constructorTagModifier = fmap toLower . drop 7 171 | , fieldLabelModifier = \x -> maybe x (fmap toLower) $ L.stripPrefix "message" x 172 | , omitNothingFields = True 173 | } 174 | 175 | instance FromJSON Message where 176 | parseJSON = genericParseJSON messageJSONOptions 177 | 178 | data ContentProvider = ContentProvider 179 | { originalContentUrl :: Maybe URL 180 | , previewImageUrl :: Maybe URL 181 | } 182 | deriving (Eq, Show, Generic) 183 | 184 | instance FromJSON ContentProvider 185 | 186 | newtype EpochMilli = EpochMilli { 187 | fromEpochMilli :: UTCTime 188 | -- ^ Acquire the underlying value. 189 | } deriving (Eq, Ord, Read, Show, FormatTime) 190 | 191 | instance FromJSON EpochMilli where 192 | parseJSON = withScientific "EpochMilli" $ \t -> 193 | pure $ millis t 194 | where 195 | millis = EpochMilli 196 | . posixSecondsToUTCTime 197 | . fromRational 198 | . toRational 199 | . (/ 1000) 200 | 201 | data Source = forall a. Source (Id a) 202 | 203 | deriving instance Show Source 204 | deriving instance Typeable Source 205 | 206 | instance FromJSON Source where 207 | parseJSON = withObject "Source" $ \o -> do 208 | messageType <- o .: "type" 209 | case messageType of 210 | "user" -> Source . UserId <$> o .: "userId" 211 | "group" -> Source . GroupId <$> o .: "groupId" 212 | "room" -> Source . RoomId <$> o .: "roomId" 213 | _ -> fail ("unknown source: " ++ messageType) 214 | 215 | instance ToJSON Source where 216 | toJSON (Source (UserId a)) = object ["type" .= String "user", "userId" .= a] 217 | toJSON (Source (GroupId a)) = object ["type" .= String "group", "groupId" .= a] 218 | toJSON (Source (RoomId a)) = object ["type" .= String "room", "roomId" .= a] 219 | 220 | data MessageSource 221 | = MessageSourceUser (Id 'User) 222 | | MessageSourceGroup (Id 'Group) (Id 'User) 223 | | MessageSourceRoom (Id 'Room) (Id 'User) 224 | 225 | deriving instance Show MessageSource 226 | deriving instance Typeable MessageSource 227 | 228 | instance FromJSON MessageSource where 229 | parseJSON = withObject "MessageSource" $ \o -> do 230 | messageType <- o .: "type" 231 | case messageType of 232 | "user" -> MessageSourceUser . UserId <$> o .: "userId" 233 | "group" -> MessageSourceGroup <$> (GroupId <$> o .: "groupId") <*> (UserId <$> o .: "userId") 234 | "room" -> MessageSourceRoom <$> (RoomId <$> o .: "roomId") <*> (UserId <$> o .: "userId") 235 | _ -> fail ("unknown message source: " ++ messageType) 236 | 237 | instance ToJSON MessageSource where 238 | toJSON (MessageSourceUser (UserId a)) = object ["type" .= String "user", "userId" .= a] 239 | toJSON (MessageSourceGroup (GroupId a) (UserId b)) = object ["type" .= String "group", "groupId" .= a, "userId" .= b] 240 | toJSON (MessageSourceRoom (RoomId a) (UserId b)) = object ["type" .= String "room", "roomId" .= a, "userId" .= b] 241 | 242 | newtype Members = Members { members :: [Source] } 243 | deriving (Show, Generic) 244 | 245 | instance FromJSON Members 246 | 247 | data PostbackDateTime = 248 | PostbackDay Day 249 | | PostbackLocalTime LocalTime 250 | | PostbackTimeOfDay TimeOfDay 251 | deriving (Eq, Show) 252 | 253 | instance FromJSON PostbackDateTime where 254 | parseJSON = withObject "PostbackDateTime" $ \o -> 255 | asum 256 | [ PostbackDay <$> o .: "date" 257 | , PostbackLocalTime <$> o .: "datetime" 258 | , PostbackTimeOfDay <$> o .: "time" 259 | ] 260 | 261 | data Postback = Postback Text (Maybe PostbackDateTime) 262 | deriving (Eq, Show) 263 | 264 | instance FromJSON Postback where 265 | parseJSON = withObject "Postback" $ \o -> do 266 | postbackData <- o .: "data" 267 | params <- o .:? "params" 268 | return $ Postback postbackData params 269 | 270 | data BeaconEvent = Enter | Leave | Banner 271 | deriving (Show, Read, Eq, Ord, Generic) 272 | 273 | instance FromJSON BeaconEvent where 274 | parseJSON = genericParseJSON $ 275 | defaultOptions { constructorTagModifier = fmap toLower 276 | , allNullaryToStringTag = True 277 | } 278 | 279 | data Beacon = Beacon 280 | { hwid :: Text 281 | , eventType :: BeaconEvent 282 | , dm :: Maybe Text 283 | } 284 | deriving (Eq, Show, Generic) 285 | 286 | instance FromJSON Beacon where 287 | parseJSON = withObject "Beacon" $ \o -> do 288 | hwid <- o .: "hwid" 289 | eventType <- o .: "type" 290 | dm <- o .:? "dm" 291 | return Beacon{..} 292 | 293 | data AccountLinkResult = Ok | Failed 294 | deriving (Eq, Show, Generic) 295 | 296 | instance FromJSON AccountLinkResult where 297 | parseJSON = genericParseJSON $ 298 | defaultOptions { constructorTagModifier = fmap toLower 299 | , allNullaryToStringTag = True 300 | } 301 | 302 | data AccountLink = AccountLink 303 | { nonce :: Text 304 | , result :: AccountLinkResult 305 | } 306 | deriving (Eq, Show, Generic) 307 | 308 | instance FromJSON AccountLink 309 | 310 | data ThingsEvent = Link | Unlink 311 | deriving (Show, Read, Eq, Ord, Generic) 312 | 313 | instance FromJSON ThingsEvent where 314 | parseJSON = genericParseJSON $ 315 | defaultOptions { constructorTagModifier = fmap toLower 316 | , allNullaryToStringTag = True 317 | } 318 | 319 | data Things = Things 320 | { deviceId :: Text 321 | , eventType :: ThingsEvent 322 | } 323 | deriving (Eq, Show, Generic) 324 | 325 | instance FromJSON Things where 326 | parseJSON = withObject "Things" $ \o -> do 327 | deviceId <- o .: "deviceId" 328 | eventType <- o .: "type" 329 | return Things{..} 330 | 331 | newtype TrackingId = TrackingId 332 | { trackingId :: Text 333 | } 334 | deriving (Eq, Show, Generic) 335 | 336 | instance FromJSON TrackingId where 337 | parseJSON = withObject "TrackingId" $ \o -> do 338 | trackingId <- o .: "trackingId" 339 | return TrackingId{..} 340 | -------------------------------------------------------------------------------- /stack.yaml: -------------------------------------------------------------------------------- 1 | resolver: lts-17.8 2 | allow-newer: false 3 | -------------------------------------------------------------------------------- /test/Line/Bot/ClientSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE OverloadedStrings #-} 4 | {-# LANGUAGE QuasiQuotes #-} 5 | {-# LANGUAGE RecordWildCards #-} 6 | {-# LANGUAGE TypeFamilies #-} 7 | {-# LANGUAGE TypeOperators #-} 8 | {-# LANGUAGE TypeApplications #-} 9 | 10 | module Line.Bot.ClientSpec (spec) where 11 | 12 | import Control.DeepSeq (NFData) 13 | import Control.Monad ((>=>)) 14 | import Control.Monad.Free 15 | import Control.Monad.Trans.Reader (runReaderT) 16 | import Data.Aeson (Value) 17 | import Data.Aeson.QQ 18 | import Data.ByteString as B (stripPrefix) 19 | import Data.Foldable (toList) 20 | import Data.Text.Encoding 21 | import Data.Time.Calendar (fromGregorian) 22 | import Line.Bot.Client hiding (runLine) 23 | import Line.Bot.Internal.Endpoints 24 | import Line.Bot.Types 25 | import Network.HTTP.Client (newManager) 26 | import Network.HTTP.Client.TLS (tlsManagerSettings) 27 | import Network.HTTP.Types (hAuthorization) 28 | import Network.Wai as Wai (Request, 29 | requestHeaders) 30 | import Network.Wai.Handler.Warp (Port, withApplication) 31 | import Servant 32 | import Servant.Client.Core 33 | import Servant.Client.Free as F 34 | import Servant.Client.Streaming 35 | import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, 36 | mkAuthHandler) 37 | import Test.Hspec 38 | import Test.Hspec.Expectations.Contrib 39 | 40 | type ChannelAuth = AuthProtect "channel-token" 41 | type instance AuthServerData ChannelAuth = ChannelToken 42 | 43 | -- a dummy auth handler that returns the channel access token 44 | authHandler :: AuthHandler Wai.Request ChannelToken 45 | authHandler = mkAuthHandler $ \request -> 46 | case lookup hAuthorization (Wai.requestHeaders request) >>= B.stripPrefix "Bearer " of 47 | Nothing -> throwError $ err401 { errBody = "Bad" } 48 | Just t -> return $ ChannelToken $ decodeUtf8 t 49 | 50 | serverContext :: Context '[AuthHandler Wai.Request ChannelToken] 51 | serverContext = authHandler :. EmptyContext 52 | 53 | type API = GetProfile' Value 54 | :<|> GetGroupMemberProfile' Value 55 | :<|> GetRoomMemberProfile' Value 56 | 57 | getReplyMessageCountF :: LineDate -> Free ClientF MessageCount 58 | getReplyMessageCountF = F.client (Proxy @GetReplyMessageCount) 59 | 60 | getPushMessageCountF :: LineDate -> Free ClientF MessageCount 61 | getPushMessageCountF = F.client (Proxy @GetPushMessageCount) 62 | 63 | getMulticastMessageCountF :: LineDate -> Free ClientF MessageCount 64 | getMulticastMessageCountF = F.client (Proxy @GetMulticastMessageCount) 65 | 66 | testProfile :: Value 67 | testProfile = [aesonQQ| 68 | { 69 | displayName: "LINE taro", 70 | userId: "U4af4980629...", 71 | pictureUrl: "https://obs.line-apps.com/...", 72 | statusMessage: "Hello, LINE!" 73 | } 74 | |] 75 | 76 | withPort :: Port -> (ClientEnv -> IO a) -> IO a 77 | withPort port app = do 78 | manager <- newManager tlsManagerSettings 79 | app $ mkClientEnv manager $ BaseUrl Http "localhost" port "" 80 | 81 | token :: ChannelToken 82 | token = "fake" 83 | 84 | runLine :: NFData a => Line a -> Port -> IO (Either ClientError a) 85 | runLine comp port = withPort port $ \env -> runClientM (runReaderT comp token) env 86 | 87 | app :: Application 88 | app = serveWithContext (Proxy :: Proxy API) serverContext $ 89 | (\_ -> return testProfile) 90 | :<|> (\_ _ -> return testProfile) 91 | :<|> (\_ _ -> return testProfile) 92 | 93 | spec :: Spec 94 | spec = describe "Line client" $ do 95 | it "should return user profile" $ 96 | withApplication (pure app) $ 97 | runLine (getProfile "1") >=> (`shouldSatisfy` isRight) 98 | 99 | it "should return group user profile" $ 100 | withApplication (pure app) $ 101 | runLine (getGroupMemberProfile "1" "1") >=> (`shouldSatisfy` isRight) 102 | 103 | it "should return room user profile" $ 104 | withApplication (pure app) $ 105 | runLine (getRoomMemberProfile "1" "1") >=> (`shouldSatisfy` isRight) 106 | 107 | it "should send `date` query param for push message count" $ do 108 | let Free (RunRequest Request{..} _) = getPushMessageCountF date 109 | toList requestQueryString `shouldBe` [("date", Just "20190407")] 110 | 111 | it "should send `date` query param for reply message count" $ do 112 | let Free (RunRequest Request{..} _) = getReplyMessageCountF date 113 | toList requestQueryString `shouldBe` [("date", Just "20190407")] 114 | 115 | it "should send `date` query param for multicast message count" $ do 116 | let Free (RunRequest Request{..} _) = getMulticastMessageCountF date 117 | toList requestQueryString `shouldBe` [("date", Just "20190407")] 118 | where 119 | date = LineDate $ fromGregorian 2019 4 7 120 | 121 | -------------------------------------------------------------------------------- /test/Line/Bot/WebhookSpec.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DataKinds #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE QuasiQuotes #-} 4 | {-# LANGUAGE TypeOperators #-} 5 | 6 | module Line.Bot.WebhookSpec (spec) where 7 | 8 | import qualified Crypto.Hash.SHA256 as SHA256 9 | import Data.Aeson (Value, encode) 10 | import Data.Aeson.QQ 11 | import Data.Aeson.Types (emptyObject) 12 | import qualified Data.ByteString.Base64 as Base64 13 | import Line.Bot.Types (ChannelSecret (..)) 14 | import Line.Bot.Webhook (Webhook) 15 | import Line.Bot.Webhook.Events (Events) 16 | import Network.HTTP.Types (HeaderName, hContentType) 17 | import Network.HTTP.Types.Method 18 | import Network.HTTP.Types.Status 19 | import Servant 20 | import Servant.Server (Context ((:.), EmptyContext)) 21 | import Test.Hspec hiding (context) 22 | import Test.Hspec.Wai 23 | 24 | hSignature :: HeaderName 25 | hSignature = "X-Line-Signature" 26 | 27 | secret :: ChannelSecret 28 | secret = "shhhh" 29 | 30 | context :: Context (ChannelSecret ': '[]) 31 | context = secret :. EmptyContext 32 | 33 | app :: Application 34 | app = serveWithContext (Proxy :: Proxy Webhook) context webhook 35 | 36 | webhook :: Server Webhook 37 | webhook = handleEvents 38 | 39 | handleEvents :: Events -> Handler NoContent 40 | handleEvents _ = return NoContent 41 | 42 | testBody :: Value 43 | testBody = [aesonQQ| 44 | { 45 | destination: "xxxxxxxxxx", 46 | events: [ 47 | { 48 | replyToken: "8cf9239d56244f4197887e939187e19e", 49 | type: "follow", 50 | timestamp: 1462629479859, 51 | source: { 52 | type: "user", 53 | userId: "U4af4980629..." 54 | } 55 | } 56 | ] 57 | } 58 | |] 59 | 60 | spec :: Spec 61 | spec = with (pure app) $ 62 | describe "Webhook server" $ do 63 | 64 | it "should return 200 with a signed request" $ do 65 | let body = encode testBody 66 | digest = Base64.encode $ SHA256.hmaclazy (unChannelSecret secret) body 67 | headers = [(hContentType, "application/json"), (hSignature, digest)] 68 | 69 | request methodPost "/" headers body `shouldRespondWith` 200 70 | 71 | it "should return 400 for an invalid body" $ do 72 | let body = encode emptyObject 73 | digest = Base64.encode $ SHA256.hmaclazy (unChannelSecret secret) body 74 | headers = [(hContentType, "application/json"), (hSignature, digest)] 75 | 76 | request methodPost "/" headers body `shouldRespondWith` 400 77 | 78 | it "should return 401 for requests missing the signature header" $ do 79 | let body = encode testBody 80 | headers = [(hContentType, "application/json")] 81 | 82 | request methodPost "/" headers body `shouldRespondWith` 401 83 | 84 | it "should return 401 when secret is incorrect" $ do 85 | let body = encode testBody 86 | digest = Base64.encode $ SHA256.hmaclazy "incorrect" body 87 | headers = [(hContentType, "application/json"), (hSignature, digest)] 88 | 89 | request methodPost "/" headers body `shouldRespondWith` 401 90 | -------------------------------------------------------------------------------- /test/Spec.hs: -------------------------------------------------------------------------------- 1 | {-# OPTIONS_GHC -F -pgmF hspec-discover #-} 2 | --------------------------------------------------------------------------------