fbmessenger-api 0.1.0.2 → 0.1.0.3
raw patch · 3 files changed
+79/−30 lines, 3 filesdep +monad-loggerdep +waidep +wai-logger
Dependencies added: monad-logger, wai, wai-logger
Files
- example-app/example.hs +65/−27
- fbmessenger-api.cabal +5/−1
- src/Web/FBMessenger/API/Bot/WebhookAPI.hs +9/−2
example-app/example.hs view
@@ -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)
fbmessenger-api.cabal view
@@ -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
src/Web/FBMessenger/API/Bot/WebhookAPI.hs view
@@ -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)