caching - 如何在 Haskell 中进行复杂的 IO 处理和隐式缓存？

Question

在较大的应用程序中，通常有多层 IO 缓存(Hibernate L1 和 L2、Spring 缓存等)，它们通常是抽象的，因此调用者不需要知道特定的实现是 IO。有一些注意事项(范围、事务)，它允许组件之间更简单的接口(interface)。

例如，如果组件 A 需要查询数据库，它不需要知道结果是否已经缓存。它可能已被 B 或 C 检索到，而 A 对此一无所知，但是它们通常会参与某个 session 或事务——通常是隐式的。

框架倾向于使这种调用与使用 AOP 之类的技术的简单对象方法调用无法区分。

Haskell 应用程序是否有可能像这样受益？客户端的界面会是什么样子？

Answer 1

在 Haskell 中，有很多方法可以从代表各自职责的组件中组合计算。这可以在数据级别使用数据类型和函数 ( http://www.haskellforall.com/2012/05/scrap-your-type-classes.html ) 或使用类型类来完成。在 Haskell 中，您可以将每个数据类型、类型、函数、签名、类等视为一个接口(interface)；只要你有其他相同类型的东西，你就可以用兼容的东西替换一个组件。

当我们想在 Haskell 中推理计算时，我们经常使用 Monad 的抽象。 .一个 Monad是用于构建计算的接口(interface)。可以使用 return 构造基本计算这些可以与产生其他计算的函数组合在一起 >>= .当我们想为由 monad 表示的计算添加多个职责时，我们制作了 monad 转换器。在下面的代码中，有四种不同的 monad 转换器可以捕获分层系统的不同方面:
DatabaseT s添加架构类型为 s 的数据库.它处理数据 Operation s 通过将数据存储在数据库中或从数据库中检索数据。CacheT s拦截数据Operation s 表示架构 s并从内存中检索数据(如果可用)。OpperationLoggerT记录 Operation s 到标准输出ResultLoggerT记录 Operation 的结果s 到标准输出

这四个组件使用名为 MonadOperation s 的类型类(接口(interface))进行通信。 ，这要求实现它的组件提供一种方法来 perform Operation并返回其结果。

这个相同的类型类描述了使用 MonadOperation s 所需的内容。系统。它要求使用该接口(interface)的人提供数据库和缓存将依赖的类型类的实现。该接口(interface)还有两种数据类型，Operation和 CRUD .请注意，接口(interface)不需要了解有关域对象或数据库模式的任何信息，也不需要了解将实现它的不同 monad 转换器。 monad 转换器对模式或域对象一无所知，域对象和示例代码对构建系统的 monad 转换器一无所知。

示例代码唯一知道的是它可以访问 MonadOperation s由于其类型 example :: (MonadOperation TableName m) => m () .

程序main在两个不同的上下文中运行该示例两次。第一次，程序与数据库对话，其 Operations和响应被记录到标准输出。

Running example program once with an empty database
Operation Articles (Create (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."}))
    ArticleId 0
Operation Articles (Read (ArticleId 0))
    Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})
Operation Articles (Read (ArticleId 0))
    Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})

第二次运行记录程序收到的响应，通过 Operation s 通过缓存，并在请求到达数据库之前记录请求。由于对程序透明的新缓存，阅读文章的请求永远不会发生，但程序仍然收到响应:

Running example program once with an empty cache and an empty database
Operation Articles (Create (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."}))
    ArticleId 0
    Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})
    Just (Article {title = "My first article", author = "Cirdec", contents = "Lorem ipsum dolor sit amet."})

这是整个源代码。您应该将其视为四段独立的代码: 为我们的领域编写的程序，从 example 开始.一个应用程序，它是程序、讨论领域和构建它的各种工具的完整集合，从 main 开始.接下来的两部分，以架构 TableName 结尾，描述博客文章的领域；它们的唯一目的是说明其他组件如何组合在一起，而不是作为如何在 Haskell 中设计数据结构的示例。下一节描述了一个小接口(interface)，组件可以通过它来就数据进行通信；它不一定是一个好的界面。最后，源代码的其余部分实现了组合在一起形成应用程序的记录器、数据库和缓存。为了将工具和接口(interface)与域解耦，这里有一些带有可类型化和动态性的可怕技巧，这也不是为了演示处理强制转换和泛型的好方法。

