Registry.hs

{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE LambdaCase #-}

-- | This module exports tools for implementing a registry that @moto@ can use
-- in order to keep track of the migrations that have been run so far.
--
-- It's unlikely that you'll need to concern yourself with this module as an
-- end user of @moto@.
--
-- Please import as:
--
-- @
-- import qualified "Moto.Registry" as Moto
-- @
module Moto.Registry
 ( -- * Command-line support
   IC.RegistryConf(..)

   -- * Registry
 , I.Registry(..)
 , newAppendOnlyRegistry

   -- * State
 , I.State
 , I.emptyState
 , I.updateState
 , I.Log(..)

   -- * Errors
 , Err_Tainted(..)
 , I.Err_Prepare(..)
 , I.Err_Abort(..)
 , I.Err_Commit(..)
 , I.Err_UpdateState(..)
 ) where

import Control.Concurrent (readMVar, putMVar, takeMVar, newMVar)
import qualified Control.Exception.Safe as Ex
import qualified Data.Time as Time

import qualified Moto.Internal as I
import qualified Moto.Internal.Cli as IC

--------------------------------------------------------------------------------

-- | Create a 'I.Registry' backed by an append-only 'I.Log' storage.
--
-- This registry maintains its internal 'I.State' in memory as long as it is
-- possible to successfuly store all the changes in the underlying append-only
-- storage. If at some point this fails unrecoverably, then 'Err_Tainted' will
-- be thrown by the functions acting on this 'I.Registry'.
--
-- It's important to acquire some kind of exclusive lock on the underlying
-- storage, so that other applications can't poke it while our 'I.Registry' is
-- running.
newAppendOnlyRegistry
  :: I.State
  -- ^ Initial registry state obtained by reading 'I.Log's from the backing
  -- append-only storage and running 'I.updateState' on them.
  -> (I.Log -> IO ())
  -- ^ How to store a newly generated 'I.Log' in the backing append-only
  -- storage.
  --
  -- If this function throws an exception, then the execption will propagated
  -- as usual, but also, this registry will be marked as tained and each
  -- subsequent operation on it will throw 'Err_Tainted'.
  -> IO I.Registry
newAppendOnlyRegistry !state0 putLog = do
  mvState <- newMVar (Just state0)
  let supdate :: (I.State -> Either e I.Log) -> IO (Either e I.Log)
      supdate f = Ex.bracketOnError
        (takeMVar mvState)
        (\_ -> putMVar mvState Nothing)
        (\case Nothing -> Ex.throwM Err_Tainted
               Just s0 -> case f s0 of
                 Left e -> pure (Left e)
                 Right log_ -> case I.updateState s0 log_ of
                   Left e -> Ex.throwM e -- This is unreachable code.
                   Right !s1 -> do
                     putLog log_
                     putMVar mvState (Just s1)
                     pure (Right log_))
  pure $ I.Registry
    { I.registry_state = \_ -> do
        maybe (Ex.throwM Err_Tainted) pure =<< readMVar mvState
    , I.registry_prepare = \_ mId d -> do
        t <- Time.getCurrentTime
        supdate $ \s -> case I.state_status s of
           I.Dirty mId' d' -> Left (I.Err_Prepare_Dirty mId' d')
           I.Clean -> case (d, elem mId (map fst (I.state_committed s))) of
             (I.Forwards, True) -> Left (I.Err_Prepare_Duplicate mId)
             (I.Backwards, False) -> Left (I.Err_Prepare_NotFound mId)
             _ -> Right (I.Log_Prepare t mId d)
    , I.registry_abort = \_ mId d -> do
        t <- Time.getCurrentTime
        supdate $ \s -> case I.state_status s of
           I.Clean -> Left I.Err_Abort_Clean
           I.Dirty mId' d'
             | mId /= mId' || d /= d' -> Left (I.Err_Abort_Dirty mId' d')
             | otherwise -> Right (I.Log_Abort t)
    , I.registry_commit = \_ mId d -> do
        t <- Time.getCurrentTime
        supdate $ \s -> case I.state_status s of
           I.Clean -> Left I.Err_Commit_Clean
           I.Dirty mId' d'
             | mId /= mId' || d /= d' -> Left (I.Err_Commit_Dirty mId' d')
             | otherwise -> Right (I.Log_Commit t)
    }

-- | The 'I.Registry' is tainted, meaning our last attempt to interact with the
-- registry's backing storage failed. We can't be certain about the current
-- state of the 'I.Registry'.
data Err_Tainted = Err_Tainted deriving (Eq, Show)
instance Ex.Exception Err_Tainted