{-# LANGUAGE LambdaCase          #-}
{-# LANGUAGE OverloadedStrings   #-}
{-# LANGUAGE ScopedTypeVariables #-}
module Ouroboros.Consensus.Storage.VolatileDB.Impl.Util
    ( -- * FileId utilities
      parseFd
    , parseAllFds
    , filePath
    , findLastFd

      -- * Exception handling
    , wrapFsError
    , tryVolatileDB

      -- * Map of Set utilities
    , insertMapSet
    , deleteMapSet
    ) 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.Set (Set)
import qualified Data.Set as Set
import           Data.Text (Text)
import qualified Data.Text as T
import           Text.Read (readMaybe)

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 :: MonadCatch m => m a -> m a
wrapFsError :: m a -> m a
wrapFsError = (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 -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwIO (VolatileDBError -> m a)
-> (FsError -> VolatileDBError) -> FsError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. UnexpectedFailure -> VolatileDBError
UnexpectedFailure (UnexpectedFailure -> VolatileDBError)
-> (FsError -> UnexpectedFailure) -> FsError -> VolatileDBError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FsError -> UnexpectedFailure
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. MonadCatch m
  => m a
  -> m (Either VolatileDBError a)
tryVolatileDB :: m a -> m (Either VolatileDBError a)
tryVolatileDB = m a -> m (Either VolatileDBError a)
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> m (Either e a)
try (m a -> m (Either VolatileDBError a))
-> (m a -> m a) -> m a -> m (Either VolatileDBError a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. m a -> m a
forall (m :: * -> *) a. MonadCatch m => m a -> m a
wrapFsError

{------------------------------------------------------------------------------
  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