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)
1 Answer 1
Default class implementation
I've discovered a blog post about implementing monad stack with DefaultSignatures. I don't remember the link. The idea is that you create a default implementation to your monadic classes, that uses lift to implement the function when you derive this class in another transformer. For example, here is my Logger implementation:
Simple example: Logger
First, define your monad as a class with supported methods:
class (Monad m, MonadIO m) => MonadLogger m where
logMessage :: String -> m ()
Then, add the default implementation for deriving types, supposing the deriving types are derived from a MonadLogger using a MonadTrans. In this case (as in all simple cases where the monad only appears in the last position in the signature, i.e. the return type) this implementation is just the same function but lifted.
class (Monad m, MonadIO m) => MonadLogger m where
logMessage :: String -> m ()
default logMessage :: (MonadTrans t, MonadLogger m1, m ~ t m1)
=> String -> m ()
logMessage = lift . logMessage
This requires some language extensions.
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DefaultSignatures #-}
{-# LANGUAGE GADTs #-}
Next, implement the logger in a transformer:
newtype LoggerT m a = LoggerT
{ runLoggerT :: m a
} deriving ( Applicative
, Functor
, Monad
, MonadIO
)
instance MonadTrans LoggerT where
lift = LoggerT
instance (Monad m, MonadIO m) => MonadLogger (LoggerT m) where
logMessage = liftIO . putStrLn
Finally, here is how to derive MonadLogger in a monad higher in the stack. This also requires some more language extensions:
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DeriveAnyClass #-}
newtype ConfigT m a = ConfigT
{ runConfigT :: Reader.ReaderT Config m a
} deriving newtype ( Applicative
, Functor
, Monad
, MonadIO
, MonadReader Config
, MonadTrans
)
deriving anyclass ( MonadLogger )
Here, we had to derive our class using a different strategy. Honestly, I don't fully understand what anyclass does, so I won't try to explain it here. But I know that the result is somewhat equivalent if we were to derive MonadLogger by hand: instance MonadLogger m => MonadLogger (ConfigT m) where logMessage = lift . logMessage
Not here is the punch line: When m is MonadLogger, ConfigT also a MonadLogger. Here we don't need to lift at all when use it's methods:
getConfig :: MonadLogger m => (Config -> a) -> ConfigT m a
getConfig getter =
logMessage "Getting config value" >>
asks getter
Basic
I've defined a simple basic monad that would be the base of the actual stack.
type Basic = ConfigT (LoggerT IO)
runBasic :: Basic a -> IO a
runBasic basic =
runLoggerT $ (runReaderT $ runConfigT basic) =<< loadConfig
The idea is that every monad in my stack (or maybe multiple stacks) will be able to at least read app config and log messages.
Telegram and Dropbox
In the original post, Telegram and Dropbox functions lived in the ConfigT monad without defining their own monads. I've defined their classes this time:
class Monad m => MonadTelegram m where
getUpdates :: Int -> m [Update]
sendMessage :: PostMessage -> m Int
editReplyMarkup :: EditMessageReplyMarkup -> m ()
answerCallback :: String -> m ()
sendChatAction :: SendChatAction -> m ()
downloadFile :: String -> m (Maybe (String, L.ByteString))
default getUpdates :: (MonadTrans t, MonadTelegram m1, m ~ t m1)
getUpdates = lift . getUpdates
-- ... other similar default implementations that I will omit in this answer.
class Monad m => MonadDropbox m where
uploadFile :: String -> L.ByteString -> m ()
-- default uploadFile
Since these methods do not require their own monads and rely only on ConfigT which is a part of Basic, I've decided to skip the corresponding transformers and just add the functionality to Basic itself. Naturally, with more language extensions, since Basic is a type, not a newtype. So, Telegram.hs adds a MonadTelegram implementation to Basic:
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
instance MonadTelegram Basic where
getUpdates next_update = ...
sendMessage message = ...
editReplyMarkup = ...
answerCallback qid = ...
sendChatAction = ...
downloadFile fileId = ...
Dropbox.hs adds MonadDropbox to Basic in a similar fascion.
Session
Similarly, SessionMonad methods got default implementations. SessionT got more instances
newtype SessionT m a = SessionT
{ runSessionT :: StateT Session (ExceptT SessionError m) a
} deriving newtype ( Applicative
, Functor
, Monad
, MonadIO
, MonadState Session
, MonadError SessionError
)
deriving anyclass ( MonadTelegram
, MonadDropbox
, MonadLogger
)
Handler
Handler is at the top of the hierarchy right now, so I didn't define a MonadHandler class. HandlerT got more instances
newtype HandlerT m a = HandlerT
{ runHandlerT :: ExceptT String(
ReaderT HandlerContext
m) a
} deriving newtype ( Applicative
, Functor
, Monad
, MonadIO
, MonadReader HandlerContext
, MonadError String
)
deriving anyclass ( MonadSession
, MonadTelegram
, MonadDropbox
, MonadLogger
)
instance MonadTrans HandlerT where
lift = HandlerT . lift . lift
MonadStack
In the question, I've used MonadStack. It is a really cool library, in my opinion, because it is less than 10 lines of code and it looks like a math theorem. Here is it's source: https://hackage.haskell.org/package/MonadStack-0.1.0.3/docs/src/Control-Monad-MonadStack.html#MonadStack
For some reason, though, the compiler really dislikes this library. It complains about overlapping instances from time to time, and I couldn't really solve this problem. Also, there was a problem that I couldn't figure out a nice way to painlessly add monads in the middle of my stack. Now, every instance of lifting from something other than IO (including liftFrom) is removed from the project, because it is all in the default implementation. To add a monad in a stack, I only need to implement a class with a transformer and derive anyclass it up the stack. Take a look:
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE DuplicateRecordFields #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE MultiParamTypeClasses, FlexibleInstances #-}
module Handler ( HandlerAction(..)
, HandlerContext(..)
, Handler(..)
, MonadSession(..)
, Attachment(..)
, createHandler
, runHandler
, handleSessionError
, throwError
, reply
, reply_
, askQuestion
, editAnswers
, sendChatAction
, downloadFile
) where
import Control.Monad (void)
import Control.Monad.Except (ExceptT, MonadError, runExceptT, throwError)
import Control.Monad.IO.Class (MonadIO)
import Control.Monad.Reader (MonadReader, ask, asks, runReaderT)
import Control.Monad.State (MonadState)
import Control.Monad.Trans.Class (MonadTrans(..), lift)
import Control.Monad.Trans.Reader (ReaderT)
import qualified Data.ByteString.Lazy as L
import Basic (Basic)
import Session (SessionT, SessionError, MonadSession(..))
import Telegram (MonadTelegram)
import Dropbox (MonadDropbox)
import Logger (MonadLogger(..))
import qualified Telegram
import qualified Telegram.Types as TTypes
import Utils (r, (.:))
-- Public
type HandlerAction = HandlerT (SessionT Basic)
data Handler = Handler
{ command :: String
, handleMessage :: String -> HandlerAction ()
, handleResponse :: Maybe (String -> HandlerAction ())
, handleAnswer :: Maybe (String -> HandlerAction ())
}
createHandler :: String -> Handler
createHandler command = Handler
{ command = command
, handleMessage = const $ throwError "Handler not implemented"
, handleResponse = Nothing
, handleAnswer = Nothing
}
data Attachment = Attachment String
data HandlerContext = HandlerContext
{ userId :: Int
, messageId :: Int
, attachment :: Maybe Attachment
}
runHandler :: HandlerAction a -> HandlerContext -> SessionT Basic ()
runHandler handler context = reportErrors context =<< run handler context
where
reportErrors :: HandlerContext -> Either String a -> SessionT Basic ()
reportErrors context = either (sendError context) (const $ return ())
sendError :: HandlerContext -> String -> SessionT Basic ()
sendError = flip sendMessage_
run :: HandlerAction a -> HandlerContext -> SessionT Basic (Either String a)
run = runReaderT . runExceptT . runHandlerT
handleSessionError :: HandlerContext -> SessionError -> Basic ()
handleSessionError context error = sendMessage_ (show error) context
reply :: String -> HandlerAction ()
reply message = do
context <- ask
id <- postMessage (\m -> m { TTypes.text = message
, TTypes.reply_markup = Just $ TTypes.ForceReply { TTypes.force_reply = True }
} )
context
setId $ show id
reply_ :: String -> HandlerAction ()
reply_ message = askContext >>=
sendMessage message >>=
setId . show
askQuestion :: String -> [[String]] -> HandlerAction ()
askQuestion question answers = do
context <- ask
messageId <- show <$> sendQuestion question (mapAnswers answers) context
setId messageId
save "keyboardId" messageId
sendChatAction :: TTypes.ChatAction -> HandlerAction ()
sendChatAction chatAction = asks userId >>= \chatId ->
Telegram.sendChatAction $ TTypes.SendChatAction
{ TTypes.chat_id = chatId
, TTypes.action = chatAction
}
editAnswers :: [[String]] -> HandlerAction ()
editAnswers answers = do
context <- ask
messageId <- recall "keyboardId" :: HandlerAction String
void $ Telegram.editReplyMarkup $ TTypes.EditReplyMarkup
{ TTypes.message_id = messageId
, TTypes.chat_id = userId context
, TTypes.reply_markup = TTypes.InlineKeyboardMarkup
{ TTypes.inline_keyboard = mapAnswers answers }
}
downloadFile :: String -> HandlerAction (String, L.ByteString)
downloadFile fileId = do
result <- Telegram.downloadFile fileId
maybe (throwError "Не качается с телеграма") return result
-- Private
askContext :: HandlerAction HandlerContext
askContext = ask
newtype HandlerT m a = HandlerT
{ runHandlerT :: ExceptT String(
ReaderT HandlerContext
m) a
} deriving newtype ( Applicative
, Functor
, Monad
, MonadIO
, MonadReader HandlerContext
, MonadError String
)
deriving anyclass ( MonadSession
, MonadTelegram
, MonadDropbox
, MonadLogger
)
instance MonadTrans HandlerT where
lift = HandlerT . lift . lift
postMessage :: MonadTelegram m
=> (TTypes.PostMessage -> TTypes.PostMessage)
-> HandlerContext
-> m Int
postMessage initializer context =
let chatId = userId context
originalId = messageId context
in Telegram.sendMessage $ initializer $
TTypes.PostMessage { TTypes.chat_id = chatId
, TTypes.reply_to_message_id = Just originalId
, TTypes.reply_markup = Nothing
, TTypes.text = ""
}
mapAnswers :: [[String]] -> [[TTypes.InlineKeyboardButton]]
mapAnswers = (map . map) (\answer -> TTypes.InlineKeyboardButton
{ text = answer
, callback_data = answer
})
sendQuestion :: MonadTelegram m
=> String
-> [[TTypes.InlineKeyboardButton]]
-> HandlerContext
-> m Int
sendQuestion question keyboard =
let initialize message = message { TTypes.text = question
, TTypes.reply_markup = Just $ TTypes.InlineKeyboardMarkup
{ inline_keyboard = keyboard }
}
in postMessage initialize
sendMessage :: MonadTelegram m
=> String -> HandlerContext -> m Int
sendMessage message = postMessage (\m -> m {TTypes.text = message})
sendMessage_ :: MonadTelegram m => String -> HandlerContext -> m ()
sendMessage_ = void .: sendMessage
Conclusions
I like the default signatures because it removes most of the code duplication and lifts from the project. I can add monads to the stack and shuffle them around with not too much pain.
To add a monad, in general case I need to implement it's class and it's transformer, which is reasonable. I need to add derivations of it's transformer everywhere up the stack, which is annoying. I also need to copy-pase default implementations for derivation, which is incredibly annoying. Maybe some time in the future I will try to tackle the default implementations with TemplateHaskell, but it's too daunting for me for now.