{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}

-- | This module is a relatively direct translation of the official directory
-- layer code in Python and Go.
module FoundationDB.Layer.Directory.Internal where

import Control.Monad (unless, when)
import Data.ByteString (ByteString)
import qualified Data.ByteString as BS
import Data.Foldable (forM_)
import Data.Maybe (isJust)
import Data.Sequence (Seq (Empty, (:<|)))
import Data.Serialize.Get (getWord32le, runGet)
import Data.Serialize.Put (putWord32le, runPut)
import Data.Text (Text)
import Data.Word (Word32)
import FoundationDB
import FoundationDB.Layer.Directory.Internal.Error
import FoundationDB.Layer.Directory.Internal.HCA
import FoundationDB.Layer.Directory.Internal.Node
import FoundationDB.Layer.Subspace
import qualified FoundationDB.Layer.Tuple as Tuple

_SUBDIRS :: Integer
_SUBDIRS :: Integer
_SUBDIRS = Integer
0

majorVersion, minorVersion, microVersion :: Word32
majorVersion :: Word32
majorVersion = Word32
1
minorVersion :: Word32
minorVersion = Word32
0
microVersion :: Word32
microVersion = Word32
0

throwing :: String -> Either a b -> Transaction b
throwing :: String -> Either a b -> Transaction b
throwing String
s = (a -> Transaction b)
-> (b -> Transaction b) -> Either a b -> Transaction b
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Transaction b -> a -> Transaction b
forall a b. a -> b -> a
const (Transaction b -> a -> Transaction b)
-> Transaction b -> a -> Transaction b
forall a b. (a -> b) -> a -> b
$ String -> Transaction b
forall a. String -> Transaction a
throwDirInternalError String
s) b -> Transaction b
forall (m :: * -> *) a. Monad m => a -> m a
return

-- | Represents a directory tree. A value of this type must be supplied to all
-- functions in this module.
data DirectoryLayer = DirectoryLayer
  { -- | Subspace for directory metadata.
    DirectoryLayer -> Subspace
nodeSS :: Subspace,
    -- | Subspace for directory content.
    DirectoryLayer -> Subspace
contentSS :: Subspace,
    DirectoryLayer -> HCA
allocator :: HCA,
    DirectoryLayer -> Subspace
rootNode :: Subspace,
    DirectoryLayer -> Bool
allowManualPrefixes :: Bool,
    DirectoryLayer -> [Text]
dlPath :: [Text]
  }
  deriving (Int -> DirectoryLayer -> ShowS
[DirectoryLayer] -> ShowS
DirectoryLayer -> String
(Int -> DirectoryLayer -> ShowS)
-> (DirectoryLayer -> String)
-> ([DirectoryLayer] -> ShowS)
-> Show DirectoryLayer
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DirectoryLayer] -> ShowS
$cshowList :: [DirectoryLayer] -> ShowS
show :: DirectoryLayer -> String
$cshow :: DirectoryLayer -> String
showsPrec :: Int -> DirectoryLayer -> ShowS
$cshowsPrec :: Int -> DirectoryLayer -> ShowS
Show, DirectoryLayer -> DirectoryLayer -> Bool
(DirectoryLayer -> DirectoryLayer -> Bool)
-> (DirectoryLayer -> DirectoryLayer -> Bool) -> Eq DirectoryLayer
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DirectoryLayer -> DirectoryLayer -> Bool
$c/= :: DirectoryLayer -> DirectoryLayer -> Bool
== :: DirectoryLayer -> DirectoryLayer -> Bool
$c== :: DirectoryLayer -> DirectoryLayer -> Bool
Eq, Eq DirectoryLayer
Eq DirectoryLayer
-> (DirectoryLayer -> DirectoryLayer -> Ordering)
-> (DirectoryLayer -> DirectoryLayer -> Bool)
-> (DirectoryLayer -> DirectoryLayer -> Bool)
-> (DirectoryLayer -> DirectoryLayer -> Bool)
-> (DirectoryLayer -> DirectoryLayer -> Bool)
-> (DirectoryLayer -> DirectoryLayer -> DirectoryLayer)
-> (DirectoryLayer -> DirectoryLayer -> DirectoryLayer)
-> Ord DirectoryLayer
DirectoryLayer -> DirectoryLayer -> Bool
DirectoryLayer -> DirectoryLayer -> Ordering
DirectoryLayer -> DirectoryLayer -> DirectoryLayer
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DirectoryLayer -> DirectoryLayer -> DirectoryLayer
$cmin :: DirectoryLayer -> DirectoryLayer -> DirectoryLayer
max :: DirectoryLayer -> DirectoryLayer -> DirectoryLayer
$cmax :: DirectoryLayer -> DirectoryLayer -> DirectoryLayer
>= :: DirectoryLayer -> DirectoryLayer -> Bool
$c>= :: DirectoryLayer -> DirectoryLayer -> Bool
> :: DirectoryLayer -> DirectoryLayer -> Bool
$c> :: DirectoryLayer -> DirectoryLayer -> Bool
<= :: DirectoryLayer -> DirectoryLayer -> Bool
$c<= :: DirectoryLayer -> DirectoryLayer -> Bool
< :: DirectoryLayer -> DirectoryLayer -> Bool
$c< :: DirectoryLayer -> DirectoryLayer -> Bool
compare :: DirectoryLayer -> DirectoryLayer -> Ordering
$ccompare :: DirectoryLayer -> DirectoryLayer -> Ordering
$cp1Ord :: Eq DirectoryLayer
Ord)

-- | A path is a list of unicode strings.
type Path = [Text]

-- | Represents a single directory.
data Directory = Directory
  { Directory -> Subspace
directorySubspace :: Subspace,
    Directory -> [Text]
directoryPath :: Path,
    Directory -> ByteString
directoryLayer :: ByteString
  }
  deriving (Int -> Directory -> ShowS
[Directory] -> ShowS
Directory -> String
(Int -> Directory -> ShowS)
-> (Directory -> String)
-> ([Directory] -> ShowS)
-> Show Directory
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [Directory] -> ShowS
$cshowList :: [Directory] -> ShowS
show :: Directory -> String
$cshow :: Directory -> String
showsPrec :: Int -> Directory -> ShowS
$cshowsPrec :: Int -> Directory -> ShowS
Show, Directory -> Directory -> Bool
(Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool) -> Eq Directory
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: Directory -> Directory -> Bool
$c/= :: Directory -> Directory -> Bool
== :: Directory -> Directory -> Bool
$c== :: Directory -> Directory -> Bool
Eq, Eq Directory
Eq Directory
-> (Directory -> Directory -> Ordering)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Bool)
-> (Directory -> Directory -> Directory)
-> (Directory -> Directory -> Directory)
-> Ord Directory
Directory -> Directory -> Bool
Directory -> Directory -> Ordering
Directory -> Directory -> Directory
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: Directory -> Directory -> Directory
$cmin :: Directory -> Directory -> Directory
max :: Directory -> Directory -> Directory
$cmax :: Directory -> Directory -> Directory
>= :: Directory -> Directory -> Bool
$c>= :: Directory -> Directory -> Bool
> :: Directory -> Directory -> Bool
$c> :: Directory -> Directory -> Bool
<= :: Directory -> Directory -> Bool
$c<= :: Directory -> Directory -> Bool
< :: Directory -> Directory -> Bool
$c< :: Directory -> Directory -> Bool
compare :: Directory -> Directory -> Ordering
$ccompare :: Directory -> Directory -> Ordering
$cp1Ord :: Eq Directory
Ord)

