diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -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. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/line.cabal b/line.cabal new file mode 100644 --- /dev/null +++ b/line.cabal @@ -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 +copyright: (c) 2016 Jun +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 + . + For example usages, please see the + 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 diff --git a/src/Line/Messaging/API.hs b/src/Line/Messaging/API.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/API.hs @@ -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 +. +-} + +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 +-- 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 +-- . +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 +-- . +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 +-- . +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 +-- . +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 +-- . +leaveRoom :: ID -> APIIO () +leaveRoom = leave "room" + +-- | Leave a group, specified by @'ID'@. +-- +-- For more information, please refer to +-- . +leaveGroup :: ID -> APIIO () +leaveGroup = leave "group" diff --git a/src/Line/Messaging/API/Types.hs b/src/Line/Messaging/API/Types.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/API/Types.hs @@ -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 +-- . +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 +-- . +-- +-- 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 . +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 . +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 +-- . +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 +-- . +-- +-- 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 . +-- +-- 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 +-- . +data ImageMap = ImageMap { getBaseImageURL :: 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 +-- . +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. +-- +-- <> +-- +-- For more details of each field, please refer to the +-- 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. +-- +-- <> +-- +-- For more details of each field, please refer to the +-- 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. +-- +-- <> +-- +-- For more details of each field, please refer to the +-- 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 +-- and +-- 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 . + | 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" diff --git a/src/Line/Messaging/Common/Types.hs b/src/Line/Messaging/Common/Types.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/Common/Types.hs @@ -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 diff --git a/src/Line/Messaging/Types.hs b/src/Line/Messaging/Types.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/Types.hs @@ -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 diff --git a/src/Line/Messaging/Webhook.hs b/src/Line/Messaging/Webhook.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/Webhook.hs @@ -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 diff --git a/src/Line/Messaging/Webhook/Types.hs b/src/Line/Messaging/Webhook/Types.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/Webhook/Types.hs @@ -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 + -- . + 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 +-- 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" diff --git a/src/Line/Messaging/Webhook/Validation.hs b/src/Line/Messaging/Webhook/Validation.hs new file mode 100644 --- /dev/null +++ b/src/Line/Messaging/Webhook/Validation.hs @@ -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 +-- . +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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"