{-# LANGUAGE DeriveTraversable #-}
{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE UndecidableInstances #-}

module Cardano.Tools.DBImmutaliser.Run
  ( Opts (..)
  , run

    -- * Setup
  , DBDirs (..)
  , withDBs

    -- * Immutalise
  , TraceImmutalisationEvent (..)
  , immutalise
  ) where

import qualified Cardano.Tools.DBAnalyser.Block.Cardano as Cardano
import Cardano.Tools.DBAnalyser.HasAnalysis (mkProtocolInfo)
import Control.Monad (unless)
import Control.ResourceRegistry
import Control.Tracer (Tracer (..), stdoutTracer, traceWith)
import Data.Foldable (for_)
import Data.Functor.Contravariant ((>$<))
import Data.List (intercalate, sortOn)
import Data.List.NonEmpty (NonEmpty)
import qualified Data.List.NonEmpty as NE
import Data.Maybe (fromJust, listToMaybe)
import Data.Ord (Down (..))
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.Text as T
import Data.Traversable (for)
import qualified Dot
import Ouroboros.Consensus.Block
import Ouroboros.Consensus.Config
import Ouroboros.Consensus.Ledger.SupportsProtocol
import Ouroboros.Consensus.Node.InitStorage
import Ouroboros.Consensus.Node.ProtocolInfo (ProtocolInfo (..))
import Ouroboros.Consensus.Protocol.Abstract
import qualified Ouroboros.Consensus.Storage.ChainDB.Impl.Paths as Paths
import Ouroboros.Consensus.Storage.Common (BlockComponent (..))
import Ouroboros.Consensus.Storage.ImmutableDB
  ( ImmutableDB
  , ImmutableDbArgs (..)
  , Tip
  , tipToPoint
  )
import qualified Ouroboros.Consensus.Storage.ImmutableDB as ImmutableDB
import Ouroboros.Consensus.Storage.VolatileDB
  ( VolatileDB
  , VolatileDbArgs (..)
  )
import qualified Ouroboros.Consensus.Storage.VolatileDB.API as VolatileDB
import qualified Ouroboros.Consensus.Storage.VolatileDB.Impl as VolatileDB
import Ouroboros.Consensus.Util
import Ouroboros.Consensus.Util.Args
import Ouroboros.Consensus.Util.IOLike
import Ouroboros.Network.Block (MaxSlotNo)
import System.FS.API (SomeHasFS (..))
import System.FS.API.Types (MountPoint (..))
import System.FS.IO (ioHasFS)

data Opts = Opts
  { Opts -> DBDirs FilePath
dbDirs :: DBDirs FilePath
  , Opts -> FilePath
configFile :: FilePath
  , Opts -> Bool
verbose :: Bool
  , Opts -> Maybe FilePath
dotOut :: Maybe FilePath
  , Opts -> Bool
dryRun :: Bool
  }

run :: Opts -> IO ()
run :: Opts -> IO ()
run Opts{DBDirs FilePath
dbDirs :: Opts -> DBDirs FilePath
dbDirs :: DBDirs FilePath
dbDirs, FilePath
configFile :: Opts -> FilePath
configFile :: FilePath
configFile, Bool
verbose :: Opts -> Bool
verbose :: Bool
verbose, Maybe FilePath
dotOut :: Opts -> Maybe FilePath
dotOut :: Maybe FilePath
dotOut, Bool
dryRun :: Opts -> Bool
dryRun :: Bool
dryRun} = do
  let dbDirs' :: DBDirs (SomeHasFS IO)
dbDirs' = HasFS IO HandleIO -> SomeHasFS IO
forall h (m :: * -> *). Eq h => HasFS m h -> SomeHasFS m
SomeHasFS (HasFS IO HandleIO -> SomeHasFS IO)
-> (FilePath -> HasFS IO HandleIO) -> FilePath -> SomeHasFS IO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MountPoint -> HasFS IO HandleIO
forall (m :: * -> *).
(MonadIO m, PrimState IO ~ PrimState m) =>
MountPoint -> HasFS m HandleIO
ioHasFS (MountPoint -> HasFS IO HandleIO)
-> (FilePath -> MountPoint) -> FilePath -> HasFS IO HandleIO
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FilePath -> MountPoint
MountPoint (FilePath -> SomeHasFS IO)
-> DBDirs FilePath -> DBDirs (SomeHasFS IO)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DBDirs FilePath
dbDirs
      args :: Args (CardanoBlock StandardCrypto)
args = FilePath
-> Maybe PBftSignatureThreshold
-> Args (CardanoBlock StandardCrypto)
Cardano.CardanoBlockArgs FilePath
configFile Maybe PBftSignatureThreshold
forall a. Maybe a
Nothing
  ProtocolInfo{pInfoConfig = cfg} <- Args (CardanoBlock StandardCrypto)
-> IO (ProtocolInfo (CardanoBlock StandardCrypto))
forall blk.
HasProtocolInfo blk =>
Args blk -> IO (ProtocolInfo blk)
mkProtocolInfo Args (CardanoBlock StandardCrypto)
args
  withRegistry $ \ResourceRegistry IO
registry ->
    TopLevelConfig (CardanoBlock StandardCrypto)
-> ResourceRegistry IO
-> DBDirs (SomeHasFS IO)
-> (ImmutableDB IO (CardanoBlock StandardCrypto)
    -> VolatileDB IO (CardanoBlock StandardCrypto) -> IO ())
-> IO ()
forall (m :: * -> *) blk a.
(IOLike m, ConvertRawHash blk, LedgerSupportsProtocol blk,
 ImmutableDbSerialiseConstraints blk,
 VolatileDbSerialiseConstraints blk, NodeInitStorage blk) =>
TopLevelConfig blk
-> ResourceRegistry m
-> DBDirs (SomeHasFS m)
-> (ImmutableDB m blk -> VolatileDB m blk -> m a)
-> m a
withDBs TopLevelConfig (CardanoBlock StandardCrypto)
cfg ResourceRegistry IO
registry DBDirs (SomeHasFS IO)
dbDirs' ((ImmutableDB IO (CardanoBlock StandardCrypto)
  -> VolatileDB IO (CardanoBlock StandardCrypto) -> IO ())
 -> IO ())
