diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,1 +1,1 @@ -# line-bot-sdk +# line-bot-sdk [![Build Status](https://travis-ci.org/moleike/line-bot-sdk.svg?branch=master)](https://travis-ci.org/moleike/line-bot-sdk) diff --git a/examples/Echo.hs b/examples/Echo.hs --- a/examples/Echo.hs +++ b/examples/Echo.hs @@ -6,7 +6,7 @@ module Main (main) where -import Control.Monad (mapM_) +import Control.Monad (forM_) import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Data.String (fromString) @@ -25,14 +25,14 @@ type API = "webhook" :> Webhook echo :: Event -> Line NoContent -echo EventMessage { message = W.Text { text }, replyToken } = - replyMessage replyToken [B.Text text Nothing] +echo EventMessage { message = W.MessageText { text }, replyToken } = + replyMessage replyToken [B.MessageText text Nothing] echo _ = return NoContent handleEvents :: [Event] -> WebM NoContent handleEvents events = do token <- ask - _ <- liftIO $ mapM_ (flip runLine token . echo) events + _ <- liftIO $ forM_ events $ flip runLine token . echo return NoContent echoServer :: ServerT API WebM @@ -41,10 +41,9 @@ app :: ChannelToken -> ChannelSecret -> Application app token secret = serveWithContext api context server where - api = Proxy :: Proxy API - server = hoistServerWithContext api pc nt echoServer - nt = flip runReaderT token - pc = Proxy :: Proxy '[ChannelSecret] + api = Proxy :: Proxy API + pc = Proxy :: Proxy '[ChannelSecret] + server = hoistServerWithContext api pc (flip runReaderT token) echoServer context = secret :. EmptyContext main :: IO () diff --git a/line-bot-sdk.cabal b/line-bot-sdk.cabal --- a/line-bot-sdk.cabal +++ b/line-bot-sdk.cabal @@ -1,5 +1,5 @@ name: line-bot-sdk -version: 0.3.0.0 +version: 0.4.0.0 synopsis: Haskell SDK for LINE Messaging API homepage: https://github.com/moleike/line-bot-sdk#readme bug-reports: https://github.com/moleike/line-bot-sdk/issues @@ -30,10 +30,9 @@ exposed-modules: Line.Bot.Webhook , Line.Bot.Webhook.Events , Line.Bot.Client - , Line.Bot.Types - - other-modules: Line.Bot.Endpoints , Line.Bot.Client.Auth + , Line.Bot.Types + , Line.Bot.Endpoints build-depends: base >= 4.7 && < 5 , aeson >= 1.4.2 && < 1.5 @@ -79,13 +78,29 @@ test-suite line-bot-sdk-test type: exitcode-stdio-1.0 hs-source-dirs: test + other-modules: Line.Bot.WebhookSpec + , Line.Bot.ClientSpec main-is: Spec.hs build-depends: base , line-bot-sdk + , base64-bytestring + , cryptohash-sha256 + , text + , bytestring , hspec , hspec-wai - , hspec-wai-json + , hspec-expectations + , http-types + , http-client , aeson + , transformers + , aeson-qq + , servant >= 0.15 + , servant-server >= 0.15 + , servant-client >= 0.15 + , servant-client-core >= 0.15 + , wai + , warp ghc-options: -threaded -rtsopts -with-rtsopts=-N default-language: Haskell2010 diff --git a/src/Line/Bot/Client.hs b/src/Line/Bot/Client.hs --- a/src/Line/Bot/Client.hs +++ b/src/Line/Bot/Client.hs @@ -16,7 +16,8 @@ module Line.Bot.Client ( Line , runLine - , runLineWith + , runLine' + , withLineEnv -- ** Profile , getProfile -- ** Group @@ -30,6 +31,9 @@ , pushMessage , multicastMessage , getContent + , getPushMessageCount + , getReplyMessageCount + , getMulticastMessageCount -- ** Account Link , issueLinkToken -- ** OAuth @@ -42,14 +46,13 @@ import Control.Monad.Trans.Reader (ReaderT, ask, runReaderT) import Data.ByteString.Lazy (ByteString) import Data.Proxy -import Data.String -import Data.Text as T +import Data.Time.Calendar (Day) import Line.Bot.Client.Auth import Line.Bot.Endpoints import Line.Bot.Types import Network.HTTP.Client (newManager) import Network.HTTP.Client.TLS (tlsManagerSettings) -import Servant.API hiding (addHeader) +import Servant.API import Servant.Client host :: BaseUrl @@ -59,22 +62,18 @@ -- OAuth access token for a channel type Line = ReaderT ChannelToken ClientM -defaultClient :: ClientM a -> IO (Either ServantError a) -defaultClient comp = do +withLineEnv :: (ClientEnv -> IO a) -> IO a +withLineEnv app = do manager <- newManager tlsManagerSettings - runClientM comp (mkClientEnv manager host) + app $ mkClientEnv manager host +-- | Executes a request in the LINE plaform (default) +runLine' :: ClientM a -> IO (Either ServantError a) +runLine' comp = withLineEnv $ \env -> runClientM comp env + -- | Runs a @Line@ computation with the given channel access token runLine :: Line a -> ChannelToken -> IO (Either ServantError a) -runLine = runLineWith defaultClient - --- | Runs the monad with a different client evironment -runLineWith - :: (ClientM a -> IO (Either ServantError a)) - -> Line a - -> ChannelToken - -> IO (Either ServantError a) -runLineWith f comp token = f $ runReaderT comp token +runLine comp token = runLine' $ runReaderT comp token getProfile' :: Auth -> Id User -> ClientM Profile @@ -94,11 +93,17 @@ getContent' :: Auth -> MessageId -> ClientM ByteString +getPushMessageCount' :: Auth -> LineDate -> ClientM MessageCount + +getReplyMessageCount' :: Auth -> LineDate -> ClientM MessageCount + +getMulticastMessageCount' :: Auth -> LineDate -> ClientM MessageCount + issueLinkToken' :: Auth -> Id User -> ClientM LinkToken -issueChannelToken :: ClientCredentials -> ClientM ShortLivedChannelToken +issueChannelToken' :: ClientCredentials -> ClientM ShortLivedChannelToken -revokeChannelToken :: ChannelToken -> ClientM NoContent +revokeChannelToken' :: ChannelToken -> ClientM NoContent getProfile' :<|> getGroupMemberProfile' @@ -109,9 +114,12 @@ :<|> pushMessage' :<|> multicastMessage' :<|> getContent' + :<|> getPushMessageCount' + :<|> getReplyMessageCount' + :<|> getMulticastMessageCount' :<|> issueLinkToken' - :<|> issueChannelToken - :<|> revokeChannelToken = client (Proxy :: Proxy Endpoints) + :<|> issueChannelToken' + :<|> revokeChannelToken' = client (Proxy :: Proxy Endpoints) getProfile :: Id User -> Line Profile getProfile a = ask >>= \token -> lift $ getProfile' (mkAuth token) a @@ -143,9 +151,28 @@ >>= \token -> lift $ multicastMessage' (mkAuth token) body where body = MulticastMessageBody a ms +-- | TODO: this should use a streaming library for constant memory usage over large data getContent :: MessageId -> Line ByteString getContent a = ask >>= \token -> lift $ getContent' (mkAuth token) a +getPushMessageCount :: Day -> Line MessageCount +getPushMessageCount a = + ask >>= \token -> lift $ getPushMessageCount' (mkAuth token) (LineDate a) + +getReplyMessageCount :: Day -> Line MessageCount +getReplyMessageCount a = + ask >>= \token -> lift $ getReplyMessageCount' (mkAuth token) (LineDate a) + +getMulticastMessageCount :: Day -> Line MessageCount +getMulticastMessageCount a = + ask >>= \token -> lift $ getMulticastMessageCount' (mkAuth token) (LineDate a) + issueLinkToken :: Id User -> Line LinkToken issueLinkToken a = ask >>= \token -> lift $ issueLinkToken' (mkAuth token) a + +issueChannelToken :: ChannelId -> ChannelSecret -> ClientM ShortLivedChannelToken +issueChannelToken a b = issueChannelToken' $ ClientCredentials a b + +revokeChannelToken :: ChannelToken -> ClientM NoContent +revokeChannelToken = revokeChannelToken' diff --git a/src/Line/Bot/Client/Auth.hs b/src/Line/Bot/Client/Auth.hs --- a/src/Line/Bot/Client/Auth.hs +++ b/src/Line/Bot/Client/Auth.hs @@ -17,9 +17,10 @@ mkAuthenticatedRequest) import Servant.Client.Core.Internal.Request (Request, addHeader) -type Auth = AuthenticatedRequest (AuthProtect ChannelAuth) -type instance AuthClientData (AuthProtect ChannelAuth) = ChannelToken +type instance AuthClientData ChannelAuth = ChannelToken + +type Auth = AuthenticatedRequest ChannelAuth mkAuth :: ChannelToken -> Auth mkAuth token = mkAuthenticatedRequest token addAuthorizationHeader diff --git a/src/Line/Bot/Endpoints.hs b/src/Line/Bot/Endpoints.hs --- a/src/Line/Bot/Endpoints.hs +++ b/src/Line/Bot/Endpoints.hs @@ -21,64 +21,86 @@ import Servant.API import Servant.Client -data ChannelAuth +-- | Combinator for authenticating with the channel access token +type ChannelAuth = AuthProtect "channel-access-token" -type GetProfile = AuthProtect ChannelAuth +type GetProfile = ChannelAuth :> "profile" :> Capture "userId" (Id User) :> Get '[JSON] Profile -type GetGroupMemberProfile = AuthProtect ChannelAuth +type GetGroupMemberProfile = ChannelAuth :> "group" :> Capture "groupId" (Id Group) :> "member" :> Capture "userId" (Id User) :> Get '[JSON] Profile -type LeaveGroup = AuthProtect ChannelAuth +type LeaveGroup = ChannelAuth :> "group" :> Capture "groupId" (Id Group) :> "leave" :> PostNoContent '[JSON] NoContent -type GetRoomMemberProfile = AuthProtect ChannelAuth +type GetRoomMemberProfile = ChannelAuth :> "room" :> Capture "roomId" (Id Room) :> "member" :> Capture "userId" (Id User) :> Get '[JSON] Profile -type LeaveRoom = AuthProtect ChannelAuth +type LeaveRoom = ChannelAuth :> "room" :> Capture "roomId" (Id Room) :> "leave" :> PostNoContent '[JSON] NoContent -type ReplyMessage = AuthProtect ChannelAuth +type ReplyMessage = ChannelAuth :> ReqBody '[JSON] ReplyMessageBody :> "message" :> "reply" :> PostNoContent '[JSON] NoContent -type PushMessage = AuthProtect ChannelAuth +type PushMessage = ChannelAuth :> ReqBody '[JSON] PushMessageBody :> "message" :> "push" :> PostNoContent '[JSON] NoContent -type MulticastMessage = AuthProtect ChannelAuth +type MulticastMessage = ChannelAuth :> ReqBody '[JSON] MulticastMessageBody :> "message" :> "multicast" :> PostNoContent '[JSON] NoContent -type GetContent = AuthProtect ChannelAuth +type GetContent = ChannelAuth :> "message" :> Capture "messageId" MessageId :> "content" :> Get '[OctetStream] ByteString -type IssueLinkToken = AuthProtect ChannelAuth +type GetReplyMessageCount = ChannelAuth + :> "message" + :> "delivery" + :> "reply" + :> QueryParam' '[Required, Strict] "date" LineDate + :> Get '[JSON] MessageCount + +type GetPushMessageCount = ChannelAuth + :> "message" + :> "delivery" + :> "push" + :> QueryParam' '[Required, Strict] "date" LineDate + :> Get '[JSON] MessageCount + +type GetMulticastMessageCount = ChannelAuth + :> "message" + :> "delivery" + :> "multicast" + :> QueryParam' '[Required, Strict] "date" LineDate + :> Get '[JSON] MessageCount + +type IssueLinkToken = ChannelAuth :> "user" :> Capture "userId" (Id User) :> "linkToken" @@ -106,6 +128,9 @@ :<|> PushMessage :<|> MulticastMessage :<|> GetContent + :<|> GetReplyMessageCount + :<|> GetPushMessageCount + :<|> GetMulticastMessageCount :<|> IssueLinkToken :<|> IssueChannelToken :<|> RevokeChannelToken diff --git a/src/Line/Bot/Types.hs b/src/Line/Bot/Types.hs --- a/src/Line/Bot/Types.hs +++ b/src/Line/Bot/Types.hs @@ -22,6 +22,7 @@ module Line.Bot.Types ( ChannelToken(..) , ChannelSecret(..) + , ChannelId(..) , ChatType(..) , Id(..) , MessageId @@ -38,9 +39,12 @@ , Action(..) , ClientCredentials(..) , ShortLivedChannelToken(..) + , LineDate(..) + , MessageCount(..) ) where +import Control.Arrow ((>>>)) import Data.Aeson import Data.Aeson.Types import qualified Data.ByteString.Char8 as B @@ -51,12 +55,15 @@ import Data.String import Data.Text as T hiding (drop, toLower) import Data.Text.Encoding +import Data.Time.Calendar (Day) +import Data.Time.Format import GHC.Generics hiding (to) import Servant.API import Text.Show import Web.FormUrlEncoded (ToForm (..)) -newtype ChannelToken = ChannelToken Text + +newtype ChannelToken = ChannelToken { unChannelToken :: Text } deriving (Eq, Show, Generic) instance FromJSON ChannelToken @@ -65,13 +72,13 @@ fromString s = ChannelToken (fromString s) instance ToHttpApiData ChannelToken where - toQueryParam (ChannelToken t) = "Bearer " <> t + toHeader (ChannelToken t) = encodeUtf8 $ "Bearer " <> t + toQueryParam (ChannelToken t) = t instance ToForm ChannelToken where toForm (ChannelToken t) = [ ("access_token", t) ] -newtype ChannelSecret = ChannelSecret - { unChannelSecret :: B.ByteString } +newtype ChannelSecret = ChannelSecret { unChannelSecret :: B.ByteString } instance IsString ChannelSecret where fromString s = ChannelSecret (B.pack s) @@ -79,6 +86,15 @@ instance ToHttpApiData ChannelSecret where toQueryParam = decodeUtf8 . unChannelSecret +newtype ChannelId = ChannelId { unChannelId :: Text } + deriving (Eq, Show, Generic) + +instance IsString ChannelId where + fromString s = ChannelId (fromString s) + +instance ToHttpApiData ChannelId where + toQueryParam (ChannelId t) = t + data ChatType = User | Group | Room -- | ID of a chat user, group or room @@ -99,6 +115,15 @@ instance ToJSON (Id a) where toJSON = String . toQueryParam +instance IsString (Id User) where + fromString s = UserId (fromString s) + +instance IsString (Id Group) where + fromString s = GroupId (fromString s) + +instance IsString (Id Room) where + fromString s = RoomId (fromString s) + instance FromJSON (Id User) where parseJSON = withText "Id User" $ return . UserId @@ -117,31 +142,31 @@ instance FromJSON URL data Message = - Text { text :: Text - , quickReply :: Maybe QuickReply - } - | Sticker { packageId :: Text - , stickerId :: Text - , quickReply :: Maybe QuickReply - } - | Image { originalContentUrl :: URL - , previewImageUrl :: URL - , quickReply :: Maybe QuickReply - } - | Video { originalContentUrl :: URL - , previewImageUrl :: URL - , quickReply :: Maybe QuickReply - } - | Audio { originalContentUrl :: URL - , duration :: Int - , quickReply :: Maybe QuickReply - } - | Location { title :: Text - , address :: Text - , latitude :: Double - , longitude :: Double - , quickReply :: Maybe QuickReply - } + MessageText { text :: Text + , quickReply :: Maybe QuickReply + } + | MessageSticker { packageId :: Text + , stickerId :: Text + , quickReply :: Maybe QuickReply + } + | MessageImage { originalContentUrl :: URL + , previewImageUrl :: URL + , quickReply :: Maybe QuickReply + } + | MessageVideo { originalContentUrl :: URL + , previewImageUrl :: URL + , quickReply :: Maybe QuickReply + } + | MessageAudio { originalContentUrl :: URL + , duration :: Int + , quickReply :: Maybe QuickReply + } + | MessageLocation { title :: Text + , address :: Text + , latitude :: Double + , longitude :: Double + , quickReply :: Maybe QuickReply + } deriving (Eq, Show, Generic) instance ToJSON Message where @@ -153,7 +178,7 @@ { tagFieldName = "type" , contentsFieldName = undefined } - , constructorTagModifier = fmap toLower + , constructorTagModifier = fmap toLower . drop 7 , omitNothingFields = True } @@ -163,7 +188,7 @@ , pictureUrl :: URL , statusMessage :: Maybe Text } - deriving (Show, Generic) + deriving (Eq, Show, Generic) instance FromJSON Profile @@ -207,32 +232,24 @@ instance ToJSON MulticastMessageBody -data QuickReply = QuickReply +newtype QuickReply = QuickReply { items :: [QuickReplyButton] } deriving (Eq, Show, Generic) instance ToJSON QuickReply -data QuickReplyButton = - Action { imageUrl :: Maybe URL - , action :: Action - } - deriving (Eq, Show, Generic) - -quickReplyButtonJSONOptions :: Options -quickReplyButtonJSONOptions = defaultOptions - { sumEncoding = TaggedObject - { tagFieldName = "type" - , contentsFieldName = undefined - } - , constructorTagModifier = fmap toLower - , omitNothingFields = True - , tagSingleConstructors = True +data QuickReplyButton = QuickReplyButton + { imageUrl :: Maybe URL + , action :: Action } + deriving (Eq, Show) instance ToJSON QuickReplyButton where - toJSON = genericToJSON quickReplyButtonJSONOptions - + toJSON QuickReplyButton{..} = object + [ "type" .= pack "action" + , "imageUrl" .= imageUrl + , "action" .= action + ] data Action = ActionPostback { label :: Text @@ -242,8 +259,8 @@ | ActionMessage { label :: Text , text :: Text } - | ActionURI { label :: Text - , uri :: Text + | ActionUri { label :: Text + , uri :: URL } | ActionCamera { label :: Text } @@ -262,16 +279,11 @@ { tagFieldName = "type" , contentsFieldName = undefined } - , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 6 + , constructorTagModifier = drop 6 >>> \(x:xs) -> toLower x : xs , omitNothingFields = True - , fieldLabelModifier = \orig -> - case L.stripPrefix "postback" orig of - Just s -> fmap toLower s - Nothing -> orig + , fieldLabelModifier = \x -> maybe x (fmap toLower) $ L.stripPrefix "postback" x } -type ChannelId = Id User - data ClientCredentials = ClientCredentials { clientId :: ChannelId , clientSecret :: ChannelSecret @@ -292,3 +304,22 @@ instance FromJSON ShortLivedChannelToken where parseJSON = genericParseJSON defaultOptions { fieldLabelModifier = camelTo2 '_' } + +newtype LineDate = LineDate { unLineDate :: Day } deriving (Eq) + +instance Show LineDate where + show = formatTime defaultTimeLocale "%Y%m%d" . unLineDate + +instance ToHttpApiData LineDate where + toQueryParam = T.pack . show + +data MessageCount = MessageCount + { count :: Int + , status :: String + } deriving (Eq, Show) + +instance FromJSON MessageCount where + parseJSON = withObject "MessageCount" $ \o -> do + count <- o .: "success" + status <- o .: "status" + return $ MessageCount{..} diff --git a/src/Line/Bot/Webhook/Events.hs b/src/Line/Bot/Webhook/Events.hs --- a/src/Line/Bot/Webhook/Events.hs +++ b/src/Line/Bot/Webhook/Events.hs @@ -32,6 +32,7 @@ ) where +import Control.Arrow ((>>>)) import Data.Aeson import Data.Aeson.Types import Data.Char @@ -112,44 +113,43 @@ deriving (Eq, Show, Generic) instance FromJSON Event where - parseJSON = genericParseJSON $ - defaultOptions { sumEncoding = TaggedObject - { tagFieldName = "type" - , contentsFieldName = undefined - } - , constructorTagModifier = (\(x : xs) -> toLower x : xs) . drop 5 - } - + parseJSON = genericParseJSON defaultOptions + { sumEncoding = TaggedObject + { tagFieldName = "type" + , contentsFieldName = undefined + } + , constructorTagModifier = drop 5 >>> \(x:xs) -> toLower x : xs + } data Message = - Text { messageId :: MessageId - , text :: Text - } - | Image { messageId :: MessageId - , contentProvider :: ContentProvider - } - | Video { messageId :: MessageId - , duration :: Int - , contentProvider :: ContentProvider - } - | Audio { messageId :: MessageId - , duration :: Int - , contentProvider :: ContentProvider - } - | File { messageId :: MessageId - , fileSize :: Int - , fileName :: Text - } - | Location { messageId :: MessageId - , title :: Text - , address :: Text - , latitude :: Double - , longitude :: Double - } - | Sticker { messageId :: MessageId - , packageId :: Text - , stickerId :: Text - } + MessageText { messageId :: MessageId + , text :: Text + } + | MessageImage { messageId :: MessageId + , contentProvider :: ContentProvider + } + | MessageVideo { messageId :: MessageId + , duration :: Int + , contentProvider :: ContentProvider + } + | MessageAudio { messageId :: MessageId + , duration :: Int + , contentProvider :: ContentProvider + } + | MessageFile { messageId :: MessageId + , fileSize :: Int + , fileName :: Text + } + | MessageLocation { messageId :: MessageId + , title :: Text + , address :: Text + , latitude :: Double + , longitude :: Double + } + | MessageSticker { messageId :: MessageId + , packageId :: Text + , stickerId :: Text + } deriving (Eq, Show, Generic) messageJSONOptions :: Options @@ -158,17 +158,13 @@ { tagFieldName = "type" , contentsFieldName = undefined } - , constructorTagModifier = fmap toLower - , fieldLabelModifier = \orig -> - case L.stripPrefix "message" orig of - Just s -> fmap toLower s - Nothing -> orig + , constructorTagModifier = fmap toLower . drop 7 + , fieldLabelModifier = \x -> maybe x (fmap toLower) $ L.stripPrefix "message" x , omitNothingFields = True } instance FromJSON Message where parseJSON = genericParseJSON messageJSONOptions - data ContentProvider = ContentProvider { originalContentUrl :: Maybe URL diff --git a/test/Line/Bot/ClientSpec.hs b/test/Line/Bot/ClientSpec.hs new file mode 100644 --- /dev/null +++ b/test/Line/Bot/ClientSpec.hs @@ -0,0 +1,83 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} + +module Line.Bot.ClientSpec (spec) where + +import Control.Arrow (left) +import Control.Monad.Trans.Reader (runReaderT) +import Data.Aeson (Value) +import Data.Aeson.QQ +import Data.ByteString as B (stripPrefix) +import Data.Text +import Data.Text.Encoding +import Line.Bot.Client hiding (runLine) +import Line.Bot.Client.Auth +import Line.Bot.Endpoints (ChannelAuth) +import Line.Bot.Types +import Network.HTTP.Client (defaultManagerSettings, + newManager) +import Network.HTTP.Types (hAuthorization) +import Network.Wai (Request, requestHeaders) +import Network.Wai.Handler.Warp (Port, withApplication) +import Servant +import Servant.Client +import Servant.Client.Core.Reexport +import Servant.Server (Context (..)) +import Servant.Server.Experimental.Auth (AuthHandler, AuthServerData, + mkAuthHandler) +import Test.Hspec +import Test.Hspec.Expectations.Contrib +import Test.Hspec.Wai + +type instance AuthServerData ChannelAuth = ChannelToken + +-- a dummy auth handler that returns the channel access token +authHandler :: AuthHandler Request ChannelToken +authHandler = mkAuthHandler $ \request -> do + case lookup hAuthorization (requestHeaders request) >>= B.stripPrefix "Bearer " of + Nothing -> throwError $ err401 { errBody = "Bad" } + Just t -> return $ ChannelToken $ decodeUtf8 t + +serverContext :: Context '[AuthHandler Request ChannelToken] +serverContext = authHandler :. EmptyContext + +type API = + ChannelAuth :> "v2" :> "bot" :> "profile" :> "1" :> Get '[JSON] Value + :<|> ChannelAuth :> "v2" :> "bot" :> "group" :> "1" :> "member" :> "1" :> Get '[JSON] Value + +testProfile :: Value +testProfile = [aesonQQ| + { + displayName: "LINE taro", + userId: "U4af4980629...", + pictureUrl: "https://obs.line-apps.com/...", + statusMessage: "Hello, LINE!" + } +|] + +withPort :: Port -> (ClientEnv -> IO a) -> IO a +withPort port app = do + manager <- newManager defaultManagerSettings + app $ mkClientEnv manager $ BaseUrl Http "localhost" port "" + +runLine :: Line a -> Port -> IO (Either ServantError a) +runLine comp port = withPort port $ runClientM $ runReaderT comp "fake" + +app :: Application +app = serveWithContext (Proxy :: Proxy API) serverContext $ + (\_ -> return testProfile) + :<|> (\_ -> return testProfile) + +spec :: Spec +spec = describe "Line client" $ do + it "should return user profile" $ do + withApplication (pure app) $ \port -> do + runLine (getProfile "1") port >>= \x -> x `shouldSatisfy` isRight + + it "should return group user profile" $ do + withApplication (pure app) $ \port -> do + runLine (getGroupMemberProfile "1" "1") port >>= \x -> x `shouldSatisfy` isRight diff --git a/test/Line/Bot/WebhookSpec.hs b/test/Line/Bot/WebhookSpec.hs new file mode 100644 --- /dev/null +++ b/test/Line/Bot/WebhookSpec.hs @@ -0,0 +1,89 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE QuasiQuotes #-} +{-# LANGUAGE TypeOperators #-} + +module Line.Bot.WebhookSpec (spec) where + +import qualified Crypto.Hash.SHA256 as SHA256 +import Data.Aeson (Value, encode) +import Data.Aeson.QQ +import Data.Aeson.Types (emptyObject) +import qualified Data.ByteString.Base64 as Base64 +import Line.Bot.Types (ChannelSecret (..)) +import Line.Bot.Webhook (Webhook) +import Line.Bot.Webhook.Events (Events) +import Network.HTTP.Types (HeaderName, hContentType) +import Network.HTTP.Types.Method +import Network.HTTP.Types.Status +import Servant +import Servant.Server (Context ((:.), EmptyContext)) +import Test.Hspec hiding (context) +import Test.Hspec.Wai + +hSignature :: HeaderName +hSignature = "X-Line-Signature" + +secret :: ChannelSecret +secret = "shhhh" + +context :: Context (ChannelSecret ': '[]) +context = secret :. EmptyContext + +app :: Application +app = serveWithContext (Proxy :: Proxy Webhook) context webhook + +webhook :: Server Webhook +webhook = handleEvents + +handleEvents :: Events -> Handler NoContent +handleEvents _ = return NoContent + +testBody :: Value +testBody = [aesonQQ| + { + destination: "xxxxxxxxxx", + events: [ + { + replyToken: "8cf9239d56244f4197887e939187e19e", + type: "follow", + timestamp: 1462629479859, + source: { + type: "user", + userId: "U4af4980629..." + } + } + ] + } +|] + +spec :: Spec +spec = with (pure app) $ do + describe "Webhook server" $ do + + it "should return 200 with a signed request" $ do + let body = encode testBody + digest = Base64.encode $ SHA256.hmaclazy (unChannelSecret secret) body + headers = [(hContentType, "application/json"), (hSignature, digest)] + + request methodPost "/" headers body `shouldRespondWith` 200 + + it "should return 400 for an invalid body" $ do + let body = encode emptyObject + digest = Base64.encode $ SHA256.hmaclazy (unChannelSecret secret) body + headers = [(hContentType, "application/json"), (hSignature, digest)] + + request methodPost "/" headers body `shouldRespondWith` 400 + + it "should return 401 for requests missing the signature header" $ do + let body = encode testBody + headers = [(hContentType, "application/json")] + + request methodPost "/" headers body `shouldRespondWith` 401 + + it "should return 401 when secret is incorrect" $ do + let body = encode testBody + digest = Base64.encode $ SHA256.hmaclazy "incorrect" body + headers = [(hContentType, "application/json"), (hSignature, digest)] + + request methodPost "/" headers body `shouldRespondWith` 401 diff --git a/test/Spec.hs b/test/Spec.hs --- a/test/Spec.hs +++ b/test/Spec.hs @@ -1,20 +1,1 @@ -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE OverloadedStrings #-} -module Main (main) where - -import Lib (app) -import Test.Hspec -import Test.Hspec.Wai -import Test.Hspec.Wai.JSON - -main :: IO () -main = hspec spec - -spec :: Spec -spec = with (return app) $ do - describe "GET /users" $ do - it "responds with 200" $ do - get "/users" `shouldRespondWith` 200 - it "responds with [User]" $ do - let users = "[{\"userId\":1,\"userFirstName\":\"Isaac\",\"userLastName\":\"Newton\"},{\"userId\":2,\"userFirstName\":\"Albert\",\"userLastName\":\"Einstein\"}]" - get "/users" `shouldRespondWith` users +{-# OPTIONS_GHC -F -pgmF hspec-discover #-}