{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

module Ouroboros.Consensus.Storage.VolatileDB.Impl.Util
  ( -- * FileId utilities
    filePath
  , findLastFd
  , parseAllFds
  , parseFd

    -- * Exception handling
  , tryVolatileDB
  , wrapFsError

    -- * Map of Set utilities
  , deleteMapSet
  , insertMapSet
  ) where

import Control.Monad
import Data.Bifunctor (first)
import Data.List (sortOn)
import Data.Map.Strict (Map)
import qualified Data.Map.Strict as Map
import Data.Proxy (Proxy (..))
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Text (Text)
import qualified Data.Text as T
import Data.Typeable (Typeable)
import Ouroboros.Consensus.Block (StandardHash)
import Ouroboros.Consensus.Storage.VolatileDB.API
import Ouroboros.Consensus.Storage.VolatileDB.Impl.Types
import Ouroboros.Consensus.Util (lastMaybe)
import Ouroboros.Consensus.Util.IOLike
import System.FS.API.Types
import Text.Read (readMaybe)

{------------------------------------------------------------------------------
  FileId utilities
------------------------------------------------------------------------------}

parseFd :: FsPath -> Maybe FileId
parseFd :: FsPath -> Maybe Int
parseFd FsPath
file =
  Text -> Maybe Int
parseFilename (Text -> Maybe Int)
-> ([Text] -> Maybe Text) -> [Text] -> Maybe Int
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< [Text] -> Maybe Text
forall a. [a] -> Maybe a
lastMaybe ([Text] -> Maybe Int) -> [Text] -> Maybe Int
forall a b. (a -> b) -> a -> b
$ FsPath -> [Text]
fsPathToList FsPath
file
 where
  parseFilename :: Text -> Maybe FileId
  parseFilename :: Text -> Maybe Int
parseFilename =
    [Char] -> Maybe Int
forall a. Read a => [Char] -> Maybe a
readMaybe
      ([Char] -> Maybe Int) -> (Text -> [Char]) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> [Char]
T.unpack
      (Text -> [Char]) -> (Text -> Text) -> Text -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> b
snd
      ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOnEnd Text
"-"
      (Text -> (Text, Text)) -> (Text -> Text) -> Text -> (Text, Text)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Text, Text) -> Text
forall a b. (a, b) -> a
fst
      ((Text, Text) -> Text) -> (Text -> (Text, Text)) -> Text -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. HasCallStack => Text -> Text -> (Text, Text)
Text -> Text -> (Text, Text)
T.breakOn Text
"."

-- | Parses the 'FileId' of each 'FsPath' and zips them together. Returns
-- the results sorted on the 'FileId'.
--
-- Return separately any 'FsPath' which failed to parse.
parseAllFds :: [FsPath] -> ([(FileId, FsPath)], [FsPath])
parseAllFds :: [FsPath] -> ([(Int, FsPath)], [FsPath])
parseAllFds = ([(Int, FsPath)] -> [(Int, FsPath)])
-> ([(Int, FsPath)], [FsPath]) -> ([(Int, FsPath)], [FsPath])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((Int, FsPath) -> Int) -> [(Int, FsPath)] -> [(Int, FsPath)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (Int, FsPath) -> Int
forall a b. (a, b) -> a
fst) (([(Int, FsPath)], [FsPath]) -> ([(Int, FsPath)], [FsPath]))
-> ([FsPath] -> ([(Int, FsPath)], [FsPath]))
-> [FsPath]
-> ([(Int, FsPath)], [FsPath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FsPath
 -> ([(Int, FsPath)], [FsPath]) -> ([(Int, FsPath)], [FsPath]))
-> ([(Int, FsPath)], [FsPath])
-> [FsPath]
-> ([(Int, FsPath)], [FsPath])
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr FsPath
-> ([(Int, FsPath)], [FsPath]) -> ([(Int, FsPath)], [FsPath])
judge ([], [])
 where
  judge :: FsPath
-> ([(Int, FsPath)], [FsPath]) -> ([(Int, FsPath)], [FsPath])
judge FsPath
fsPath ([(Int, FsPath)]
parsed, [FsPath]
notParsed) = case FsPath -> Maybe Int
parseFd FsPath
fsPath of
    Maybe Int
Nothing -> ([(Int, FsPath)]
parsed, FsPath
fsPath FsPath -> [FsPath] -> [FsPath]
forall a. a -> [a] -> [a]
: [FsPath]
notParsed)
    Just Int
fileId -> ((Int
fileId, FsPath
fsPath) (Int, FsPath) -> [(Int, FsPath)] -> [(Int, FsPath)]
forall a. a -> [a] -> [a]
: [(Int, FsPath)]
parsed, [FsPath]
notParsed)

-- | This also returns any 'FsPath' which failed to parse.
findLastFd :: [FsPath] -> (Maybe FileId, [FsPath])
findLastFd :: [FsPath] -> (Maybe Int, [FsPath])
findLastFd = ([(Int, FsPath)] -> Maybe Int)
-> ([(Int, FsPath)], [FsPath]) -> (Maybe Int, [FsPath])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((Int, FsPath) -> Int) -> Maybe (Int, FsPath) -> Maybe Int
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int, FsPath) -> Int
forall a b. (a, b) -> a
fst (Maybe (Int, FsPath) -> Maybe Int)
-> ([(Int, FsPath)] -> Maybe (Int, FsPath))
-> [(Int, FsPath)]
-> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Int, FsPath)] -> Maybe (Int, FsPath)
forall a. [a] -> Maybe a
lastMaybe) (([(Int, FsPath)], [FsPath]) -> (Maybe Int, [FsPath]))
-> ([FsPath] -> ([(Int, FsPath)], [FsPath]))
-> [FsPath]
-> (Maybe Int, [FsPath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FsPath] -> ([(Int, FsPath)], [FsPath])
parseAllFds

filePath :: FileId -> FsPath
filePath :: Int -> FsPath
filePath Int
fd = [[Char]] -> FsPath
mkFsPath [[Char]
"blocks-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
fd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
".dat"]

{------------------------------------------------------------------------------
  Exception handling
------------------------------------------------------------------------------}

wrapFsError ::
  forall m a blk.
  (MonadCatch m, StandardHash blk, Typeable blk) =>
  Proxy blk ->
  m a ->
  m a
wrapFsError :: forall (m :: * -> *) a blk.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError Proxy blk
_ = (FsError -> m a) -> m a -> m a
forall e a. Exception e => (e -> m a) -> m a -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
(e -> m a) -> m a -> m a
handle ((FsError -> m a) -> m a -> m a) -> (FsError -> m a) -> m a -> m a
forall a b. (a -> b) -> a -> b
$ VolatileDBError blk -> m a
forall e a. Exception e => e -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError blk -> m a)
-> (FsError -> VolatileDBError blk) -> FsError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall blk. UnexpectedFailure blk -> VolatileDBError blk
UnexpectedFailure @blk (UnexpectedFailure blk -> VolatileDBError blk)
-> (FsError -> UnexpectedFailure blk)
-> FsError
-> VolatileDBError blk
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsError -> UnexpectedFailure blk
forall blk. FsError -> UnexpectedFailure blk
FileSystemError

