Haskell 不同类型的里德尔？_Haskell_Higher Kinded Types_Data Kinds

Haskell 不同类型的里德尔？

haskell

Haskell 不同类型的里德尔？,haskell,higher-kinded-types,data-kinds,Haskell,Higher Kinded Types,Data Kinds,冒着这一风险，是否可能有一个具有不同类型环境的ReaderT？我正在尝试类似于 type AppM (perms :: [*]) = ReaderT (perms :: [*]) IO …但是编译器抱怨 Expected a type, but ‘(perms :: [*])’ has kind ‘[*]’ …大概是因为ReaderT被定义为 newtype ReaderT r (m :: k -> *) (a :: k) = ReaderT {runReaderT :: r ->

冒着这一风险，是否可能有一个具有不同类型环境的

ReaderT

？我正在尝试类似于

type AppM (perms :: [*]) = ReaderT (perms :: [*]) IO

…但是编译器抱怨

Expected a type, but ‘(perms :: [*])’ has kind ‘[*]’

…大概是因为

ReaderT

被定义为

newtype ReaderT r (m :: k -> *) (a :: k) = ReaderT {runReaderT :: r -> m a}

…其中

属于

我试图在类型级别跟踪权限/角色，我的最终目标是编写如下函数

ensurePermission :: (p :: Permission) -> AppM (p :. ps) ()

。。。其中，对

的每次调用都会在monad的权限列表（在类型级别）中添加/预先添加一个新权限
编辑
我尝试了以下内容，它似乎已经编译好了，但我不确定到底发生了什么。从概念上讲，perms
不是一种[*]
。编译器如何接受此代码段，而原始代码段却不是
data HList (l :: [*]) where
  HNil :: HList '[]
  HCons :: e -> HList l -> HList (e ': l)

type AppM (perms :: [*]) = ReaderT (HList perms) IO

编辑#2
我试图改进我的代码片段以进一步匹配我的最终目标，但我又遇到了一个不同的“类”问题：
编译器不接受以下代码：
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}

data Permission = PermissionA
                | PermissionB

$(genSingletons [''Permission])

data PList (perms :: [Permission]) where
  PNil :: PList '[]
  PCons :: p -> PList perms -> PList (p ': perms)

--     • Expected kind ‘[Permission]’, but ‘p : perms’ has kind ‘[*]’
--     • In the first argument of ‘PList’, namely ‘(p : perms)’
--       In the type ‘PList (p : perms)’
--       In the definition of data constructor ‘PCons’
--    |
-- 26 |   PCons :: p -> PList perms -> PList (p ': perms)
--    |                                       ^^^^^^^^^^


它也不接受以下变化
data PList (perms :: [Permission]) where
  PNil :: PList '[]
  PCons :: (p :: Permission) -> PList perms -> PList (p ': perms)


--     • Expected a type, but ‘(p :: Permission)’ has kind ‘Permission’
--     • In the type ‘(p :: Permission)’
--       In the definition of data constructor ‘PCons’
--       In the data declaration for ‘PList’
--    |
-- 26 |   PCons :: (p :: Permission) -> PList perms -> PList (p ': perms)
--    |            ^^^^^^^^^^^^^^^^^

是的，我想我们在这里有一个XY问题，所以我们后退一步。< /P>
Reader
是一种单子，用于携带方便读取的值。您没有一个值--您有一个要在类型级别强制执行的权限列表--所以我认为您不需要或不需要一个读卡器，或者一个异构列表，或者其他类似的东西
相反，给定一个布尔权限列表：
data Permission = PermissionA | PermissionB deriving (Show)

-- runM with no permissions
runM :: M '[] a -> IO a
runM (M act) = act

data Permission
  = ReadP            -- read content
  | MetaP            -- view (private) metadata
  | WriteP           -- write content
  | AdminP           -- all permissions
  deriving (Show, Eq)

requireRead :: MonadIO m => EntryT' r c m () -> EntryT' r (ReadP:c) m ()
requireRead = unsafeRequire ReadP
requireWrite :: MonadIO m => EntryT' r c m () -> EntryT' r (WriteP:c) m ()
requireWrite = unsafeRequire WriteP
-- plus functions for the rest of the permissions

您希望定义一个在类型级别参数化的monad，并列出其授予的权限。围绕基础IO
monad的新类型包装器可以：
{-# LANGUAGE DataKinds, KindSignatures, GeneralizedNewtypeDeriving #-}
newtype M (ps :: [Permission]) a = M (IO a) deriving (Functor, Applicative, Monad)

您还需要一个类型函数（也称为类型族）来确定权限是否在权限列表中：
{-# LANGUAGE TypeFamilies, TypeOperators #-}
type family Allowed (p :: Permission) ps where
  Allowed p '[] = False
  Allowed p (p:ps) = True
  Allowed p (q:ps) = Allowed p ps

现在，如果要编写需要特定权限的函数，可以编写以下内容：
deleteA :: (Allowed PermissionA ps ~ True) => M ps ()
deleteA = M $ print "Deleted A"

readB :: (Allowed PermissionB ps ~ True) => M ps ()
readB = M $ print "Read B"

copyBtoA :: ( Allowed PermissionA ps ~ True
            , Allowed PermissionB ps ~ True) => M ps ()
copyBtoA = M $ print "Copied B to A"

要运行M
操作，我们将引入一个无权限运行的函数：
data Permission = PermissionA | PermissionB deriving (Show)

-- runM with no permissions
runM :: M '[] a -> IO a
runM (M act) = act

data Permission
  = ReadP            -- read content
  | MetaP            -- view (private) metadata
  | WriteP           -- write content
  | AdminP           -- all permissions
  deriving (Show, Eq)

requireRead :: MonadIO m => EntryT' r c m () -> EntryT' r (ReadP:c) m ()
requireRead = unsafeRequire ReadP
requireWrite :: MonadIO m => EntryT' r c m () -> EntryT' r (WriteP:c) m ()
requireWrite = unsafeRequire WriteP
-- plus functions for the rest of the permissions

请注意，如果您尝试runM readB
，您将得到一个类型错误（无法将False
与True
匹配，这不是最大的错误消息，而是…）
为了授予权限，我们引入了以下功能：
-- grant permissions
grantA :: M (PermissionA:ps) a -> M ps a
grantA (M act) = M act
grantB :: M (PermissionB:ps) a -> M ps a
grantB (M act) = M act

这些函数本质上是术语级的标识函数——它们只是展开并重新包装M
构造函数。但是，它们在类型级别的操作是向其输入参数添加权限。这意味着：
runM $ grantB $ readB

现在输入检查。我们也要这样做：
runM $ grantA . grantB $ readB
runM $ grantB . grantA $ readB
runM $ grantB . grantA . grantB $ readB
etc.

然后您可以编写如下程序：
program :: IO ()
program = runM $ do
  grantA $ do
    deleteA
    grantB $ do
      readB
      copyBtoA

program1 :: IO ()
program1 = runM $ do
  grantA $ do
    deleteA
    grantB $ do
      readB
    copyBtoA    -- error, needs PermissionB

在拒绝以下程序时：
program :: IO ()
program = runM $ do
  grantA $ do
    deleteA
    grantB $ do
      readB
      copyBtoA

program1 :: IO ()
program1 = runM $ do
  grantA $ do
    deleteA
    grantB $ do
      readB
    copyBtoA    -- error, needs PermissionB

这个基础结构可能有点难看，但它应该是基于类型、完全编译时权限检查所需要的全部
也许可以尝试一下这个版本，看看它是否满足您的需要。完整代码为：
{-# LANGUAGE DataKinds, KindSignatures, GeneralizedNewtypeDeriving,
             TypeFamilies, TypeOperators #-}

data Permission = PermissionA | PermissionB deriving (Show)

newtype M (ps :: [Permission]) a = M (IO a) deriving (Functor, Applicative, Monad)

type family Allowed (p :: Permission) ps where
  Allowed p '[] = False
  Allowed p (p:ps) = True
  Allowed p (q:ps) = Allowed p ps

-- runM with no permissions
runM :: M '[] a -> IO a
runM (M act) = act

-- grant permissions
grantA :: M (PermissionA:ps) a -> M ps a
grantA (M act) = M act
grantB :: M (PermissionB:ps) a -> M ps a
grantB (M act) = M act

deleteA :: (Allowed PermissionA ps ~ True) => M ps ()
deleteA = M $ print "Deleted A"

readB :: (Allowed PermissionB ps ~ True) => M ps ()
readB = M $ print "Read B"

copyBtoA :: ( Allowed PermissionA ps ~ True
            , Allowed PermissionB ps ~ True) => M ps ()
copyBtoA = M $ print "Copied B to A"

program :: IO ()
program = runM $ do
  grantA $ do
    deleteA
    grantB $ do
      readB
      copyBtoA

根据@dfeuer的评论增加了两条注释。首先，它提醒我，grantA
和grantB
同样可以使用Data中的“safe”concure
函数编写。concure
如下所示。此版本与上述版本之间生成的代码没有差异，因此这是一个品味问题：
import Data.Coerce

-- grant permissions
grantA :: M (PermissionA:ps) a -> M ps a
grantA = coerce
grantB :: M (PermissionB:ps) a -> M ps a
grantB = coerce

其次，@dfeuer所说的是，在控制权限的受信任代码库和依赖类型系统强制执行权限系统的代码“其余”之间没有明确的区分。例如，M
构造函数上的模式匹配本质上是危险的，因为您可以从一个权限上下文中提取IO a
，然后在另一个权限上下文中重建它。（这基本上就是grantA
和grantB
无条件提升特权所做的事情。）如果您在受信任的代码库之外“意外”这样做，您可能最终会绕过权限系统。在许多应用程序中，这并不是什么大问题
但是，如果您试图证明一个系统是安全的，那么您可能需要一个小的可信代码库，它与危险的M
构造函数一起工作，并且只导出一个“安全”的API，以确保通过类型系统的安全性。在这种情况下，您将有一个模块导出类型M
，而不是其构造函数M（…）
。相反，您应该导出智能构造函数来创建具有适当权限的M
操作
此外，出于模糊的技术原因，即使不导出M
构造函数，“不受信任”的代码仍有可能在不同的权限上下文之间进行强制：
stealPermission :: M (PermissionA:ps) a -> M ps a
stealPermission = coerce

因为M
类型构造函数的第一个参数有一个所谓的“role”，默认为“phantom”而不是“nominal”。如果覆盖此选项：
{-# LANGUAGE RoleAnnotations #-}
type role M nominal _

然后，强制
只能在构造函数在作用域内的情况下使用，这就堵塞了这个漏洞。不受信任的代码仍然可以使用非安全性
，但有一些机制（谷歌的“安全Haskell”）可以防止这种情况发生。
在另一个要点中，您评论道：
@K.A.Buhr，哇！谢谢你如此详细的答复。你是对的，这是一个XY问题，你已经基本解决了我试图解决的实际问题。上下文的另一个重要部分是，在某种程度上，这些类型级别的权限必须在值级别“具体化”。这是因为最终检查是针对授予当前登录用户的权限进行的，这些权限存储在数据库中
考虑到这一点，我计划有两个“通用”功能，比如：
requiredPermission :: (RequiredPermission p ps) => Proxy p -> AppM ps ()
optionalPermission :: (OptionalPermission p ps) => Proxy p -> AppM ps ()

区别在于：

requiredPermission
只需将权限添加到类型级别列表中，并在调用runAppM
时对其进行验证。如果当前用户没有所有必需的权限，则runAppM
将立即向UI抛出401错误
另一方面，optionalPermission
将从阅读器环境中提取用户，ch
readPageWithMeta :: ( Allowed 'ReadP perms ~ 'True, Allowed 'MetaP perms ~ 'True
    , MonadIO m) => Int -> AppT perms m ()
readPageWithMeta n = do
  readPage n
  metaPage n

readPageWithOptionalMeta :: ( Allowed 'ReadP perms ~ 'True
    , MonadIO m) => Int -> AppT perms m ()
readPageWithOptionalMeta n = do
  readPage n
  whenMeta $ metaPage n

newtype EntryT' (reqP :: [Permission]) (checkedP :: [Permission]) m a
  = EntryT (ReaderT Env m a)
  deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO)
type EntryT reqP = EntryT' reqP reqP

runEntryT :: MonadIO m => User -> EntryT req m () -> m ()
runEntryT u (EntryT act)
  = case lookup u userDB of
      Nothing   -> say $ "error 401: no such user '" ++ u ++ "'"
      Just perms -> runReaderT act (Env perms u)

entryReadPage :: MonadIO m => Int -> EntryT '[ReadP] m ()
entryReadPage n = _somethingspecial_ $ do
  readPage n
  whenMeta $ metaPage n

(Allowed 'ReadP perms ~ 'True, MonadIO m) => Int -> AppT perms m ()

requireRead :: MonadIO m => EntryT' r c m () -> EntryT' r (ReadP:c) m ()
requireRead = unsafeRequire ReadP
requireWrite :: MonadIO m => EntryT' r c m () -> EntryT' r (WriteP:c) m ()
requireWrite = unsafeRequire WriteP
-- plus functions for the rest of the permissions

unsafeRequire :: MonadIO m => Permission -> EntryT' r c m () -> EntryT' r c' m ()
unsafeRequire p act = do
  ps <- asks uperms
  if allowed p ps
    then coerce act
    else say $ "error 403: requires permission " ++ show p

entryReadPage :: MonadIO m => Int -> EntryT '[ReadP] m ()
entryReadPage n = requireRead . _ $ do
  readPage n
  whenMeta $ metaPage n

AppT perms0 m0 () -> EntryT' '[ReadP] '[] m ()

toRunAppT :: MonadIO m => AppT r m a -> EntryT' r '[] m a
toRunAppT = coerce

entryReadPage :: MonadIO m => Int -> EntryT '[ReadP] m ()
entryReadPage n = requireRead . toRunAppT $ do
  readPage n
  whenMeta $ metaPage n

entryEditPage :: MonadIO m => Int -> EntryT '[ReadP, WriteP] m ()
entryEditPage n = requireRead . requireWrite . toRunAppT $ do
  editPage n
  whenMeta $ metaPage n

whenMeta :: Monad m => AppT (MetaP:perms) m () -> AppT perms m ()
whenMeta = unsafeWhen MetaP
-- and similar functions for other permissions

unsafeWhen :: Monad m => Permission -> AppT perms m () -> AppT perms' m ()
unsafeWhen p act = do
  ps <- asks uperms
  if allowed p ps
    then coerce act
    else return ()

Username/Req (e.g., "alice Read 5"): alice Read 5    -- Alice...
Read page 5
Username/Req (e.g., "alice Read 5"): bob Read 5      -- and Bob can read.
Read page 5
Username/Req (e.g., "alice Read 5"): carl Read 5     -- Carl gets the metadata, too
Read page 5
Secret metadata 25
Username/Req (e.g., "alice Read 5"): bob Edit 3      -- Bob can't edit...
error 403: requires permission WriteP
Username/Req (e.g., "alice Read 5"): alice Edit 3    -- but Alice can.
Edit page 3
Username/Req (e.g., "alice Read 5"):

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Realistic where

import Control.Monad.Reader
import Data.Coerce

-- |Set of permissions
data Permission
  = ReadP            -- read content
  | MetaP            -- view (private) metadata
  | WriteP           -- write content
  | AdminP           -- all permissions
  deriving (Show, Eq)

type User = String
-- |User database
userDB :: [(User, [Permission])]
userDB
  = [ ("alice", [ReadP, WriteP])
    , ("bob",   [ReadP])
    , ("carl",  [AdminP])
    ]

-- |Environment with 'uperms' and whatever else is needed
data Env = Env
  { uperms :: [Permission]   -- user's actual permissions
  , user :: String           -- other Env stuff
  } deriving (Show)

-- |Check for permission in type-level and term-level lists
type family Allowed (p :: Permission) ps where
  Allowed p (AdminP:ps) = True   -- admins can do anything
  Allowed p '[] = False
  Allowed p (p:ps) = True
  Allowed p (q:ps) = Allowed p ps
allowed :: Permission -> [Permission] -> Bool
allowed p (AdminP:ps) = True
allowed p (q:ps) | p == q = True
                 | otherwise = allowed p ps
allowed p [] = False

-- |An application action running with a given list of checked permissions.
newtype AppT (perms :: [Permission]) m a = AppT (ReaderT Env m a)
  deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO)

-- Optional actions run if permissions are available at runtime.
whenRead :: Monad m => AppT (ReadP:perms) m () -> AppT perms m ()
whenRead = unsafeWhen ReadP
whenMeta :: Monad m => AppT (MetaP:perms) m () -> AppT perms m ()
whenMeta = unsafeWhen MetaP
whenWrite :: Monad m => AppT (WriteP:perms) m () -> AppT perms m ()
whenWrite = unsafeWhen WriteP
whenAdmin :: Monad m => AppT (AdminP:perms) m () -> AppT perms m ()
whenAdmin = unsafeWhen AdminP
unsafeWhen :: Monad m => Permission -> AppT perms m () -> AppT perms' m ()
unsafeWhen p act = do
  ps <- asks uperms
  if allowed p ps
    then coerce act
    else return ()

-- |An entry point, requiring a list of permissions
newtype EntryT' (reqP :: [Permission]) (checkedP :: [Permission]) m a
  = EntryT (ReaderT Env m a)
  deriving (Functor, Applicative, Monad, MonadReader Env, MonadIO)
-- |An entry point whose full list of required permission has been (statically) checked).
type EntryT reqP = EntryT' reqP reqP

-- |Run an entry point whose required permissions have been checked.
runEntryT :: MonadIO m => User -> EntryT req m () -> m ()
runEntryT u (EntryT act)
  = case lookup u userDB of
      Nothing   -> say $ "error 401: no such user '" ++ u ++ "'"
      Just perms -> runReaderT act (Env perms u)

-- Functions to build the list of required permissions for an entry point.
requireRead :: MonadIO m => EntryT' r c m () -> EntryT' r (ReadP:c) m ()
requireRead = unsafeRequire ReadP
requireMeta :: MonadIO m => EntryT' r c m () -> EntryT' r (MetaP:c) m ()
requireMeta = unsafeRequire MetaP
requireWrite :: MonadIO m => EntryT' r c m () -> EntryT' r (WriteP:c) m ()
requireWrite = unsafeRequire WriteP
requireAdmin :: MonadIO m => EntryT' r c m () -> EntryT' r (AdminP:c) m ()
requireAdmin = unsafeRequire AdminP
unsafeRequire :: MonadIO m => Permission -> EntryT' r c m () -> EntryT' r c' m ()
unsafeRequire p act = do
  ps <- asks uperms
  if allowed p ps
    then coerce act
    else say $ "error 403: requires permission " ++ show p

-- Adapt an entry point w/ all static checks to an underlying application action.
toRunAppT :: MonadIO m => AppT r m a -> EntryT' r '[] m a
toRunAppT = coerce

-- Example application actions
readPage :: (Allowed ReadP perms ~ True, MonadIO m) => Int -> AppT perms m ()
readPage n = say $ "Read page " ++ show n
metaPage :: (Allowed ReadP perms ~ True, MonadIO m) => Int -> AppT perms m ()
metaPage n = say $ "Secret metadata " ++ show (n^2)
editPage :: (Allowed ReadP perms ~ True, Allowed WriteP perms ~ True, MonadIO m) => Int -> AppT perms m ()
editPage n = say $ "Edit page " ++ show n

say :: MonadIO m => String -> m ()
say = liftIO . putStrLn

-- Example entry points
entryReadPage :: MonadIO m => Int -> EntryT '[ReadP] m ()
entryReadPage n = requireRead . toRunAppT $ do
  readPage n
  whenMeta $ metaPage n
entryEditPage :: MonadIO m => Int -> EntryT '[ReadP, WriteP] m ()
entryEditPage n = requireRead . requireWrite . toRunAppT $ do
  editPage n
  whenMeta $ metaPage n

-- Test harnass
data Req = Read Int
         | Edit Int
         deriving (Read)
main :: IO ()
main = do
  putStr "Username/Req (e.g., \"alice Read 5\"): "
  ln <- getLine
  case break (==' ') ln of
    (user, ' ':rest) -> case read rest of
      Read n -> runEntryT user $ entryReadPage n
      Edit n -> runEntryT user $ entryEditPage n
  main