#StackBounty: #haskell #monads Telegram bot in Haskell using custom monad transformers

Bounty: 100

Note: I show almost all of my code for completeness, but I really only want the review to focus on Session.hs, Handler.hs, and maybe Controller.hs. I can delete the extra code from the review or collapse it to definitions.

The project

I’ve never heard of monad transformers and monad stacks before, but I’ve decided to learn them while making a real world Haskell application. This is a Telegram bot that can do various tasks based on the user’s commands. The project is meant to teach me about monad stacks and how to use them properly, while also being a useful tool for my own disposal.

The scope of the review

The project is on the proof of concept stage. The bot is working, but right now it’s only a silly number guessing game. Some important features like logging and security are missing. Nothing is final here, and every part of the program will be added upon, but the basis is done, and I need to know that the foundation is good and flexible enough before moving on. I want this review to focus on my implementation and usage of monad stacks and monad transformers. I would also like know about my idiomatic mistakes that have to do with Haskell. Focus on what is done wrong, not what could be added.

For example, I know that I need a WriterT for logging somewhere in the stack, so don’t tell it to me, but I would like to hear if stack implementation prevents me from doing it later. I don’t want to hear about the missing error handling in the API communication code, but I would like to hear about mistakes in the error handling that I’ve already done.

A working example

A working example

One example of a bot’s function would be a number guessing game. The user writes a command guess to initiate the game. The bot generates a random number between 1 and 10. The user then proceeds to guess the number with multiple attempts while the bot provides the information if the guessed numbers are greater or less than what was generated.

General introduction

The framework has 3 main components: controller, session and handlers.

A handler is a subroutine that reacts to it’s specific command and the follow-ups. In the example, the part that generates a number and provides feedback is a handler.

The session is a persistent storage that is attached to one chain of messages. When a handler needs to save something, it places the information in the session. The handler’s reply to the user is then associated with this session, and when the user replies to the handler’s message, the session is restored and passed back to the handler. The session also stores which handler is to be used for the reply handling: the used did not need to type ‘guess 5’ in the example: just ‘5’ was enough.

The controller is a piece that glues these components together. When the user sends any message to the bot, a controller creates or restores the session and passes the control to the appropriate handler.

There is also a component to handle the Telegram API interactions, but I’ll leave it out of the scope because it’s a work in progress and it’s not a part of the stack for now.

The code

Config.hs

This is a simple monad that reads the appication config. Note the lack of error handling here: if the config format is invalid the program may crash as it will, I don’t care about proper error messages at this point.

