{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TupleSections #-}
{-# LANGUAGE TypeApplications #-}
module RON.Storage (
Collection (..),
CollectionDocId (..),
CollectionName,
DocId (..),
Document (..),
DocVersion,
MonadStorage (..),
createDocument,
decodeDocId,
docIdFromUuid,
loadDocument,
modify,
readVersion,
) where
import qualified Data.ByteString.Lazy.Char8 as BSLC
import Data.String (fromString)
import qualified Data.Text as Text
import qualified Text.Show
import RON.Data (ReplicatedAsObject, reduceObject)
import RON.Error (Error (Error), MonadE, errorContext, 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
data CollectionDocId = forall a. Collection a => CollectionDocId (DocId a)
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
loadDocument :: (Collection a, MonadStorage m) => DocId a -> m (Document a)
loadDocument docid = loadRetry (3 :: Int)
where
loadRetry n
| n > 0 = do
versions0 <- getDocumentVersions docid
case versions0 of
[] ->
throwErrorString $
"Document with id " ++ show docid ++ " has not found."
v:vs -> do
let versions = v :| vs
let wrapDoc (value, isTouched) =
Document{value, versions, isTouched}
readResults <-
errorContext ("document " <> show docid) $
for versions $ \ver ->
try $
errorContext ("version " <> Text.pack ver) $
readVersion docid ver
liftEither $ wrapDoc <$> vsconcat readResults
| otherwise = throwError "Maximum retries exceeded"
vsconcat
:: NonEmpty (Either Error (Object a, IsTouched))
-> Either Error (Object a, IsTouched)
vsconcat = foldr1 vappend
where
vappend (Left e1) (Left e2) = Left $ Error "vappend" [e1, e2]
vappend e1@(Left _ ) (Right _ ) = e1
vappend (Right _ ) e2@(Left _ ) = e2
vappend (Right r1) (Right r2) =
(, IsTouched (t1 || t2)) <$> reduceObject a1 a2 where
(a1, IsTouched t1) = r1
(a2, IsTouched t2) = r2
try :: MonadError e m => m a -> m (Either e a)
try ma = (Right <$> ma) `catchError` (pure . Left)
modify
:: (Collection a, MonadStorage m)
=> DocId a -> StateT (Object a) m () -> m (Object a)
modify docid f = do
oldDoc <- loadDocument docid
newObj <- execStateT f $ value oldDoc
createVersion (Just (docid, oldDoc)) newObj
pure newObj
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
createDocument :: (Collection a, MonadStorage m) => Object a -> m ()
createDocument = createVersion Nothing
docIdFromUuid :: UUID -> DocId a
docIdFromUuid = DocId . UUID.encodeBase32