Ops.hs

-- |
-- Module:      Network.Riak.CRDT.Ops
-- Copyright:   (c) 2016 Sentenai
-- Author:      Antonio Nikishaev <me@lelf.lu>
-- License:     Apache
-- Maintainer:  Tim McGilchrist <timmcgil@gmail.com>, Mark Hibberd <mark@hibberd.id.au>
-- Stability:   experimental
-- Portability: portable
--
--
-- Conversions of CRDT operations to 'PB.DtOp'
--
module Network.Riak.CRDT.Ops (
    counterUpdateOp
  , setUpdateOp
  , SetOpsComb(..)
  , toOpsComb
  , mapUpdateOp
  ) where

import           Data.ByteString (ByteString)
import           Data.Semigroup (Semigroup((<>)))
import qualified Data.Set as S

import qualified Data.Riak.Proto as Proto
import           Network.Riak.CRDT.Types
import           Network.Riak.Lens

counterUpdateOp :: [CounterOp] -> Proto.DtOp
counterUpdateOp ops = Proto.defMessage & Proto.counterOp .~ counterOpPB ops

counterOpPB :: [CounterOp] -> Proto.CounterOp
counterOpPB ops = Proto.defMessage & Proto.increment .~ i
    where CounterInc i = mconcat ops


data SetOpsComb = SetOpsComb { setAdds    :: S.Set ByteString,
                               setRemoves :: S.Set ByteString }
             deriving (Show)

instance Semigroup SetOpsComb where
    (SetOpsComb a b) <> (SetOpsComb x y) = SetOpsComb (a<>x) (b<>y)

instance Monoid SetOpsComb where
    mempty = SetOpsComb mempty mempty
    (SetOpsComb a b) `mappend` (SetOpsComb x y) = SetOpsComb (a<>x) (b<>y)

toOpsComb :: SetOp -> SetOpsComb
toOpsComb (SetAdd s)    = SetOpsComb (S.singleton s) S.empty
toOpsComb (SetRemove s) = SetOpsComb S.empty (S.singleton s)



setUpdateOp :: [SetOp] -> Proto.DtOp
setUpdateOp ops = Proto.defMessage & Proto.setOp .~ setOpPB ops

setOpPB :: [SetOp] -> Proto.SetOp
setOpPB ops = Proto.defMessage & Proto.adds .~ S.toList adds
                               & Proto.removes .~ S.toList rems
    where SetOpsComb adds rems = mconcat . map toOpsComb $ ops

flagOpPB :: FlagOp -> Proto.MapUpdate'FlagOp
flagOpPB (FlagSet True)  = Proto.MapUpdate'ENABLE
flagOpPB (FlagSet False) = Proto.MapUpdate'DISABLE

registerOpPB :: RegisterOp -> ByteString
registerOpPB (RegisterSet x) = x

mapUpdateOp :: [MapOp] -> Proto.DtOp
mapUpdateOp ops = Proto.defMessage & Proto.mapOp .~ mapOpPB ops

mapOpPB :: [MapOp] -> Proto.MapOp
mapOpPB ops = Proto.defMessage & Proto.removes .~ rems
                               & Proto.updates .~ updates
    where rems    = [ toRemove f   | MapRemove f <- ops ]
          updates = [ toUpdate f u | MapUpdate f u <- ops ]

toRemove :: MapField -> Proto.MapField
toRemove (MapField t name) = toField name t

toUpdate :: MapPath -> MapValueOp -> Proto.MapUpdate
toUpdate (MapPath (e :| [])) op     = toUpdate' e (mapEntryTag op) op
toUpdate (MapPath (e :| (r:rs))) op = toUpdate' e MapMapTag op'
    where op' = MapMapOp (MapUpdate (MapPath (r:|rs)) op)

toUpdate' :: ByteString -> MapEntryTag -> MapValueOp -> Proto.MapUpdate
toUpdate' f t op = setSpecificOp op (updateNothing f t)

setSpecificOp :: MapValueOp -> Proto.MapUpdate -> Proto.MapUpdate
setSpecificOp (MapCounterOp cop)   = Proto.counterOp .~ counterOpPB [cop]
setSpecificOp (MapSetOp sop)       = Proto.setOp .~ setOpPB [sop]
setSpecificOp (MapRegisterOp rop)  = Proto.registerOp .~ registerOpPB rop
setSpecificOp (MapFlagOp fop)      = Proto.flagOp .~ flagOpPB fop
setSpecificOp (MapMapOp mop)       = Proto.mapOp .~ mapOpPB [mop]


updateNothing :: ByteString -> MapEntryTag -> Proto.MapUpdate
updateNothing f t = Proto.defMessage & Proto.field .~ toField f t

toField :: ByteString -> MapEntryTag -> Proto.MapField
toField name t = Proto.defMessage & Proto.name .~ name
                                  & Proto.type' .~ typ t
    where typ MapCounterTag  = Proto.MapField'COUNTER
          typ MapSetTag      = Proto.MapField'SET
          typ MapRegisterTag = Proto.MapField'REGISTER
          typ MapFlagTag     = Proto.MapField'FLAG
          typ MapMapTag      = Proto.MapField'MAP