12
\$\begingroup\$

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)
\$\endgroup\$
0
\$\begingroup\$

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.

\$\endgroup\$

Your Answer

By clicking “Post Your Answer”, you agree to our terms of service, privacy policy and cookie policy

Not the answer you're looking for? Browse other questions tagged or ask your own question.