-> (ImmutableDB IO (CardanoBlock StandardCrypto)
    -> VolatileDB IO (CardanoBlock StandardCrypto) -> IO ())
-> IO ()
forall a b. (a -> b) -> a -> b
$
      BlockConfig (CardanoBlock StandardCrypto)
-> Tracer
     IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
-> Bool
-> ImmutableDB IO (CardanoBlock StandardCrypto)
-> VolatileDB IO (CardanoBlock StandardCrypto)
-> IO ()
forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk) =>
BlockConfig blk
-> Tracer m (TraceImmutalisationEvent blk)
-> Bool
-> ImmutableDB m blk
-> VolatileDB m blk
-> m ()
immutalise (TopLevelConfig (CardanoBlock StandardCrypto)
-> BlockConfig (CardanoBlock StandardCrypto)
forall blk. TopLevelConfig blk -> BlockConfig blk
configBlock TopLevelConfig (CardanoBlock StandardCrypto)
cfg) (Tracer IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
tracer Tracer IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
-> Tracer
     IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
-> Tracer
     IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
forall a. Semigroup a => a -> a -> a
<> Tracer IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
dotTracer) Bool
dryRun
 where
  tracer :: Tracer IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
tracer = Bool
-> TraceImmutalisationEvent (CardanoBlock StandardCrypto)
-> FilePath
forall blk.
(ConsensusProtocol (BlockProtocol blk), StandardHash blk) =>
Bool -> TraceImmutalisationEvent blk -> FilePath
prettyTrace Bool
verbose (TraceImmutalisationEvent (CardanoBlock StandardCrypto)
 -> FilePath)
-> Tracer IO FilePath
-> Tracer
     IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
forall (f :: * -> *) a b. Contravariant f => (a -> b) -> f b -> f a
>$< Tracer IO FilePath
forall (m :: * -> *). MonadIO m => Tracer m FilePath
stdoutTracer
  dotTracer :: Tracer IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
dotTracer = (TraceImmutalisationEvent (CardanoBlock StandardCrypto) -> IO ())
-> Tracer
     IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
forall (m :: * -> *) a. (a -> m ()) -> Tracer m a
Tracer ((TraceImmutalisationEvent (CardanoBlock StandardCrypto) -> IO ())
 -> Tracer
      IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto)))
-> (TraceImmutalisationEvent (CardanoBlock StandardCrypto)
    -> IO ())
-> Tracer
     IO (TraceImmutalisationEvent (CardanoBlock StandardCrypto))
forall a b. (a -> b) -> a -> b
$ \case
    TraceAllCandidates [(NonEmpty (HeaderHash (CardanoBlock StandardCrypto)),
  SelectView (BlockProtocol (CardanoBlock StandardCrypto)))]
candidates -> do
      let dot :: DotGraph
dot = [NonEmpty (HeaderHash (CardanoBlock StandardCrypto))] -> DotGraph
forall hash. Show hash => [NonEmpty hash] -> DotGraph
dotCandidates ([NonEmpty (HeaderHash (CardanoBlock StandardCrypto))] -> DotGraph)
-> [NonEmpty (HeaderHash (CardanoBlock StandardCrypto))]
-> DotGraph
forall a b. (a -> b) -> a -> b
$ (NonEmpty (HeaderHash (CardanoBlock StandardCrypto)),
 SelectView (BlockProtocol (CardanoBlock StandardCrypto)))
-> NonEmpty (HeaderHash (CardanoBlock StandardCrypto))
forall a b. (a, b) -> a
fst ((NonEmpty (HeaderHash (CardanoBlock StandardCrypto)),
  SelectView (BlockProtocol (CardanoBlock StandardCrypto)))
 -> NonEmpty (HeaderHash (CardanoBlock StandardCrypto)))
-> [(NonEmpty (HeaderHash (CardanoBlock StandardCrypto)),
     SelectView (BlockProtocol (CardanoBlock StandardCrypto)))]
-> [NonEmpty (HeaderHash (CardanoBlock StandardCrypto))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(NonEmpty (HeaderHash (CardanoBlock StandardCrypto)),
  SelectView (BlockProtocol (CardanoBlock StandardCrypto)))]
candidates
      Maybe FilePath -> (FilePath -> IO ()) -> IO ()
