{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module RON.Storage.Backend (
Collection (..),
CollectionName,
DocId (..),
Document (..),
DocVersion,
IsTouched (..),
MonadStorage (..),
createVersion,
decodeDocId,
readVersion,
) where
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.String (fromString)
import qualified Text.Show (show)
import RON.Data (ReplicatedAsObject)
import RON.Error (MonadE, liftMaybe, throwErrorString)
import RON.Event (ReplicaClock, getEventUuid)
import RON.Text (parseStateFrame, serializeStateFrame)
import RON.Types (Object (Object, frame, id), UUID)
import RON.Util (ByteStringL)
import qualified RON.UUID as UUID
type DocVersion = FilePath
newtype DocId a = DocId FilePath
deriving (Eq, Ord)
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 (Object 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 (Object a, IsTouched)
readVersion docid version = do
(isObjectIdValid, id) <-
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 (Object{id, frame}, IsTouched False)
Left ronError ->
do object <- fallbackParse id 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
{ value :: Object a
, versions :: NonEmpty DocVersion
, isTouched :: IsTouched
}
deriving Show
createVersion
:: forall a m
. (Collection a, MonadStorage m)
=> Maybe (DocId a, Document a)
-> Object a
-> m ()
createVersion mDoc newObj = case mDoc of
Nothing -> save (DocId @a $ UUID.encodeBase32 id) []
Just (docid, oldDoc) -> do
let Document{value = oldObj, versions, isTouched = IsTouched isTouched}
= oldDoc
when (newObj /= oldObj || length versions /= 1 || isTouched) $
save docid $ toList versions
where
Object{id, frame} = newObj
save docid oldVersions = do
newVersion <- UUID.encodeBase32 <$> getEventUuid
saveVersionContent docid newVersion (serializeStateFrame frame)
for_ oldVersions $ deleteVersion docid