{-# LANGUAGE StandaloneDeriving, GADTs, DeriveDataTypeable, FlexibleInstances, FlexibleContexts, GeneralizedNewtypeDeriving, MultiParamTypeClasses, ScopedTypeVariables,  KindSignatures, FunctionalDependencies, UndecidableInstances #-}

module Main (
    main
) where

import Data.Typeable
import qualified Data.Map as Map
import Control.Monad.State
import Control.Monad.State.Class
import Control.Monad.Trans
import Data.Dynamic

-- Example

example :: (MonadOperation TableName m) => m ()
example =
    do
        id <- perform $ Operation Articles $ Create $ Article {
            title = "My first article",
            author = "Cirdec",
            contents = "Lorem ipsum dolor sit amet."
        }
        perform $ Operation Articles $ Read id
        perform $ Operation Articles $ Read id
        cid <- perform $ Operation Comments $ Create $ Comment {
            article = id,
            user = "Cirdec",
            comment = "Commenting on my own article!"
        }

        perform $ Operation Equality $ Create False
        perform $ Operation Equality $ Create True
        perform $ Operation Inequality $ Create True
        perform $ Operation Inequality $ Create False

        perform $ Operation Articles $ List
        perform $ Operation Comments $ List
        perform $ Operation Equality $ List
        perform $ Operation Inequality $ List
        return ()

-- Run the example twice, changing the cache transparently to the code

main :: IO ()
main = do
    putStrLn "Running example program once with an empty database"
    runDatabaseT (runOpperationLoggerT (runResultLoggerT example)) Types { types = Map.empty }
    putStrLn "\nRunning example program once with an empty cache and an empty database"
    runDatabaseT (runOpperationLoggerT (runCacheT (runResultLoggerT example) Types { types = Map.empty })) Types { types = Map.empty }        
    return ()

-- Domain objects

data Article = Article {
    title :: String,
    author :: String,
    contents :: String

}
deriving instance Eq Article
deriving instance Ord Article
deriving instance Show Article
deriving instance Typeable Article

newtype ArticleId = ArticleId Int

deriving instance Eq ArticleId
deriving instance Ord ArticleId
deriving instance Show ArticleId
deriving instance Typeable ArticleId
deriving instance Enum ArticleId

data Comment = Comment {
    article :: ArticleId,
    user :: String,
    comment :: String
}

deriving instance Eq Comment
deriving instance Ord Comment
deriving instance Show Comment
deriving instance Typeable Comment

newtype CommentId = CommentId Int

deriving instance Eq CommentId
deriving instance Ord CommentId
deriving instance Show CommentId
deriving instance Typeable CommentId
deriving instance Enum CommentId

-- Database Schema

data TableName k v where
    Articles :: TableName ArticleId Article
    Comments :: TableName CommentId Comment
    Equality :: TableName Bool Bool
    Inequality :: TableName Bool Bool

deriving instance Eq (TableName k v)
deriving instance Ord (TableName k v)
deriving instance Show (TableName k v)
deriving instance Typeable2 TableName

-- Data interface (Persistance library types)

data CRUD k v r where
    Create :: v -> CRUD k v k
    Read :: k -> CRUD k v (Maybe v)
    List :: CRUD k v [(k,v)]
    Update :: k -> v -> CRUD k v (Maybe ())
    Delete :: k -> CRUD k v (Maybe ())

deriving instance (Eq k, Eq v) => Eq (CRUD k v r)
deriving instance (Ord k, Ord v) => Ord (CRUD k v r)
deriving instance (Show k, Show v) => Show (CRUD k v r)

data Operation s t k v r where
    Operation :: t ~ s k v => t -> CRUD k v r -> Operation s t k v r

deriving instance (Eq (s k v), Eq k, Eq v) => Eq (Operation s t k v r)
deriving instance (Ord (s k v), Ord k, Ord v) => Ord (Operation s t k v r)
deriving instance (Show (s k v), Show k, Show v) => Show (Operation s t k v r)

class (Monad m) => MonadOperation s m | m -> s where
    perform :: (Typeable2 s, Typeable k, Typeable v, t ~ s k v, Show t, Ord v, Ord k, Enum k, Show k, Show v, Show r) => Operation s t k v r -> m r

-- Database implementation

data Tables t k v = Tables {
    tables :: Map.Map String (Map.Map k v)
}

deriving instance Typeable3 Tables

emptyTablesFor :: Operation s t k v r -> Tables t k v
emptyTablesFor _ = Tables {tables = Map.empty} 

data Types = Types {
    types :: Map.Map TypeRep Dynamic
}

-- Database emulator

mapOperation :: (Enum k, Ord k, MonadState (Map.Map k v) m) => (CRUD k v r) -> m r
mapOperation (Create value) = do
    current <- get
    let id = case Map.null current of
            True -> toEnum 0
            _ -> succ maxId where
                (maxId, _) = Map.findMax current
    put (Map.insert id value current)
    return id
mapOperation (Read key) = do
    current <- get
    return (Map.lookup key current)
mapOperation List = do
    current <- get
    return (Map.toList current)
mapOperation (Update key value) = do
    current <- get
    case (Map.member key current) of
        True -> do
            put (Map.update (\_ -> Just value) key current)
            return (Just ())
        _ -> return Nothing
mapOperation (Delete key) = do
    current <- get
    case (Map.member key current) of
        True -> do
            put (Map.delete key current)
            return (Just ())
        _ -> return Nothing

tableOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t,  MonadState (Tables t k v) m) => Operation s t k v r -> m r
tableOperation (Operation tableName op) = do
    current <- get
    let currentTables =  tables current
    let tableKey = show tableName
    let table = Map.findWithDefault (Map.empty) tableKey currentTables 
    let (result,newState) = runState (mapOperation op) table
    put Tables { tables = Map.insert tableKey newState currentTables }
    return result

typeOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Typeable2 s, Typeable k, Typeable v, MonadState Types m) => Operation s t k v r -> m r
typeOperation op = do
    current <- get
    let currentTypes = types current
    let empty = emptyTablesFor op
    let typeKey = typeOf (empty)
    let typeMap = fromDyn (Map.findWithDefault (toDyn empty) typeKey currentTypes) empty
    let (result, newState) = runState (tableOperation op) typeMap
    put Types { types = Map.insert typeKey (toDyn  newState) currentTypes }
    return result

-- Database monad transformer (clone of StateT)

newtype DatabaseT (s :: * -> * -> *) m a = DatabaseT {
    databaseStateT :: StateT Types m a
}

runDatabaseT :: DatabaseT s m a -> Types -> m (a, Types)  
runDatabaseT = runStateT . databaseStateT

instance (Monad m) => Monad (DatabaseT s m) where
    return = DatabaseT . return
    (DatabaseT m) >>= k = DatabaseT (m >>= \x -> databaseStateT (k x))

instance MonadTrans (DatabaseT s) where
    lift = DatabaseT . lift

instance (MonadIO m) => MonadIO (DatabaseT s m) where
    liftIO = DatabaseT . liftIO      

instance (Monad m) => MonadOperation s (DatabaseT s m) where
    perform = DatabaseT . typeOperation

-- State monad transformer can preserve operations


instance (MonadOperation s m) => MonadOperation s (StateT state m) where
    perform = lift . perform

-- Cache implementation (very similar to emulated database)

cacheMapOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Show k, Show v, Typeable2 s, Typeable k, Typeable v, MonadState (Map.Map k v) m, MonadOperation s m) =>  Operation s t k v r -> m r
cacheMapOperation op@(Operation _ (Create value)) = do
    key <- perform op
    modify (Map.insert key value)
    return key
cacheMapOperation op@(Operation _ (Read key)) = do
    current <- get
    case (Map.lookup key current) of
        Just value -> return (Just value) 
        _ -> do
            value <- perform op
            modify (Map.update (\_ -> value) key)
            return value