{-# LANGUAGE PackageImports #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}

module Config ( Config(..)
          , ConfigT
          , runConfigT
          , asks
          , loadConfig
          ) where

import               Control.Monad.IO.Class (MonadIO)
import               Control.Monad.Reader (MonadReader, asks)
import qualified     Control.Monad.Trans.Reader as Reader (ReaderT(..))
import "yaml-config" Data.Yaml.Config (load, lookup)
import               Prelude hiding(lookup)

data Config = Config
  {
    telegram_bot_api_key :: String,
    dropbox_access_token :: String
  }

newtype ConfigT a = ConfigT
  { runConfigTa :: Reader.ReaderT Config IO a
  } deriving ( Applicative
         , Functor
         , Monad
         , MonadIO
         , MonadReader Config )

runConfigT :: ConfigT a -> Config -> IO a
runConfigT = Reader.runReaderT . runConfigTa

loadConfig :: IO Config
loadConfig = do
  config <- load "./config/secrets.yaml"
  telegram <- lookup "telegram_bot_api_key" config
  dropbox <- lookup "dropbox_access_token" config
  return Config
    { telegram_bot_api_key = telegram
    , dropbox_access_token = dropbox
    }

Session.hs

When a user invokes a command, a new empty session is created. When a user answers a bot’s message, an existing session is restored. When a session is restored, it is deleted from the drive. If the bot answers a user and the session has any info saved, it is written back to the drive with the new id. The id of a session is the id of this reply in Telegram. When a handler is finished with the whole interaction (the game is won in the example) the session can be cleared via deleteSession. When a handler action finishes and a the session is clear, no further files are created. This way, only active sessions are stored, and only for the last messasges in each active session (so that you can’t continue the sesion from a middle).

I’ve created a new class MonadSession here, but I wonder if it is any good. I failed to use it as I have planned in the end.

Don’t worry about the implementation details: I know that sessions can be stored in a database, that the usage of read and show is not elegant, and that using SomeException is bad.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE FlexibleContexts #-}

module Session ( SessionError
           , SessionT
           , MonadSession(..)
           , withSession
           ) where

import           Control.Exception (SomeException, try, tryJust, catchJust)
import           Control.Monad (forM_, unless)
import           Control.Monad.Except (MonadError, throwError, runExceptT, guard)
import           Control.Monad.IO.Class (MonadIO, liftIO)
import           Control.Monad.State (MonadState, state, modify, gets)
import           Control.Monad.Trans.Class (MonadTrans(..))
import           Control.Monad.Trans.Except (ExceptT(..))
import           Control.Monad.Trans.State.Lazy (StateT, runStateT)
import qualified Data.Map as Map
import           Data.String.Utils (maybeRead)
import           System.Directory (removeFile, doesFileExist)
import           System.IO.Error (isDoesNotExistError)

import           Config (ConfigT)

-- Public

newtype SessionError = SessionError String

instance Show SessionError where
  show (SessionError message) = "Session error: " ++ message

data Session = Session
  { originalId :: Maybe String
  , newId :: Maybe String
  , info :: Map.Map String String
  }

class Monad m => MonadSession m where
  save :: Show a => String -> a -> m ()
  setId :: String -> m ()
  recall :: Read a => String -> m a
  tryRecall :: Read a => String -> m (Maybe a)
  deleteSession :: m ()

newtype SessionT m a = SessionT
  { runSessionT :: StateT Session (ExceptT SessionError m) a
  } deriving ( Applicative
         , Functor
         , Monad
         , MonadIO
         , MonadState Session
         , MonadError SessionError
         )

instance MonadTrans SessionT where
  lift = SessionT . liftState . liftExcept
    where liftState = lift :: Monad m => m a -> StateT Session m a
      liftExcept = lift :: Monad m => m a -> ExceptT SessionError m a

instance Monad m => MonadSession (SessionT m) where
    save key value = modify (session -> session {info = Map.insert key (show value) $ info session})
    setId newId = modify (session -> session { newId = Just newId })
    recall key = maybe (throwError $ SessionError $ "Missing field: " ++ key) return =<< tryRecall key
    tryRecall key = gets ((read <$>) . Map.lookup key . info)
    deleteSession = modify (session -> session {info = Map.empty})


withSession :: MonadIO m => Maybe String -> SessionT m a -> m (Either SessionError a)
withSession sessionId scoped =
  runExceptT (runAndSave scoped =<< maybe createSession getSession sessionId)
  where
    runAndSave scoped session = do
      (result, session') <- runStateT (runSessionT scoped) session
      saveSession session'
      return result

-- Private

sessionFileName :: String -> String
sessionFileName sessionId = sessionId ++ ".ses"

createSession :: MonadIO m => ExceptT SessionError m Session
createSession = return $ Session
    { originalId = Nothing
    , newId = Nothing
    , info = Map.empty
    }

getSession :: MonadIO m => String -> ExceptT SessionError m Session
getSession sessionId = do
  saved <- liftIO (tryJust (guard . isDoesNotExistError)
               (readFile $ sessionFileName sessionId)) >>=
       either (const $ throwError $ SessionError "Session not found") return
  info <- maybe (throwError $ SessionError "Session data corrupted") return $
        maybeRead saved
  return $ Session { originalId = Just sessionId
           , newId = Nothing
           , info = info }

saveSession :: MonadIO m => Session -> ExceptT SessionError m ()
saveSession session =
  let oldSessionName = sessionFileName <$> originalId session
      newSessionName = sessionFileName <$> newId session
      sessionInfo = show $ info session
  in liftIO (try (forM_ newSessionName $ sessionFile -> do
             unless (Map.null $ info session) $
               writeFile sessionFile sessionInfo
             forM_ oldSessionName justDelete)) >>=
     either handleException return

  where handleException :: MonadIO m => SomeException -> ExceptT SessionError m ()
    handleException exception = throwError $ SessionError $
      "Session failed to save " ++ show exception

    justDelete :: String -> IO ()
    justDelete fileName =
      catchJust (guard . isDoesNotExistError) (removeFile fileName) return

Handler.hs

There are a lot of constructs in this file.

First of all, there is data Handler. This structure represents an actual handler. Every handler has a command that initiates it (‘guess’ in our example). Every handler must be able to respond to messages starting with this command (function handleMessage). Some handlers may handle responses via handleResponse, and buttom presses via handleAnswer, hense the Maybe. This structure will be extended in the future to allow handling file attachments and other interactions.

data HandlerContext is everything a handler needs to at least send an error message to the user.

HandlerT adds handling functionality to the stack. It adds it’s own exceptions and provides the HandlerContext.

newtype HandlerAction is my whole monad stack so far. I could derive instances from HandlerT automatically, but I had to lift the MonadSession instance explicitly. I don’t like this manual labor, but I don’t know if I can do anything about it. Shoud I maybe add it to HandlerT so I can automatically derive it in the HandlerAction? Like: MonadSession m => MonadSession (HandlerT m).

Now for the functions:
runHandler just runs the given HandlerAction and reports any errors to the user. It needs a valid session. If the session failed to initialize or restore, handleSessionError should be called instead.

reply is used only in the Handler implementations. It would a protected method in C++-like languages. It replies to the user’s message and associates the session with this reply.

{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}

module Handler ( HandlerAction
           , HandlerContext(..)
           , Handler(..)
           , MonadSession(..)
           , runHandler
           , handleSessionError
           , throwError
           , reply
           ) where

import           Control.Monad (void)
import           Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import           Control.Monad.IO.Class (MonadIO)
import           Control.Monad.MonadStack (MonadStack, liftFrom)
import           Control.Monad.Reader (MonadReader, ask, runReaderT)
import           Control.Monad.State (MonadState)
import           Control.Monad.Trans.Class (MonadTrans(..), lift)
import           Control.Monad.Trans.Reader (ReaderT)

import           Config (ConfigT)
import           Session (SessionT, SessionError, MonadSession(..))
import qualified Telegram
import qualified Telegram.Types as TTypes

-- Public

newtype HandlerAction a = HandlerAction
  { runHandlerAction :: HandlerT (SessionT ConfigT) a
  } deriving ( Applicative, Functor, Monad, MonadIO
         , MonadError String, MonadReader HandlerContext
         )

instance MonadSession HandlerAction where
  save key value = HandlerAction $ lift $ (Session.save key value :: SessionT ConfigT ())
  setId = HandlerAction . lift . Session.setId
  recall = HandlerAction . lift . Session.recall
  tryRecall = HandlerAction . lift . Session.tryRecall
  deleteSession = HandlerAction $ lift $ Session.deleteSession

data Handler = Handler
    { command :: String
    , handleMessage :: String -> HandlerAction ()
    , handleResponse :: Maybe (String -> HandlerAction ())
    , handleAnswer :: Maybe (String -> HandlerAction ())
    }

data HandlerContext = HandlerContext
  { userId :: Int
  , messageId :: Int
  }

runHandler :: HandlerAction a -> HandlerContext -> SessionT ConfigT ()
runHandler handler = runReaderT (reportErrors =<< run handler)
  where
    reportErrors :: Either String a -> ReaderT HandlerContext (SessionT ConfigT) ()
    reportErrors = either sendError (const $ return ())

    sendError :: String -> ReaderT HandlerContext (SessionT ConfigT) ()
    sendError message = do
      context <- ask
      liftFrom $ sendMessage_ context message

    run :: HandlerAction a -> ReaderT HandlerContext (SessionT ConfigT) (Either String a)
    run = runExceptT . runHandlerT . runHandlerAction

handleSessionError :: HandlerContext -> SessionError -> ConfigT ()
handleSessionError context error = sendMessage_ context $ show error

reply :: String -> HandlerAction ()
reply message = do
  context <- ask
  id <- HandlerAction $ liftFrom $ sendMessage context message
  setId $ show id

-- Private

newtype HandlerT m a = HandlerT
  { runHandlerT :: ExceptT String(
           ReaderT HandlerContext
           m) a
  } deriving ( Applicative
         , Functor
         , Monad
         , MonadIO
         , MonadReader HandlerContext
         , MonadError String
         )

instance MonadTrans HandlerT where
  lift = HandlerT . lift . lift

sendMessage :: HandlerContext -> String -> ConfigT Int
sendMessage context message =
  let chatId = userId context
      originalId = messageId context
      postMessage = TTypes.PostMessage
    { TTypes.chat_id = chatId
    , TTypes.text = message
    , TTypes.reply_markup = Nothing
    , TTypes.reply_to_message_id = Just originalId
    }
  in Telegram.sendMessage postMessage

sendMessage_ :: HandlerContext -> String -> ConfigT ()
sendMessage_ context message  = void $ sendMessage context message

Controller.hs

processUpdate is the only public function. It takes a raw telegram message, determines it’s type, creates or restores a session, and passes the execution to a handler.

data UpdateInfo and data Request are adaptations of Telegram’s entities that are only used by this module.

r is a function that deals with duplicate record fields of Telegram’s entities.

{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE FlexibleContexts #-}

module Controller ( Controller(..)
          , processUpdate
          ) where

import           Control.Applicative ((<|>))
import           Data.Char (toLower)
import           Data.List (find, isPrefixOf)
import           Data.Maybe (fromMaybe, isNothing)

import           Config (ConfigT)
import           Handler (Handler(..), HandlerContext(..), HandlerAction,
              runHandler, handleSessionError, throwError)
import           Session (SessionT, MonadSession(..), withSession)
import qualified Telegram.Types as TTypes

-- Public

newtype Controller = Controller
  { handlers :: [Handler]
  }

processUpdate :: Controller -> TTypes.Update -> ConfigT ()
processUpdate controller update = do
  updateInfo <- getUpdateInfo update
  let sid = sessionId updateInfo
  let context = HandlerContext { userId = r @UpdateInfo user_id  updateInfo
                   , messageId = r @UpdateInfo message_id updateInfo
                   }
  result <- withSession sid $ do
    handlerAction <- findHandler updateInfo $ handlers controller
    runHandler handlerAction context
  either (handleSessionError context) return result


-- Private

data UpdateInfo = UpdateInfo
  { request :: Request
  , message :: String
  , user_id :: Int
  , message_id :: Int
  , sessionId :: Maybe String
  }

data Request
  = MessageRequest { message :: TTypes.GetMessage }
  | ResponseRequest { message :: TTypes.GetMessage }
  | QueryRequest { query :: TTypes.CallbackQuery
         , message :: TTypes.GetMessage }

r :: (r -> a) -> r -> a
r = ($)

getUpdateInfo :: TTypes.Update -> ConfigT UpdateInfo
getUpdateInfo update =
  let request = fromMaybe handleError $
        tryMessage update <|>
        tryEditedMessage update <|>
        tryCallbackQuery update
  in return UpdateInfo { request = request
               , message = getText request
               , user_id = getUser request
               , message_id = TTypes.message_id $ getMessage request
               , sessionId = show . TTypes.message_id <$> getInitialMessage request
               }

  where
    tryMessage :: TTypes.Update -> Maybe Request
    tryMessage update = messageOrReply <$> r @TTypes.Update TTypes.message update

    tryEditedMessage :: TTypes.Update -> Maybe Request
    tryEditedMessage update = messageOrReply <$> r @TTypes.Update TTypes.edited_message update

    tryCallbackQuery :: TTypes.Update -> Maybe Request
    tryCallbackQuery update = do
      query <- TTypes.callback_query update
      message <- r @TTypes.CallbackQuery TTypes.message query
      Just $ QueryRequest { query = query
              , message = message
              }

    getUser :: Request -> Int
    getUser (MessageRequest message) =
      r @TTypes.User TTypes.id $
    r @TTypes.GetMessage TTypes.from message
    getUser (ResponseRequest message) =
      r @TTypes.User TTypes.id $
    r @TTypes.GetMessage TTypes.from message
    getUser (QueryRequest query _) =
      r @TTypes.User TTypes.id $
    r @TTypes.CallbackQuery TTypes.from query

    getMessage :: Request -> TTypes.GetMessage
    getMessage request@MessageRequest{} = r @Request message request
    getMessage request@ResponseRequest{} = r @Request message request
    getMessage request@QueryRequest{} = r @Request message request

    getText :: Request -> String
    getText request@MessageRequest{} =
      fromMaybe "" $ r @TTypes.GetMessage TTypes.text $ getMessage request
    getText request@ResponseRequest{} =
      fromMaybe "" $ r @TTypes.GetMessage TTypes.text $ getMessage request
    getText request@QueryRequest{} = TTypes.info $ query request

    getInitialMessage :: Request -> Maybe TTypes.GetMessage
    getInitialMessage (MessageRequest message) = Nothing
    getInitialMessage (ResponseRequest message) = TTypes.reply_to_message message
    getInitialMessage (QueryRequest _ message) = Just message

    -- A proper error handler will be possible when Telegram service errors are implemented
    handleError :: a
    handleError = error "No message"

    messageOrReply :: TTypes.GetMessage -> Request
    messageOrReply message = if isNothing $ TTypes.reply_to_message message
                 then MessageRequest { message = message }
                 else ResponseRequest { message = message }

findHandler :: UpdateInfo -> [Handler] -> SessionT ConfigT (HandlerAction ())
findHandler updateInfo handlers =
  tryRecall "handler" >>= savedVerb ->
    let messageText = r @UpdateInfo message updateInfo
    verb = fromMaybe (map toLower messageText) savedVerb
    predicate handler = command handler `isPrefixOf` verb
    maybeHandler = find predicate handlers
    noHandler = throwError "Handler not found"
    noMethod = throwError "Method not found"
    prepareHandler handler =
        let maybeMethod = case request updateInfo of
            MessageRequest _ -> Just $ handleMessage handler
            ResponseRequest _ -> handleResponse handler
        in save "handler" (command handler) >>
           maybe noMethod ($ messageText) maybeMethod

    in return $ maybe noHandler prepareHandler maybeHandler

Telegram.hs

I will include the Telegram entities from Telegram/Types.hs for completeness, but they are really not important. I will not include Telegram.hs because there are a lot of open issues in the module and I don’t want the review to derail there. You wouldn’t be able to run the bot without a telegram API key anyway, and if you would like to compile it, you can mock every function from Telegram with undefined.

{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DuplicateRecordFields #-}

module Telegram.Types where

import Data.Aeson ( FromJSON(..), ToJSON(..), Options(..)
          , defaultOptions, genericToJSON, genericParseJSON )
import GHC.Generics (Generic)

-- GET queries

data File = File
  { file_id :: String
  , file_path :: Maybe String
  } deriving (Show, Generic, FromJSON)

data User = User
  { id :: Int
  } deriving (Show, Generic, FromJSON)

data PhotoSize = PhotoSize
  { file_id :: String
  , width :: Int
  , height :: Int
  } deriving (Show, Generic, FromJSON)

data GetMessage = GetMessage
  { message_id :: Int
  , from :: User
  , date :: Int
  , text :: Maybe String
  , photo :: Maybe [PhotoSize]
  , caption :: Maybe String
  , reply_to_message :: Maybe GetMessage
  } deriving (Show, Generic, FromJSON)

data CallbackQuery = CallbackQuery
  { id :: String
  , message :: Maybe GetMessage
  , from :: User
  , info :: String
  } deriving (Show, Generic)


instance FromJSON CallbackQuery
  where parseJSON = genericParseJSON defaultOptions
            { fieldLabelModifier = f -> if f == "info" then "data" else f
            }

data Update = Update
  { update_id :: Int
  , message :: Maybe GetMessage
  , callback_query :: Maybe CallbackQuery
  , edited_message :: Maybe GetMessage
  } deriving (Show, Generic, FromJSON)

data Response a = Response
  { ok :: Bool
  , result :: Maybe a
  } deriving (Show, Generic, FromJSON)

-- POST queries

data InlineKeyboardButton = InlineKeyboardButton
  { text :: String
  , callback_data :: String
  } deriving (Show, Generic, ToJSON)

data InlineKeyboardMarkup = InlineKeyboardMarkup
  { inline_keyboard :: [[InlineKeyboardButton]]
  } deriving (Show, Generic, ToJSON)

data PostMessage = PostMessage
  { chat_id :: Int
  , text :: String
  , reply_markup :: Maybe InlineKeyboardMarkup
  , reply_to_message_id :: Maybe Int
  } deriving (Show, Generic)

instance ToJSON PostMessage where
  toJSON = genericToJSON defaultOptions
    { omitNothingFields = True }

Usage

Here is how to use the framework: you write a number of handlers, create a controller with these handlers and start polling messages to your bot from Telegram. You then pass each new message to Handler.

Handlers/NumberGameHandler.hs

{-# LANGUAGE FlexibleContexts #-}

module Handlers.NumberGameHandler (numberGameHandler) where

import Control.Monad.IO.Class (liftIO)
import System.Random (randomRIO)
import Text.Read (readMaybe)

import Handler

numberGameHandler :: Handler
numberGameHandler = Handler
  { command = "guess"
  , handleMessage = doHandleMessage
  , handleResponse = Just doHandleResponse
  , handleAnswer = Nothing
  }

doHandleMessage :: String -> HandlerAction ()
doHandleMessage _ = do
  number <- liftIO (randomRIO (1, 10) :: IO Int)
  save "number" number
  reply "Guess a number between 1 and 10"

doHandleResponse :: String -> HandlerAction ()
doHandleResponse message = do
  guess <- readNumber message
  number <- recall "number"
  case compare guess number of
    LT -> reply "My number is greater"
    GT -> reply "My number is less"
    EQ -> reply "Correct!" >> deleteSession

  where
    readNumber :: String -> HandlerAction Int
    readNumber message = maybe (throwError "This is not a number") return $ readMaybe message

Main.hs

module Main where

import           Control.Monad (unless)
import           Control.Monad.IO.Class (liftIO)

import           Config (ConfigT, runConfigT, loadConfig)
import           Handlers.PingHandler
import           Handlers.NumberGameHandler
import           Controller (Controller(..), processUpdate)
import qualified Telegram (getUpdates)
import qualified Telegram.Types as TTypes (Update(..), GetMessage(..))

controller = Controller
  { handlers = [ pingHandler
           , numberGameHandler
           ]
  }

pollUpdates :: Int -> ConfigT ()
pollUpdates nextUpdate = do
  updates <- Telegram.getUpdates nextUpdate
  update_ids <- mapM process updates
  unless (null update_ids) $ pollUpdates $ maximum update_ids + 1

  where
    process :: TTypes.Update -> ConfigT Int
    process update = do
      liftIO $ showUpdate update
      processUpdate controller update
      return $ TTypes.update_id update

    showUpdate :: TTypes.Update -> IO ()
    showUpdate update = maybe (return ()) putStrLn $ TTypes.message update >>= TTypes.text

main :: IO ()
main = loadConfig >>= runConfigT (pollUpdates 0)


Get this bounty!!!

Leave a Reply

Your email address will not be published. Required fields are marked *

This site uses Akismet to reduce spam. Learn how your comment data is processed.