|
1 | | -{-# LANGUAGE AllowAmbiguousTypes #-} |
2 | | -{-# LANGUAGE FlexibleContexts #-} |
3 | | -{-# LANGUAGE LambdaCase #-} |
| 1 | +{-# LANGUAGE BlockArguments #-} |
4 | 2 | {-# LANGUAGE MultiWayIf #-} |
5 | | -{-# LANGUAGE NamedFieldPuns #-} |
6 | | -{-# LANGUAGE NoImplicitPrelude #-} |
7 | 3 | {-# LANGUAGE OverloadedStrings #-} |
8 | 4 | {-# LANGUAGE PatternSynonyms #-} |
9 | | -{-# LANGUAGE ScopedTypeVariables #-} |
10 | 5 | {-# LANGUAGE TemplateHaskell #-} |
11 | | -{-# LANGUAGE TypeApplications #-} |
| 6 | +{-# LANGUAGE NoImplicitPrelude #-} |
| 7 | + |
| 8 | +module FF.Upgrade (upgradeDatabase) where |
12 | 9 |
|
13 | | -module FF.Upgrade |
14 | | - ( upgradeDatabase |
15 | | - ) |
16 | | -where |
| 10 | +import RON.Prelude |
17 | 11 |
|
18 | 12 | import qualified Data.Map.Strict as Map |
19 | | -import RON.Data (MonadObjectState, getObjectStateChunk, |
20 | | - reducibleOpType, stateFromWireChunk, |
21 | | - stateToWireChunk) |
22 | | -import RON.Data.LWW (LwwRep (LwwRep)) |
23 | | -import RON.Data.ORSet (ORSetRep (ORSetRep)) |
24 | | -import RON.Error (Error (Error), MonadE, errorContext, liftMaybe) |
25 | | -import RON.Event (ReplicaClock, getEventUuid) |
26 | | -import RON.Prelude |
27 | | -import RON.Storage.Backend (MonadStorage, changeDocId, getCollections, |
28 | | - getDocuments) |
29 | | -import RON.Storage.FS (Collection, DocId, decodeDocId, docIdFromUuid, |
30 | | - modify) |
31 | | -import RON.Types (Atom (AUuid), ObjectRef (ObjectRef), |
32 | | - Op (Op, opId, payload, refId), |
33 | | - StateChunk (StateChunk), StateFrame, UUID, |
34 | | - WireStateChunk (WireStateChunk, stateType)) |
35 | | -import RON.UUID (pattern Zero) |
| 13 | +import RON.Data ( |
| 14 | + MonadObjectState, |
| 15 | + getObjectStateChunk, |
| 16 | + reducibleOpType, |
| 17 | + stateFromWireChunk, |
| 18 | + stateToWireChunk, |
| 19 | + ) |
| 20 | +import RON.Data.LWW (LwwRep (LwwRep)) |
| 21 | +import RON.Data.ORSet (ORSetRep (ORSetRep)) |
| 22 | +import RON.Error (Error (Error), MonadE, errorContext, liftMaybe) |
| 23 | +import RON.Event (ReplicaClock, getEventUuid) |
| 24 | +import RON.Storage.Backend ( |
| 25 | + MonadStorage, |
| 26 | + changeDocId, |
| 27 | + getCollections, |
| 28 | + getDocuments, |
| 29 | + ) |
| 30 | +import RON.Storage.FS ( |
| 31 | + Collection, |
| 32 | + DocId, |
| 33 | + decodeDocId, |
| 34 | + docIdFromUuid, |
| 35 | + modify, |
| 36 | + ) |
| 37 | +import RON.Types ( |
| 38 | + Atom (AUuid), |
| 39 | + ObjectRef (ObjectRef), |
| 40 | + Op (Op, opId, payload, refId), |
| 41 | + StateChunk (StateChunk), |
| 42 | + StateFrame, |
| 43 | + UUID, |
| 44 | + WireStateChunk (WireStateChunk, stateType), |
| 45 | + ) |
| 46 | +import RON.UUID (pattern Zero) |
36 | 47 | import qualified RON.UUID as UUID |
37 | 48 |
|
38 | | -import FF.Types (Note) |
| 49 | +import FF.Types (Note) |
39 | 50 |
|
40 | 51 | upgradeDatabase :: (MonadStorage m) => m () |
41 | 52 | upgradeDatabase = do |
42 | | - collections <- getCollections |
43 | | - for_ collections $ \case |
44 | | - "note" -> upgradeNoteCollection |
45 | | - collection -> throwError $ Error ("unsupported type " <> show collection) [] |
| 53 | + collections <- getCollections |
| 54 | + for_ collections $ \case |
| 55 | + "note" -> upgradeNoteCollection |
| 56 | + collection -> |
| 57 | + throwError $ Error ("unsupported type " <> show collection) [] |
46 | 58 |
|
47 | | -upgradeNoteCollection :: MonadStorage m => m () |
| 59 | +upgradeNoteCollection :: (MonadStorage m) => m () |
48 | 60 | upgradeNoteCollection = do |
49 | | - docs <- getDocuments @_ @Note |
50 | | - for_ docs $ \docid -> do |
51 | | - docid' <- upgradeDocId docid |
52 | | - modify docid' $ errorContext ("docid' = " <> show docid') $ do |
53 | | - ObjectRef noteId <- ask |
54 | | - errorContext "convert note" $ convertLwwToSet noteId |
55 | | - mTrack <- note_track_get |
56 | | - whenJust mTrack |
57 | | - $ errorContext "convert track" |
58 | | - . convertLwwToSet |
| 61 | + docs <- getDocuments @_ @Note |
| 62 | + for_ docs $ \docid -> do |
| 63 | + docid' <- upgradeDocId docid |
| 64 | + modify docid' $ errorContext ("docid' = " <> show docid') do |
| 65 | + ObjectRef noteId <- ask |
| 66 | + errorContext "convert note" $ convertLwwToSet noteId |
| 67 | + mTrack <- note_track_get |
| 68 | + whenJust mTrack |
| 69 | + $ errorContext "convert track" |
| 70 | + . convertLwwToSet |
59 | 71 |
|
60 | | -convertLwwToSet |
61 | | - :: (MonadE m, MonadState StateFrame m, ReplicaClock m) => UUID -> m () |
| 72 | +convertLwwToSet :: |
| 73 | + (MonadE m, MonadState StateFrame m, ReplicaClock m) => UUID -> m () |
62 | 74 | convertLwwToSet uuid = |
63 | | - errorContext "convertLwwToSet" $ do |
64 | | - frame <- get |
65 | | - chunk@WireStateChunk{stateType} <- |
66 | | - liftMaybe "no such object in chunk" $ Map.lookup uuid frame |
67 | | - if |
68 | | - | stateType == lwwType -> doConvert chunk |
69 | | - | stateType == setType -> |
70 | | - pure () -- OK |
71 | | - | otherwise -> |
72 | | - throwError |
73 | | - $ Error "bad type" |
74 | | - ["expected set or lww", Error ("got " <> show stateType) []] |
| 75 | + errorContext "convertLwwToSet" do |
| 76 | + frame <- get |
| 77 | + chunk@WireStateChunk{stateType} <- |
| 78 | + liftMaybe "no such object in chunk" $ Map.lookup uuid frame |
| 79 | + if |
| 80 | + | stateType == lwwType -> doConvert chunk |
| 81 | + | stateType == setType -> |
| 82 | + pure () -- OK |
| 83 | + | otherwise -> |
| 84 | + throwError |
| 85 | + $ Error |
| 86 | + "bad type" |
| 87 | + [ "expected set or lww" |
| 88 | + , Error ("got " <> show stateType) [] |
| 89 | + ] |
75 | 90 | where |
76 | 91 | lwwType = reducibleOpType @LwwRep |
77 | 92 | setType = reducibleOpType @ORSetRep |
78 | 93 |
|
79 | 94 | doConvert chunk = do |
80 | | - LwwRep lwwRep <- stateFromWireChunk chunk |
81 | | - opMap <- |
82 | | - for (Map.assocs lwwRep) $ \(field, Op{payload}) -> do |
83 | | - opId <- getEventUuid |
84 | | - pure |
85 | | - ( opId |
86 | | - , Op{ opId |
87 | | - , refId = Zero |
88 | | - , payload = AUuid field : removeOption payload |
89 | | - } |
90 | | - ) |
91 | | - modify' |
92 | | - $ Map.insert uuid |
93 | | - $ stateToWireChunk |
94 | | - $ ORSetRep |
95 | | - $ Map.fromList opMap |
| 95 | + LwwRep lwwRep <- stateFromWireChunk chunk |
| 96 | + opMap <- |
| 97 | + for (Map.assocs lwwRep) $ \(field, Op{payload}) -> do |
| 98 | + opId <- getEventUuid |
| 99 | + pure |
| 100 | + ( opId |
| 101 | + , Op |
| 102 | + { opId |
| 103 | + , refId = Zero |
| 104 | + , payload = AUuid field : removeOption payload |
| 105 | + } |
| 106 | + ) |
| 107 | + modify' |
| 108 | + $ Map.insert uuid |
| 109 | + $ stateToWireChunk |
| 110 | + $ ORSetRep |
| 111 | + $ Map.fromList opMap |
96 | 112 |
|
97 | 113 | removeOption = \case |
98 | | - AUuid u : payload | u == some' -> payload |
99 | | - [AUuid u] | u == none' -> [] |
100 | | - payload -> payload |
| 114 | + AUuid u : payload | u == some' -> payload |
| 115 | + [AUuid u] | u == none' -> [] |
| 116 | + payload -> payload |
101 | 117 | where |
102 | 118 | some' = $(UUID.liftName "some") |
103 | 119 | none' = $(UUID.liftName "none") |
104 | 120 |
|
105 | 121 | note_track_get :: (MonadE m, MonadObjectState Note m) => m (Maybe UUID) |
106 | 122 | note_track_get = do |
107 | | - StateChunk stateBody <- getObjectStateChunk |
108 | | - pure $ |
109 | | - asum |
110 | | - [ case payload of |
111 | | - AUuid field : AUuid ref : _ | field == track -> Just ref |
112 | | - _ -> Nothing |
113 | | - | Op{refId = Zero, payload} <- stateBody |
114 | | - ] |
| 123 | + StateChunk stateBody <- getObjectStateChunk |
| 124 | + pure |
| 125 | + $ asum |
| 126 | + [ case payload of |
| 127 | + AUuid field : AUuid ref : _ | field == track -> Just ref |
| 128 | + _ -> Nothing |
| 129 | + | Op{refId = Zero, payload} <- stateBody |
| 130 | + ] |
115 | 131 | where |
116 | 132 | track = $(UUID.liftName "track") |
117 | 133 |
|
118 | 134 | upgradeDocId :: (Collection a, MonadStorage m) => DocId a -> m (DocId a) |
119 | 135 | upgradeDocId docid = do |
120 | | - let mu = decodeDocId docid |
121 | | - case mu of |
122 | | - Just (True, _) -> pure docid |
123 | | - Just (False, uuid) -> do |
124 | | - let docid' = docIdFromUuid uuid |
125 | | - changeDocId docid docid' |
126 | | - pure docid' |
127 | | - Nothing -> do |
128 | | - docid' <- docIdFromUuid <$> getEventUuid |
129 | | - changeDocId docid docid' |
130 | | - pure docid' |
| 136 | + let mu = decodeDocId docid |
| 137 | + case mu of |
| 138 | + Just (True, _) -> pure docid |
| 139 | + Just (False, uuid) -> do |
| 140 | + let docid' = docIdFromUuid uuid |
| 141 | + changeDocId docid docid' |
| 142 | + pure docid' |
| 143 | + Nothing -> do |
| 144 | + docid' <- docIdFromUuid <$> getEventUuid |
| 145 | + changeDocId docid docid' |
| 146 | + pure docid' |
0 commit comments