-- | Execute an action and catch the 'VolatileDBError' and 'FsError' that can
-- be thrown by it, and wrap the 'FsError' in an 'VolatileDBError' using the
-- 'FileSystemError' constructor.
--
-- This should be used whenever you want to run an action on the VolatileDB
-- and catch the 'VolatileDBError' and the 'FsError' (wrapped in the former)
-- it may thrown.
tryVolatileDB ::
  forall m a blk.
  (MonadCatch m, Typeable blk, StandardHash blk) =>
  Proxy blk ->
  m a ->
  m (Either (VolatileDBError blk) a)
tryVolatileDB :: forall (m :: * -> *) a blk.
(MonadCatch m, Typeable blk, StandardHash blk) =>
Proxy blk -> m a -> m (Either (VolatileDBError blk) a)
tryVolatileDB Proxy blk
pb = m a -> m (Either (VolatileDBError blk) a)
forall e a. Exception e => m a -> m (Either e a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either (VolatileDBError blk) a))
-> (m a -> m a) -> m a -> m (Either (VolatileDBError blk) a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Proxy blk -> m a -> m a
forall (m :: * -> *) a blk.
(MonadCatch m, StandardHash blk, Typeable blk) =>
Proxy blk -> m a -> m a
wrapFsError Proxy blk
pb

{------------------------------------------------------------------------------
  Map of Set utilities
------------------------------------------------------------------------------}

insertMapSet ::
  forall k v.
  (Ord k, Ord v) =>
  k ->
  v ->
  Map k (Set v) ->
  Map k (Set v)
insertMapSet :: forall k v.
(Ord k, Ord v) =>
k -> v -> Map k (Set v) -> Map k (Set v)
insertMapSet k
k v
v = (Maybe (Set v) -> Maybe (Set v))
-> k -> Map k (Set v) -> Map k (Set v)
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter Maybe (Set v) -> Maybe (Set v)
ins k
k
 where
  ins :: Maybe (Set v) -> Maybe (Set v)
  ins :: Maybe (Set v) -> Maybe (Set v)
ins = \case
    Maybe (Set v)
Nothing -> Set v -> Maybe (Set v)
forall a. a -> Maybe a
Just (Set v -> Maybe (Set v)) -> Set v -> Maybe (Set v)
forall a b. (a -> b) -> a -> b
$ v -> Set v
forall a. a -> Set a
Set.singleton v
v
    Just Set v
set -> Set v -> Maybe (Set v)
forall a. a -> Maybe a
Just (Set v -> Maybe (Set v)) -> Set v -> Maybe (Set v)
forall a b. (a -> b) -> a -> b
$ v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.insert v
v Set v
set

deleteMapSet ::
  forall k v.
  (Ord k, Ord v) =>
  k ->
  v ->
  Map k (Set v) ->
  Map k (Set v)
deleteMapSet :: forall k v.
(Ord k, Ord v) =>
k -> v -> Map k (Set v) -> Map k (Set v)
deleteMapSet k
k v
v = (Set v -> Maybe (Set v)) -> k -> Map k (Set v) -> Map k (Set v)
forall k a. Ord k => (a -> Maybe a) -> k -> Map k a -> Map k a
Map.update Set v -> Maybe (Set v)
del k
k
 where
  del :: Set v -> Maybe (Set v)
  del :: Set v -> Maybe (Set v)
del Set v
set
    | Set v -> Bool
forall a. Set a -> Bool
Set.null Set v
set' =
        Maybe (Set v)
forall a. Maybe a
Nothing
    | Bool
otherwise =
        Set v -> Maybe (Set v)
forall a. a -> Maybe a
Just Set v
set'
   where
    set' :: Set v
set' = v -> Set v -> Set v
forall a. Ord a => a -> Set a -> Set a
Set.delete v
v Set v
set