cacheMapOperation op@(Operation _ (List)) = do
    values <- perform op
    modify (Map.union (Map.fromList values))
    current <- get
    return (Map.toList current)
cacheMapOperation op@(Operation _ (Update key value)) = do
    successful <- perform op
    modify (Map.update (\_ -> (successful >>= (\_ -> Just value))) key)
    return successful
cacheMapOperation op@(Operation _ (Delete key)) = do
    result <- perform op
    modify (Map.delete key)
    return result


cacheTableOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Show k, Show v, Typeable2 s, Typeable k, Typeable v,  MonadState (Tables t k v) m, MonadOperation s m) => Operation s t k v r -> m r
cacheTableOperation op@(Operation tableName _) = do
    current <- get
    let currentTables =  tables current
    let tableKey = show tableName
    let table = Map.findWithDefault (Map.empty) tableKey currentTables 
    (result,newState) <- runStateT (cacheMapOperation op) table
    put Tables { tables = Map.insert tableKey newState currentTables }
    return result

cacheTypeOperation :: (Enum k, Ord k, Ord v, t ~ s k v, Show t, Show k, Show v, Typeable2 s, Typeable k, Typeable v, MonadState Types m, MonadOperation s m) => Operation s t k v r -> m r
cacheTypeOperation op = do
    current <- get
    let currentTypes = types current
    let empty = emptyTablesFor op
    let typeKey = typeOf (empty)
    let typeMap = fromDyn (Map.findWithDefault (toDyn empty) typeKey currentTypes) empty
    (result, newState) <- runStateT (cacheTableOperation op) typeMap
    put Types { types = Map.insert typeKey (toDyn  newState) currentTypes }
    return result

-- Cache monad transformer

newtype CacheT (s :: * -> * -> *) m a = CacheT {
    cacheStateT :: StateT Types m a
}

runCacheT :: CacheT s m a -> Types -> m (a, Types)  
runCacheT = runStateT . cacheStateT

instance (Monad m) => Monad (CacheT s m) where
    return = CacheT . return
    (CacheT m) >>= k = CacheT (m >>= \x -> cacheStateT (k x))

instance MonadTrans (CacheT s) where
    lift = CacheT . lift

instance (MonadIO m) => MonadIO (CacheT s m) where
    liftIO = CacheT . liftIO      

instance (Monad m, MonadOperation s m) => MonadOperation s (CacheT s m) where
    perform = CacheT . cacheTypeOperation

-- Logger monad transform

newtype OpperationLoggerT m a = OpperationLoggerT {
    runOpperationLoggerT :: m a
}

instance (Monad m) => Monad (OpperationLoggerT m) where
    return = OpperationLoggerT . return
    (OpperationLoggerT m) >>= k = OpperationLoggerT (m >>= \x -> runOpperationLoggerT (k x))

instance MonadTrans (OpperationLoggerT) where
    lift = OpperationLoggerT

instance (MonadIO m) => MonadIO (OpperationLoggerT m) where
    liftIO = OpperationLoggerT . liftIO    

instance (MonadOperation s m, MonadIO m) => MonadOperation s (OpperationLoggerT m) where
    perform op = do
        liftIO $ putStrLn $ show op
        lift (perform op)      

-- Result logger

newtype ResultLoggerT m a = ResultLoggerT {
    runResultLoggerT :: m a
}

instance (Monad m) => Monad (ResultLoggerT m) where
    return = ResultLoggerT . return
    (ResultLoggerT m) >>= k = ResultLoggerT (m >>= \x -> runResultLoggerT (k x))

instance MonadTrans (ResultLoggerT) where
    lift = ResultLoggerT

instance (MonadIO m) => MonadIO (ResultLoggerT m) where
    liftIO = ResultLoggerT . liftIO    

instance (MonadOperation s m, MonadIO m) => MonadOperation s (ResultLoggerT m) where
    perform op = do
        result <- lift (perform op)
        liftIO $ putStrLn $ "\t" ++ (show result)
        return result

要构建此示例，您需要 mtl和 containers图书馆。