Making RelationalError extendable/customizeable

[farzadbekran]

Given that most API calls take a Connection and SessionId and return an Either RelationalError a result type, I have made a ReaderT + ExceptT monad stack and wrapped the API calls in it. Like this:

data DBEnv = DBEnv { getHead :: Text
                   , getConnection :: Connection
                   , getSessionId :: SessionId
                   }

type Action a = ReaderT DBEnv (ExceptT RelationalError IO) a

connInfo :: ConnectionInfo
connInfo = RemoteConnectionInfo
  "my-db"
  "127.0.0.1"
  "6543"
  emptyNotificationCallback

conn :: IO Connection
conn = handleIOError $ connectProjectM36 connInfo

handleIOError :: Show e => IO (Either e a) -> IO a
handleIOError m = do
  v <- m
  handleError v

handleError :: Show e => Either e a -> IO a
handleError eErr = case eErr of
  Left err -> print err >> error "Died due to errors."
  Right v  -> pure v

The wrapped API calls look like this:

execRelExp :: RelationalExpr -> Action Relation
execRelExp rExp = do
  env <- ask
  lift
    $ ExceptT
    $ executeRelationalExpr (getSessionId env) (getConnection env) rExp

Then I use runDB to run the stack:

runDB :: Action a -> IO (Either RelationalError a)
runDB a = do
  c <- liftIO conn
  sessionId <- liftIO $ createSessionAtHead c "master"
  case sessionId of
    Right sid -> withTransaction
      sid
      c
      (runExceptT
         (runReaderT
            a
            DBEnv { getHead = "master", getConnection = c, getSessionId = sid }))
      (autoMergeToHead sid c UnionMergeStrategy "master")
    Left e    -> return $ Left e

Now let's say I want a function that given a RelVar name, returns its contents. But it also makes sure the user making the call has read access to that RelVar. To do this, I would do something like this:

checkReadAccess :: UserId -> RelVarName -> Action Bool
checkReadAccess uid rv = ... -- see if the user has access to that rel var

getRelVar :: RelVarName -> Action Relation
getRelVar rv = do
  let userId = ... -- get user ID from http session or something
  hasReadAccess <- checkReadAccess userId rv
  if hasReadAccess 
    then execRelExp $ RelationVariable rv ()
    else throwError (AccessError userId rv) -- need to signal this problem somehow

This whole thing can go wrong in multiple ways, some of which come from Project:M36 and some are app specific. (i.e. rel var is not defined or user is not logged in or user has no read access). If somehow RelationalError could be extended to allow for app specific errors, things could become very easy in monad stacks and very composable in general.

So far I can't think of a way to do this cleanly. Any suggestions are welcome!

[YuMingLiao]

How about using sum types to extend errors?

data AllErrors = DBError RelationalError | AppError AppError
data AppError = AccessError UserID RelVarName

type Action a = ReaderT DBEnv (ExceptT AllErrors IO) a
And this way, you can throw your customized errors in your monad.
throwError (AppError (AccessError userId rv))

[farzadbekran]

@YuMingLiao You're right, this would work. I was hoping for something that is usable out of the box, so that I could completely separate my lower level functions from the application logic. For example if I use AllErrors, then my Action type would have to change and the wrapped API calls would have to change, and in general my data layer would not be agnostic about what the application might be doing. I wouldn't be able to put my data layer in a separate library for example.

Maybe TypeFamilies or type classes or some Haskell type system magic can solve it, but I'm not experienced enough to think of something.

In any case, if something like the above is not possible, I think I will have to do it your way. I would also like to hear what @agentm thinks about this. And thanks for the reply!

[YuMingLiao]

@farzadbekran Type famlies! of course...

OpenErrorLibrary.hs
-- like your data layer in a separate library

{-# LANGUAGE TypeFamilies #-}
module OpenErrorLibrary where

type family Error e
type instance Error RelationalError = RelationalError

a :: Error RelationalError
a = ...

OpenErrorUser.hs

{-# LANGUAGE TypeFamilies #-}
import OpenErrorLibrary

data AppError = ... deriving Show
type instance Error AppError = AppError
type instance Error (Either AppError RelationalError) = Either AppError RelationalError

b :: Error AppErrpr
b = ...

c :: Error (Either AppError RelationalError)
c = ...

type Action e a = ReaderT DBEnv (ExceptT (Error e) IO) a
type Action (Error RelationalError) a is for your data layer. Your data layer would be agnostic about the app.
type Action (Error (Either AppError RelationalError)) a or type Action (Error AppError)) a would be your app layer.

In this way, you change less things. You abstract Action type and runDB type, but need not change your old, relational-error-related-only, data-level wrapped api calls (if I understand you correctly).

[farzadbekran]

@YuMingLiao Yup, I think this does it. I'll try this tomorrow and let you know how it goes. Thanks again!

[farzadbekran]

@YuMingLiao I failed to make Actions composable using TypeFamilies but I came up with a solution which does not require any changes in the Project:M36. Let me know what you think.

{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE StandaloneDeriving #-}

import Control.Monad.Except
import Control.Monad.Reader

-------- this would be defined in Project:M36 (RelationalError)
data DBError = E1 | E2 String
  deriving (Show)

dbAPI :: Int -> IO (Either DBError String)
dbAPI i =
  if i > 0
    then return $ Right "OK"
    else return $ Left $ E2 "Negative Int Error!"

----------------- My Data layer begins here
data CombinedErrors where
  DBE :: DBError -> CombinedErrors
  UE :: Show e => e -> CombinedErrors

deriving instance Show CombinedErrors

newtype DBEnv = DBEnv { getHead :: String }

type Action a = ReaderT DBEnv (ExceptT CombinedErrors IO) a

class Actionable e a where
  toActionIO :: IO (Either e a) -> Action a
  toAction :: Either e a -> Action a

runAction :: Action a -> IO (Either CombinedErrors a)
runAction action = runExceptT (runReaderT action (DBEnv "test"))

instance Actionable DBError a where
  toActionIO a = do
    v <- liftIO a
    case v of
      Left l -> liftEither $ Left $ DBE l
      Right r -> liftEither $ Right r
  toAction a = do
    case a of
      Left l -> liftEither $ Left $ DBE l
      Right r -> liftEither $ Right r

wrappedAPI :: Int -> Action String
wrappedAPI i = toActionIO $ dbAPI i

----------------- My App layer begins here
data UserError = UE1 | UE2 String
  deriving (Show)

instance Actionable UserError a where
  toActionIO a = do
    v <- liftIO a
    case v of
      Left l -> liftEither $ Left $ UE l
      Right r -> liftEither $ Right r
  toAction a = do
    case a of
      Left l -> liftEither $ Left $ UE l
      Right r -> liftEither $ Right r

appFn :: Int -> Action String
appFn i = do
  if i <= 100
    then wrappedAPI i
    else toAction $ Left $ UE2 "Int Is Too Large!"

--------------- all compose relatively well now
test :: Int -> IO (Either CombinedErrors (String, String))
test i = runAction $ do
  r1 <- appFn i
  r2 <- wrappedAPI i
  return (r1, r2)

[YuMingLiao]

Oh! right, IO is the real tricky thing.

Brilliant! Now you can have IO/pure expressions with any error and compose them together later in your Action. Thanks for sharing!

[agentm]

This is not directly related, but there is also the project-m36-typed project which provides a more strongly typed means of interacting with the Project:M36 client library.