В статье описывается механизм создания собственного модифицированного варианта монады IO в Haskell, с ограничениями операций ввода-вывода.

Хорошим тоном организации структуры любой программы на Haskell считается разделение кода на блоки, выполняющие IO операции ввода-вывода, и блоки, полностью состоящие из чистых функций, т.е. функций, не выполняющих IO операций, а лишь принимающие на вход некоторые данные и возвращающие их в преобразованном виде. Такого рода чистые блоки по сути представляют из себя функции в математическом смысле слова, принимающие аргумент и возвращающие значение функции, и напоминают программы зари компьютерной эры, когда данные с перфокарт загружались в программу в самом начале её работы, после чего некоторое время обрабатывались, и по итогу работы программы выводила на печать итоговый результат расчётов, при этом в ходе работы программы не предполагалось никакого интерактивного взаимодействия с ней.

Чтобы добавить в программу интерактивность, но при этом максимально сохранить математическую целостность функций, применяется примерно такой подход:

mainLoop :: ReadParams -> ApplicationState -> IO ()
mainLoop readParams appState = do
    -- IO операция считывающая ввод пользователя (клавиатура, мышь, и т.п.), 
    -- а также загрузка необходимых данных с жесткого диска, из базы данных или по сети.
    -- Никакой другой логики здесь быть не должно!
    inputData <- ioGetInputData readParams appState

    -- Чистая функция. Вся логика программы содержится внутри неё.
    let newState = processBusinessLogic inputData appState

    -- IO операция - вывод информации на экран, сохранение нужных данных в файл, в базу данных и т.п.
    -- И снова никакой другой логики, кроме вывода данных здесь нет.
    ioOutputData newState

    mainLoop readParams newState

Это примерная структура главного цикла программы, сознательно упрощенная до одного потока. Конечно, в реальном приложении, имеет смысл запускать операции ввода-вывода ioGetInputData и ioOutputData в отдельных потоках, например, с помощью команды forkIO, чтобы с точки зрения пользователя интерактивность взаимодействия ощущалась мгновенной и без лагов. Но в данной статье речь пойдёт не об этом. Поэтому, без ограничения общности будем считать, что каждый шаг цикла mainLoop выполняется быстрее, чем за 1/60 секунды :)

Вся бизнес-логика приложения находится в функции processBusinessLogic, но в ходе работы processBusinessLogic может потребоваться дозагрузить что-то ещё из исходных данных, а такой возможности у неё нет, т.к. это чистая функция. Придётся ждать следующего шага цикла. Информацию о том, какие данные надо дозагрузить processBusinessLogic положит в newState и на следующем шаге ioGetInputData выгрузит новую порцию данных. Для этого ioGetInputData и принимает на вход appState. Разумеется, в реальном приложении нет смысла передавать ioGetInputData весь appState, достаточно передать лишь ту информацию, которая указывает что нужно выгрузить.

К сожалению, на практике придерживаться представленного архитектурного шаблона получается далеко не всегда. Если логика работы требует часто требует обращения к IO операциям, то писать код в таком стиле становиться неудобным. К тому же если каждый раз ждать следующего шага цикла, чтобы продолжить выполнение бизнес логики, это может очень плохо сказаться на производительности. Например, рекурсивный алгоритм обхода каталогов на жестком диске для поиска файла требует IO операции считывания содержимого папки на каждом своём шаге. И если для поиска файла потребуется каждый раз ждать нового шага цикла mainLoop, производительность чудовищно ухудшится.

Поэтому очень часто приходится идти на компромисс и писать бизнес логику в IO монаде, сознательно жертвуя архитектурой.

Итак, если по какой-либо причине мы вынуждены писать бизнес логику в монаде IO, то можно ли как-то модифицировать IO монаду, чтобы коду внутри неё позволено было выполнять лишь те IO операции, которые выполнять необходимо? Конечно да! И сейчас мы это сделаем.

Для начала рассмотрим простую задачу. Коду, находящемуся внутри processBusinessLogic необходимо получать системное время (например, для seed-а генератора случайных чисел). Никаких других IO операций processBusinessLogic не требуется. В идеале, конечно, системное время должно быть получено на этапе работы ioGetInputData и передаваться в processBusinessLogic как аргумент, но мы уже решили, что по каким-то причинам это невозможно. Ну не давать же в самом деле функции processBusinessLogic доступ к полноценной монаде IO ради такой мелочи?