-- | Gets the content subspace of a directory, which can be used to store
-- tuple-based keys.
dirSubspace :: Directory -> Subspace
dirSubspace :: Directory -> Subspace
dirSubspace = Directory -> Subspace
directorySubspace

-- | Gets the path of a directory.
dirPath :: Directory -> Path
dirPath :: Directory -> [Text]
dirPath = Directory -> [Text]
directoryPath

-- | Gets the layer tag that was specified when the directory was created.
dirLayer :: Directory -> ByteString
dirLayer :: Directory -> ByteString
dirLayer = Directory -> ByteString
directoryLayer

-- TODO: this library doesn't yet support partitions. Some code exists, but it's
-- not yet used.
data DirPartition = DirPartition
  { DirPartition -> DirectoryLayer
dirPartition :: DirectoryLayer,
    DirPartition -> DirectoryLayer
dirPartitionParentDL :: DirectoryLayer
  }
  deriving (Int -> DirPartition -> ShowS
[DirPartition] -> ShowS
DirPartition -> String
(Int -> DirPartition -> ShowS)
-> (DirPartition -> String)
-> ([DirPartition] -> ShowS)
-> Show DirPartition
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DirPartition] -> ShowS
$cshowList :: [DirPartition] -> ShowS
show :: DirPartition -> String
$cshow :: DirPartition -> String
showsPrec :: Int -> DirPartition -> ShowS
$cshowsPrec :: Int -> DirPartition -> ShowS
Show, DirPartition -> DirPartition -> Bool
(DirPartition -> DirPartition -> Bool)
-> (DirPartition -> DirPartition -> Bool) -> Eq DirPartition
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DirPartition -> DirPartition -> Bool
$c/= :: DirPartition -> DirPartition -> Bool
== :: DirPartition -> DirPartition -> Bool
$c== :: DirPartition -> DirPartition -> Bool
Eq, Eq DirPartition
Eq DirPartition
-> (DirPartition -> DirPartition -> Ordering)
-> (DirPartition -> DirPartition -> Bool)
-> (DirPartition -> DirPartition -> Bool)
-> (DirPartition -> DirPartition -> Bool)
-> (DirPartition -> DirPartition -> Bool)
-> (DirPartition -> DirPartition -> DirPartition)
-> (DirPartition -> DirPartition -> DirPartition)
-> Ord DirPartition
DirPartition -> DirPartition -> Bool
DirPartition -> DirPartition -> Ordering
DirPartition -> DirPartition -> DirPartition
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DirPartition -> DirPartition -> DirPartition
$cmin :: DirPartition -> DirPartition -> DirPartition
max :: DirPartition -> DirPartition -> DirPartition
$cmax :: DirPartition -> DirPartition -> DirPartition
>= :: DirPartition -> DirPartition -> Bool
$c>= :: DirPartition -> DirPartition -> Bool
> :: DirPartition -> DirPartition -> Bool
$c> :: DirPartition -> DirPartition -> Bool
<= :: DirPartition -> DirPartition -> Bool
$c<= :: DirPartition -> DirPartition -> Bool
< :: DirPartition -> DirPartition -> Bool
$c< :: DirPartition -> DirPartition -> Bool
compare :: DirPartition -> DirPartition -> Ordering
$ccompare :: DirPartition -> DirPartition -> Ordering
$cp1Ord :: Eq DirPartition
Ord)

-- | Creates a new directory layer, containing a  hierarchy of directories.
newDirectoryLayer ::
  -- | node subspace for directory metadata
  Subspace ->
  -- | content subspace
  Subspace ->
  -- | allow manual prefixes
  Bool ->
  DirectoryLayer
newDirectoryLayer :: Subspace -> Subspace -> Bool -> DirectoryLayer
newDirectoryLayer Subspace
nodeSS Subspace
contentSS Bool
allowManualPrefixes =
  let rootNode :: Subspace
rootNode = Subspace -> [Elem] -> Subspace
extend Subspace
nodeSS [ByteString -> Elem
Tuple.Bytes (Subspace -> ByteString
subspaceKey Subspace
nodeSS)]
      allocator :: HCA
allocator = Subspace -> HCA
newHCA (Subspace -> [Elem] -> Subspace
extend Subspace
rootNode [ByteString -> Elem
Tuple.Bytes ByteString
"hca"])
      dlPath :: [a]
dlPath = []
   in DirectoryLayer :: Subspace
-> Subspace -> HCA -> Subspace -> Bool -> [Text] -> DirectoryLayer
DirectoryLayer {Bool
[Text]
Subspace
HCA
forall a. [a]
dlPath :: forall a. [a]
allocator :: HCA
rootNode :: Subspace
allowManualPrefixes :: Bool
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
..}

-- | The default directory layer has node subspace prefix @0xfe@.
-- This corresponds to using the defaults for all arguments to the
-- @DirectoryLayer@ constructor in other languages' bindings.
defaultDirLayer :: DirectoryLayer
defaultDirLayer :: DirectoryLayer
defaultDirLayer = Subspace -> Subspace -> Bool -> DirectoryLayer
newDirectoryLayer (ByteString -> Subspace
Subspace ByteString
"\xfe") (ByteString -> Subspace
Subspace ByteString
"") Bool
False

-- | Tries to open a directory at the given path.
--   If the directory exists, returns it. Otherwise, returns 'Nothing'.
open ::
  DirectoryLayer ->
  Path ->
  Transaction (Maybe Directory)
open :: DirectoryLayer -> [Text] -> Transaction (Maybe Directory)
open DirectoryLayer
dl [Text]
p = DirectoryLayer
-> [Text]
-> ByteString
-> Maybe ByteString
-> Transaction (Maybe Directory)
open' DirectoryLayer
dl [Text]
p ByteString
"" Maybe ByteString
forall a. Maybe a
Nothing

-- | Opens a directory at the given path. If the directory does not exist, it
-- is created.
createOrOpen ::
  DirectoryLayer ->
  Path ->
  Transaction Directory