forall (f :: * -> *) a.
Applicative f =>
Maybe a -> (a -> f ()) -> f ()
whenJust Maybe FilePath
dotOut ((FilePath -> IO ()) -> IO ()) -> (FilePath -> IO ()) -> IO ()
forall a b. (a -> b) -> a -> b
$ (FilePath -> DotGraph -> IO ()) -> DotGraph -> FilePath -> IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip FilePath -> DotGraph -> IO ()
Dot.encodeToFile DotGraph
dot
    TraceImmutalisationEvent (CardanoBlock StandardCrypto)
_ -> () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

{-------------------------------------------------------------------------------
  Setup
-------------------------------------------------------------------------------}

data DBDirs a = DBDirs
  { forall a. DBDirs a -> a
immDBDir :: a
  , forall a. DBDirs a -> a
volDBDir :: a
  }
  deriving stock ((forall a b. (a -> b) -> DBDirs a -> DBDirs b)
-> (forall a b. a -> DBDirs b -> DBDirs a) -> Functor DBDirs
forall a b. a -> DBDirs b -> DBDirs a
forall a b. (a -> b) -> DBDirs a -> DBDirs b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
$cfmap :: forall a b. (a -> b) -> DBDirs a -> DBDirs b
fmap :: forall a b. (a -> b) -> DBDirs a -> DBDirs b
$c<$ :: forall a b. a -> DBDirs b -> DBDirs a
<$ :: forall a b. a -> DBDirs b -> DBDirs a
Functor, (forall m. Monoid m => DBDirs m -> m)
-> (forall m a. Monoid m => (a -> m) -> DBDirs a -> m)
-> (forall m a. Monoid m => (a -> m) -> DBDirs a -> m)
-> (forall a b. (a -> b -> b) -> b -> DBDirs a -> b)
-> (forall a b. (a -> b -> b) -> b -> DBDirs a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBDirs a -> b)
-> (forall b a. (b -> a -> b) -> b -> DBDirs a -> b)
-> (forall a. (a -> a -> a) -> DBDirs a -> a)
-> (forall a. (a -> a -> a) -> DBDirs a -> a)
-> (forall a. DBDirs a -> [a])
-> (forall a. DBDirs a -> Bool)
-> (forall a. DBDirs a -> Int)
-> (forall a. Eq a => a -> DBDirs a -> Bool)
-> (forall a. Ord a => DBDirs a -> a)
-> (forall a. Ord a => DBDirs a -> a)
-> (forall a. Num a => DBDirs a -> a)
-> (forall a. Num a => DBDirs a -> a)
-> Foldable DBDirs
forall a. Eq a => a -> DBDirs a -> Bool
forall a. Num a => DBDirs a -> a
forall a. Ord a => DBDirs a -> a
forall m. Monoid m => DBDirs m -> m
forall a. DBDirs a -> Bool
forall a. DBDirs a -> Int
forall a. DBDirs a -> [a]
forall a. (a -> a -> a) -> DBDirs a -> a
forall m a. Monoid m => (a -> m) -> DBDirs a -> m
forall b a. (b -> a -> b) -> b -> DBDirs a -> b
forall a b. (a -> b -> b) -> b -> DBDirs a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
$cfold :: forall m. Monoid m => DBDirs m -> m
fold :: forall m. Monoid m => DBDirs m -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
foldMap' :: forall m a. Monoid m => (a -> m) -> DBDirs a -> m
$cfoldr :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
foldr :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> DBDirs a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
foldl :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
foldl' :: forall b a. (b -> a -> b) -> b -> DBDirs a -> b
$cfoldr1 :: forall a. (a -> a -> a) -> DBDirs a -> a
foldr1 :: forall a. (a -> a -> a) -> DBDirs a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> DBDirs a -> a
foldl1 :: forall a. (a -> a -> a) -> DBDirs a -> a
$ctoList :: forall a. DBDirs a -> [a]
toList :: forall a. DBDirs a -> [a]
$cnull :: forall a. DBDirs a -> Bool
null :: forall a. DBDirs a -> Bool
$clength :: forall a. DBDirs a -> Int
length :: forall a. DBDirs a -> Int
$celem :: forall a. Eq a => a -> DBDirs a -> Bool
elem :: forall a. Eq a => a -> DBDirs a -> Bool
$cmaximum :: forall a. Ord a => DBDirs a -> a
maximum :: forall a. Ord a => DBDirs a -> a
$cminimum :: forall a. Ord a => DBDirs a -> a
minimum :: forall a. Ord a => DBDirs a -> a
$csum :: forall a. Num a => DBDirs a -> a
sum :: forall a. Num a => DBDirs a -> a
$cproduct :: forall a. Num a => DBDirs a -> a
product :: forall a. Num a => DBDirs a -> a
Foldable, Functor DBDirs
Foldable DBDirs
(Functor DBDirs, Foldable DBDirs) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> DBDirs a -> f (DBDirs b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    DBDirs (f a) -> f (DBDirs a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> DBDirs a -> m (DBDirs b))
-> (forall (m :: * -> *) a.
    Monad m =>
    DBDirs (m a) -> m (DBDirs a))
-> Traversable DBDirs
forall (t :: * -> *).
(Functor t, Foldable t) =>
(forall (f :: * -> *) a b.
 Applicative f =>
 (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a. Monad m => DBDirs (m a) -> m (DBDirs a)
forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> DBDirs a -> f (DBDirs b)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
DBDirs (f a) -> f (DBDirs a)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> DBDirs a -> m (DBDirs b)
$csequence :: forall (m :: * -> *) a. Monad m => DBDirs (m a) -> m (DBDirs a)
sequence :: forall (m :: * -> *) a. Monad m => DBDirs (m a) -> m (DBDirs a)
Traversable)

withDBs ::
  forall m blk a.
  ( IOLike m
  , ConvertRawHash blk
  , LedgerSupportsProtocol blk
  , ImmutableDB.ImmutableDbSerialiseConstraints blk
  , VolatileDB.VolatileDbSerialiseConstraints blk
  , NodeInitStorage blk
  ) =>
  TopLevelConfig blk ->
  ResourceRegistry m ->
  DBDirs (SomeHasFS m) ->
  (ImmutableDB m blk -> VolatileDB m blk -> m a) ->
  m a
withDBs :: forall (m :: * -> *) blk a.
(IOLike m, ConvertRawHash blk, LedgerSupportsProtocol blk,
 ImmutableDbSerialiseConstraints blk,
 VolatileDbSerialiseConstraints blk, NodeInitStorage blk) =>
TopLevelConfig blk
-> ResourceRegistry m
-> DBDirs (SomeHasFS m)
-> (ImmutableDB m blk -> VolatileDB m blk -> m a)
-> m a
withDBs TopLevelConfig blk
cfg ResourceRegistry m
registry DBDirs (SomeHasFS m)
dbDirs ImmutableDB m blk -> VolatileDB m blk -> m a
f =
  m (ImmutableDB m blk) -> (ImmutableDB m blk -> m a) -> m a
forall (m :: * -> *) blk a.
(HasCallStack, MonadThrow m) =>
m (ImmutableDB m blk) -> (ImmutableDB m blk -> m a) -> m a
ImmutableDB.withDB (Complete ImmutableDbArgs m blk
-> (forall st.
    WithTempRegistry st m (ImmutableDB m blk, st)
    -> m (ImmutableDB m blk))
-> m (ImmutableDB m blk)
forall (m :: * -> *) blk ans.
(IOLike m, GetPrevHash blk, ConvertRawHash blk,
 ImmutableDbSerialiseConstraints blk, HasCallStack) =>
Complete ImmutableDbArgs m blk
-> (forall st.
    WithTempRegistry st m (ImmutableDB m blk, st) -> ans)
-> ans
ImmutableDB.openDB Complete ImmutableDbArgs m blk
immDBArgs WithTempRegistry st m (ImmutableDB m blk, st)
-> m (ImmutableDB m blk)
forall st.
WithTempRegistry st m (ImmutableDB m blk, st)
-> m (ImmutableDB m blk)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry) ((ImmutableDB m blk -> m a) -> m a)
-> (ImmutableDB m blk -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \ImmutableDB m blk
immDB ->
    m (VolatileDB m blk) -> (VolatileDB m blk -> m a) -> m a
forall (m :: * -> *) blk a.
(HasCallStack, MonadThrow m) =>
m (VolatileDB m blk) -> (VolatileDB m blk -> m a) -> m a
VolatileDB.withDB (Complete VolatileDbArgs m blk
-> (forall st.
    WithTempRegistry st m (VolatileDB m blk, st)
    -> m (VolatileDB m blk))
-> m (VolatileDB m blk)
forall (m :: * -> *) blk ans.
(HasCallStack, IOLike m, GetPrevHash blk,
 VolatileDbSerialiseConstraints blk) =>
Complete VolatileDbArgs m blk
-> (forall st. WithTempRegistry st m (VolatileDB m blk, st) -> ans)
-> ans
VolatileDB.openDB Complete VolatileDbArgs m blk
volDBArgs WithTempRegistry st m (VolatileDB m blk, st)
-> m (VolatileDB m blk)
forall st.
WithTempRegistry st m (VolatileDB m blk, st)
-> m (VolatileDB m blk)
forall (m :: * -> *) st a.
(MonadSTM m, MonadMask m, MonadThread m, HasCallStack) =>
WithTempRegistry st m (a, st) -> m a
runWithTempRegistry) ((VolatileDB m blk -> m a) -> m a)
-> (VolatileDB m blk -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \VolatileDB m blk
volDB -> do
      ImmutableDB m blk -> VolatileDB m blk -> m a
f ImmutableDB m blk
immDB VolatileDB m blk
volDB
 where
  codecCfg :: CodecConfig blk
codecCfg = TopLevelConfig blk -> CodecConfig blk
forall blk. TopLevelConfig blk -> CodecConfig blk
configCodec TopLevelConfig blk
cfg
  storageCfg :: StorageConfig blk
storageCfg = TopLevelConfig blk -> StorageConfig blk
forall blk. TopLevelConfig blk -> StorageConfig blk
configStorage TopLevelConfig blk
cfg

  immDBArgs :: Complete ImmutableDbArgs m blk
  immDBArgs :: Complete ImmutableDbArgs m blk
immDBArgs =
    Incomplete ImmutableDbArgs m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete ImmutableDbArgs m blk
ImmutableDB.defaultArgs
      { immCheckIntegrity = nodeCheckIntegrity storageCfg
      , immChunkInfo = nodeImmutableDbChunkInfo storageCfg
      , immCodecConfig = codecCfg
      , immRegistry = registry
      , immHasFS = immDBDir dbDirs
      }

  volDBArgs :: Complete VolatileDbArgs m blk
  volDBArgs :: Complete VolatileDbArgs m blk
volDBArgs =
    Incomplete VolatileDbArgs m blk
forall (m :: * -> *) blk.
Applicative m =>
Incomplete VolatileDbArgs m blk
VolatileDB.defaultArgs
      { volCheckIntegrity = nodeCheckIntegrity (configStorage cfg)
      , volCodecConfig = codecCfg
      , volHasFS = volDBDir dbDirs
      }

{-------------------------------------------------------------------------------
  Immutalise
-------------------------------------------------------------------------------}

-- | Copy a specific chain from the given 'VolatileDB' to the 'ImmutableDB',
-- such that other tools that only work with an 'ImmutableDB' can process the
-- corresponding blocks.
--
-- This function requires exclusive access to the databases.
--
-- Currently, this will pick the best (according to the 'SelectView') chain
-- extending the immutable tip, and it will _not_ do any kind of validation.
--
-- Future work might include customizing this behavior, like:
--
--   * picking the best _valid_ chain (requires reading a ledger snapshot and/or
--     replaying)
--
--   * picking a chain that contains particular points (user input)
immutalise ::
  forall m blk.
  ( IOLike m
  , BlockSupportsProtocol blk
  ) =>
  BlockConfig blk ->
  Tracer m (TraceImmutalisationEvent blk) ->
  -- | Dry run?
  Bool ->
  ImmutableDB m blk ->
  VolatileDB m blk ->
  m ()
immutalise :: forall (m :: * -> *) blk.
(IOLike m, BlockSupportsProtocol blk) =>
BlockConfig blk
-> Tracer m (TraceImmutalisationEvent blk)
-> Bool
-> ImmutableDB m blk
-> VolatileDB m blk
-> m ()
immutalise BlockConfig blk
bcfg Tracer m (TraceImmutalisationEvent blk)
tracer Bool
dryRun ImmutableDB m blk
immDB VolatileDB m blk
volDB = do
  immTip <- STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk)))
-> STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
ImmutableDB.getTip ImmutableDB m blk
immDB
  volMaxSlotNo <- atomically $ VolatileDB.getMaxSlotNo volDB
  traceWith tracer $ TraceStartImmutalisation immTip volMaxSlotNo

  (succsOf, getBlockInfo) <-
    atomically $
      (,) <$> VolatileDB.filterByPredecessor volDB <*> VolatileDB.getBlockInfo volDB
  let candidates =
        (ChainHash blk -> Set (HeaderHash blk))
-> Maybe Word64 -> Point blk -> [NonEmpty (HeaderHash blk)]
forall blk.
(ChainHash blk -> Set (HeaderHash blk))
-> Maybe Word64 -> Point blk -> [NonEmpty (HeaderHash blk)]
Paths.maximalCandidates ChainHash blk -> Set (HeaderHash blk)
succsOf Maybe Word64
forall a. Maybe a
Nothing (WithOrigin (Tip blk) -> Point blk
forall blk. WithOrigin (Tip blk) -> Point blk
tipToPoint WithOrigin (Tip blk)
immTip)

      -- All blocks that are reachable from the immutable tip. There might be
      -- further blocks in the VolatileDB, but the public API currently does
      -- not provide a way to observe them.
      reachableBlocks :: [VolatileDB.BlockInfo blk]
      reachableBlocks =
        (HeaderHash blk -> BlockInfo blk)
-> [HeaderHash blk] -> [BlockInfo blk]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe (BlockInfo blk) -> BlockInfo blk
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (BlockInfo blk) -> BlockInfo blk)
-> (HeaderHash blk -> Maybe (BlockInfo blk))
-> HeaderHash blk
-> BlockInfo blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HeaderHash blk -> Maybe (BlockInfo blk)
getBlockInfo) ([HeaderHash blk] -> [BlockInfo blk])
-> [HeaderHash blk] -> [BlockInfo blk]
forall a b. (a -> b) -> a -> b
$
          Set (HeaderHash blk) -> [HeaderHash blk]
