{-# 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           Text.Read (readMaybe)

import           Ouroboros.Consensus.Block (StandardHash)
import           Ouroboros.Consensus.Util (lastMaybe)
import           Ouroboros.Consensus.Util.IOLike

import           Ouroboros.Consensus.Storage.FS.API.Types
import           Ouroboros.Consensus.Storage.VolatileDB.API
import           Ouroboros.Consensus.Storage.VolatileDB.Impl.Types

{------------------------------------------------------------------------------
  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 = String -> Maybe FileId
forall a. Read a => String -> Maybe a
readMaybe
                  (String -> Maybe FileId)
-> (Text -> String) -> Text -> Maybe FileId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
T.unpack
                  (Text -> String) -> (Text -> Text) -> Text -> String
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
. 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
. 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 (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 (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 (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (((FileId, FsPath) -> FileId)
-> Maybe (FileId, FsPath) -> Maybe FileId
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 = [String] -> FsPath
mkFsPath [String
"blocks-" String -> String -> String
forall a. [a] -> [a] -> [a]
++ FileId -> String
forall a. Show a => a -> String
show FileId
fd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
".dat"]

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

wrapFsError ::
     forall m a blk. (MonadCatch m, StandardHash blk, Typeable blk)
  => Proxy blk
  -> m a
  -> m a
wrapFsError :: Proxy blk -> m a -> m a
wrapFsError Proxy blk
_ = (FsError -> 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 (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
. UnexpectedFailure blk -> VolatileDBError blk
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 :: Proxy blk -> m a -> m (Either (VolatileDBError blk) a)
tryVolatileDB Proxy blk
pb = m a -> m (Either (VolatileDBError blk) 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 :: 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 :: 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