diff --git a/example-app/example.hs b/example-app/example.hs --- a/example-app/example.hs +++ b/example-app/example.hs @@ -3,17 +3,26 @@ {-# LANGUAGE TypeOperators #-} {-# LANGUAGE OverloadedStrings #-} -import Control.Monad (when) +import Control.Concurrent (forkIO, threadDelay) +import Control.Monad (when, forever) +import Control.Monad.IO.Class (liftIO) import Control.Monad.Trans.Except (ExceptT) +import qualified Data.ByteString.Lazy.Char8 as C +--import Data.Either (either) +import Data.Foldable (traverse_) import Data.Maybe (fromMaybe) import Data.Proxy -import Data.Text as T hiding (map) -import Network.HTTP.Client hiding (Proxy, port) -import Network.HTTP.Client.TLS +import qualified Data.Text as T +import Network.HTTP.Client (newManager) +import Network.HTTP.Client.TLS (tlsManagerSettings) +import Network.Wai import Network.Wai.Handler.Warp +import Network.Wai.Logger (withStdoutLogger) import Servant import System.Environment +import System.Exit (exitFailure) import System.IO +import Text.Printf (printf) import Web.FBMessenger.API.Bot type WebHookAPI = "webhook" :> @@ -22,48 +31,77 @@ Get '[PlainText] String :<|> "webhook" :> ReqBody '[JSON] RemoteEventList :> - Post '[PlainText] String + Post '[PlainText,JSON] String webHookAPI :: Proxy WebHookAPI webHookAPI = Proxy -server :: String -> Server WebHookAPI -server verifyTokenStored = +-- TODO: use monad-logger to implement proper logging + +server :: String -> String -> Server WebHookAPI +server verifyTokenStored pageTokenStored = webhook_verify :<|> webhook_message where webhook_verify :: Maybe String -> Maybe String -> ExceptT ServantErr IO String webhook_verify (Just verifyToken) (Just challenge) | verifyToken == verifyTokenStored = return challenge - webhook_verify _ _ = throwError err500 { errBody = "Error, wrong validation token"} + webhook_verify tk ch = let + eB :: String + eB = printf "[ERROR]: wrong validation request. Got (token, challenge) = (%s, %s)" (show tk) (show ch) + in do + liftIO $ putStrLn eB + throwError err500 { errBody = C.pack eB} webhook_message :: RemoteEventList -> ExceptT ServantErr IO String webhook_message (RemoteEventList res) = do - let _ = map (echoMessage . evt_messaging) res - return "ok" + r <- traverse echoMessage (concatMap evt_messaging res) + liftIO $ traverse_ (putStrLn . T.unpack) r + return "{\"status\":\"fulfilled\"}" - echoMessage :: [EventMessage] -> IO () - echoMessage msgs = mapM_ process msgs >> return () - where - process msg = case evtContent msg of - EmTextMessage _ _ text -> do - case recipient (Just $ evtSenderId msg) Nothing of - Nothing -> return () - Just r -> do - let req = sendTextMessageRequest Nothing r text - m <- newManager tlsManagerSettings - let t = Token $ T.pack verifyTokenStored - let _ = sendTextMessage (Just $ t) req m - return () - _ -> return () + token = Token $ T.pack pageTokenStored + echoMessage :: EventMessage -> ExceptT ServantErr IO T.Text + echoMessage msg = do + case evtContent msg of + EmTextMessage _ _ text -> liftIO $ echoTextMessage text (evtSenderId msg) + _ -> return "[WARN]: this is just an example, no complex message is echoed." + + echoTextMessage text rcptId = do + m <- newManager tlsManagerSettings + -- create the recipient using the sender id + -- (we know that this is successful when only one argument is not Nothing) + let (Just rcpt) = recipient (Just rcptId) Nothing + -- prepare the Send API request body + let messageReq = sendTextMessageRequest Nothing rcpt text + -- finally send the message request using the tls http connection manager + logRsp <- sendTextMessage (Just token) messageReq m + -- restructure the response to get a decent log out of it + -- e.g. one could add the response or the error in the log message + let logMsg = either (\_ -> printf "[ERROR]: failed to echo message") + (\_ -> printf "[INFO]: sent \"%s\" to %s" (T.unpack text) (show rcpt)) + logRsp + return (T.pack logMsg) +app :: String -> String -> Application +app verifyToken pageToke = serve webHookAPI $ server verifyToken pageToken + main :: IO () main = do hSetBuffering stdout LineBuffering env <- getEnvironment + let port = maybe 3000 read $ lookup "PORT" env + let verifyToken = fromMaybe "" $ lookup "VERIFY_TOKEN" env - when (verifyToken == "") (putStrLn "Please set VERIFY_TOKEN to a safe string") - putStrLn $ "Server listening on port " ++ show port - run port $ serve webHookAPI $ server verifyToken + when (verifyToken == "") $ do + putStrLn "[WARN]: please set VERIFY_TOKEN to a safe string" + exitFailure + + let pageToken = fromMaybe "" $ lookup "PAGE_TOKEN" env + when (pageToken == "") $ putStrLn "[WARN]: make sure to set up the correct page token" + + putStrLn $ printf "[INFO]: server listening on port %i" port + withStdoutLogger $ \aplogger -> do + let settings = setPort port $ setLogger aplogger defaultSettings + runSettings settings (app verifyToken pageToken) diff --git a/fbmessenger-api.cabal b/fbmessenger-api.cabal --- a/fbmessenger-api.cabal +++ b/fbmessenger-api.cabal @@ -1,5 +1,5 @@ name: fbmessenger-api -version: 0.1.0.2 +version: 0.1.0.3 synopsis: High-level bindings to Facebook Messenger Platform API description: Please see README.md homepage: https://github.com/mseri/fbmessenger-api-hs#readme @@ -50,14 +50,18 @@ ghc-options: -fwarn-tabs -O2 -Wall -threaded build-depends: base , aeson + , bytestring , http-client , http-client-tls , fbmessenger-api + , monad-logger , servant == 0.7.* , servant-server == 0.7.* , stm , text , transformers + , wai + , wai-logger , warp default-language: Haskell2010 diff --git a/src/Web/FBMessenger/API/Bot/WebhookAPI.hs b/src/Web/FBMessenger/API/Bot/WebhookAPI.hs --- a/src/Web/FBMessenger/API/Bot/WebhookAPI.hs +++ b/src/Web/FBMessenger/API/Bot/WebhookAPI.hs @@ -6,12 +6,15 @@ {-# LANGUAGE TypeOperators #-} module Web.FBMessenger.API.Bot.WebhookAPI ( + -- * Types RemoteEvent (..) , RemoteEventList (..) , EventMessage (..) , EventMessageContent (..) , EventMessageAttachment (..) , EventMessageAttachmentType (..) + -- * Functions + , extractMessagingEvents ) where import Control.Monad (when) @@ -74,8 +77,8 @@ evtSenderId <- o .: "sender" >>= (.: "id") evtRecipientId <- o .: "recipient" >>= (.: "id") evtTimestamp <- o .:? "timestamp" - -- not too clean but seems to do the job - -- if we refactor, it's faster if we get the first true only + -- not too clean but does the job + -- if we refactor, it's maybe faster if we get the first true only let evtChoices = filter (`member` o) (["message", "optin", "delivery", "postback"]::[Text]) when (null evtChoices) $ fail "unknown message content" @@ -83,6 +86,10 @@ evtContent <- o .: head evtChoices return EventMessage{..} +-- | Helper to extract all messaging events from the 'RemoteEventList' in the +-- webhook call body +extractMessagingEvents :: RemoteEventList -> [EventMessage] +extractMessagingEvents (RemoteEventList res) = concatMap evt_messaging res data EventMessageContent = EmTextMessage Text Int Text -- ^ Message ID; Message sequence number; Message text. | EmStructuredMessage Text Int [EventMessageAttachment] -- ^ Message ID; Message sequence number; Array containing attachment data (image, video, audio)