Как же ограничить IO? Надо обернуть её в другой тип (назовём его GetTime), сделать его монадой, реализовав соответствующий instance, и не дать пользователю доступа к его конструктору типа-обёртки. Тогда из монады GetTime невозможно будет запустить никаких других IO операций, кроме тех, которые реализованы в модуле GetTime и экспортируются из него (в данном примере это единственная функция getTime).

module GetTime
  ( GetTime (), -- Это важно! Нельзя экспортировать конструктор UnsafeGetTime
    runGetTime, -- "запускалка" монады GetTime
    getTime, -- единственная дозволенная IO операция
  )
where

import Control.Monad (ap)
import qualified Data.Time as Time

-- GetTime - это обёртка над IO, но за пределами модуля нет доступа к его конструктору
newtype GetTime a = UnsafeGetTime {runGetTime :: IO a}

instance Functor GetTime where
  -- стандартная имплементация функтора для типа-обёртки
  fmap f (UnsafeGetTime io) = UnsafeGetTime (f <$> io)

instance Applicative GetTime where
  -- тоже все стандартно  
  pure = UnsafeGetTime . pure
  -- А вы знали, что так можно? Функция ap сама реализует 
  -- функцию (<*>) через (>>=), раз уж всё равно мы пишем монаду
  (<*>) = ap 

instance Monad GetTime where
  -- и опять стандартная имплементация монады для типа-обёртки
  (UnsafeGetTime io) >>= k = UnsafeGetTime $ io >>= runGetTime . k

-- Имея конструктор UnsafeGetTime мы можем после него написать любую IO операцию, 
-- а за пределами модуля это будет невозможно
getTime :: GetTime Time.UTCTime
getTime = UnsafeGetTime Time.getCurrentTime

И действительно при попытке выполнить любую IO операцию находясь внутри монады GetTime, мы получим ошибку согласования типов. Всё что мы можем, это выполнять getTime, чего мы и добивались.

module BusinessLogic where
import GetTime