forall a. Set a -> [a]
Set.toAscList (Set (HeaderHash blk) -> [HeaderHash blk])
-> Set (HeaderHash blk) -> [HeaderHash blk]
forall a b. (a -> b) -> a -> b
$
            (NonEmpty (HeaderHash blk) -> Set (HeaderHash blk))
-> [NonEmpty (HeaderHash blk)] -> Set (HeaderHash blk)
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([HeaderHash blk] -> Set (HeaderHash blk)
forall a. Ord a => [a] -> Set a
Set.fromList ([HeaderHash blk] -> Set (HeaderHash blk))
-> (NonEmpty (HeaderHash blk) -> [HeaderHash blk])
-> NonEmpty (HeaderHash blk)
-> Set (HeaderHash blk)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty (HeaderHash blk) -> [HeaderHash blk]
forall a. NonEmpty a -> [a]
NE.toList) [NonEmpty (HeaderHash blk)]
candidates
  traceWith tracer $ TraceReachableBlocks reachableBlocks

  candidatesAndTipHdrs <- for candidates $ \NonEmpty (HeaderHash blk)
candidate -> do
    tipHdr <-
      VolatileDB m blk
-> BlockComponent blk (Header blk)
-> HeaderHash blk
-> m (Header blk)
forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk -> BlockComponent blk b -> HeaderHash blk -> m b
VolatileDB.getKnownBlockComponent VolatileDB m blk
volDB BlockComponent blk (Header blk)
forall blk. BlockComponent blk (Header blk)
GetHeader (NonEmpty (HeaderHash blk) -> HeaderHash blk
forall a. NonEmpty a -> a
NE.last NonEmpty (HeaderHash blk)
candidate)
    pure (candidate, tipHdr)
  let sortedCandidates ::
        [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
      sortedCandidates = ((NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))
 -> Down (SelectView (BlockProtocol blk)))
