summaryrefslogtreecommitdiff
path: root/src/Data/Mergeless/Item.hs
blob: bda97c0bfbacf1539ab1c4693b1bebc7ac34bdec (plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
143
144
145
146
147
148
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}

module Data.Mergeless.Item where

import Control.DeepSeq
import Data.Aeson
import Data.Validity
import Data.Validity.Containers ()
import GHC.Generics (Generic)

{-# ANN module ("HLint: ignore Use lambda-case" :: String) #-}

data ClientItem a
  = ClientEmpty
  | ClientAdded !a
  | ClientSynced !a
  | ClientDeleted
  deriving (Show, Eq, Ord, Generic)

instance Validity a => Validity (ClientItem a)

instance NFData a => NFData (ClientItem a)

instance FromJSON a => FromJSON (ClientItem a)

instance ToJSON a => ToJSON (ClientItem a)

-- | A synchronisation request for items with identifiers of type @i@ and values of type @a@
data ItemSyncRequest a
  = ItemSyncRequestPoll
  | ItemSyncRequestNew a
  | ItemSyncRequestKnown
  | ItemSyncRequestDeleted
  deriving (Show, Eq, Ord, Generic)

instance Validity a => Validity (ItemSyncRequest a)

instance NFData a => NFData (ItemSyncRequest a)

instance FromJSON a => FromJSON (ItemSyncRequest a)

instance ToJSON a => ToJSON (ItemSyncRequest a)

makeItemSyncRequest :: ClientItem a -> ItemSyncRequest a
makeItemSyncRequest ci =
  case ci of
    ClientEmpty -> ItemSyncRequestPoll
    ClientAdded a -> ItemSyncRequestNew a
    ClientSynced _ -> ItemSyncRequestKnown
    ClientDeleted -> ItemSyncRequestDeleted

-- | A synchronisation response for items with identifiers of type @i@ and values of type @a@
data ItemSyncResponse a
  = ItemSyncResponseInSyncEmpty
  | ItemSyncResponseInSyncFull
  | ItemSyncResponseClientAdded
  | ItemSyncResponseClientDeleted
  | ItemSyncResponseServerAdded !a
  | ItemSyncResponseServerDeleted
  deriving (Show, Eq, Ord, Generic)

instance Validity a => Validity (ItemSyncResponse a)

instance NFData a => NFData (ItemSyncResponse a)

instance FromJSON a => FromJSON (ItemSyncResponse a)

instance ToJSON a => ToJSON (ItemSyncResponse a)

-- | Merge a synchronisation response back into a client-side store.
mergeItemSyncResponse :: ClientItem a -> ItemSyncResponse a -> ClientItem a
mergeItemSyncResponse ci sr =
  let mismatch = ci
   in case ci of
        ClientEmpty ->
          case sr of
            ItemSyncResponseInSyncEmpty -> ClientEmpty
            ItemSyncResponseServerAdded s -> ClientSynced s
            _ -> mismatch
        ClientAdded a ->
          case sr of
            ItemSyncResponseClientAdded -> ClientSynced a
            ItemSyncResponseServerAdded s -> ClientSynced s
            -- For completeness sake.
            -- This can only happen if two clients make the item at the same time.
            -- In practice, with named items in a collection, this will never happen.
            _ -> mismatch
        ClientSynced _ ->
          case sr of
            ItemSyncResponseInSyncFull -> ci -- No change
            ItemSyncResponseServerDeleted -> ClientEmpty
            _ -> mismatch
        ClientDeleted ->
          case sr of
            ItemSyncResponseClientDeleted -> ClientEmpty
            _ -> mismatch

-- | An item in a central store with a value of type @a@
data ServerItem a
  = ServerItemEmpty
  | ServerItemFull !a
  deriving (Show, Eq, Ord, Generic)

instance Validity a => Validity (ServerItem a)

instance NFData a => NFData (ServerItem a)

instance FromJSON a => FromJSON (ServerItem a)

instance ToJSON a => ToJSON (ServerItem a)

processServerItemSync :: ServerItem a -> ItemSyncRequest a -> (ItemSyncResponse a, ServerItem a)
processServerItemSync si sr =
  case si of
    ServerItemEmpty ->
      case sr of
        ItemSyncRequestPoll
          -- Both the client and the server think the item is empty, fine.
         -> (ItemSyncResponseInSyncEmpty, si)
        ItemSyncRequestNew a
          -- The client has a new item and the server has space for it, add it.
         -> (ItemSyncResponseClientAdded, ServerItemFull a)
        ItemSyncRequestKnown
          -- The client has an item that the server doesn't, so the server must have
          -- deleted it when another client asked to do that.
          -- Leave it deleted.
         -> (ItemSyncResponseServerDeleted, si)
        ItemSyncRequestDeleted
          -- The server has deleted an item but the current client hasn't been made aware of that
          -- AND this server also deleted that item in the meantime.
          -- Just leave it deleted.
         -> (ItemSyncResponseClientDeleted, si)
    ServerItemFull s ->
      case sr of
        ItemSyncRequestPoll
          -- The server has an item that the client doesn't, send it to the client.
         -> (ItemSyncResponseServerAdded s, si)
        ItemSyncRequestNew _
          -- The client wants to add an item that the server already has.
          -- That means that another client has added that same item in the meantime.
          -- This wouldn't happen if the items were named.
          -- In this case, for completeness sake,
         -> (ItemSyncResponseServerAdded s, si)
        ItemSyncRequestKnown -> (ItemSyncResponseInSyncFull, si)
        ItemSyncRequestDeleted -> (ItemSyncResponseClientDeleted, ServerItemEmpty)