someBusinessLogic :: GetTime String
someBusinessLogic = do
    t <- getTime

    -- print "Unsuccessful Hack"
    -- ^^^ Если раскомментировать строку выше, то компилятор ругается:
    -- Couldn't match type `IO' with `GetTime' -- Expected: GetTime () -- Actual: IO ()

    -- а вот если бы у нас был UnsafeGetTime, мы могли бы имели доступ ко всем IO операциям, например так:
    -- UnsafeGetTime $ print "Ho-ho-ho"

    -- Хоть мы и внутри монады GetTime, но необязательно возвращать тип UTCTime, 
    -- можно вернуть что угодно, например, строку
    pure ("Текущее время: " ++ show t ) 

Всё получилось? Ну, не совсем. Ведь в Haskell есть чудесная функция unsafeCoerce, которая может "превратить" всякий тип данных в любой другой, а по сути просто даёт указание компилятору не проводить тайпчекинг в данном месте. Поэтому строчка unsafeCoerce $ print "Successful Hack" взламывает всю нашу систему защиты.

К счастью существует прагма Safe, которая запрещает использовать unsafeCoerce и любые другие функции её производные. Достаточно разместить прагму Safe в одном единственном месте в модуле, из которого вызывается монада GetTime (например, в модуле Main), и мы можем быть уверены, что во всём коде, который выполняется внутри монады GetTime, сколь бы большим он не был, нет unsafeCoerce или аналогичных ей функций (иначе компилятор сообщит об ошибке).

{-# LANGUAGE Safe #-}
module Main where

import GetTime
import qualified BusinessLogic

main :: IO ()
main = do
  -- запуск единственной функции getTime
  timeResult <- runGetTime getTime
  print timeResult

  -- запуск сколь угодно большого куска программного кода, 
  -- в котором гарантированно не будет выполнено никаких других IO операций, кроме getTime
  stringResult <- runGetTime BusinessLogic.someBusinessLogic
  putStrLn stringResult

Понятно, как создать ограниченную IO монаду для общего случая по аналогии с GetTime.

Мы хотим, чтобы некоторый код мог взаимодействовать с базой данных и файловой системой, но при этом мы не хотим давать этому коду полноценный доступ ко всей БД и всему жесткому диску, а хотим ограничить его права определенными каталогами и таблицами в БД. На сей раз тип обёртку назовём RIO - Restricted IO. Именно так и называется пакет в репозитории Hackage.

module RIO
  ( RIO (), -- обёртка монады IO без конструктора
    Permission(..), -- настройки ограничений
    runRIO, 
    rioReadFile, -- несколько разрешенных IO операций
    rioWriteFile,
    rioReadFromDB,
    rioWriteToDB
  )
where

import Control.Monad (ap)
import Control.Monad.Reader (MonadIO (liftIO), ReaderT (runReaderT), asks)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS


-- С помощью типа данных Permission можно определить доступ к необходимым папкам и таблицам БД
data Permission = Permission
  { allowedReadDirs :: [FilePath],
    allowedWriteDirs :: [FilePath],
    allowedReadDBTables :: [String],
    allowedWriteDBTables :: [String]
  }

-- тип обёртка монады IO
newtype RIO a = UnsafeRIO {unRIO :: ReaderT Permission IO a}

runRIO :: Permission -> RIO a -> IO a
runRIO permissons routine = runReaderT (unRIO routine) permissons

-- Реализация функтора, аппликатива и монады полностью аналогичка предыдущему примеру.
instance Functor RIO where
  fmap f (UnsafeRIO io) = UnsafeRIO (fmap f io)

instance Applicative RIO where
  pure = UnsafeRIO . pure
  (<*>) = ap

instance Monad RIO where
  (UnsafeRIO ioA) >>= k = UnsafeRIO $ ioA >>= unRIO . k

-- Дозволенные IO операции
rioReadFile :: FilePath -> RIO (Maybe ByteString)
rioReadFile file =
  UnsafeRIO $ do
    readDirs <- asks allowedReadDirs
    if checkFilePath readDirs file
      then liftIO (BS.readFile file) >>= pure . Just
      else pure Nothing

rioWriteFile :: FilePath -> ByteString -> RIO Bool
rioWriteFile file content =
  UnsafeRIO $ do
    writeDirs <- asks allowedWriteDirs
    if checkFilePath writeDirs file
      then liftIO (BS.writeFile file content) >> pure True
      else pure False

-- Понятно, как реализовать и остальные необходимые функции. 
-- Здесь они представлены как заглушки для примера.
rioReadFromDB :: Connection -> TableName -> Fields -> RIO (Maybe [[ByteString]])
rioReadFromDB con table fields = undefined

rioWriteToDB :: Connection -> TableName -> Fields -> [[ByteString]] -> RIO Bool
rioWriteToDB con table fields content = undefined

checkFilePath :: [FilePath] -> FilePath -> Bool
checkFilePath = undefined

Обратите внимание, что тип обёртка определяется как newtype RIO a = UnsafeRIO {unRIO :: ReaderT Permission IO a}, а не так

newtype RIO' a = UnsafeRIO {unRIO' :: IO a}

type RIO a = ReaderT Permission RIO' a

В противном случае пользователь будет иметь доступ к монаде ReaderT, а значит сможет подменить содержание Permission, например, с помощью функции local.

Использование монады RIO из сторонних модулей полностью аналогично использованию монады GetTime. Не забудьте добавить прагму Safe.

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE Safe #-}

module RunRIO where

import Data.ByteString (ByteString)
import Data.Maybe (fromMaybe)
import RIO

conn = "Provider=PostgreSQL..."

routine :: RIO ByteString
routine = do
  mayFile <- rioReadFile "input_data/csv_files/file1.csv"
  mayData <- rioReadFromDB conn "users.accounts" ["Username", "email"]
  _ <- rioWriteToDB conn "log.common_logs" ["severity", "message"] [["info", "write OK"]]
  pure (fromMaybe "" mayFile)

main :: IO ()
main = do
  let permission =
        Permission
          { allowedReadDirs = ["input_data/csv_files/"],
            allowedWriteDirs = [],
            allowedReadDBTables = ["users.accounts", "transactions.transactions", "log.common_logs"],
            allowedWriteDBTables = ["log.common_logs"]
          }
  bs <- runRIO permission routine
  print bs

С помощью этого приёма можно разделить программу на блоки, каждый из которых имеет набор нужных ему IO операций. Такой подход понизит вероятность возникновения случайной ошибки при написании кода или при его рефакторинге, а также сделает всю систему более защищённой, и не позволит случайной (или предумышленно созданной) ошибке повредить базу данных, файловую систему или получить несанкционированный доступ к информации.