-> [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
-> [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (SelectView (BlockProtocol blk)
-> Down (SelectView (BlockProtocol blk))
forall a. a -> Down a
Down (SelectView (BlockProtocol blk)
 -> Down (SelectView (BlockProtocol blk)))
-> ((NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))
    -> SelectView (BlockProtocol blk))
-> (NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))
-> Down (SelectView (BlockProtocol blk))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))
-> SelectView (BlockProtocol blk)
forall a b. (a, b) -> b
snd) ([(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
 -> [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))])
-> [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
-> [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
forall a b. (a -> b) -> a -> b
$ do
        (candidate, tipHdr) <- [(NonEmpty (HeaderHash blk), Header blk)]
candidatesAndTipHdrs
        pure (candidate, selectView bcfg tipHdr)

  traceWith tracer $ TraceAllCandidates sortedCandidates

  case sortedCandidates of
    [] -> do
      Tracer m (TraceImmutalisationEvent blk)
-> TraceImmutalisationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceImmutalisationEvent blk)
tracer TraceImmutalisationEvent blk
forall blk. TraceImmutalisationEvent blk
TraceNoVolatileCandidate
    (NonEmpty (HeaderHash blk)
candidate, SelectView (BlockProtocol blk)
sv) : [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
_ -> do
      Tracer m (TraceImmutalisationEvent blk)
-> TraceImmutalisationEvent blk -> m ()
forall (m :: * -> *) a. Tracer m a -> a -> m ()
traceWith Tracer m (TraceImmutalisationEvent blk)
tracer (TraceImmutalisationEvent blk -> m ())
-> TraceImmutalisationEvent blk -> m ()
forall a b. (a -> b) -> a -> b
$
        HeaderHash blk
-> Int
-> SelectView (BlockProtocol blk)
-> TraceImmutalisationEvent blk
forall blk.
HeaderHash blk
-> Int
-> SelectView (BlockProtocol blk)
-> TraceImmutalisationEvent blk
TraceCandidateToImmutalise
          (NonEmpty (HeaderHash blk) -> HeaderHash blk
forall a. NonEmpty a -> a
NE.last NonEmpty (HeaderHash blk)
candidate)
          (NonEmpty (HeaderHash blk) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (HeaderHash blk)
candidate)
          SelectView (BlockProtocol blk)
sv

      Bool -> m () -> m ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
dryRun (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ do
        -- Copy the candidate blocks from volDB to immDB.
        NonEmpty (HeaderHash blk) -> (HeaderHash blk -> m ()) -> m ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ NonEmpty (HeaderHash blk)
candidate ((HeaderHash blk -> m ()) -> m ())
-> (HeaderHash blk -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \HeaderHash blk
hdrHash -> do
          blk <- VolatileDB m blk
-> BlockComponent blk blk -> HeaderHash blk -> m blk
forall (m :: * -> *) blk b.
(MonadThrow m, HasHeader blk) =>
VolatileDB m blk -> BlockComponent blk b -> HeaderHash blk -> m b
VolatileDB.getKnownBlockComponent VolatileDB m blk
volDB BlockComponent blk blk
forall blk. BlockComponent blk blk
GetBlock HeaderHash blk
hdrHash
          ImmutableDB.appendBlock immDB blk

        newImmTip <- STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a. HasCallStack => STM m a -> m a
forall (m :: * -> *) a.
(MonadSTM m, HasCallStack) =>
STM m a -> m a
atomically (STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk)))
-> STM m (WithOrigin (Tip blk)) -> m (WithOrigin (Tip blk))
forall a b. (a -> b) -> a -> b
$ ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
forall (m :: * -> *) blk.
HasCallStack =>
ImmutableDB m blk -> STM m (WithOrigin (Tip blk))
ImmutableDB.getTip ImmutableDB m blk
immDB
        traceWith tracer $ TraceCopiedtoImmutableDB newImmTip

{-------------------------------------------------------------------------------
  Tracing
-------------------------------------------------------------------------------}

data TraceImmutalisationEvent blk
  = TraceStartImmutalisation
      -- | Tip of the ImmutableDB.
      (WithOrigin (Tip blk))
      -- | 'MaxSlotNo' of the VolatileDB.
      MaxSlotNo
  | TraceReachableBlocks
      -- | The set of volatile blocks reachable from the immutable tip.
      [VolatileDB.BlockInfo blk]
  | -- | No blocks in the VolatileDB extend the immutable tip.
    TraceNoVolatileCandidate
  | -- | Found these volatile candidates extending the immutable tip.
    TraceAllCandidates
      -- | Each candidate is represented by its block hashes of the candidate
      -- after the immutable tip, and the 'SelectView' of the candidate tip. The
      -- candidates are sorted by this 'SelectView' in decreasing order.
      [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
  | -- | The volatile candidate to immutalise.
    TraceCandidateToImmutalise
      -- | Hash of the candidate tip.
      (HeaderHash blk)
      -- | Blocks to be added to the ImmutableDB.
      Int
      -- | 'SelectView' of the candidate tip.
      (SelectView (BlockProtocol blk))
  | TraceCopiedtoImmutableDB
      -- | New tip of the ImmutableDB.
      (WithOrigin (Tip blk))

deriving stock instance
  ( ConsensusProtocol (BlockProtocol blk)
  , StandardHash blk
  ) =>
  Show (TraceImmutalisationEvent blk)

prettyTrace ::
  forall blk.
  ( ConsensusProtocol (BlockProtocol blk)
  , StandardHash blk
  ) =>
  -- | verbose?
  Bool ->
  TraceImmutalisationEvent blk ->
  String
prettyTrace :: forall blk.
(ConsensusProtocol (BlockProtocol blk), StandardHash blk) =>
Bool -> TraceImmutalisationEvent blk -> FilePath
prettyTrace Bool
verbose = \case
  TraceStartImmutalisation WithOrigin (Tip blk)
immTip MaxSlotNo
volMaxSlot ->
    FilePath
"Start immutalisation: ImmutableDB tip at "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> WithOrigin (Tip blk) -> FilePath
forall a. Show a => a -> FilePath
show WithOrigin (Tip blk)
immTip
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
", VolatileDB max slot at "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> MaxSlotNo -> FilePath
forall a. Show a => a -> FilePath
show MaxSlotNo
volMaxSlot
  TraceReachableBlocks [BlockInfo blk]
reachableBlocks ->
    FilePath
"Number of volatile blocks reachable from ImmutableDB tip: "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ([BlockInfo blk] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [BlockInfo blk]
reachableBlocks)
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" (VolatileDB might contain more blocks)"
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
verbose then FilePath
"\nAll hashes:\n" FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> [FilePath] -> FilePath
unlines (BlockInfo blk -> FilePath
render (BlockInfo blk -> FilePath) -> [BlockInfo blk] -> [FilePath]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [BlockInfo blk]
reachableBlocks) else FilePath
""
   where
    render :: VolatileDB.BlockInfo blk -> String
    render :: BlockInfo blk -> FilePath
render BlockInfo blk
bi = FilePath -> [FilePath] -> FilePath
forall a. [a] -> [[a]] -> [a]
intercalate FilePath
"\t" [HeaderHash blk -> FilePath
forall a. Show a => a -> FilePath
show HeaderHash blk
biHash, SlotNo -> FilePath
forall a. Show a => a -> FilePath
show SlotNo
biSlotNo, BlockNo -> FilePath
forall a. Show a => a -> FilePath
show BlockNo
biBlockNo]
     where
      VolatileDB.BlockInfo
        { HeaderHash blk
biHash :: HeaderHash blk
biHash :: forall blk. BlockInfo blk -> HeaderHash blk
VolatileDB.biHash
        , SlotNo
biSlotNo :: SlotNo
biSlotNo :: forall blk. BlockInfo blk -> SlotNo
VolatileDB.biSlotNo
        , BlockNo
biBlockNo :: BlockNo
biBlockNo :: forall blk. BlockInfo blk -> BlockNo
VolatileDB.biBlockNo
        } = BlockInfo blk
bi
  TraceImmutalisationEvent blk
TraceNoVolatileCandidate ->
    FilePath
"No volatile candidate found for immutalisation"
  TraceAllCandidates [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
candidates ->
    [FilePath] -> FilePath
unlines ([FilePath] -> FilePath) -> [FilePath] -> FilePath
forall a b. (a -> b) -> a -> b
$
      FilePath
"Number of candidates: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show ([(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
-> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
candidates)
        FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [[FilePath]] -> [FilePath]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[FilePath]
selectViewInfo | Bool
verbose]
   where
    selectViewInfo :: [FilePath]
selectViewInfo =
      FilePath
"All candidates:"
        FilePath -> [FilePath] -> [FilePath]
forall a. a -> [a] -> [a]
: [ [FilePath] -> FilePath
unlines
              [ FilePath
" - Length: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty (HeaderHash blk) -> Int
forall a. NonEmpty a -> Int
NE.length NonEmpty (HeaderHash blk)
c)
              , FilePath
"   Tip hash: " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderHash blk -> FilePath
forall a. Show a => a -> FilePath
show (NonEmpty (HeaderHash blk) -> HeaderHash blk
forall a. NonEmpty a -> a
NE.last NonEmpty (HeaderHash blk)
c)
              , FilePath
"   " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SelectView (BlockProtocol blk) -> FilePath
forall a. Show a => a -> FilePath
show SelectView (BlockProtocol blk)
sv
              ]
          | (NonEmpty (HeaderHash blk)
c, SelectView (BlockProtocol blk)
sv) <- [(NonEmpty (HeaderHash blk), SelectView (BlockProtocol blk))]
candidates
          ]
  TraceCandidateToImmutalise HeaderHash blk
tipHash Int
numBlocks SelectView (BlockProtocol blk)
sv ->
    FilePath
"Immutalising volatile candidate of length "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> FilePath
forall a. Show a => a -> FilePath
show Int
numBlocks
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> FilePath
" with tip hash "
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> HeaderHash blk -> FilePath
forall a. Show a => a -> FilePath
show HeaderHash blk
tipHash
      FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> if Bool
verbose then FilePath
" and tip select view " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> SelectView (BlockProtocol blk) -> FilePath
forall a. Show a => a -> FilePath
show SelectView (BlockProtocol blk)
sv else FilePath
""
  TraceCopiedtoImmutableDB WithOrigin (Tip blk)
newImmTip ->
    FilePath
"Copied to ImmutableDB, new tip is " FilePath -> ShowS
forall a. Semigroup a => a -> a -> a
<> WithOrigin (Tip blk) -> FilePath
forall a. Show a => a -> FilePath
show WithOrigin (Tip blk)
newImmTip

-- | Construct a 'Dot.DotGraph' out of a list of candidates.
dotCandidates :: forall hash. Show hash => [NonEmpty hash] -> Dot.DotGraph
dotCandidates :: forall hash. Show hash => [NonEmpty hash] -> DotGraph
dotCandidates [NonEmpty hash]
candidates =
  Strictness -> Directionality -> Maybe Id -> [Statement] -> DotGraph
Dot.DotGraph Strictness
Dot.Strict Directionality
Dot.Directed Maybe Id
forall a. Maybe a
Nothing ([Statement] -> DotGraph) -> [Statement] -> DotGraph
forall a b. (a -> b) -> a -> b
$ do
    candidate <- (hash -> FilePath) -> [hash] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap hash -> FilePath
renderHash ([hash] -> [FilePath])
-> (NonEmpty hash -> [hash]) -> NonEmpty hash -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty hash -> [hash]
forall a. NonEmpty a -> [a]
NE.toList (NonEmpty hash -> [FilePath]) -> [NonEmpty hash] -> [[FilePath]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NonEmpty hash]
candidates
    (from, to) <- zip ("ImmTip" : candidate) candidate
    let fromTo = EdgeElement -> EdgeElement -> [EdgeElement] -> ListTwo EdgeElement
forall a. a -> a -> [a] -> ListTwo a
Dot.ListTwo (FilePath -> EdgeElement
toNode FilePath
from) (FilePath -> EdgeElement
toNode FilePath
to) []
    pure $ Dot.StatementEdge $ Dot.EdgeStatement fromTo []
 where
  toNode :: String -> Dot.EdgeElement
  toNode :: FilePath -> EdgeElement
toNode FilePath
l = NodeId -> EdgeElement
Dot.EdgeNode (NodeId -> EdgeElement) -> NodeId -> EdgeElement
forall a b. (a -> b) -> a -> b
$ Id -> Maybe Port -> NodeId
Dot.NodeId (Text -> Id
Dot.Id (Text -> Id) -> Text -> Id
forall a b. (a -> b) -> a -> b
$ FilePath -> Text
T.pack FilePath
l) Maybe Port
forall a. Maybe a
Nothing

  -- Render a shortened hash like in git, i.e. the smallest prefix length
  -- such that the hashes still are unique.
  renderHash :: hash -> String
  renderHash :: hash -> FilePath
renderHash = Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
prefix ShowS -> (hash -> FilePath) -> hash -> FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. hash -> FilePath
forall a. Show a => a -> FilePath
show
   where
    prefix :: Int
prefix =
      Maybe Int -> Int
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$
        [Int] -> Maybe Int
forall a. [a] -> Maybe a
listToMaybe ([Int] -> Maybe Int) -> [Int] -> Maybe Int
forall a b. (a -> b) -> a -> b
$
          [ Int
k
          | Int
k <- [Int
4 ..]
          , Set FilePath -> Int
forall a. Set a -> Int
Set.size (ShowS -> Set FilePath -> Set FilePath
forall b a. Ord b => (a -> b) -> Set a -> Set b
Set.map (Int -> ShowS
forall a. Int -> [a] -> [a]
take Int
k) Set FilePath
allHashes) Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Set FilePath -> Int
forall a. Set a -> Int
Set.size Set FilePath
allHashes
          ]

    allHashes :: Set String
    allHashes :: Set FilePath
allHashes =
      (NonEmpty hash -> Set FilePath) -> [NonEmpty hash] -> Set FilePath
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap ([FilePath] -> Set FilePath
forall a. Ord a => [a] -> Set a
Set.fromList ([FilePath] -> Set FilePath)
-> (NonEmpty hash -> [FilePath]) -> NonEmpty hash -> Set FilePath
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (hash -> FilePath) -> [hash] -> [FilePath]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap hash -> FilePath
forall a. Show a => a -> FilePath
show ([hash] -> [FilePath])
-> (NonEmpty hash -> [hash]) -> NonEmpty hash -> [FilePath]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonEmpty hash -> [hash]
forall a. NonEmpty a -> [a]
NE.toList) [NonEmpty hash]
candidates