createOrOpen :: DirectoryLayer -> [Text] -> Transaction Directory
createOrOpen DirectoryLayer
dl [Text]
p = DirectoryLayer
-> [Text]
-> ByteString
-> Maybe ByteString
-> Transaction Directory
createOrOpen' DirectoryLayer
dl [Text]
p ByteString
"" Maybe ByteString
forall a. Maybe a
Nothing

-- | Open a directory, with optional custom prefix and layer.
-- Returns 'Nothing' if the directory doesn't exist.
open' ::
  DirectoryLayer ->
  Path ->
  -- | layer
  ByteString ->
  -- | optional custom prefix
  Maybe ByteString ->
  Transaction (Maybe Directory)
open' :: DirectoryLayer
-> [Text]
-> ByteString
-> Maybe ByteString
-> Transaction (Maybe Directory)
open' DirectoryLayer
_ [] ByteString
_ Maybe ByteString
_ = DirLayerUserError -> Transaction (Maybe Directory)
forall a. DirLayerUserError -> Transaction a
throwDirUserError DirLayerUserError
CannotOpenRoot
-- TODO: prefix won't be used until we add partition support
open' DirectoryLayer
dl [Text]
path ByteString
layer Maybe ByteString
_prefix = do
  DirectoryLayer -> Transaction ()
checkVersion DirectoryLayer
dl
  DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl [Text]
path Transaction (Maybe FoundNode)
-> (Maybe FoundNode -> Transaction (Maybe Directory))
-> Transaction (Maybe Directory)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe FoundNode
Nothing -> Maybe Directory -> Transaction (Maybe Directory)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Directory
forall a. Maybe a
Nothing
    Just FoundNode
node -> do
      ByteString
existingLayer <- FoundNode -> Transaction ByteString
getFoundNodeLayer FoundNode
node
      Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when
        (ByteString
layer ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
/= ByteString
existingLayer)
        (DirLayerUserError -> Transaction ()
forall a. DirLayerUserError -> Transaction a
throwDirUserError (DirLayerUserError -> Transaction ())
-> DirLayerUserError -> Transaction ()
forall a b. (a -> b) -> a -> b
$ ByteString -> ByteString -> DirLayerUserError
LayerMismatch ByteString
layer ByteString
existingLayer)
      Directory -> Maybe Directory
forall a. a -> Maybe a
Just
        (Directory -> Maybe Directory)
-> Transaction Directory -> Transaction (Maybe Directory)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirectoryLayer
-> Subspace -> [Text] -> ByteString -> Transaction Directory
contentsOfNodeSubspace
          DirectoryLayer
dl
          (FoundNode -> Subspace
nodeNodeSS FoundNode
node)
          (FoundNode -> [Text]
nodePath FoundNode
node)
          ByteString
existingLayer

-- | Opens a directory at the given path, with optional custom prefix and layer.
createOrOpen' ::
  DirectoryLayer ->
  Path ->
  -- | layer
  ByteString ->
  -- | optional custom prefix
  Maybe ByteString ->
  Transaction Directory
createOrOpen' :: DirectoryLayer
-> [Text]
-> ByteString
-> Maybe ByteString
-> Transaction Directory
createOrOpen' DirectoryLayer
_ [] ByteString
_ Maybe ByteString
_ = DirLayerUserError -> Transaction Directory
forall a. DirLayerUserError -> Transaction a
throwDirUserError DirLayerUserError
CannotOpenRoot
createOrOpen' dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} [Text]
path ByteString
layer Maybe ByteString
prefix = do
  Maybe Directory
tryOpen <- DirectoryLayer
-> [Text]
-> ByteString
-> Maybe ByteString
-> Transaction (Maybe Directory)
open' DirectoryLayer
dl [Text]
path ByteString
layer Maybe ByteString
prefix
  case Maybe Directory
tryOpen of
    Just Directory
ss -> Directory -> Transaction Directory
forall (m :: * -> *) a. Monad m => a -> m a
return Directory
ss
    Maybe Directory
Nothing -> do
      ByteString
prefixToUse <- case Maybe ByteString
prefix of
        Maybe ByteString
Nothing -> do
          Subspace
newDirPrefix <- HCA -> Subspace -> Transaction Subspace
allocate HCA
allocator Subspace
contentSS
          Bool
isPrefixEmpty <- RangeQuery -> Transaction Bool
isRangeEmpty (Subspace -> RangeQuery
subspaceRangeQuery Subspace
newDirPrefix)
          Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            Bool
isPrefixEmpty
            ( String -> Transaction ()
forall a. String -> Transaction a
throwDirInternalError
                String
"Failed to alloc new dir: prefix not empty."
            )
          Bool
isFree <- DirectoryLayer -> ByteString -> Transaction Bool
isPrefixFree DirectoryLayer
dl (Subspace -> [Elem] -> ByteString
pack Subspace
newDirPrefix [])
          Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            Bool
isFree
            (DirLayerUserError -> Transaction ()
forall a. DirLayerUserError -> Transaction a
throwDirUserError (ByteString -> DirLayerUserError
ManualPrefixConflict (ByteString -> DirLayerUserError)
-> ByteString -> DirLayerUserError
forall a b. (a -> b) -> a -> b
$ Subspace -> ByteString
rawPrefix Subspace
newDirPrefix))
          ByteString -> Transaction ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return (Subspace -> [Elem] -> ByteString
pack Subspace
newDirPrefix [])
        Just ByteString
prefixBytes -> do
          Bool
isFree <- DirectoryLayer -> ByteString -> Transaction Bool
isPrefixFree DirectoryLayer
dl ByteString
prefixBytes
          Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless
            Bool
isFree
            (DirLayerUserError -> Transaction ()
forall a. DirLayerUserError -> Transaction a
throwDirUserError DirLayerUserError
PrefixInUse)
          ByteString -> Transaction ByteString
forall (m :: * -> *) a. Monad m => a -> m a
return ByteString
prefixBytes
      Subspace
parentNode <-
        if [Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
path Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1
          then do
            Directory
pd <- DirectoryLayer
-> [Text]
-> ByteString
-> Maybe ByteString
-> Transaction Directory
createOrOpen' DirectoryLayer
dl ([Text] -> [Text]
forall a. [a] -> [a]
init [Text]
path) ByteString
"" Maybe ByteString
forall a. Maybe a
Nothing
            let pdk :: ByteString
pdk = Subspace -> ByteString
subspaceKey (Directory -> Subspace
directorySubspace Directory
pd)
            Subspace -> Transaction Subspace
forall (m :: * -> *) a. Monad m => a -> m a
return (Subspace -> Transaction Subspace)
-> Subspace -> Transaction Subspace
forall a b. (a -> b) -> a -> b
$ DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix DirectoryLayer
dl ByteString
pdk
          else Subspace -> Transaction Subspace
forall (m :: * -> *) a. Monad m => a -> m a
return Subspace
rootNode
      let node :: Subspace
node = DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix DirectoryLayer
dl ByteString
prefixToUse
      ByteString -> ByteString -> Transaction ()
set
        (Subspace -> [Elem] -> ByteString
pack Subspace
parentNode [Integer -> Elem
Tuple.Int Integer
_SUBDIRS, Text -> Elem
Tuple.Text ([Text] -> Text
forall a. [a] -> a
last [Text]
path)])
        ByteString
prefixToUse
      ByteString -> ByteString -> Transaction ()
set (Subspace -> [Elem] -> ByteString
pack Subspace
node [ByteString -> Elem
Tuple.Bytes ByteString
"layer"]) ByteString
layer
      DirectoryLayer
-> Subspace -> [Text] -> ByteString -> Transaction Directory
contentsOfNodeSubspace DirectoryLayer
dl Subspace
node [Text]
path ByteString
layer

-- | Returns 'True' iff the given path exists.
exists ::
  DirectoryLayer ->
  Path ->
  Transaction Bool
exists :: DirectoryLayer -> [Text] -> Transaction Bool
exists DirectoryLayer
dl [Text]
path = Maybe FoundNode -> Bool
forall a. Maybe a -> Bool
isJust (Maybe FoundNode -> Bool)
-> Transaction (Maybe FoundNode) -> Transaction Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl [Text]
path

-- | List the names of the immediate subdirectories of a directory.
-- Returns an empty list if the directory does not exist.
list :: DirectoryLayer -> Path -> Transaction (Seq Text)
list :: DirectoryLayer -> [Text] -> Transaction (Seq Text)
list DirectoryLayer
dl [Text]
path =
  DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl [Text]
path Transaction (Maybe FoundNode)
-> (Maybe FoundNode -> Transaction (Seq Text))
-> Transaction (Seq Text)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe FoundNode
Nothing -> Seq Text -> Transaction (Seq Text)
forall (m :: * -> *) a. Monad m => a -> m a
return Seq Text
forall a. Seq a
Empty
    Just FoundNode
node -> DirectoryLayer -> Subspace -> Transaction (Seq Text)
subdirNames DirectoryLayer
dl (FoundNode -> Subspace
nodeNodeSS FoundNode
node)

-- | Represents all ways 'move' may fail.
data MoveError
  = -- | returned by 'move' if you attempt to move a directory into a subdirectory
    --   of itself.
    SelfSubDir
  | -- | Returned by 'move' if the source subdirectory does not exist.
    SourceDoesNotExist
  | -- | Returned by 'move' if you attempt to move a directory from one partition
    --   to another.
    MoveBetweenPartitions
  | -- | Returned by 'move' if the destination directory already exists.
    DestinationAlreadyExists
  | -- | Returned by 'move' if the parent of the destination directory doesn't
    --   already exist.
    DestinationParentDoesNotExist
  | -- | Returned by 'move' if the destination path is the root path.
    CannotMoveToRoot
  deriving (Int -> MoveError -> ShowS
[MoveError] -> ShowS
MoveError -> String
(Int -> MoveError -> ShowS)
-> (MoveError -> String)
-> ([MoveError] -> ShowS)
-> Show MoveError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MoveError] -> ShowS
$cshowList :: [MoveError] -> ShowS
show :: MoveError -> String
$cshow :: MoveError -> String
showsPrec :: Int -> MoveError -> ShowS
$cshowsPrec :: Int -> MoveError -> ShowS
Show, MoveError -> MoveError -> Bool
(MoveError -> MoveError -> Bool)
-> (MoveError -> MoveError -> Bool) -> Eq MoveError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: MoveError -> MoveError -> Bool
$c/= :: MoveError -> MoveError -> Bool
== :: MoveError -> MoveError -> Bool
$c== :: MoveError -> MoveError -> Bool
Eq, Eq MoveError
Eq MoveError
-> (MoveError -> MoveError -> Ordering)
-> (MoveError -> MoveError -> Bool)
-> (MoveError -> MoveError -> Bool)
-> (MoveError -> MoveError -> Bool)
-> (MoveError -> MoveError -> Bool)
-> (MoveError -> MoveError -> MoveError)
-> (MoveError -> MoveError -> MoveError)
-> Ord MoveError
MoveError -> MoveError -> Bool
MoveError -> MoveError -> Ordering
MoveError -> MoveError -> MoveError
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: MoveError -> MoveError -> MoveError
$cmin :: MoveError -> MoveError -> MoveError
max :: MoveError -> MoveError -> MoveError
$cmax :: MoveError -> MoveError -> MoveError
>= :: MoveError -> MoveError -> Bool
$c>= :: MoveError -> MoveError -> Bool
> :: MoveError -> MoveError -> Bool
$c> :: MoveError -> MoveError -> Bool
<= :: MoveError -> MoveError -> Bool
$c<= :: MoveError -> MoveError -> Bool
< :: MoveError -> MoveError -> Bool
$c< :: MoveError -> MoveError -> Bool
compare :: MoveError -> MoveError -> Ordering
$ccompare :: MoveError -> MoveError -> Ordering
$cp1Ord :: Eq MoveError
Ord)

-- | Move a directory from one path to another. Returns @Just err@ if an error
-- occurred. If an error is returned, the directory structure is left
-- unchanged.
move ::
  DirectoryLayer ->
  -- | from path
  Path ->
  -- | to path
  Path ->
  Transaction (Maybe MoveError)
move :: DirectoryLayer -> [Text] -> [Text] -> Transaction (Maybe MoveError)
move DirectoryLayer
_ [Text]
_ [] = Maybe MoveError -> Transaction (Maybe MoveError)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe MoveError -> Transaction (Maybe MoveError))
-> Maybe MoveError -> Transaction (Maybe MoveError)
forall a b. (a -> b) -> a -> b
$ MoveError -> Maybe MoveError
forall a. a -> Maybe a
Just MoveError
CannotMoveToRoot
move DirectoryLayer
dl [Text]
oldPath [Text]
newPath = do
  let sliceEnd :: Int
sliceEnd = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
oldPath) ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
newPath)
  if [Text]
oldPath [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take Int
sliceEnd [Text]
newPath
    then Maybe MoveError -> Transaction (Maybe MoveError)
forall (m :: * -> *) a. Monad m => a -> m a
return (MoveError -> Maybe MoveError
forall a. a -> Maybe a
Just MoveError
SelfSubDir)
    else do
      Maybe FoundNode
oldNodeM <- DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl [Text]
oldPath
      Maybe FoundNode
newNodeM <- DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl [Text]
newPath
      Maybe FoundNode
parentNodeM <- DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl ([Text] -> [Text]
forall a. [a] -> [a]
init [Text]
newPath)
      case (Maybe FoundNode
oldNodeM, Maybe FoundNode
newNodeM, Maybe FoundNode
parentNodeM) of
        (Maybe FoundNode
Nothing, Maybe FoundNode
_, Maybe FoundNode
_) -> Maybe MoveError -> Transaction (Maybe MoveError)
forall (m :: * -> *) a. Monad m => a -> m a
return (MoveError -> Maybe MoveError
forall a. a -> Maybe a
Just MoveError
SourceDoesNotExist)
        (Maybe FoundNode
_, Just FoundNode
_, Maybe FoundNode
_) -> Maybe MoveError -> Transaction (Maybe MoveError)
forall (m :: * -> *) a. Monad m => a -> m a
return (MoveError -> Maybe MoveError
forall a. a -> Maybe a
Just MoveError
DestinationAlreadyExists)
        (Maybe FoundNode
_, Maybe FoundNode
_, Maybe FoundNode
Nothing) -> Maybe MoveError -> Transaction (Maybe MoveError)
forall (m :: * -> *) a. Monad m => a -> m a
return (MoveError -> Maybe MoveError
forall a. a -> Maybe a
Just MoveError
DestinationParentDoesNotExist)
        (Just FoundNode
oldNode, Maybe FoundNode
Nothing, Just FoundNode
parentNode) -> do
          let k :: ByteString
k =
                Subspace -> [Elem] -> ByteString
pack
                  (FoundNode -> Subspace
nodeNodeSS FoundNode
parentNode)
                  [Integer -> Elem
Tuple.Int Integer
_SUBDIRS, Text -> Elem
Tuple.Text ([Text] -> Text
forall a. [a] -> a
last [Text]
newPath)]
          let ve :: Either String [Elem]
ve =
                Subspace -> ByteString -> Either String [Elem]
unpack (DirectoryLayer -> Subspace
nodeSS DirectoryLayer
dl) (Subspace -> ByteString
rawPrefix (Subspace -> ByteString) -> Subspace -> ByteString
forall a b. (a -> b) -> a -> b
$ FoundNode -> Subspace
nodeNodeSS FoundNode
oldNode)
          case Either String [Elem]
ve of
            Left String
e -> String -> Transaction (Maybe MoveError)
forall a. String -> Transaction a
throwDirInternalError (String -> Transaction (Maybe MoveError))
-> String -> Transaction (Maybe MoveError)
forall a b. (a -> b) -> a -> b
$ String
"move failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
            Right (Tuple.Bytes ByteString
v : [Elem]
_) -> do
              ByteString -> ByteString -> Transaction ()
set ByteString
k ByteString
v
              DirectoryLayer -> [Text] -> Transaction ()
removeFromParent DirectoryLayer
dl [Text]
oldPath
              Maybe MoveError -> Transaction (Maybe MoveError)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe MoveError
forall a. Maybe a
Nothing
            Either String [Elem]
x -> String -> Transaction (Maybe MoveError)
forall a. String -> Transaction a
throwDirInternalError (String -> Transaction (Maybe MoveError))
-> String -> Transaction (Maybe MoveError)
forall a b. (a -> b) -> a -> b
$ String
"move unpack failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ Either String [Elem] -> String
forall a. Show a => a -> String
show Either String [Elem]
x

-- | Remove a directory path, its contents, and all subdirectories.
-- Returns 'True' if removal succeeds. Fails for nonexistent paths and the root
-- directory. In cases of failure, the directory structure is unchanged.
remove ::
  DirectoryLayer ->
  Path ->
  Transaction Bool
-- can't remove root dir
remove :: DirectoryLayer -> [Text] -> Transaction Bool
remove DirectoryLayer
_ [] = Bool -> Transaction Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
remove DirectoryLayer
dl [Text]
path =
  DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl [Text]
path Transaction (Maybe FoundNode)
-> (Maybe FoundNode -> Transaction Bool) -> Transaction Bool
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe FoundNode
Nothing -> Bool -> Transaction Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    Just FoundNode
node -> do
      DirectoryLayer -> Subspace -> Transaction ()
removeRecursive DirectoryLayer
dl (FoundNode -> Subspace
nodeNodeSS FoundNode
node)
      DirectoryLayer -> [Text] -> Transaction ()
removeFromParent DirectoryLayer
dl [Text]
path
      Bool -> Transaction Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

-- | Internal helper function that removes all subdirectories of the given
-- node subspace. Does not remove the given node from its parent.
removeRecursive ::
  DirectoryLayer ->
  -- | node
  Subspace ->
  Transaction ()
removeRecursive :: DirectoryLayer -> Subspace -> Transaction ()
removeRecursive dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} Subspace
node = do
  Seq Subspace
nodes <- DirectoryLayer -> Subspace -> Transaction (Seq Subspace)
subdirNodes DirectoryLayer
dl Subspace
node
  Seq Subspace -> (Subspace -> Transaction ()) -> Transaction ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Seq Subspace
nodes (DirectoryLayer -> Subspace -> Transaction ()
removeRecursive DirectoryLayer
dl)
  let p :: Either String [Elem]
p = Subspace -> ByteString -> Either String [Elem]
unpack Subspace
nodeSS (Subspace -> [Elem] -> ByteString
pack Subspace
node [])
  case Either String [Elem]
p of
    Left String
e ->
      String -> Transaction ()
forall a. String -> Transaction a
throwDirInternalError (String -> Transaction ()) -> String -> Transaction ()
forall a b. (a -> b) -> a -> b
$
        String
"removeRecursive: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e
    Right (Tuple.Bytes ByteString
p' : [Elem]
_) -> case RangeQuery -> (ByteString, ByteString)
rangeKeys (RangeQuery -> (ByteString, ByteString))
-> Maybe RangeQuery -> Maybe (ByteString, ByteString)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> Maybe RangeQuery
prefixRange ByteString
p' of
      Just (ByteString
start, ByteString
end) -> ByteString -> ByteString -> Transaction ()
clearRange ByteString
start ByteString
end
      Maybe (ByteString, ByteString)
Nothing ->
        String -> Transaction ()
forall a. String -> Transaction a
throwDirInternalError (String -> Transaction ()) -> String -> Transaction ()
forall a b. (a -> b) -> a -> b
$
          String
"removeRecursive: couldn't make prefix range:"
            String -> ShowS
forall a. [a] -> [a] -> [a]
++ ByteString -> String
forall a. Show a => a -> String
show ByteString
p'
    Right [Elem]
_ -> String -> Transaction ()
forall a. String -> Transaction a
throwDirInternalError String
"node unpacked to non-bytes tuple element"
  (ByteString -> ByteString -> Transaction ())
-> (ByteString, ByteString) -> Transaction ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry ByteString -> ByteString -> Transaction ()
clearRange (RangeQuery -> (ByteString, ByteString)
rangeKeys (Subspace -> RangeQuery
subspaceRangeQuery Subspace
node))

-- | Internal helper function that removes a path from its parent. Does not
-- remove the children of the removed path.
removeFromParent :: DirectoryLayer -> Path -> Transaction ()
removeFromParent :: DirectoryLayer -> [Text] -> Transaction ()
removeFromParent DirectoryLayer
_ [] = () -> Transaction ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
removeFromParent DirectoryLayer
dl [Text]
path =
  DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find DirectoryLayer
dl ([Text] -> [Text]
forall a. [a] -> [a]
init [Text]
path) Transaction (Maybe FoundNode)
-> (Maybe FoundNode -> Transaction ()) -> Transaction ()
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Maybe FoundNode
Nothing -> String -> Transaction ()
forall a. String -> Transaction a
throwDirInternalError (String -> Transaction ()) -> String -> Transaction ()
forall a b. (a -> b) -> a -> b
$ String
"parent not found for " String -> ShowS
forall a. [a] -> [a] -> [a]
++ [Text] -> String
forall a. Show a => a -> String
show [Text]
path
    Just (FoundNode Subspace
sub [Text]
_ [Text]
_) ->
      ByteString -> Transaction ()
clear (Subspace -> [Elem] -> ByteString
pack Subspace
sub [Integer -> Elem
Tuple.Int Integer
_SUBDIRS, Text -> Elem
Tuple.Text ([Text] -> Text
forall a. [a] -> a
last [Text]
path)])

subdirNameNodes ::
  DirectoryLayer ->
  -- | node
  Subspace ->
  Transaction (Seq (Text, Subspace))
subdirNameNodes :: DirectoryLayer -> Subspace -> Transaction (Seq (Text, Subspace))
subdirNameNodes DirectoryLayer
dl Subspace
node = do
  let sd :: Subspace
sd = Subspace -> [Elem] -> Subspace
extend Subspace
node [Integer -> Elem
Tuple.Int Integer
_SUBDIRS]
  Seq (ByteString, ByteString)
kvs <- RangeQuery -> Transaction (Seq (ByteString, ByteString))
getEntireRange (Subspace -> RangeQuery
subspaceRangeQuery Subspace
sd)
  let unpackKV :: (ByteString, ByteString) -> Transaction (Text, Subspace)
unpackKV (ByteString
k, ByteString
v) = case Subspace -> ByteString -> Either String [Elem]
unpack Subspace
sd ByteString
k of
        Right [Tuple.Text Text
t] -> (Text, Subspace) -> Transaction (Text, Subspace)
forall (m :: * -> *) a. Monad m => a -> m a
return (Text
t, DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix DirectoryLayer
dl ByteString
v)
        Either String [Elem]
_ -> String -> Transaction (Text, Subspace)
forall a. String -> Transaction a
throwDirInternalError String
"failed to unpack node name in subdirNameNodes"
  ((ByteString, ByteString) -> Transaction (Text, Subspace))
-> Seq (ByteString, ByteString)
-> Transaction (Seq (Text, Subspace))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ByteString, ByteString) -> Transaction (Text, Subspace)
unpackKV Seq (ByteString, ByteString)
kvs

subdirNames :: DirectoryLayer -> Subspace -> Transaction (Seq Text)
subdirNames :: DirectoryLayer -> Subspace -> Transaction (Seq Text)
subdirNames DirectoryLayer
dl Subspace
node = (Seq (Text, Subspace) -> Seq Text)
-> Transaction (Seq (Text, Subspace)) -> Transaction (Seq Text)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Text, Subspace) -> Text) -> Seq (Text, Subspace) -> Seq Text
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Subspace) -> Text
forall a b. (a, b) -> a
fst) (DirectoryLayer -> Subspace -> Transaction (Seq (Text, Subspace))
subdirNameNodes DirectoryLayer
dl Subspace
node)

subdirNodes :: DirectoryLayer -> Subspace -> Transaction (Seq Subspace)
subdirNodes :: DirectoryLayer -> Subspace -> Transaction (Seq Subspace)
subdirNodes DirectoryLayer
dl Subspace
node = (Seq (Text, Subspace) -> Seq Subspace)
-> Transaction (Seq (Text, Subspace)) -> Transaction (Seq Subspace)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (((Text, Subspace) -> Subspace)
-> Seq (Text, Subspace) -> Seq Subspace
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Text, Subspace) -> Subspace
forall a b. (a, b) -> b
snd) (DirectoryLayer -> Subspace -> Transaction (Seq (Text, Subspace))
subdirNameNodes DirectoryLayer
dl Subspace
node)

nodeContainingKey ::
  DirectoryLayer -> ByteString -> Transaction (Maybe Subspace)
nodeContainingKey :: DirectoryLayer -> ByteString -> Transaction (Maybe Subspace)
nodeContainingKey dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} ByteString
k
  | ByteString -> ByteString -> Bool
BS.isPrefixOf (Subspace -> [Elem] -> ByteString
pack Subspace
nodeSS []) ByteString
k = Maybe Subspace -> Transaction (Maybe Subspace)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Subspace -> Transaction (Maybe Subspace))
-> Maybe Subspace -> Transaction (Maybe Subspace)
forall a b. (a -> b) -> a -> b
$ Subspace -> Maybe Subspace
forall a. a -> Maybe a
Just Subspace
rootNode
  | Bool
otherwise = do
    let r :: RangeQuery
r =
          KeySelector -> KeySelector -> Maybe Int -> Bool -> RangeQuery
RangeQuery
            (RangeQuery -> KeySelector
rangeBegin (RangeQuery -> KeySelector) -> RangeQuery -> KeySelector
forall a b. (a -> b) -> a -> b
$ Subspace -> RangeQuery
subspaceRangeQuery Subspace
nodeSS)
            (ByteString -> KeySelector
FirstGreaterOrEq (Subspace -> [Elem] -> ByteString
pack Subspace
nodeSS [ByteString -> Elem
Tuple.Bytes ByteString
k] ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\x00"))
            (Int -> Maybe Int
forall a. a -> Maybe a
Just Int
1)
            Bool
True
    Seq (ByteString, ByteString)
rr <- RangeQuery -> Transaction (Seq (ByteString, ByteString))
getEntireRange RangeQuery
r
    case Seq (ByteString, ByteString)
rr of
      Seq (ByteString, ByteString)
Empty -> Maybe Subspace -> Transaction (Maybe Subspace)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Subspace
forall a. Maybe a
Nothing
      ((ByteString, ByteString)
kv :<| Seq (ByteString, ByteString)
_) -> (ByteString, ByteString) -> Transaction (Maybe Subspace)
forall b. (ByteString, b) -> Transaction (Maybe Subspace)
processKV (ByteString, ByteString)
kv
  where
    processKV :: (ByteString, b) -> Transaction (Maybe Subspace)
processKV (ByteString
k', b
_) = do
      let unpacked :: Either String [Elem]
unpacked = Subspace -> ByteString -> Either String [Elem]
unpack Subspace
nodeSS ByteString
k'
      case Either String [Elem]
unpacked of
        Left String
_ -> String -> Transaction (Maybe Subspace)
forall a. String -> Transaction a
throwDirInternalError String
"Failed to unpack in nodeContainingKey"
        Right (Tuple.Bytes ByteString
prevPrefix : [Elem]
_) ->
          if ByteString -> ByteString -> Bool
BS.isPrefixOf ByteString
prevPrefix ByteString
k
            then Maybe Subspace -> Transaction (Maybe Subspace)
forall (m :: * -> *) a. Monad m => a -> m a
return (Subspace -> Maybe Subspace
forall a. a -> Maybe a
Just (Subspace -> Maybe Subspace) -> Subspace -> Maybe Subspace
forall a b. (a -> b) -> a -> b
$ DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix DirectoryLayer
dl ByteString
prevPrefix)
            else Maybe Subspace -> Transaction (Maybe Subspace)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Subspace
forall a. Maybe a
Nothing
        Right [Elem]
_ -> String -> Transaction (Maybe Subspace)
forall a. String -> Transaction a
throwDirInternalError String
"node unpacked to non-bytes element"

isPrefixFree :: DirectoryLayer -> ByteString -> Transaction Bool
isPrefixFree :: DirectoryLayer -> ByteString -> Transaction Bool
isPrefixFree dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} ByteString
prefix
  | ByteString -> Int
BS.length ByteString
prefix Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 = Bool -> Transaction Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise = do
    Maybe Subspace
nck <- DirectoryLayer -> ByteString -> Transaction (Maybe Subspace)
nodeContainingKey DirectoryLayer
dl ByteString
prefix
    case Maybe Subspace
nck of
      Just Subspace
_ -> Bool -> Transaction Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Maybe Subspace
Nothing -> case ByteString -> Maybe RangeQuery
prefixRange ByteString
prefix of
        Maybe RangeQuery
Nothing -> Bool -> Transaction Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        Just RangeQuery
r -> do
          let (ByteString
bk, ByteString
ek) = RangeQuery -> (ByteString, ByteString)
rangeKeys RangeQuery
r
          let r' :: RangeQuery
r' =
                ByteString -> ByteString -> RangeQuery
keyRangeQuery
                  (Subspace -> [Elem] -> ByteString
pack Subspace
nodeSS [ByteString -> Elem
Tuple.Bytes ByteString
bk])
                  (Subspace -> [Elem] -> ByteString
pack Subspace
nodeSS [ByteString -> Elem
Tuple.Bytes ByteString
ek])
          RangeQuery -> Transaction Bool
isRangeEmpty RangeQuery
r'

checkVersion :: DirectoryLayer -> Transaction ()
checkVersion :: DirectoryLayer -> Transaction ()
checkVersion dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} = do
  Maybe ByteString
mver <- ByteString -> Transaction (Future (Maybe ByteString))
get (Subspace -> [Elem] -> ByteString
pack Subspace
rootNode [ByteString -> Elem
Tuple.Bytes ByteString
"version"]) Transaction (Future (Maybe ByteString))
-> (Future (Maybe ByteString) -> Transaction (Maybe ByteString))
-> Transaction (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Future (Maybe ByteString) -> Transaction (Maybe ByteString)
forall a. Future a -> Transaction a
await
  case Maybe ByteString
mver of
    Maybe ByteString
Nothing -> DirectoryLayer -> Transaction ()
initializeDirectory DirectoryLayer
dl
    Just ByteString
verBytes -> do
      (Word32
major, Word32
minor, Word32
micro) <-
        String
-> Either String (Word32, Word32, Word32)
-> Transaction (Word32, Word32, Word32)
forall a b. String -> Either a b -> Transaction b
throwing String
"Couldn't parse directory version!" (Either String (Word32, Word32, Word32)
 -> Transaction (Word32, Word32, Word32))
-> Either String (Word32, Word32, Word32)
-> Transaction (Word32, Word32, Word32)
forall a b. (a -> b) -> a -> b
$
          Get (Word32, Word32, Word32)
-> ByteString -> Either String (Word32, Word32, Word32)
forall a. Get a -> ByteString -> Either String a
runGet
            ((,,) (Word32 -> Word32 -> Word32 -> (Word32, Word32, Word32))
-> Get Word32 -> Get (Word32 -> Word32 -> (Word32, Word32, Word32))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Get Word32
getWord32le Get (Word32 -> Word32 -> (Word32, Word32, Word32))
-> Get Word32 -> Get (Word32 -> (Word32, Word32, Word32))
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32le Get (Word32 -> (Word32, Word32, Word32))
-> Get Word32 -> Get (Word32, Word32, Word32)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Get Word32
getWord32le)
            ByteString
verBytes
      Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
major Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
majorVersion) (Transaction () -> Transaction ())
-> Transaction () -> Transaction ()
forall a b. (a -> b) -> a -> b
$
        DirLayerUserError -> Transaction ()
forall a. DirLayerUserError -> Transaction a
throwDirUserError (DirLayerUserError -> Transaction ())
-> DirLayerUserError -> Transaction ()
forall a b. (a -> b) -> a -> b
$
          Word32 -> Word32 -> Word32 -> DirLayerUserError
VersionError Word32
major Word32
minor Word32
micro
      Bool -> Transaction () -> Transaction ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Word32
minor Word32 -> Word32 -> Bool
forall a. Ord a => a -> a -> Bool
> Word32
minorVersion) (Transaction () -> Transaction ())
-> Transaction () -> Transaction ()
forall a b. (a -> b) -> a -> b
$
        DirLayerUserError -> Transaction ()
forall a. DirLayerUserError -> Transaction a
throwDirUserError (DirLayerUserError -> Transaction ())
-> DirLayerUserError -> Transaction ()
forall a b. (a -> b) -> a -> b
$
          Word32 -> Word32 -> Word32 -> DirLayerUserError
VersionError Word32
major Word32
minor Word32
micro

initializeDirectory :: DirectoryLayer -> Transaction ()
initializeDirectory :: DirectoryLayer -> Transaction ()
initializeDirectory DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} = do
  let verBytes :: ByteString
verBytes = Put -> ByteString
runPut (Put -> ByteString) -> Put -> ByteString
forall a b. (a -> b) -> a -> b
$ do
        Putter Word32
putWord32le Word32
majorVersion
        Putter Word32
putWord32le Word32
minorVersion
        Putter Word32
putWord32le Word32
microVersion
  ByteString -> ByteString -> Transaction ()
set (Subspace -> [Elem] -> ByteString
pack Subspace
rootNode [ByteString -> Elem
Tuple.Bytes ByteString
"version"]) ByteString
verBytes

nodeWithPrefix :: DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix :: DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} ByteString
prefix =
  Subspace -> [Elem] -> Subspace
extend Subspace
nodeSS [ByteString -> Elem
Tuple.Bytes ByteString
prefix]

-- | Returns the longest prefix of @path@ that doesn't exist. If the entire
-- path exists, returns it.
find ::
  DirectoryLayer ->
  Path ->
  Transaction (Maybe FoundNode)
find :: DirectoryLayer -> [Text] -> Transaction (Maybe FoundNode)
find dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} [Text]
queryPath = FoundNode -> [(Int, Text)] -> Transaction (Maybe FoundNode)
go FoundNode
baseNode ([Int] -> [Text] -> [(Int, Text)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0 ..] [Text]
queryPath)
  where
    baseNode :: FoundNode
baseNode = Subspace -> [Text] -> [Text] -> FoundNode
FoundNode Subspace
rootNode [] [Text]
queryPath

    go :: FoundNode -> [(Int, Text)] -> Transaction (Maybe FoundNode)
go FoundNode
n [] = Maybe FoundNode -> Transaction (Maybe FoundNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (FoundNode -> Maybe FoundNode
forall a. a -> Maybe a
Just FoundNode
n)
    go FoundNode
n ((Int
i, Text
p) : [(Int, Text)]
ps) = do
      let nodePrefixKey :: ByteString
nodePrefixKey =
            Subspace -> [Elem] -> ByteString
pack
              (FoundNode -> Subspace
nodeNodeSS FoundNode
n)
              [Integer -> Elem
Tuple.Int Integer
_SUBDIRS, Text -> Elem
Tuple.Text Text
p]
      ByteString -> Transaction (Future (Maybe ByteString))
get ByteString
nodePrefixKey Transaction (Future (Maybe ByteString))
-> (Future (Maybe ByteString) -> Transaction (Maybe ByteString))
-> Transaction (Maybe ByteString)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Future (Maybe ByteString) -> Transaction (Maybe ByteString)
forall a. Future a -> Transaction a
await Transaction (Maybe ByteString)
-> (Maybe ByteString -> Transaction (Maybe FoundNode))
-> Transaction (Maybe FoundNode)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Maybe ByteString
Nothing -> Maybe FoundNode -> Transaction (Maybe FoundNode)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe FoundNode
forall a. Maybe a
Nothing
        Just ByteString
prefix -> do
          let n' :: FoundNode
n' =
                Subspace -> [Text] -> [Text] -> FoundNode
FoundNode
                  (DirectoryLayer -> ByteString -> Subspace
nodeWithPrefix DirectoryLayer
dl ByteString
prefix)
                  (Int -> [Text] -> [Text]
forall a. Int -> [a] -> [a]
take (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) [Text]
queryPath)
                  []
          ByteString
layer <- FoundNode -> Transaction ByteString
getFoundNodeLayer FoundNode
n'
          if ByteString
layer ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"partition" then Maybe FoundNode -> Transaction (Maybe FoundNode)
forall (m :: * -> *) a. Monad m => a -> m a
return (FoundNode -> Maybe FoundNode
forall a. a -> Maybe a
Just FoundNode
n') else FoundNode -> [(Int, Text)] -> Transaction (Maybe FoundNode)
go FoundNode
n' [(Int, Text)]
ps

contentsOfNodePartition ::
  DirectoryLayer ->
  -- | node
  Subspace ->
  Path ->
  Transaction DirPartition
contentsOfNodePartition :: DirectoryLayer -> Subspace -> [Text] -> Transaction DirPartition
contentsOfNodePartition dl :: DirectoryLayer
dl@DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} Subspace
node [Text]
queryPath = do
  [Elem]
p <- String -> Either String [Elem] -> Transaction [Elem]
forall a b. String -> Either a b -> Transaction b
throwing String
"can't unpack node!" (Subspace -> ByteString -> Either String [Elem]
unpack Subspace
nodeSS (Subspace -> [Elem] -> ByteString
pack Subspace
node []))
  case [Elem]
p of
    [Tuple.Bytes ByteString
prefix] -> do
      let newPath :: [Text]
newPath = [Text]
dlPath [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
queryPath
      let newDL :: DirectoryLayer
newDL =
            Subspace -> Subspace -> Bool -> DirectoryLayer
newDirectoryLayer
              ([Elem] -> Subspace
subspace [ByteString -> Elem
Tuple.Bytes (ByteString
prefix ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
"\xfe")])
              Subspace
contentSS
              Bool
False
      DirPartition -> Transaction DirPartition
forall (m :: * -> *) a. Monad m => a -> m a
return (DirectoryLayer -> DirectoryLayer -> DirPartition
DirPartition DirectoryLayer
newDL {dlPath :: [Text]
dlPath = [Text]
newPath} DirectoryLayer
dl)
    [Elem]
_ -> String -> Transaction DirPartition
forall a. String -> Transaction a
throwDirInternalError String
"unexpected parse in contentsOfNodePartition"

contentsOfNodeSubspace ::
  DirectoryLayer ->
  Subspace ->
  Path ->
  ByteString ->
  Transaction Directory
contentsOfNodeSubspace :: DirectoryLayer
-> Subspace -> [Text] -> ByteString -> Transaction Directory
contentsOfNodeSubspace DirectoryLayer {Bool
[Text]
Subspace
HCA
dlPath :: [Text]
allowManualPrefixes :: Bool
rootNode :: Subspace
allocator :: HCA
contentSS :: Subspace
nodeSS :: Subspace
dlPath :: DirectoryLayer -> [Text]
allowManualPrefixes :: DirectoryLayer -> Bool
rootNode :: DirectoryLayer -> Subspace
allocator :: DirectoryLayer -> HCA
contentSS :: DirectoryLayer -> Subspace
nodeSS :: DirectoryLayer -> Subspace
..} Subspace
node [Text]
queryPath ByteString
layer = do
  [Elem]
p <- String -> Either String [Elem] -> Transaction [Elem]
forall a b. String -> Either a b -> Transaction b
throwing String
"can't unpack node!" (Subspace -> ByteString -> Either String [Elem]
unpack Subspace
nodeSS (Subspace -> [Elem] -> ByteString
pack Subspace
node []))
  case [Elem]
p of
    [Tuple.Bytes ByteString
prefixBytes] -> do
      let newPath :: [Text]
newPath = [Text]
dlPath [Text] -> [Text] -> [Text]
forall a. Semigroup a => a -> a -> a
<> [Text]
queryPath
      Directory -> Transaction Directory
forall (m :: * -> *) a. Monad m => a -> m a
return (Directory -> Transaction Directory)
-> Directory -> Transaction Directory
forall a b. (a -> b) -> a -> b
$ Subspace -> [Text] -> ByteString -> Directory
Directory (ByteString -> Subspace
Subspace ByteString
prefixBytes) [Text]
newPath ByteString
layer
    [Elem]
_ -> String -> Transaction Directory
forall a. String -> Transaction a
throwDirInternalError String
"unexpected contents for node prefix value"