O Managed и MonadCatch или что делать если нельзя, но очень хочется…

Есть такой классный человек — Gabriel Gonzalez. Он делает с Haskell довольно классные и простые вещи. Зачастую ими совершенно никто не пользуется, но тем не менее они есть и на них стоит посмотреть хотя бы для того чтобы проникнуться и не делать из Хаскеля промышленную Яву. В частности именно он является автором пакета managed, который позволяет экономить отступы управлять ресурсами довольно своеобразным способом.

Что такое Managed?

Положим у есть файл. и нужно с ним сделать что-то хорошее. Файл надо открыть, получить его Handle, сделать с ним что-то и закрыть. Примерно так:

    hnd <- openFile "path/to/file" ReadMode
    hPutStrLn hnd "\1051\1103\1093, \1080\1076\1080 \1085\1072 \1093\1091\1081"
    hClose hnd

Что будет если попытаться записать что-то в файл открытый на чтение? Вылетит исключение и если его не поймать — тред упадёт. Если он главный и единственный можно заканчивать разговор. Если же есть друге треды то видимо где-то остался висеть открытый файл. Плохо. Хорошо, пишем так.

    hnd <- openFile "path/to/file" ReadMode
    hPutStrLn hnd "\1051\1103\1093, \1080\1076\1080 \1085\1072 \1093\1091\1081" `onException` hClose hnd
    hClose hnd

Уже лучше. Правда может прилететь асинхронное исключение из соседнего треда, которое может успеть помешать закрыть файл, но от него можно обезопасить себя при помощи mask. А можно обнаружить в стандартной библиотеке функцию withFile, которая всё это делает за вас примерно так.

    withFile "path/to/file" ReadMode $ \hnd -> hPutStrLn hnd "\1051\1103\1093, \1080\1076\1080 \1085\1072 \1093\1091\1081"

Всё прекрасно до тех пор пока нам не нужно записать содержимое одного файла в другой или даже записать содержимое двух файлов в один:

    withFile "path/to/file" ReadMode $ \hnd ->
        withFile "path/to/file1" ReadMode $ \hnd1 ->
            withFile "path/to/file2" ReadMode $ \hnd2 -> do
                hGetContents hnd  >>= hPutStr hnd2
                hGetContents hnd1 >>= hPutStr hnd2

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

    runMagicState $ do
        hnd  <- smartFileOpen "path/to/file"  ReadMode
        hnd1 <- smartFileOpen "path/to/file1" ReadMode
        hnd2 <- smartFileOpen "path/to/file2" ReadMode
        liftIO $ hGetContents hnd  >>= hPutStr hnd2
        liftIO $ hGetContents hnd1 >>= hPutStr hnd2

Можно сделать так чтобы смарт-конструкторы возвращали ещё и универсальный ключ, добавить подсчёт ссылок, передавать ресурсы между тредами, освобождать в рантайме и вообще сделать свой собственный resourcet. Правда придётся писать для всех ресурсов смарт-конструкторы регистрирующие финализаторы, которые можно использовать только с волшебной монадой, что немного расстраивает. А можно решить что во варианте с withFile итак всё было хорошо кроме способа соединения вычислений между собой и поискать тут монаду более хитрую монаду.

    newtype Managed a = Managed { with :: forall r . (a -> IO r) -> IO r }

    instance Functor Managed where
        fmap f mx = Managed $ \return_ ->
            with mx $ \x ->
            return_ $ f x

    instance Applicative Managed where
        pure r    = Managed $ \return_ -> return_ r

        mf <*> mx = Managed $ \return_ ->
            with mf $ \f ->
            with mx $ \x ->
            return_ $ f x

    instance Monad Managed where
        return   = pure

        ma >>= f = Managed $ \return_ ->
            with ma $ \a ->
            with (f a) $ \b ->
            return_ b

    instance MonadIO Managed where
        liftIO m = Managed $ \return_ -> do
            v <- m
            return_ v

