{-# 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 FileId
parseFd FsPath
file =
  Text -> Maybe FileId
parseFilename (Text -> Maybe FileId)
-> ([Text] -> Maybe Text) -> [Text] -> Maybe FileId
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 FileId) -> [Text] -> Maybe FileId
forall a b. (a -> b) -> a -> b
$ FsPath -> [Text]
fsPathToList FsPath
file
 where
  parseFilename :: Text -> Maybe FileId
  parseFilename :: Text -> Maybe FileId
parseFilename =
    [Char] -> Maybe FileId
forall a. Read a => [Char] -> Maybe a
readMaybe
      ([Char] -> Maybe FileId)
-> (Text -> [Char]) -> Text -> Maybe FileId
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] -> ([(FileId, FsPath)], [FsPath])
parseAllFds = ([(FileId, FsPath)] -> [(FileId, FsPath)])
-> ([(FileId, FsPath)], [FsPath]) -> ([(FileId, 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 (((FileId, FsPath) -> FileId)
-> [(FileId, FsPath)] -> [(FileId, FsPath)]
forall b a. Ord b => (a -> b) -> [a] -> [a]
sortOn (FileId, FsPath) -> FileId
forall a b. (a, b) -> a
fst) (([(FileId, FsPath)], [FsPath]) -> ([(FileId, FsPath)], [FsPath]))
-> ([FsPath] -> ([(FileId, FsPath)], [FsPath]))
-> [FsPath]
-> ([(FileId, FsPath)], [FsPath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (FsPath
 -> ([(FileId, FsPath)], [FsPath])
 -> ([(FileId, FsPath)], [FsPath]))
-> ([(FileId, FsPath)], [FsPath])
-> [FsPath]
-> ([(FileId, 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
-> ([(FileId, FsPath)], [FsPath]) -> ([(FileId, FsPath)], [FsPath])
judge ([], [])
 where
  judge :: FsPath
-> ([(FileId, FsPath)], [FsPath]) -> ([(FileId, FsPath)], [FsPath])
judge FsPath
fsPath ([(FileId, FsPath)]
parsed, [FsPath]
notParsed) = case FsPath -> Maybe FileId
parseFd FsPath
fsPath of
    Maybe FileId
Nothing -> ([(FileId, FsPath)]
parsed, FsPath
fsPath FsPath -> [FsPath] -> [FsPath]
forall a. a -> [a] -> [a]
: [FsPath]
notParsed)
    Just FileId
fileId -> ((FileId
fileId, FsPath
fsPath) (FileId, FsPath) -> [(FileId, FsPath)] -> [(FileId, FsPath)]
forall a. a -> [a] -> [a]
: [(FileId, FsPath)]
parsed, [FsPath]
notParsed)

-- | This also returns any 'FsPath' which failed to parse.
findLastFd :: [FsPath] -> (Maybe FileId, [FsPath])
findLastFd :: [FsPath] -> (Maybe FileId, [FsPath])
findLastFd = ([(FileId, FsPath)] -> Maybe FileId)
-> ([(FileId, FsPath)], [FsPath]) -> (Maybe FileId, [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 (((FileId, FsPath) -> FileId)
-> Maybe (FileId, FsPath) -> Maybe FileId
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FileId, FsPath) -> FileId
forall a b. (a, b) -> a
fst (Maybe (FileId, FsPath) -> Maybe FileId)
-> ([(FileId, FsPath)] -> Maybe (FileId, FsPath))
-> [(FileId, FsPath)]
-> Maybe FileId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(FileId, FsPath)] -> Maybe (FileId, FsPath)
forall a. [a] -> Maybe a
lastMaybe) (([(FileId, FsPath)], [FsPath]) -> (Maybe FileId, [FsPath]))
-> ([FsPath] -> ([(FileId, FsPath)], [FsPath]))
-> [FsPath]
-> (Maybe FileId, [FsPath])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [FsPath] -> ([(FileId, FsPath)], [FsPath])
parseAllFds

filePath :: FileId -> FsPath
filePath :: FileId -> FsPath
filePath FileId
fd = [[Char]] -> FsPath
mkFsPath [[Char]
"blocks-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ FileId -> [Char]
forall a. Show a => a -> [Char]
show FileId
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