content: {-# LANGUAGE CPP, GADTs, TypeFamilies,
               FlexibleContexts, BangPatterns,
               DefaultSignatures, ScopedTypeVariables #-}
  -----------------------------------------------------------------------------
  -- |
  -- Module      :  Data.Acid.Core
  -- Copyright   :  PublicDomain
  --
  -- Maintainer  :  lemmih@gmail.com
  -- Portability :  non-portable (uses GHC extensions)
  --
  -- Low-level controls for transaction-based state changes. This module defines
  -- structures and tools for running state modifiers indexed either by an Method
  -- or a serialized Method. This module should rarely be used directly although
  -- the 'Method' class is needed when defining events manually.
  --
  -- The term \'Event\' is loosely used for transactions with ACID guarantees.
  -- \'Method\' is loosely used for state operations without ACID guarantees
  --
  module Data.Acid.Core
      ( Core(coreMethods)
      , Method(..)
      , MethodContainer(..)
      , Tagged
      , mkCore
      , closeCore
      , closeCore'
      , modifyCoreState
      , modifyCoreState_
      , withCoreState
      , lookupHotMethod
      , lookupHotMethodAndSerialiser
      , lookupColdMethod
      , runHotMethod
      , runColdMethod
      , MethodMap
      , mkMethodMap
  
      , Serialiser(..)
      , safeCopySerialiser
      , MethodSerialiser(..)
      , safeCopyMethodSerialiser
      , encodeMethod
      , decodeMethod
      , encodeResult
      , decodeResult
      ) where
  
  import Control.Concurrent                 ( MVar, newMVar, withMVar
                                            , modifyMVar, modifyMVar_ )
  import Control.Monad                      ( liftM )
  import Control.Monad.State                ( State, runState )
  import qualified Data.Map as Map
  #if !MIN_VERSION_base(4,11,0)
  import Data.Monoid                        ((<>))
  #endif
  import Data.ByteString.Lazy as Lazy       ( ByteString )
  import Data.ByteString.Lazy.Char8 as Lazy ( pack, unpack )
  
  import Data.Serialize                     ( runPutLazy, runGetLazy )
  import Data.SafeCopy                      ( SafeCopy, safeGet, safePut )
  
  import Data.Typeable                      ( Typeable, TypeRep, typeRepTyCon, typeOf, tyConModule )
  import Unsafe.Coerce                      ( unsafeCoerce )
  
  -- in base >= 4.4 the Show instance for TypeRep no longer provides a
  -- fully qualified name. But we have old data around that expects the
  -- FQN. So we will recreate the old naming system for newer versions
  -- of base. We could do something better, but happstack-state is
  -- end-of-life anyway.
  showQualifiedTypeRep :: TypeRep -> String
  showQualifiedTypeRep tr = tyConModule con ++ "." ++ show tr
    where con = typeRepTyCon tr
  
  -- | Interface for (de)serialising values of type @a@.
  --
  -- A @'Serialiser' { 'serialiserEncode', 'serialiserDecode' }@ must
  -- satisfy the round-trip property:
  --
  -- > forall x . serialiserDecode (serialiserEncode x) == Right x
  data Serialiser a =
      Serialiser
          { serialiserEncode :: a -> Lazy.ByteString
            -- ^ Serialise a value to a bytestring.
          , serialiserDecode :: Lazy.ByteString -> Either String a
            -- ^ Deserialise a value, generating a string error message
            -- on failure.
          }
  
  -- | Default implementation of 'Serialiser' interface using 'SafeCopy'.
  safeCopySerialiser :: SafeCopy a => Serialiser a
  safeCopySerialiser = Serialiser (runPutLazy . safePut) (runGetLazy safeGet)
  
  
  -- | Interface for (de)serialising a method, namely 'Serialiser's for
  -- its arguments type and its result type.
  data MethodSerialiser method =
      MethodSerialiser
          { methodSerialiser :: Serialiser method
          , resultSerialiser :: Serialiser (MethodResult method)
          }
  
  -- | Default implementation of 'MethodSerialiser' interface using 'SafeCopy'.
  safeCopyMethodSerialiser :: (SafeCopy method, SafeCopy (MethodResult method)) => MethodSerialiser method
  safeCopyMethodSerialiser = MethodSerialiser safeCopySerialiser safeCopySerialiser
  
  -- | Encode the arguments of a method using the given serialisation strategy.
  encodeMethod :: MethodSerialiser method -> method -> ByteString
  encodeMethod ms = serialiserEncode (methodSerialiser ms)
  
  -- | Decode the arguments of a method using the given serialisation strategy.
  decodeMethod :: MethodSerialiser method -> ByteString -> Either String method
  decodeMethod ms = serialiserDecode (methodSerialiser ms)
  
  -- | Encode the result of a method using the given serialisation strategy.
  encodeResult :: MethodSerialiser method -> MethodResult method -> ByteString
  encodeResult ms = serialiserEncode (resultSerialiser ms)
  
  -- | Decode the result of a method using the given serialisation strategy.
  decodeResult :: MethodSerialiser method -> ByteString -> Either String (MethodResult method)
  decodeResult ms = serialiserDecode (resultSerialiser ms)
  
  
  -- | The basic Method class. Each Method has an indexed result type
  --   and a unique tag.
  class Method ev where
      type MethodResult ev
      type MethodState ev
      methodTag :: ev -> Tag
      default methodTag :: Typeable ev => ev -> Tag
      methodTag ev = Lazy.pack (showQualifiedTypeRep (typeOf ev))
  
  
  -- | The control structure at the very center of acid-state.
  --   This module provides access to a mutable state through
  --   methods. No efforts towards durability, checkpointing or
  --   sharding happens at this level.
  --   Important things to keep in mind in this module:
  --     * We don't distinguish between updates and queries.
  --     * We allow direct access to the core state as well
  --       as through events.
  data Core st
      = Core { coreState   :: MVar st
             , coreMethods :: MethodMap st
             }
  
  -- | Construct a new Core using an initial state and a list of Methods.
  mkCore :: [MethodContainer st]   -- ^ List of methods capable of modifying the state.
         -> st                     -- ^ Initial state value.
         -> IO (Core st)
  mkCore methods initialValue
      = do mvar <- newMVar initialValue
           return Core{ coreState   = mvar
                      , coreMethods = mkMethodMap methods }
  
  -- | Mark Core as closed. Any subsequent use will throw an exception.
  closeCore :: Core st -> IO ()
  closeCore core
      = closeCore' core (\_st -> return ())
  
  -- | Access the state and then mark the Core as closed. Any subsequent use
  --   will throw an exception.
  closeCore' :: Core st -> (st -> IO ()) -> IO ()
  closeCore' core action
      = modifyMVar_ (coreState core) $ \st ->
        do action st
           return errorMsg
      where errorMsg = error "Data.Acid.Core: Access failure: Core closed."
  
  -- | Modify the state component. The resulting state is ensured to be in
  --   WHNF.
  modifyCoreState :: Core st -> (st -> IO (st, a)) -> IO a
  modifyCoreState core action
      = modifyMVar (coreState core) $ \st -> do (!st', a) <- action st
                                                return (st', a)
  
  -- | Modify the state component. The resulting state is ensured to be in
  --   WHNF.
  modifyCoreState_ :: Core st -> (st -> IO st) -> IO ()
  modifyCoreState_ core action
      = modifyMVar_ (coreState core) $ \st -> do !st' <- action st
                                                 return st'
  
  -- | Access the state component.
  withCoreState :: Core st -> (st -> IO a) -> IO a
  withCoreState core = withMVar (coreState core)
  
  -- | Execute a method as given by a type identifier and an encoded string.
  --   The exact format of the encoded string depends on the type identifier.
  --   Results are encoded and type tagged before they're handed back out.
  --   This function is used when running events from a log-file or from another
  --   server. Events that originate locally are most likely executed with
  --   the faster 'runHotMethod'.
  runColdMethod :: Core st -> Tagged Lazy.ByteString -> IO Lazy.ByteString
  runColdMethod core taggedMethod
      = modifyCoreState core $ \st ->
        do let (a, st') = runState (lookupColdMethod core taggedMethod) st
           return ( st', a)
  
  -- | Find the state action that corresponds to a tagged and serialized method.
  lookupColdMethod :: Core st -> Tagged Lazy.ByteString -> State st Lazy.ByteString
  lookupColdMethod core (storedMethodTag, methodContent)
      = case Map.lookup storedMethodTag (coreMethods core) of
          Nothing      -> missingMethod storedMethodTag
          Just (Method method ms)
            -> liftM (encodeResult ms) (method (lazyDecode ms methodContent))
  
  lazyDecode :: MethodSerialiser method -> Lazy.ByteString -> method
  lazyDecode ms inp
      = case decodeMethod ms inp of
          Left msg  -> error $ "Data.Acid.Core: " <> msg
          Right val -> val
  
  missingMethod :: Tag -> a
  missingMethod tag
      = error $ "Data.Acid.Core: " <> msg
      where msg = "This method is required but not available: " ++ show (Lazy.unpack tag) ++
                  ". Did you perhaps remove it before creating a checkpoint?"
  
  -- | Apply an in-memory method to the state.
  runHotMethod :: Method method => Core (MethodState method) -> method -> IO (MethodResult method)
  runHotMethod core method
      = modifyCoreState core $ \st ->
        do let (a, st') = runState (lookupHotMethod (coreMethods core) method) st
           return ( st', a)
  
  -- | Find the state action that corresponds to an in-memory method.
  lookupHotMethod :: Method method => MethodMap (MethodState method) -> method
                  -> State (MethodState method) (MethodResult method)
  lookupHotMethod methodMap method = fst (lookupHotMethodAndSerialiser methodMap method)
  
  -- | Find the state action and serialiser that correspond to an
  -- in-memory method.
  lookupHotMethodAndSerialiser :: Method method => MethodMap (MethodState method) -> method
                               -> (State (MethodState method) (MethodResult method), MethodSerialiser method)
  lookupHotMethodAndSerialiser methodMap method
      = case Map.lookup (methodTag method) methodMap of
          Nothing -> missingMethod (methodTag method)
          Just (Method methodHandler ms)
            -> -- If the methodTag doesn't index the right methodHandler then we're in deep
               -- trouble. Luckly, it would take deliberate malevolence for that to happen.
               (unsafeCoerce methodHandler method, unsafeCoerce ms)
  
  -- | Method tags must be unique and are most commonly generated automatically.
  type Tag = Lazy.ByteString
  type Tagged a = (Tag, a)
  
  type MethodBody method = method -> State (MethodState method) (MethodResult method)
  
  -- | Method container structure that hides the exact type of the method.
  data MethodContainer st where
      Method :: (Method method) => MethodBody method -> MethodSerialiser method -> MethodContainer (MethodState method)
  
  -- | Collection of Methods indexed by a Tag.
  type MethodMap st = Map.Map Tag (MethodContainer st)
  
  -- | Construct a 'MethodMap' from a list of Methods using their associated tag.
  mkMethodMap :: [MethodContainer st] -> MethodMap st
  mkMethodMap methods
      = Map.fromList [ (methodType method, method) | method <- methods ]
      where -- A little bit of ugliness is required to access the methodTags.
            methodType :: MethodContainer st -> Tag
            methodType m = case m of
                             Method fn _ -> let ev :: (ev -> State st res) -> ev
                                                ev _ = undefined
                                            in methodTag (ev fn)
  