В принципе это примерно весь код, который необходим для работы Managed. Теперь можно писать код как-то так.

    with $ do
        hnd  <- Managed $ withFile "path/to/file" ReadMode
        hnd1 <- Managed $ withFile "path/to/file1" ReadMode
        hnd2 <- Managed $ withFile "path/to/file2" ReadMode
        liftIO $ hGetContents hnd  >>= hPutStr hnd2
        liftIO $ hGetContents hnd1 >>= hPutStr hnd2

Плюсом данного подхода является использование готовых смарт-конструкторов, написанных автором библиотеки, отсутствие явного стейта, который можно было бы как-то хитро сломать и простота кода. Минусом скромность возможностей: нельзя передать ресурс во владение другому треду, нельзя запустить финализацию раньше времени¹. Примерно как RAII в C++.

MonadCatch и MonadMask

Наступило счастье? Скорее всего нет. В реальной жизни почти всегда почему-то недостаточно дёрнуть финализатор перед смертью. Ситуаций где это достаточно и необходимо станет совсем не много. Если начать задумываться о том что в ходе выполнения программы возникают исключения, то почему-то сразу начинает требоваться ловить эти исключения и передавать в другой тред, откладывать исключения до момента пока не закончится вон та очень важная операция и многое другое, типа таймеров, юзер-интерапта и прочего KillThread. Также очень часто приходится работать не с одной монадой, а со стеком монадных трансформеров. Трансформер на вершине стека не зависит от конкретной монады нижнего уровня и опирается лишь на констрейнты, которыми он её ограничивает. Итого: нужно обрабатывать исключения в рамках Managed, а не только вызывать финализацию, нужны инстансы MonadCatch и MonadMask для Managed. А вот тут возникают проблемы.

• В числе законов MonadCatch указан только:

  catch (throwM e) f = f e

  который выполнить довольно легко, но если не обеспечить также поведение вида:

  catch (try meval) f >> throwM e = throwM e

  то скорее всего люди столкнувшись с таким catch’ем будут озадачены настолько что отрубят автору такого инстанса руки. Но для Managed следующее связанное выражение выполняется не после текущего, а внутри. Так что если обернуть его целиком в catch, то мы заодно обернём в catch и все последующие связанные выражения в этой монаде и получится что-то вроде такого поведения.

  catch (try meval) f >> throwM e = f e

• Если оборачивать в catch Managed-выражение, должны быть перехвачены исключение возникшие только до следующего связывания или в финализаторе тоже?

Можно попытаться вспомнить что Managed, это в теории такой специализированный вид монады ContT из transfomers, а в exceptions есть необходимые инстансы для стандартных монад. Но если посмотреть туда, станет понятно что ContT чуть ли не единственная монада оттуда для которой Эдвард Кметт не придумал MonadCatch и MonadMask. В общем случае решить эти вопросы довольно трудно, традиционно принято их не решать вообще и пользоваться либо managed, либо exceptions.

Костыли

Что делать если очень хочется? Для начала попробуем себя уговорить, что проблемы нет. Начнём со второго вопроса. Итак, по сути каждое вычисление в Managed состоит из самого «вычисления» и некоего «финализатора», который выполнится после того как выполнятся все связанные вычисления.

    Managed $ \следующее -> вычисление >>= следующее >> финализатор

Традиционный withSome выглядит примерно так:

    withSome eval = bracket
        resourceInitialize
        (\resource -> finalize resource)
        (\resource -> eval resource)

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

Хорошо. Как в таком случае обернуть в catch только половину функции, которая соответствует только нашему «вычислению»? Наверное никак. Но вместо этого мы можем попробовать инвалидировать финализатор.

