View on GitHub
File Changes
    , http-media
    , http-types
    , iohk-monitoring
+
    , lifted-base
    , memory
    , monad-logger
    , network
    , ErrWrongPassphrase (..)
    , HasLogger
    , genesisData
+
    , logger
    , networkLayer
    )
import Cardano.Wallet.Api
    , getApiMnemonicT
    )
import Cardano.Wallet.DB
-
    ( DBFactory )
+
    ( DBFactory (..) )
import Cardano.Wallet.Logging
    ( fromLogObject, transformTextTrace )
import Cardano.Wallet.Network
    ( NFData )
import Control.Exception
    ( IOException, bracket, tryJust )
+
import Control.Exception.Lifted
+
    ( finally )
import Control.Monad
    ( forM, forM_, void )
import Control.Monad.IO.Class
    ( MonadIO, liftIO )
import Control.Monad.Trans.Except
-
    ( ExceptT, catchE, throwE, withExceptT )
+
    ( ExceptT (..), catchE, runExceptT, throwE, withExceptT )
import Control.Tracer
    ( Tracer, contramap )
import Data.Aeson
    -> Handler NoContent
deleteWallet ctx (ApiT wid) = do
    liftHandler $ withWorkerCtx @_ @s @k ctx wid throwE $ \_ -> pure ()
-
    liftIO $ (df ^. #removeDatabase) wid
+
    liftIO $ removeDatabase df wid
    liftIO $ Registry.remove re wid
    return NoContent
  where
    -> ApiT WalletId
    -> Handler NoContent
forceResyncWallet ctx (ApiT wid) = do
-
    liftHandler $ withWorkerCtx ctx wid throwE $ \wrk ->
-
        W.rollbackBlocks wrk wid W.slotMinBound
+
    liftHandler $ withWorkerCtx @_ @s @k ctx wid throwE $ \_ -> pure ()
+
    flip finally (liftIO $ registerWorker ctx wid) $ do
+
        liftIO $ Registry.remove re wid
+
        liftHandler $ ExceptT safeRollback
    pure NoContent
+
  where
+
    re = ctx ^. workerRegistry @s @k
+
    tr = ctx ^. logger
+
    df = ctx ^. dbFactory @s @k
+
    -- NOTE Safe because it happens without any worker running.
+
    safeRollback = do
+
        let tr' = Registry.transformTrace wid tr
+
        withDatabase df wid $ \db -> do
+
            let wrk = hoistResource db (ctx & logger .~ tr')
+
            runExceptT $ W.rollbackBlocks wrk wid W.slotMinBound

                      
{-------------------------------------------------------------------------------
                                  Coin Selections
            defaultWorkerAfter . transformTextTrace

                      
        , workerAcquire =
-
            (df ^. #withDatabase) wid
+
            withDatabase df wid
        }
    re = ctx ^. workerRegistry @s @k
    df = ctx ^. dbFactory @s @k
    re <- Registry.empty
    let tr' = contramap MsgFromWorker tr
    let ctx = ApiLayer (fromLogObject tr') g0 nw tl df re
-
    forM_ wids (registerWorker re ctx)
+
    forM_ wids (registerWorker ctx)
    return ctx
+

                      
+
-- | Register a restoration worker to the registry.
+
registerWorker
+
    :: forall ctx s t k.
+
        ( ctx ~ ApiLayer s t k
+
        )
+
    => ApiLayer s t k
+
    -> WalletId
+
    -> IO ()
+
registerWorker ctx wid = do
+
    newWorker @_ @_ @ctx ctx wid config >>= \case
+
        Nothing ->
+
            return ()
+
        Just worker ->
+
            Registry.insert re worker
  where
-
    registerWorker re ctx wid = do
-
        let config = MkWorker
-
                { workerBefore =
-
                    \_ _ -> return ()
-

                      
-
                , workerMain = \ctx' _ -> do
-
                    -- FIXME:
-
                    -- Review error handling here
-
                    unsafeRunExceptT $
-
                        W.restoreWallet @(WorkerCtx ctx) @s @t ctx' wid
-

                      
-
                , workerAfter =
-
                    defaultWorkerAfter . transformTextTrace
-

                      
-
                , workerAcquire =
-
                    (df ^. #withDatabase) wid
-
                }
-
        newWorker @_ @_ @ctx ctx wid config >>= \case
-
            Nothing ->
-
                return ()
-
            Just worker ->
-
                Registry.insert re worker
+
    re = ctx ^. workerRegistry
+
    df = ctx ^. dbFactory
+
    config = MkWorker
+
        { workerBefore =
+
            \_ _ -> return ()
+

                      
+
        , workerMain = \ctx' _ -> do
+
            -- FIXME:
+
            -- Review error handling here
+
            unsafeRunExceptT $
+
                W.restoreWallet @(WorkerCtx ctx) @s @t ctx' wid
+

                      
+
        , workerAfter =
+
            defaultWorkerAfter . transformTextTrace
+

                      
+
        , workerAcquire =
+
            withDatabase df wid
+
        }

                      
-- | Run an action in a particular worker context. Fails if there's no worker
-- for a given id.
    ( Quantity (..) )
import Data.Word
    ( Word32 )
-
import GHC.Generics
-
    ( Generic )

                      
import qualified Data.List as L

                      
-- | Instantiate database layers at will
data DBFactory m s k = DBFactory
-
    { withDatabase :: WalletId -> (DBLayer m s k -> IO ()) -> IO ()
+
    { withDatabase :: forall a. WalletId -> (DBLayer m s k -> IO a) -> IO a
        -- ^ Creates a new or use an existing database, maintaining an open
        -- connection so long as necessary

                      
    , removeDatabase :: WalletId -> IO ()
        -- ^ Erase any trace of the database
-
    } deriving (Generic)
+
    }

                      
-- | A Database interface for storing various things in a DB. In practice,
-- we'll need some extra contraints on the wallet state that allows us to
      -- * Logging
    , WithWorkerKey (..)
    , WorkerRegistryLog (..)
+
    , transformTrace
    ) where

                      
import Prelude hiding
            , workerResource = resource
            }
  where
-
    tr = ctx ^. logger
-
    tr' = contramap (fmap (toText . WithWorkerKey k)) $ appendName "worker" tr
+
    tr  = ctx ^. logger
+
    tr' = transformTrace k tr
    cleanup mvar e = tryPutMVar mvar Nothing *> after tr' e

                      
-- | A worker log event includes the key (i.e. wallet ID) as context.
                                    Logging
-------------------------------------------------------------------------------}

                      
+
transformTrace
+
    :: ToText key
+
    => key
+
    -> Trace IO Text
+
    -> Trace IO Text
+
transformTrace k tr =
+
    contramap (fmap (toText . WithWorkerKey k)) $ appendName "worker" tr
+

                      
data WorkerRegistryLog
    = MsgFinished
    | MsgThreadKilled