Question

我在工作中使用了很多数据库（以及其他数据源），每个数据库略有不同，可能是不同的后端，或者需要在运行时提供稍微不同的信息，所以每当我编写程序时haskell我必须兼顾很多逻辑，使用这个和ConnectInfo，在这里或那里传递这个句柄，它最终淹没了我的程序的逻辑，这通常很简单。

所以我决定写一个小库来为我做所有繁重的工作。

我觉得我正在接近我的目标，但我不在那里。在这里我有两个假装数据库，A和B，一个只需要一个查询，但另一个需要我指定我想要查询的数据库的名称。

#!/usr/bin/env stack
-- stack --resolver lts-6.22  runghc --package mtl --package mysql-simple

{-# LANGUAGE ExistentialQuantification, LambdaCase, FlexibleInstances, FlexibleContexts, UndecidableInstances, OverloadedStrings #-}
{-# OPTIONS_GHC -Wall #-}
module West.Databases.Types where

import Control.Monad.Trans.Resource
import Control.Monad.Trans
import Control.Monad.State.Strict

import Database.MySQL.Simple as MS
import Database.MySQL.Simple.QueryParams as MS
import Database.MySQL.Simple.QueryResults as MS

newtype DBName = DBName String deriving Eq

data DBState = DBState {
    aDBConn :: Maybe Connection
  , bDBConn :: Maybe (Connection, DBName)
}

class MonadResource m => MonadDB m where
  liftDB :: DBAction a -> m a

runB :: DBName -> BQuery a -> DBAction a
runB dbname (BQuery q p f) = BAction dbname q p f

runA :: AQuery a -> DBAction a
runA (AQuery q p f) = AAction q p f

instance (MonadState DBState m, MonadResource m, MonadIO m) => MonadDB m where
  liftDB (AAction q p f) = f <$> do
    (aDBConn <$> get) >>= \case
      Nothing -> do
        newconn <- snd <$> allocate (MS.connect (undefined :: ConnectInfo)) MS.close
        modify (\dbs -> dbs { aDBConn = Just newconn })
        liftIO (MS.query newconn q p)
      Just aconn -> liftIO (MS.query aconn q p)
  liftDB (BAction newdbname q p f) = f <$> do
    (bDBConn <$> get) >>= \case
      Nothing -> undefined
      Just (bconn, dbname) -> if dbname == newdbname
        then liftIO (MS.query bconn q p)
        else do
          -- MS.query "use newdbname"
          liftIO (MS.query bconn q p)

data DBAction a =
    forall r p. AAction Query p ([r] -> a)
  | forall r p. BAction DBName Query p ([r] -> a)

instance Functor DBAction where
  fmap f (AAction q p fr) = AAction  q p (f . fr)
  fmap f (BAction dbname q p fr) = BAction dbname q p (f . fr)

-- TODO
instance Applicative DBAction
instance Monad DBAction

data BQuery a = forall r p. BQuery Query p ([r] -> a)
data AQuery a = forall r p. AQuery Query p ([r] -> a)

这允许我编写像这样的代码

data UID
data Password

me :: AQuery (UID, DBName)
me = AQuery "select uid,customerdb from users where user_name rlike 'me@blah.com'" () undefined

friends :: UID -> BQuery Int
friends uid = BQuery "select count(*) from friends where uid = ?" uid undefined

userCount :: AQuery Int
userCount = AQuery "select count(*) from users" () toCount
  where
    toCount ((Only i):_) = i
    toCount _ = error "userCount should not occur"

userAuth :: UID -> Password -> AQuery Bool
userAuth uid pass = AQuery "select count(*) from users where uid = ? and password = ?" (uid, pass)
  (\c -> head c > (0 :: Int))

并且还将不同数据库的操作组合到我可以运行liftDB的过程中。这会在主数据库中找到用户，然后查询所述数据库以获取有关该用户的更多深度信息。

myFriends :: DBAction Int
myFriends = do
  (uid, dbname) <- runA me
  runB dbname (friends uid)

问题是msyql/postgresql-simple库的query功能非常相似，具有以下类型

query :: (ToRow q, FromRow r) => Connection -> Query -> q -> IO [r]
query :: (QueryParams q, QueryResults r) => Connection -> Query -> q -> IO [r]

导致ToRow/QueryParams/FromRow/QueryResults传播到MonadDB类，这可能不应该发生，但我无法弄清楚如何防止它。我觉得DBAction应该以某种方式包含运行查询和更新某些状态所需的逻辑......

Answer 1

经过一段时间的努力，我找到了我正在寻找的解决方案。

data DBAction a =
    forall p r. (QueryParams p, QueryResults r) => AAction Query p ([r] -> a)
  | forall p r. (QueryParams p, QueryResults r) => BAction DBName Query p ([r] -> a)
  -- forall p r. (FromRow r, ToRow r) => .... etc.

data AQuery a = forall r p. (QueryParams p, QueryResults r) => AQuery Query p ([r] -> a)
data BQuery a = forall r p. (QueryParams p, QueryResults r) => BQuery Query p ([r] -> a)

然后更改我的查询，以便在查询时给出具体类型以消除歧义。

friends :: UID -> BQuery Int
friends uid = BQuery "select count(*) from friends where uid = ?" (undefined uid :: (Only Int)) toCount
  where
    toCount ((Only i):_) = i
    toCount _ = 0

防止类型类约束向上传播通过变换器堆栈

1 个答案: