{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
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
data DirectoryLayer = DirectoryLayer
{
DirectoryLayer -> Subspace
nodeSS :: Subspace,
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)
type Path = [Text]
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)
dirSubspace :: Directory -> Subspace
dirSubspace :: Directory -> Subspace
dirSubspace = Directory -> Subspace
directorySubspace
dirPath :: Directory -> Path
dirPath :: Directory -> [Text]
dirPath = Directory -> [Text]
directoryPath
dirLayer :: Directory -> ByteString
dirLayer :: Directory -> ByteString
dirLayer = Directory -> ByteString
directoryLayer
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)
newDirectoryLayer ::
Subspace ->
Subspace ->
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
..}
defaultDirLayer :: DirectoryLayer
defaultDirLayer :: DirectoryLayer
defaultDirLayer = Subspace -> Subspace -> Bool -> DirectoryLayer
newDirectoryLayer (ByteString -> Subspace
Subspace ByteString
"\xfe") (ByteString -> Subspace
Subspace ByteString
"") Bool
False
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
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' ::
DirectoryLayer ->
Path ->
ByteString ->
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
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
createOrOpen' ::
DirectoryLayer ->
Path ->
ByteString ->
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
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 :: 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)
data MoveError
=
SelfSubDir
|
SourceDoesNotExist
|
MoveBetweenPartitions
|
DestinationAlreadyExists
|
DestinationParentDoesNotExist
|
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 ::
DirectoryLayer ->
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 ::
DirectoryLayer ->
Path ->
Transaction Bool
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
removeRecursive ::
DirectoryLayer ->
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))
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 ->
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]
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 ->
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"