{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module RON.Storage.Backend
( Collection (..),
CollectionName,
DocId (..),
Document (..),
DocVersion,
IsTouched (..),
MonadStorage (..),
RawDocId,
createVersion,
decodeDocId,
readVersion,
)
where
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.String (fromString)
import RON.Data (ReplicatedAsObject)
import RON.Error (MonadE, liftMaybe, throwErrorString)
import RON.Event (ReplicaClock, getEventUuid)
import RON.Prelude
import RON.Text (parseStateFrame, serializeStateFrame)
import RON.Types (ObjectFrame (ObjectFrame, frame, uuid), UUID)
import qualified RON.UUID as UUID
import RON.Util (ByteStringL)
import System.FilePath ((</>))
import qualified Text.Show (show)
type DocVersion = FilePath
type RawDocId = FilePath
newtype DocId a = DocId RawDocId
deriving (Eq, Ord, Hashable)
instance Collection a => Show (DocId a) where
show (DocId file) = collectionName @a </> file
type CollectionName = FilePath
class (ReplicatedAsObject a, Typeable a) => Collection a where
collectionName :: CollectionName
fallbackParse :: MonadE m => UUID -> ByteStringL -> m (ObjectFrame a)
fallbackParse _ _ = throwError "no fallback parser implemented"
class (ReplicaClock m, MonadE m) => MonadStorage m where
getCollections :: m [CollectionName]
getDocuments :: Collection a => m [DocId a]
getDocumentVersions :: Collection a => DocId a -> m [DocVersion]
saveVersionContent
:: Collection a => DocId a -> DocVersion -> ByteStringL -> m ()
loadVersionContent :: Collection a => DocId a -> DocVersion -> m ByteStringL
deleteVersion :: Collection a => DocId a -> DocVersion -> m ()
changeDocId :: Collection a => DocId a -> DocId a -> m ()
decodeDocId
:: DocId a
-> Maybe (Bool, UUID)
decodeDocId (DocId file) = do
uuid <- UUID.decodeBase32 file
pure (UUID.encodeBase32 uuid == file, uuid)
readVersion
:: MonadStorage m
=> Collection a
=> DocId a
-> DocVersion
-> m (ObjectFrame a, IsTouched)
readVersion docid version = do
(isObjectIdValid, uuid) <-
liftMaybe ("Bad Base32 UUID " <> show docid)
$ decodeDocId docid
unless isObjectIdValid
$ throwErrorString
$ "Not a Base32 UUID "
++ show docid
contents <- loadVersionContent docid version
case parseStateFrame contents of
Right frame ->
pure (ObjectFrame {uuid, frame}, IsTouched False)
Left ronError ->
do
object <- fallbackParse uuid contents
pure (object, IsTouched True)
`catchError` \fallbackError ->
throwError $ case BSLC.head contents of
'{' -> fallbackError
_ -> fromString ronError
newtype IsTouched = IsTouched Bool
deriving (Show)
data Document a
= Document
{ objectFrame :: ObjectFrame a,
versions :: NonEmpty DocVersion,
isTouched :: IsTouched
}
deriving (Show)
createVersion
:: forall a m.
(Collection a, MonadStorage m)
=> Maybe (DocId a, Document a)
-> ObjectFrame a
-> m ()
createVersion mDoc newObj = case mDoc of
Nothing -> save (DocId @a $ UUID.encodeBase32 uuid) []
Just (docid, oldDoc) -> do
let Document
{ objectFrame = oldObj,
versions,
isTouched = IsTouched isTouched
} =
oldDoc
when (newObj /= oldObj || length versions /= 1 || isTouched)
$ save docid
$ toList versions
where
ObjectFrame {uuid, frame} = newObj
save docid oldVersions = do
newVersion <- UUID.encodeBase32 <$> getEventUuid
saveVersionContent docid newVersion (serializeStateFrame frame)
for_ oldVersions $ deleteVersion docid