line (empty) → 1.0.0.0
raw patch · 11 files changed
+1222/−0 lines, 11 filesdep +aesondep +basedep +base64-bytestringsetup-changed
Dependencies added: aeson, base, base64-bytestring, bytestring, cryptohash-sha256, http-types, lens, line, text, time, transformers, wai, wreq
Files
- LICENSE +30/−0
- Setup.hs +2/−0
- line.cabal +65/−0
- src/Line/Messaging/API.hs +208/−0
- src/Line/Messaging/API/Types.hs +495/−0
- src/Line/Messaging/Common/Types.hs +32/−0
- src/Line/Messaging/Types.hs +16/−0
- src/Line/Messaging/Webhook.hs +82/−0
- src/Line/Messaging/Webhook/Types.hs +253/−0
- src/Line/Messaging/Webhook/Validation.hs +37/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -0,0 +1,30 @@+Copyright Jun (c) 2016++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 Jun 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.
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ line.cabal view
@@ -0,0 +1,65 @@+name: line+version: 1.0.0.0+synopsis: Haskell SDK for the LINE API+homepage: https://github.com/noraesae/line+license: BSD3+license-file: LICENSE+author: Jun+maintainer: Jun <me@noraesae.net>+copyright: (c) 2016 Jun <me@noraesae.net>+category: Network+build-type: Simple+cabal-version: >=1.10+description:+ This package exports bindings to LINE APIs.+ .+ It provides the following features:+ .+ * Internal auth signature validator+ .+ * Webhook handled with handler function or WAI application+ .+ * Functions and types for <https://devdocs.line.me/en/#messaging-api LINE Messaging API>+ .+ For example usages, please see the+ <https://github.com/noraesae/line/tree/master/examples examples> directory.++library+ hs-source-dirs: src+ ghc-options: -Wall+ exposed-modules: Line.Messaging.API+ Line.Messaging.API.Types+ Line.Messaging.Common.Types+ Line.Messaging.Types+ Line.Messaging.Webhook+ Line.Messaging.Webhook.Types+ Line.Messaging.Webhook.Validation+ build-depends: base >= 4.7 && < 5+ , wai+ , http-types+ , aeson+ , bytestring+ , text+ , transformers+ , cryptohash-sha256+ , base64-bytestring+ , time+ , wreq+ , lens+ default-language: Haskell2010+ default-extensions: OverloadedStrings+++test-suite line-test+ type: exitcode-stdio-1.0+ hs-source-dirs: test+ main-is: Spec.hs+ build-depends: base+ , line+ ghc-options: -threaded -rtsopts -with-rtsopts=-N+ default-language: Haskell2010+ default-extensions: OverloadedStrings++source-repository head+ type: git+ location: https://github.com/noraesae/line
+ src/Line/Messaging/API.hs view
@@ -0,0 +1,208 @@+{-|+This module provides functions corresponding to the LINE Messaging APIs, nearly+one on one.++For more details about the APIs themselves, please refer to the+<https://devdocs.line.me/en/#messaging-api API references>.+-}++module Line.Messaging.API (+ -- * Types+ -- | Re-exported for convenience.+ module Line.Messaging.API.Types,+ -- * Monad transformer for APIs+ APIIO,+ runAPI,+ -- * LINE Messaging APIs+ -- | Every API call returns its result with @'APIIO'@. About the usage of+ -- @'APIIO'@, please refer to the previous section.+ push,+ reply,+ getContent,+ getProfile,+ leaveRoom,+ leaveGroup,+ ) where++import Control.Exception (SomeException(..))+import Control.Lens ((&), (.~), (^.))+import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Class (lift)+import Control.Monad.Trans.Reader (runReaderT, ReaderT, ask)+import Control.Monad.Trans.Except (runExceptT, ExceptT, throwE, catchE)+import Data.Aeson (ToJSON(..), (.=), object, decode', eitherDecode')+import Data.Text.Encoding (encodeUtf8)+import Line.Messaging.API.Types+import Line.Messaging.Types (ChannelAccessToken, ReplyToken)+import qualified Data.ByteString as B+import qualified Data.ByteString.Lazy as BL+import qualified Data.Text as T+import qualified Network.Wreq as Wr++-- | A monad transformer for API calls. If translated into a human-readable+-- form, it means:+--+-- 1. An API call needs a channel access token to specify through which+-- channel it should send the call (@'ReaderT' 'ChannelAccessToken'@).+-- 2. An API call effectfully returns a result if successful, @'APIError'@+-- otherwise (@'ExceptT' 'APIError'@).+type APIIO a = ReaderT ChannelAccessToken (ExceptT APIError IO) a++-- | 'runAPI' resolves the 'APIIO' monad transformer, and turns it into a plain+-- @'IO'@ with @'ChannelAccessToken'@ provided.+--+-- The reason the type of the first parameter is not @'ChannelAccessToken'@, but+-- @'IO' 'ChannelAccessToken'@, is that it is usually loaded via effectful+-- actions such as parsing command line arguments or reading a config file.+--+-- An example usage is like below:+--+-- @+-- api :: APIIO a -> IO (Either APIError a)+-- api = runAPI getChannelAccessTokenFromConfig+--+-- main :: IO ()+-- main = do+-- result <- api $ push "some_receiver_id" [ Message $ Text "Hello, world!" ]+-- case result of+-- Right _ -> return ()+-- Left err -> print err+-- @+runAPI :: IO ChannelAccessToken -> APIIO a -> IO (Either APIError a)+runAPI getToken api = getToken >>= runExceptT . runReaderT api++getOpts :: APIIO Wr.Options+getOpts = do+ token <- encodeUtf8 <$> ask+ return $ Wr.defaults & Wr.header "Authorization" .~ [ "Bearer " `B.append` token ]+ & Wr.checkStatus .~ Just (\ _ _ _ -> Nothing) -- do not throw StatusCodeException++handleError :: SomeException -> (ExceptT APIError IO) a+handleError = throwE . UndefinedError++runReqIO :: IO (Wr.Response BL.ByteString) -> APIIO BL.ByteString+runReqIO reqIO = lift $ do+ res <- liftIO reqIO `catchE` handleError+ let statusCode = res ^. Wr.responseStatus . Wr.statusCode+ let body = res ^. Wr.responseBody+ case statusCode of+ 200 -> return $ body+ 400 -> throwE $ BadRequest (decode' body)+ 401 -> throwE $ Unauthorized (decode' body)+ 403 -> throwE $ Forbidden (decode' body)+ 429 -> throwE $ TooManyRequests (decode' body)+ 500 -> throwE $ InternalServerError (decode' body)+ _ -> throwE $ UndefinedStatusCode statusCode body++get :: String -> APIIO BL.ByteString+get url = do+ opts <- getOpts+ runReqIO $ Wr.getWith opts url++post :: ToJSON a => String -> a -> APIIO BL.ByteString+post url body = do+ opts <- getOpts+ runReqIO $ Wr.postWith opts url (toJSON body)++-- | Push messages into a receiver. The receiver can be a user, a room or+-- a group, specified by 'ID'.+--+-- A 'Message' represents a message object. For types of the message object,+-- please refer to the <https://devdocs.line.me/en/#send-message-object Send message object>+-- section of the LINE documentation.+--+-- An example usage of 'Message' is like below:+--+-- @+-- messages :: [Message]+-- messages = [ Message $ 'Image' imageURL previewURL+-- , Message $ 'Text' "hello, world!"+-- , Message $ 'Template' "an example template"+-- Confirm "a confirm template"+-- [ TplMessageAction "ok label" "print this"+-- , TplURIAction "link label" linkURL+-- ]+-- ]+-- @+--+-- For more information about the API, please refer to+-- <https://devdocs.line.me/en/#push-message the API reference>.+push :: ID -> [Message] -> APIIO ()+push id' ms = do+ let url = "https://api.line.me/v2/bot/message/push"+ _ <- post url $ object [ "to" .= id'+ , "messages" .= map toJSON ms+ ]+ return ()++-- | Send messages as a reply to specific webhook event.+--+-- It works similarly to how 'push' does for messages, except that it can only+-- reply through a specific reply token. The token can be obtained from+-- <./Line-Messaging-Webhook-Types.html#t:ReplyableEvent replyable events> on a webhook server.+--+-- For more information, please refer to+-- <https://devdocs.line.me/en/#reply-message its API reference>.+reply :: ReplyToken -> [Message] -> APIIO ()+reply replyToken ms = do+ let url = "https://api.line.me/v2/bot/message/reply"+ _ <- post url $ object [ "replyToken" .= replyToken+ , "messages" .= map toJSON ms+ ]+ return ()++-- | Get content body of images, videos and audios sent with+-- <./Line-Messaging-Webhook-Types.html#t:EventMessage event messages>,+-- specified by 'ID'.+--+-- In the event messages, the content body is not included. Users should use+-- 'getContent' to downloaded the content only when it is really needed.+--+-- For more information, please refer to+-- <https://devdocs.line.me/en/#get-content its API reference>.+getContent :: ID -> APIIO BL.ByteString+getContent id' = do+ let url = concat [ "https://api.line.me/v2/bot/message/"+ , T.unpack id'+ , "/content"+ ]+ get url++-- | Get a profile of a user, specified by 'ID'.+--+-- The user identifier can be obtained via <./Line-Messaging-Webhook-Types.html#t:EventSource EventSource>.+--+-- For more information, please refer to+-- <https://devdocs.line.me/en/#bot-api-get-profile its API reference>.+getProfile :: ID -> APIIO Profile+getProfile id' = do+ let url = "https://api.line.me/v2/bot/profile/" ++ T.unpack id'+ bs <- get url+ case eitherDecode' bs of+ Right profile -> return profile+ Left errStr -> lift . throwE . JSONDecodeError $ errStr++leave :: String -> ID -> APIIO ()+leave type' id' = do+ let url = concat [ "https://api.line.me/v2/bot/"+ , type'+ , "/"+ , T.unpack id'+ , "/leave"+ ]+ _ <- post url ("" :: T.Text)+ return ()++-- | Leave a room, specified by @'ID'@.+--+-- For more information, please refer to+-- <https://devdocs.line.me/en/#leave its API reference>.+leaveRoom :: ID -> APIIO ()+leaveRoom = leave "room"++-- | Leave a group, specified by @'ID'@.+--+-- For more information, please refer to+-- <https://devdocs.line.me/en/#leave its API reference>.+leaveGroup :: ID -> APIIO ()+leaveGroup = leave "group"
+ src/Line/Messaging/API/Types.hs view
@@ -0,0 +1,495 @@+{-|+This module provides types to be used with "Line.Messaging.API".+-}++{-# LANGUAGE ExistentialQuantification #-}+{-# LANGUAGE FlexibleInstances #-}+{-# LANGUAGE StandaloneDeriving #-}++module Line.Messaging.API.Types (+ -- * Common types+ -- | Re-exported for convenience.+ module Line.Messaging.Common.Types,+ -- * Message types+ Messageable,+ Message (..),+ -- ** Text+ Text (..),+ -- ** Image+ Image (..),+ -- ** Video+ Video (..),+ -- ** Audio+ Audio (..),+ -- ** Location+ Location (..),+ -- ** Sticker+ Sticker (..),+ -- ** Image map+ ImageMap (..),+ ImageMapAction (..),+ ImageMapArea,+ -- ** Template+ Template (..),+ Buttons (..),+ Confirm (..),+ Carousel (..),+ Column (..),+ Label,+ TemplateAction (..),+ -- * Profile+ Profile (..),+ -- * Error types+ APIError (..),+ APIErrorBody (..),+ ) where++import Control.Applicative ((<|>))+import Control.Exception (SomeException)+import Data.Aeson (FromJSON(..), ToJSON(..), Value(..), object, (.:), (.=))+import Data.Aeson.Types (Pair)+import Line.Messaging.Common.Types+import qualified Data.Text as T+import qualified Data.ByteString.Lazy as BL++-- | A type class representing types to be converted into 'Message'.+--+-- It has @toType@ and @toObject@ as its minimal complete definition, but it+-- is not recommended to define any extra instance, as the new type may not work+-- with the LINE APIs.+--+-- About existing messageable types, please refer to the following instances.+-- Each instance is matched with a message object described in+-- <https://devdocs.line.me/en/#send-message-object the LINE documentation>.+class Messageable a where+ toType :: a -> T.Text+ toObject :: a -> [Pair]++ toValue :: a -> Value+ toValue a = object $ ("type" .= toType a) : toObject a++-- | A type representing a message to be sent.+--+-- The data constructor converts 'Messageable' into 'Message'. It allows+-- different types of 'Messageable' to be sent through a single API call.+--+-- An example usage is like below.+--+-- @+-- pushTextAndImage :: ID -> APIIO ()+-- pushTextAndImage identifier = push identifier [+-- Message $ 'Text' "hello",+-- Message $ 'Image' "https://example.com/image.jpg" "https://example.com/preview.jpg"+-- ]+-- @+data Message = forall a. (Show a, Messageable a) => Message a++deriving instance Show Message++instance ToJSON Message where+ toJSON (Message m) = toValue m++-- | 'Messageable' for text data.+--+-- It contains 'T.Text' of "Data.Text". Its corresponding JSON spec is described+-- <https://devdocs.line.me/en/#text here>.+--+-- This type is also used to decode text event message from webhook request.+-- About the webhook usage, please refer to+-- <./Line-Messaging-Webhook-Types.html#t:EventMessage EventMessage> in+-- "Line.Messaging.Webhook.Types".+newtype Text = Text { getText :: T.Text }+ deriving (Eq, Ord, Show)++instance FromJSON Text where+ parseJSON (Object v) = Text <$> v .: "text"+ parseJSON (String text) = return $ Text text+ parseJSON _ = fail "Text"++instance Messageable Text where+ toType _ = "text"+ toObject (Text text) = [ "text" .= text ]++-- | 'Messageable' for image data.+--+-- It contains URLs of an original image and its preview. Its corresponding JSON+-- spec is described <https://devdocs.line.me/en/#image here>.+data Image = Image { getImageURL :: URL+ , getImagePreviewURL :: URL+ }+ deriving (Eq, Show)++instance Messageable Image where+ toType _ = "image"+ toObject (Image original preview) = [ "originalContentUrl" .= original+ , "previewImageUrl" .= preview+ ]++-- | 'Messageable' for video data.+--+-- It contains URLs of an original video and its preview. Its corresponding JSON+-- spec is described <https://devdocs.line.me/en/#video here>.+data Video = Video { getVideoURL :: URL+ , getVideoPreviewURL :: URL+ }+ deriving (Eq, Show)++instance Messageable Video where+ toType _ = "video"+ toObject (Video original preview) = [ "originalContentUrl" .= original+ , "previewImageUrl" .= preview+ ]++-- | 'Messageable' for audio data.+--+-- It contains a URL of an audio, and its duration in milliseconds. Its+-- corresponding JSON spec is described+-- <https://devdocs.line.me/en/#audio here>.+data Audio = Audio { getAudioURL :: URL+ , getAudioDuration :: Integer+ }+ deriving (Eq, Show)++instance Messageable Audio where+ toType _ = "audio"+ toObject (Audio original duration) = [ "originalContentUrl" .= original+ , "duration" .= duration+ ]++-- | 'Messageable' for location data.+--+-- It contains a title, address, and geographic coordination of a location.+-- Its corresponding JSON spec is described+-- <https://devdocs.line.me/en/#location here>.+--+-- This type is also used to decode location event message from webhook request.+-- About the webhook usage, please refer to+-- <./Line-Messaging-Webhook-Types.html#t:EventMessage EventMessage> in+-- "Line.Messaging.Webhook.Types".+data Location = Location { getLocationTitle :: T.Text+ , getAddress :: T.Text+ , getLatitude :: Double+ , getLongitude :: Double+ }+ deriving (Eq, Show)++instance FromJSON Location where+ parseJSON (Object v) = Location <$> v .: "title"+ <*> v .: "address"+ <*> v .: "latitude"+ <*> v .: "longitude"+ parseJSON _ = fail "Location"++instance Messageable Location where+ toType _ = "location"+ toObject (Location title address latitude longitude) = [ "title" .= title+ , "address" .= address+ , "latitude" .= latitude+ , "longitude" .= longitude+ ]++-- | 'Messageable' for sticker data.+--+-- It contains its package and sticker ID. Its corresponding JSON spec is+-- described <https://devdocs.line.me/en/#sticker here>.+--+-- This type is also used to decode sticker event message from webhook request.+-- About the webhook usage, please refer to+-- <./Line-Messaging-Webhook-Types.html#t:EventMessage EventMessage> in+-- "Line.Messaging.Webhook.Types".+data Sticker = Sticker { getPackageID :: ID+ , getStickerID :: ID+ }+ deriving (Eq, Show)++instance FromJSON Sticker where+ parseJSON (Object v) = Sticker <$> v .: "packageId"+ <*> v .: "stickerId"+ parseJSON _ = fail "Sticker"++instance Messageable Sticker where+ toType _ = "sticker"+ toObject (Sticker packageId stickerId) = [ "packageId" .= packageId+ , "stickerId" .= stickerId+ ]++-- | 'Messageable' for image map data.+--+-- About how to send an image map message and what each field means, please+-- refer to+-- <https://devdocs.line.me/en/#imagemap-message image map message spec>.+data ImageMap = ImageMap { getBaseImageURL :: URL+ -- ^ <https://devdocs.line.me/en/#base-url Base URL> of images+ , getIMAltText :: T.Text+ -- ^ Alt text for devices not supporting image map+ , getBaseImageSize :: (Integer, Integer)+ -- ^ Image size tuple, (width, height) specifically.+ -- The width to be set to 1040, the height to be set to+ -- the value corresponding to a width of 1040.+ , getIMActions :: [ImageMapAction]+ -- ^ Actions to be executed when each area is tapped+ }+ deriving (Eq, Show)++instance Messageable ImageMap where+ toType _ = "imagemap"+ toObject (ImageMap url alt (w, h) as) = [ "baseUrl" .= url+ , "altText" .= alt+ , "baseSize" .= object [ "width" .= w+ , "height" .= h+ ]+ , "actions" .= toJSON as+ ]++-- | A type representing actions when a specific area of an image map is tapped.+--+-- It contains action data and area information.+data ImageMapAction = IMURIAction URL ImageMapArea+ -- ^ Open a web page when an area is tapped.+ | IMMessageAction T.Text ImageMapArea+ -- ^ Send a text message from the user who tapped an area.+ deriving (Eq, Show)++instance ToJSON ImageMapAction where+ toJSON (IMURIAction uri area) = object [ "type" .= ("uri" :: T.Text)+ , "linkUri" .= uri+ , "area" .= toAreaJSON area+ ]+ toJSON (IMMessageAction text area) = object [ "type" .= ("message" :: T.Text)+ , "text" .= text+ , "area" .= toAreaJSON area+ ]++-- | A type representing a tappable area in an image map+--+-- Each component means (x, y, width, height) correspondingly.+type ImageMapArea = (Integer, Integer, Integer, Integer)++toAreaJSON :: ImageMapArea -> Value+toAreaJSON (x, y, w, h) = object [ "x" .= x, "y" .= y, "width" .= w, "height" .= h ]++-- | 'Messageable' for template data.+--+-- It has a type parameter @t@ which means a template content type. The type is+-- polymolphic, but 'Messageable' instances are defined only for 'Buttons',+-- 'Confirm', and 'Carousel'.+--+-- About how to send template message and what each field means, please+-- refer to+-- <https://devdocs.line.me/en/#template-messages template message spec>.+data Template t = Template { getTemplateAltText :: T.Text+ -- ^ Alt text for devices not supporting template message+ , getTemplate :: t+ -- ^ Template content type+ }+ deriving (Eq, Show)++templateType :: Template a -> T.Text+templateType _ = "template"++templateToObject :: ToJSON a => Template a -> [Pair]+templateToObject (Template alt a) = [ "altText" .= alt+ , "template" .= toJSON a+ ]++instance Messageable (Template Buttons) where+ toType = templateType+ toObject = templateToObject++instance Messageable (Template Confirm) where+ toType = templateType+ toObject = templateToObject++instance Messageable (Template Carousel) where+ toType = templateType+ toObject = templateToObject++-- | The buttons content type for template message.+--+-- <<https://devdocs.line.me/images/buttons.png Buttons template>>+--+-- For more details of each field, please refer to the+-- <https://devdocs.line.me/en/#buttons Buttons> section in the LINE+-- documentation.+data Buttons = Buttons { getButtonsThumbnailURL :: URL+ -- ^ URL for thumbnail image+ , getButtonsTitle :: T.Text+ -- ^ Title text+ , getButtonsText :: T.Text+ -- ^ Description text+ , getButtonsActions :: [TemplateAction]+ -- ^ A list of template actions, each of which represents+ -- a button (max: 4)+ }+ deriving (Eq, Show)++instance ToJSON Buttons where+ toJSON (Buttons url title text actions) = object [ "type" .= ("buttons" :: T.Text)+ , "thumbnailImageUrl" .= url+ , "title" .= title+ , "text" .= text+ , "actions" .= toJSON actions+ ]++-- | The confirm content type for template message.+--+-- <<https://devdocs.line.me/images/confirm.png Confirm template>>+--+-- For more details of each field, please refer to the+-- <https://devdocs.line.me/en/#confirm Confirm> section in the LINE+-- documentation.+data Confirm = Confirm { getConfirmText :: T.Text+ -- ^ Confirm text+ , getConfirmActions :: [TemplateAction]+ -- ^ A list of template actions, each of which represents+ -- a button (max: 2)+ }+ deriving (Eq, Show)++instance ToJSON Confirm where+ toJSON (Confirm text actions) = object [ "type" .= ("confirm" :: T.Text)+ , "text" .= text+ , "actions" .= toJSON actions+ ]++-- | The carousel content type for template message.+--+-- <<https://devdocs.line.me/images/carousel.png Carousel template>>+--+-- For more details of each field, please refer to the+-- <https://devdocs.line.me/en/#carousel Carousel> section in the LINE+-- documentation.+data Carousel = Carousel { getColumns :: [Column]+ -- ^ A list of columns for a carousel template+ }+ deriving (Eq, Show)++instance ToJSON Carousel where+ toJSON (Carousel columns) = object [ "type" .= ("carousel" :: T.Text)+ , "columns" .= toJSON columns+ ]++-- | Actual contents of carousel template.+--+-- It has the same fields as 'Buttons', except that the number of actions is+-- up to 3.+data Column = Column { getColumnThumbnailURL :: URL+ -- ^ URL for thumbnail image+ , getColumnTitle :: T.Text+ -- ^ Title text+ , getColumnText :: T.Text+ -- ^ Description text+ , getColumnActions :: [TemplateAction]+ -- ^ A list of template actions, each of which represents+ -- a button (max: 3)+ }+ deriving (Eq, Show)++instance ToJSON Column where+ toJSON (Column url title text actions) = object [ "thumbnailImageUrl" .= url+ , "title" .= title+ , "text" .= text+ , "actions" .= toJSON actions+ ]++-- | Just a type alias for 'T.Text', used with 'TemplateAction'.+type Label = T.Text++-- | A data type for possible template actions.+--+-- Each action object represents a button in template message. A button has a+-- label and an actual action fired by click.+data TemplateAction = TplMessageAction Label T.Text+ -- ^ Message action. When clicked, a specified text will+ -- be sent into the same room by a user who clicked the+ -- button.+ | TplPostbackAction Label Postback T.Text+ -- ^ Postback action. When clicked, a specified text will+ -- be sent, and postback data will be sent to webhook+ -- server as a postback event.+ | TplURIAction Label URL+ -- ^ URI action. When clicked, a web page with a specified+ -- URI will open in the in-app browser.+ deriving (Eq, Show)++instance ToJSON TemplateAction where+ toJSON (TplPostbackAction label data' text) = object [ "type" .= ("postback" :: T.Text)+ , "label" .= label+ , "data" .= data'+ , "text" .= text+ ]+ toJSON (TplMessageAction label text) = object [ "type" .= ("message" :: T.Text)+ , "label" .= label+ , "text" .= text+ ]+ toJSON (TplURIAction label uri) = object [ "type" .= ("uri" :: T.Text)+ , "label" .= label+ , "uri" .= uri+ ]++-- | A type to represent a user's profile.+--+-- It is the return type of the <./Line-Messaging-API.html#v:getProfile getProfile>+-- API in the "Line.Messaging.API" module.+data Profile = Profile { getUserID :: ID+ , getDisplayName :: T.Text+ , getPictureURL :: Maybe URL+ , getStatusMessage :: Maybe T.Text+ }+ deriving (Eq, Show)++instance FromJSON Profile where+ parseJSON (Object v) = Profile <$> v .: "userId"+ <*> v .: "displayName"+ <*> v .: "pictureUrl"+ <*> v .: "statusMessage"+ parseJSON _ = fail "Profile"++-- | An error type possibly returned from the+-- @<./Line-Messaging-API.html#t:APIIO APIIO>@ type.+--+-- State code errors may contain a parsed error body. Other types of errors,+-- which may rarely occur if used properly, does not.+--+-- For more details of error types, please refer to+-- <https://devdocs.line.me/en/#status-codes Status codes> and+-- <https://devdocs.line.me/en/#error-response Error response> sections in the+-- LINE documentation.+data APIError = BadRequest (Maybe APIErrorBody)+ -- ^ 400 Bad Request with a parsed error body, caused by badly+ -- formatted request.+ | Unauthorized (Maybe APIErrorBody)+ -- ^ 401 Unauthorized with a parsed error body, caused by invalid+ -- access token.+ | Forbidden (Maybe APIErrorBody)+ -- ^ 403 Forbidden with a parsed error body, caused by+ -- unauthorized account or plan.+ | TooManyRequests (Maybe APIErrorBody)+ -- ^ 429 Too Many Requests with a parsed error body, caused by+ -- exceeding the <https://devdocs.line.me/en/#rate-limits rate limit>.+ | InternalServerError (Maybe APIErrorBody)+ -- ^ 500 Internal Server Error with a parsed error body.+ | UndefinedStatusCode Int BL.ByteString+ -- ^ Caused by status codes other than 200 and listed statuses+ -- above, with the status code and request body.+ | JSONDecodeError String+ -- ^ Caused by badly formatted response body from APIs.+ | UndefinedError SomeException+ -- ^ Any other exception caught as 'SomeException'.+ deriving Show++-- | An error body type.+--+-- It contains error message, and may contain property information and detailed+-- error bodies.+data APIErrorBody = APIErrorBody { getErrorMessage :: T.Text+ , getErrorProperty :: Maybe T.Text+ , getErrorDetails :: Maybe [APIErrorBody]+ }+ deriving Show++instance FromJSON APIErrorBody where+ parseJSON (Object v) = APIErrorBody <$> v .: "message"+ <*> (v .: "property" <|> return Nothing)+ <*> (v .: "details" <|> return Nothing)+ parseJSON _ = fail "APIErrorBody"
+ src/Line/Messaging/Common/Types.hs view
@@ -0,0 +1,32 @@+{-|+This module is to define aliases commonly used in other modules.+-}++module Line.Messaging.Common.Types (+ -- * General types+ ID,+ URL,+ -- * LINE API types+ ChannelSecret,+ ChannelAccessToken,+ Postback,+ ) where++import qualified Data.Text as T++-- | A type alias to specify an identifier of something.+type ID = T.Text++-- | A type alias to specify a URL.+type URL = T.Text++-- | A type alias to specify a channel secret. About issueing and using the+-- channel secret, please refer to corresponding LINE documentations.+type ChannelSecret = T.Text++-- | A type alias to specify a channel access token. About issueing and using+-- the channel access token, please refer to corresponding LINE documentations.+type ChannelAccessToken = T.Text++-- | A type alias for postback data.+type Postback = T.Text
+ src/Line/Messaging/Types.hs view
@@ -0,0 +1,16 @@+{-|+This module just re-exports other @Types@ modules.+-}++module Line.Messaging.Types (+ -- * Common types+ module Line.Messaging.Common.Types,+ -- * API types+ module Line.Messaging.API.Types,+ -- * Webhook types+ module Line.Messaging.Webhook.Types,+ ) where++import Line.Messaging.API.Types+import Line.Messaging.Common.Types+import Line.Messaging.Webhook.Types
+ src/Line/Messaging/Webhook.hs view
@@ -0,0 +1,82 @@+{-|+This module provides webhook handlers both general and WAI-specific.+-}++module Line.Messaging.Webhook (+ -- * Types+ -- | Re-exported for convenience.+ module Line.Messaging.Webhook.Types,+ -- * Basic webhook+ webhook,+ -- * Webhook as a WAI application+ webhookApp,+ defaultOnFailure,+ ) where++import Control.Monad.IO.Class (liftIO)+import Control.Monad.Trans.Except (ExceptT, throwE, runExceptT)+import Data.Aeson (decode')+import Data.ByteString.Builder (string8)+import Line.Messaging.Webhook.Types+import Line.Messaging.Webhook.Validation (validateSignature)+import Line.Messaging.Types (ChannelSecret)+import Network.HTTP.Types.Status+import Network.Wai++-- | A basic webhook function. It validates a request with a channel secret,+-- and parses the request into a list of webhook events.+--+-- To handle failures, the result is in the form of @'ExceptT' 'WebhookFailure'@.+webhook :: ChannelSecret+ -> Request+ -> ExceptT WebhookFailure IO [Event]+webhook secret req = do+ body <- liftIO $ lazyRequestBody req+ if not $ validateSignature secret req body+ then throwE SignatureVerificationFailed+ else do+ case decode' body of+ Nothing -> throwE MessageDecodeFailed+ Just (Body events) -> return events++waiResponse :: WebhookResult -> Application+waiResponse result req f = case result of+ Ok -> f $ responseBuilder status200 [] ""+ WaiResponse res -> f res+ WaiApp app -> app req f++-- | A webhook handler for WAI. It uses 'webhook' internally and returns a WAI+-- 'Application'.+--+-- An example webhook server using WAI will be like below:+--+-- @+-- app :: Application+-- app req f = case pathInfo req of+-- "webhook" : _ -> do+-- secret <- getChannelSecret+-- webhookApp secret handler defaultOnFailure req f+-- _ -> undefined+--+-- handler :: [Event] -> IO WebhookResult+-- handler events = forM_ events handleEvent $> Ok+--+-- handleEvent :: Event -> IO ()+-- handleEvent (MessageEvent event) = undefined -- handle a message event+-- handleEvent _ = return ()+-- @+webhookApp :: ChannelSecret -- ^ Channel secret+ -> ([Event] -> IO WebhookResult) -- ^ Event handler+ -> (WebhookFailure -> Application) -- ^ Error handler. Just to return 400 for failures, use 'defaultOnFailure'.+ -> Application+webhookApp secret handler failHandler req f = do+ result <- runExceptT $ webhook secret req+ case result of+ Right events -> handler events >>= waiResponse <*> pure req <*> pure f+ Left exception -> failHandler exception req f++-- | A basic error handler to be used with 'webhookApp'. It returns 400 Bad+-- Request with the 'WebhookFailure' code for its body.+defaultOnFailure :: WebhookFailure -> Application+defaultOnFailure failure _ f = f .+ responseBuilder status400 [] . string8 . show $ failure
+ src/Line/Messaging/Webhook/Types.hs view
@@ -0,0 +1,253 @@+{-|+This module provides types to be used with "Line.Messaging.Webhook".+-}++module Line.Messaging.Webhook.Types (+ -- * Common types+ -- | Re-exported for convenience.+ module Line.Messaging.Common.Types,+ -- * Result and failure+ WebhookResult (..),+ WebhookFailure (..),++ -- * Webhook request body+ -- | The following types and functions are about decoding a webhook request body.++ -- ** Body+ Body (..),+ -- ** Event+ -- | Webhook event data types and instances for proper type classes+ -- (e.g. 'FromJSON') are implemented here.+ --+ -- For the event spec, please refer to+ -- <https://devdocs.line.me/en/#webhook-event-object the LINE documentation>.+ Event (..),+ EventTuple,+ ReplyToken,+ ReplyableEvent,+ NonReplyableEvent,+ getSource,+ getDatetime,+ getReplyToken,+ getMessage,+ getPostback,+ getBeacon,+ -- *** Event source+ EventSource (..),+ getID,+ -- *** Message event+ EventMessage (..),+ -- *** Beacon event+ BeaconData (..),+ ) where++import Data.Aeson+import Data.Time.Clock (UTCTime)+import Data.Time.Clock.POSIX (posixSecondsToUTCTime)+import Line.Messaging.API.Types+import Line.Messaging.Common.Types+import Network.Wai (Response, Application)+import qualified Data.Text as T++-- | A result type a webhook event handler should return.+--+-- It is eventually transformed to a WAI response or application.+data WebhookResult = Ok -- ^ Respond with an empty 200 OK response.+ | WaiResponse Response -- ^ Respond with a WAI response.+ | WaiApp Application -- ^ Respond with a WAI application.++-- | A failure type returned when a webhook request is malformed.+data WebhookFailure = SignatureVerificationFailed -- ^ When the signature is not valid.+ | MessageDecodeFailed -- ^ When the request body cannot be decoded into defined event types.+ deriving (Eq, Show)++-- | This type represents a whole request body.+--+-- It is mainly for JSON parsing, and users may not need to use this type+-- directly.+newtype Body = Body [Event]+ deriving (Eq, Show)++instance FromJSON Body where+ parseJSON (Object v) = Body <$> v .: "events"+ parseJSON _ = fail "Body"++-- | A type to represent each webhook event. The type of an event can be+-- determined with pattern matching.+--+-- @+-- handleEvent :: Event -> IO ()+-- handleEvent (MessageEvent event) = handleMessageEvent event+-- handleEvent (BeaconEvent event) = handleBeaconEvent event+-- handleEvent _ = return ()+--+-- handleMessageEvent :: ReplyableEvent EventMessage -> IO ()+-- handleMessageEvent = undefined+--+-- handleBeaconEvent :: ReplyableEvent BeaconData -> IO ()+-- handleBeaconEvent = undefined+-- @+--+-- All the data contstructors have a type @'EventTuple' r a -> 'Event'@.+data Event = MessageEvent (ReplyableEvent EventMessage)+ | FollowEvent (ReplyableEvent ())+ | UnfollowEvent (NonReplyableEvent ())+ | JoinEvent (ReplyableEvent ())+ | LeaveEvent (NonReplyableEvent ())+ | PostbackEvent (ReplyableEvent Postback)+ | BeaconEvent (ReplyableEvent BeaconData)+ deriving (Eq, Show)++-- | The base type for an event. It is a type alias for 4-tuple containing event+-- data.+--+-- The type variable @r@ is for a reply token, which is @()@ in the case of+-- non-replyable events. The type variable @a@ is a content type, which is+-- @()@ for events without content.+type EventTuple r a = (EventSource, UTCTime, r, a)++-- | A type alias for reply token. It is also consumed by the+-- @<./Line-Messaging-API.html#v:reply reply>@ API.+type ReplyToken = T.Text++-- | A type alias to represent a replyable event.+type ReplyableEvent a = EventTuple ReplyToken a+-- | A type alias to represent a non-replyable event.+type NonReplyableEvent a = EventTuple () a++-- | Retrieve event source from an event.+getSource :: EventTuple r a -> EventSource+getSource (s, _, _, _) = s++-- | Retrieve datetime when event is sent.+getDatetime :: EventTuple r a -> UTCTime+getDatetime (_, t, _, _) = t++-- | Retrieve a reply token of an event. It can be used only for+-- 'ReplyableEvent'.+getReplyToken :: ReplyableEvent a -> ReplyToken+getReplyToken (_, _, r, _) = r++-- | Retrieve event message from an event. It can be used only for events whose+-- content is a message.+--+-- @+-- handleMessageEvent :: ReplyableEvent EventMessage -> IO ()+-- handleMessageEvent event = do+-- let message = getMessage event+-- print message+-- @+getMessage :: ReplyableEvent EventMessage -> EventMessage+getMessage (_, _, _, m) = m++-- | Retrieve postback data from an event. It can be used only for events whose+-- content is postback data.+--+-- @+-- import qualified Data.Text.IO as TIO+--+-- handlePostbackEvent :: ReplyableEvent Postback -> IO ()+-- handlePostbackEvent event = do+-- let postback = getPostback event+-- TIO.putStrLn postback+-- @+getPostback :: ReplyableEvent Postback -> Postback+getPostback (_, _, _, d) = d++-- | Retrieve beacon data from an event. It can be used only for events whose+-- content is beacon data.+--+-- @+-- handleBeaconEvent :: ReplyableEvent BeaconData -> IO ()+-- handleBeaconEvent event = do+-- let beaconData = getBeacon event+-- print beaconData+-- @+getBeacon :: ReplyableEvent BeaconData -> BeaconData+getBeacon (_, _, _, b) = b++instance FromJSON Event where+ parseJSON (Object v) = v .: "type" >>= \ t ->+ case t :: T.Text of+ "message" -> MessageEvent <$> (replyable v <*> v .: "message")+ "follow" -> FollowEvent <$> (replyable v <*> none)+ "unfollow" -> UnfollowEvent <$> (nonReplyable v <*> none)+ "join" -> JoinEvent <$> (replyable v <*> none)+ "leave" -> LeaveEvent <$> (nonReplyable v <*> none)+ "postback" -> PostbackEvent <$> (replyable v <*> ((v .: "postback") >>= (.: "data")))+ "beacon" -> BeaconEvent <$> (replyable v <*> v .: "beacon")+ _ -> fail "Event"+ where+ common o = (,,,) <$> (o .: "source")+ <*> (posixSecondsToUTCTime . (/ 1000) . fromInteger <$> o .: "timestamp")+ withReplyToken p o = p <*> o .: "replyToken"+ none = return ()+ replyable o = common o `withReplyToken` o+ nonReplyable o = common o <*> none++ parseJSON _ = fail "Event"++-- | A source from which an event is sent. It can be retrieved from events with+-- 'getSource'.+data EventSource = User ID+ | Group ID+ | Room ID+ deriving (Eq, Show)++-- | Retrieve identifier from event source+getID :: EventSource -> ID+getID (User i) = i+getID (Group i) = i+getID (Room i) = i++instance FromJSON EventSource where+ parseJSON (Object v) = v .: "type" >>= \ t ->+ case t :: T.Text of+ "user" -> User <$> v .: "userId"+ "group" -> Group <$> v .: "groupId"+ "room" -> Room <$> v .: "roomId"+ _ -> fail "EventSource"+ parseJSON _ = fail "EventSource"++-- | Represent message types sent with 'MessageEvent'. It can be retrieved from+-- message events with 'getMessage'.+--+-- There is no actual content body sent with image, video and audio+-- messages. It should be manually downloaded via the+-- @<./Line-Messaging-API.html#v:getContent getContent>@ API.+--+-- For more details of event messages, please refer to the+-- <https://devdocs.line.me/en/#message-event Message event> section of the LINE+-- documentation.+data EventMessage = TextEM ID Text -- ^ Text event message.+ | ImageEM ID -- ^ Image event message.+ | VideoEM ID -- ^ Video event message.+ | AudioEM ID -- ^ Audio event message.+ | LocationEM ID Location -- ^ Location event message.+ | StickerEM ID Sticker -- ^ Sticker event message.+ deriving (Eq, Show)++instance FromJSON EventMessage where+ parseJSON (Object v) = v .: "type" >>= \ t ->+ case t :: T.Text of+ "text" -> TextEM <$> v .: "id" <*> parseJSON (Object v)+ "image" -> ImageEM <$> v .: "id"+ "video" -> VideoEM <$> v .: "id"+ "audio" -> AudioEM <$> v .: "id"+ "location" -> LocationEM <$> v .: "id" <*> parseJSON (Object v)+ "sticker" -> StickerEM <$> v .: "id" <*> parseJSON (Object v)+ _ -> fail "EventMessage"+ parseJSON _ = fail "IncommingMessage"++-- | Represent beacon data.+data BeaconData = BeaconEnter { getHWID :: ID+ -- ^ Get hardware ID of the beacon.+ }+ deriving (Eq, Show)++instance FromJSON BeaconData where+ parseJSON (Object v) = v .: "type" >>= \ t ->+ case t :: T.Text of+ "enter" -> BeaconEnter <$> v .: "hwid"+ _ -> fail "BeaconData"+ parseJSON _ = fail "BeaconData"
+ src/Line/Messaging/Webhook/Validation.hs view
@@ -0,0 +1,37 @@+{-|+This module provides a function to check if a webhook request has a correct+signature.+-}++{-# LANGUAGE OverloadedStrings #-}++module Line.Messaging.Webhook.Validation (+ -- * Signature validation+ validateSignature,+ ) where++import Crypto.Hash.SHA256 (hmaclazy)+import Data.Text.Encoding (encodeUtf8)+import Line.Messaging.Types+import Network.Wai+import qualified Data.ByteString as B+import qualified Data.ByteString.Base64 as Base64+import qualified Data.ByteString.Lazy as BL++getSignature :: Request -> Maybe B.ByteString+getSignature req = lookup "X-Line-Signature" headers+ where+ headers = requestHeaders req++-- | Provided a channel secret, WAI request and request body, it determines+-- the request is properly signatured, which probably means it is sent+-- from a valid LINE server.+--+-- For more details of webhook authentication, please refer to+-- <https://devdocs.line.me/en/#webhook-authentication the LINE documentation>.+validateSignature :: ChannelSecret -> Request -> BL.ByteString -> Bool+validateSignature secret req body = case getSignature req of+ Nothing -> False+ Just signature -> hash == signature+ where+ hash = Base64.encode $ hmaclazy (encodeUtf8 secret) body
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"