> {-# LANGUAGE Rank2Types #-}

> import Control.Exception ( allowInterrupt )
> import Data.IORef
> import Control.Monad.Catch
> import Control.Monad.Managed

Чтобы быть MonadCatch, надо сначала стать MonadThrow. Но тут всё очевидно.

> instance MonadThrow Managed where
>     throwM = liftIO . throwM

Затем изобразим функцию catch для типов, которые скрывает Managed.

> managedCatch :: Exception e => ((a -> IO r) -> IO r) -> (e -> (a -> IO r) -> IO r) -> (a -> IO r) -> IO r
> managedCatch eval handler next = do
>     ref <- newIORef handler
>     let handler' e n = readIORef ref >>= \h -> h e n
>     catch (eval (\v -> mask_ (writeIORef ref (\e _ -> throwM e)) >> next v)) (\e -> handler' e next)

Ну и сам инстанс будет выглядеть как-то так:

> instance MonadCatch Managed where
>     catch eval handler = managed $ managedCatch (with eval) (with . handler)

Всё. Можно перехватывать и обрабатывать исключения. У этого подхода есть как минимум следующие недостатки:

• Нужна целая одна переменная. Кметту можно даже не пытаться показывать — проклянёт.
• Всё вычисления от момента использования catch и до последнего связанного выражения на самом деле завёрнуто в catch, а если их несколько штук к ряду то на самом деле это матрёшка. И тут возникает нюанс: я точно не знаю как устроена обработка исключений в ghc, но все известные мне реализации catch подразумевают если и не копирование всего стека перед вхождением catch, то хотя бы его заморозку. Иначе не получится вернутся к состоянию стека до вызова catch. В общем случае это значит, что часть объектов на стеке будут удерживаться даже если бы в любом другом случае их собрал gc. Здесь же это удерживание будет продолжаться дольше чем надо вплоть до самого конца региона. Это проблема. Но с другой стороны это проблема не только данного решения, но и функций withSomeThing вообще так что хрен с ним.
• Если асинхронное исключение прилетит после того после того как завершилось «вычисление», но до того как отработает маскировка, будет вызван оригинальный обработчик исключения, который сделает что-то. Беда-огорчение.

Этот уровень можно считать условно пройденным. Дальше MonadMask и с ним всё хуже.

Попробуем понять, что должна делать и чего делать не должна функция mask для Managed. Видимо исходя из предположения в начале она должна маскировать «вычисление» и не маскировать «финализатор». Почему нужно не маскировать «финализатор»?

• Чтобы создать гомогенность поведения и не порождать неожиданных эффектов в конце выполняемого блока catch не ловит исключения в «финализаторе», а mask не маскирует «финализатор».
• Для безопасности. Мы снова возвращаемся к тому вопросу, что «финализатор» написан человеком, который представляет себе как надо выделять и освобождать ресурс. Вероятнее всего он уже замаскирован, но если это не так, то для этого скорее всего были веские причины.

Проблема в том, что mask маскирует функцию, а с точки зрения кода «вычисление» и «финализатор» это одна функция и замаскировать её мы можем только целиком. Хорошо, расчехляем allowInterrupt.

> managedMask :: ((forall b. Managed b -> Managed b) -> Managed a) -> Managed a
> managedMask eval =
>     managed $ \next ->
>         mask $ \unmask ->
>             with (eval $ managedRestore unmask) $ \resource -> do
>                 v <- unmask (next resource)
>                 allowInterrupt
>                 return v

> managedRestore :: (forall a. IO a -> IO a) -> Managed b -> Managed b
> managedRestore oldRestore eval = managed $ \next -> oldRestore $ with eval next

Всё? Нет. Нужен ещё uninterruptibleMask. Он понятное дело выглядит абсолютно аналогично предыдущему коду, но есть одно но: allowInterrupt не производит никакого эффекта будучи вызванным из uninterruptibleMask. Другого способа размаскировать «финализатор» я не знаю и если по какой-то причине он зависнет то это уже навсегда. Кроме того это создаёт ощутимую разницу с mask в поведении. Что делать?

• Гомогенезировать поведение. Разрешить mask маскировать «финализатор», a catch ловить исключения в финализаторе. Это не сложно, но я уверен что это не совсем то поведение, которое хотелось бы видеть.
• Пойти на сомнительную сделку с собственной совестью и решить что uninterruptibleMask всё равно никто толком не использует примерно никогда, а если и использует то на коротких, гарантированно завершающихся функциях, у которых почти наверняка нет «финализатора».
• Страдать и признать поражение и страдать.

> instance MonadMask Managed where
>     mask                = managedMask
>     uninterruptibleMask =
>         \eval -> managed $ \next ->
>             uninterruptibleMask $ \unmask ->
>                 with (eval $ managedRestore unmask) $ (unmask . next)