{-# LANGUAGE DataKinds       #-}
{-# LANGUAGE GADTs           #-}
{-# LANGUAGE Rank2Types      #-}
{-# LANGUAGE RecordWildCards #-}
--------------------------------------------------------------------------------
-- |
-- Module : Database.EventStore.Internal.Operation.DeleteStream
-- Copyright : (C) 2015 Yorick Laupa
-- License : (see the file LICENSE)
--
-- Maintainer : Yorick Laupa <yo.eight@gmail.com>
-- Stability : provisional
-- Portability : non-portable
--
--------------------------------------------------------------------------------
module Database.EventStore.Internal.Operation.DeleteStream
    ( DeleteResult(..)
    , deleteStream
    ) where

--------------------------------------------------------------------------------
import Data.Maybe

--------------------------------------------------------------------------------
import Data.ProtocolBuffers

--------------------------------------------------------------------------------
import Database.EventStore.Internal.Command
import Database.EventStore.Internal.Communication (Transmit(..))
import Database.EventStore.Internal.Control (publishWith)
import Database.EventStore.Internal.Exec
import Database.EventStore.Internal.Operation
import Database.EventStore.Internal.Operation.DeleteStream.Message
import Database.EventStore.Internal.Prelude
import Database.EventStore.Internal.Settings
import Database.EventStore.Internal.Stream
import Database.EventStore.Internal.Types

--------------------------------------------------------------------------------
-- | Returned after deleting a stream. 'Position' of the write.
newtype DeleteResult = DeleteResult Position deriving (DeleteResult -> DeleteResult -> Bool
(DeleteResult -> DeleteResult -> Bool)
-> (DeleteResult -> DeleteResult -> Bool) -> Eq DeleteResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DeleteResult -> DeleteResult -> Bool
$c/= :: DeleteResult -> DeleteResult -> Bool
== :: DeleteResult -> DeleteResult -> Bool
$c== :: DeleteResult -> DeleteResult -> Bool
Eq, Int -> DeleteResult -> ShowS
[DeleteResult] -> ShowS
DeleteResult -> String
(Int -> DeleteResult -> ShowS)
-> (DeleteResult -> String)
-> ([DeleteResult] -> ShowS)
-> Show DeleteResult
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DeleteResult] -> ShowS
$cshowList :: [DeleteResult] -> ShowS
show :: DeleteResult -> String
$cshow :: DeleteResult -> String
showsPrec :: Int -> DeleteResult -> ShowS
$cshowsPrec :: Int -> DeleteResult -> ShowS
Show)

-------------------------------------------------------------------------------
deleteStream
  :: Settings
  -> Exec
  -> Text
  -> ExpectedVersion
  -> Maybe Bool
  -> Maybe Credentials
  -> IO (Async DeleteResult)
deleteStream :: Settings
-> Exec
-> Text
-> ExpectedVersion
-> Maybe Bool
-> Maybe Credentials
-> IO (Async DeleteResult)
deleteStream Settings
setts Exec
exec Text
stream ExpectedVersion
version Maybe Bool
hard Maybe Credentials
creds
  = do Mailbox
m <- IO Mailbox
forall (m :: * -> *). MonadBase IO m => m Mailbox
mailboxNew
       IO DeleteResult -> IO (Async (StM IO DeleteResult))
forall (m :: * -> *) a.
MonadBaseControl IO m =>
m a -> m (Async (StM m a))
async (IO DeleteResult -> IO (Async (StM IO DeleteResult)))
-> IO DeleteResult -> IO (Async (StM IO DeleteResult))
forall a b. (a -> b) -> a -> b
$
         do let req :: Request
req = Text -> Int64 -> Bool -> Maybe Bool -> Request
newRequest Text
stream (ExpectedVersion -> Int64
expVersionInt64 ExpectedVersion
version) (Settings -> Bool
s_requireMaster Settings
setts) Maybe Bool
hard

            Package
pkg <- Command -> Maybe Credentials -> Request -> IO Package
forall msg (m :: * -> *).
(Encode msg, MonadIO m) =>
Command -> Maybe Credentials -> msg -> m Package
createPkg Command
deleteStreamCmd Maybe Credentials
creds Request
req

            IO (Loop DeleteResult) -> IO DeleteResult
forall (m :: * -> *) a. Monad m => m (Loop a) -> m a
keepLooping (IO (Loop DeleteResult) -> IO DeleteResult)
-> IO (Loop DeleteResult) -> IO DeleteResult
forall a b. (a -> b) -> a -> b
$ do
              Exec -> Transmit -> IO ()
forall p a (m :: * -> *).
(Pub p, Typeable a, MonadIO m) =>
p -> a -> m ()
publishWith Exec
exec (Mailbox -> Lifetime -> Package -> Transmit
Transmit Mailbox
m Lifetime
OneTime Package
pkg)
              Either OperationError Response
outcome <- Mailbox -> IO (Either OperationError Response)
forall (m :: * -> *) resp.
(MonadBase IO m, Decode resp) =>
Mailbox -> m (Either OperationError resp)
mailboxReadDecoded Mailbox
m
              case Either OperationError Response
outcome of
                Left OperationError
e
                  -> OperationError -> IO (Loop DeleteResult)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw OperationError
e
                Right Response
resp
                  -> let r :: FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
r = Field 1 (RequiredField (Always (Enumeration OpResult)))
-> FieldType
     (Field 1 (RequiredField (Always (Enumeration OpResult))))
forall a. HasField a => a -> FieldType a
getField (Field 1 (RequiredField (Always (Enumeration OpResult)))
 -> FieldType
      (Field 1 (RequiredField (Always (Enumeration OpResult)))))
-> Field 1 (RequiredField (Always (Enumeration OpResult)))
-> FieldType
     (Field 1 (RequiredField (Always (Enumeration OpResult))))
forall a b. (a -> b) -> a -> b
$ Response -> Required 1 (Enumeration OpResult)
_result Response
resp
                         com_pos :: FieldType (Field 4 (OptionalField (Last (Value Int64))))
com_pos = Field 4 (OptionalField (Last (Value Int64)))
-> FieldType (Field 4 (OptionalField (Last (Value Int64))))
forall a. HasField a => a -> FieldType a
getField (Field 4 (OptionalField (Last (Value Int64)))
 -> FieldType (Field 4 (OptionalField (Last (Value Int64)))))
-> Field 4 (OptionalField (Last (Value Int64)))
-> FieldType (Field 4 (OptionalField (Last (Value Int64))))
forall a b. (a -> b) -> a -> b
$ Response -> Optional 4 (Value Int64)
_commitPosition Response
resp
                         prep_pos :: FieldType (Field 3 (OptionalField (Last (Value Int64))))
prep_pos = Field 3 (OptionalField (Last (Value Int64)))
-> FieldType (Field 3 (OptionalField (Last (Value Int64))))
forall a. HasField a => a -> FieldType a
getField (Field 3 (OptionalField (Last (Value Int64)))
 -> FieldType (Field 3 (OptionalField (Last (Value Int64)))))
-> Field 3 (OptionalField (Last (Value Int64)))
-> FieldType (Field 3 (OptionalField (Last (Value Int64))))
forall a b. (a -> b) -> a -> b
$ Response -> Optional 3 (Value Int64)
_preparePosition Response
resp
                         com_pos_int :: Int64
com_pos_int = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (-Int64
1) Maybe Int64
FieldType (Field 4 (OptionalField (Last (Value Int64))))
com_pos
                         prep_pos_int :: Int64
prep_pos_int = Int64 -> Maybe Int64 -> Int64
forall a. a -> Maybe a -> a
fromMaybe (-Int64
1) Maybe Int64
FieldType (Field 3 (OptionalField (Last (Value Int64))))
prep_pos
                         pos :: Position
pos = Int64 -> Int64 -> Position
Position Int64
com_pos_int Int64
prep_pos_int
                         res :: DeleteResult
res = Position -> DeleteResult
DeleteResult Position
pos in
                     case FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
r of
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_SUCCESS -> Loop DeleteResult -> IO (Loop DeleteResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Loop DeleteResult -> IO (Loop DeleteResult))
-> Loop DeleteResult -> IO (Loop DeleteResult)
forall a b. (a -> b) -> a -> b
$ DeleteResult -> Loop DeleteResult
forall a. a -> Loop a
Break DeleteResult
res
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_PREPARE_TIMEOUT -> Loop DeleteResult -> IO (Loop DeleteResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Loop DeleteResult
forall a. Loop a
Loop
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_FORWARD_TIMEOUT -> Loop DeleteResult -> IO (Loop DeleteResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Loop DeleteResult
forall a. Loop a
Loop
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_COMMIT_TIMEOUT -> Loop DeleteResult -> IO (Loop DeleteResult)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Loop DeleteResult
forall a. Loop a
Loop
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_WRONG_EXPECTED_VERSION -> OperationError -> IO (Loop DeleteResult)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (OperationError -> IO (Loop DeleteResult))
-> OperationError -> IO (Loop DeleteResult)
forall a b. (a -> b) -> a -> b
$ Text -> ExpectedVersion -> OperationError
WrongExpectedVersion Text
stream ExpectedVersion
version
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_STREAM_DELETED -> OperationError -> IO (Loop DeleteResult)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (OperationError -> IO (Loop DeleteResult))
-> OperationError -> IO (Loop DeleteResult)
forall a b. (a -> b) -> a -> b
$ StreamName -> OperationError
StreamDeleted (StreamName -> OperationError) -> StreamName -> OperationError
forall a b. (a -> b) -> a -> b
$ Text -> StreamName
StreamName Text
stream
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_INVALID_TRANSACTION -> OperationError -> IO (Loop DeleteResult)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw OperationError
InvalidTransaction
                       FieldType (Field 1 (RequiredField (Always (Enumeration OpResult))))
OP_ACCESS_DENIED -> OperationError -> IO (Loop DeleteResult)
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throw (OperationError -> IO (Loop DeleteResult))
-> OperationError -> IO (Loop DeleteResult)
forall a b. (a -> b) -> a -> b
$ StreamName -> OperationError
forall t. StreamId t -> OperationError
AccessDenied (Text -> StreamName
StreamName Text
stream)