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
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)
