[CDEC-454] Remove usages of -fno-warn-orphans in update

Reunite orphan instances in update (where possible)

Author: intricate

core/src/Pos/Core/Update/SystemTag.hs

@@ -12,6 +12,9 @@ module Pos.Core.Update.SystemTag
 import           Universum
 
 import           Control.Monad.Except (MonadError (throwError))
+import           Data.Aeson (FromJSON (..))
+import           Data.Aeson.Options (defaultOptions)
+import           Data.Aeson.TH (deriveToJSON)
 import           Data.Char (isAscii)
 import           Data.SafeCopy (base, deriveSafeCopySimple)
 import qualified Data.Text as T
@@ -28,6 +31,11 @@ newtype SystemTag = SystemTag { getSystemTag :: Text }
 
 instance NFData SystemTag
 
+instance FromJSON SystemTag where
+    parseJSON v = SystemTag <$> parseJSON v
+
+deriveToJSON defaultOptions ''SystemTag
+
 instance Bi SystemTag where
     encode = encode . getSystemTag
     decode = SystemTag <$> decode

update/cardano-sl-update.cabal

@@ -17,9 +17,6 @@ library
   exposed-modules:
                        Pos.Update
 
-                       -- Aeson
-                       Pos.Aeson.Update
-
                        Pos.Update.BlockVersion
 
                        -- Misc
@@ -38,9 +35,7 @@ library
                        Pos.Update.Poll.Class
                        Pos.Update.Poll.Modifier
                        Pos.Update.Poll.PollState
-                       Pos.Update.Poll.Trans
                        Pos.Update.Poll.Types
-                       Pos.Update.Poll.RollTrans
                        Pos.Update.Poll.Failure
                        Pos.Update.Poll.Pure
                        Pos.Update.Poll.DBPoll

update/src/Pos/Aeson/Update.hs

@@ -27,7 +27,6 @@ import           Distribution.System (buildArch, buildOS)
 
 -- For FromJSON instances.
 import           Pos.Aeson.Core ()
-import           Pos.Aeson.Update ()
 import           Pos.Core (ApplicationName, BlockVersion (..),
                      SoftwareVersion (..))
 import           Pos.Core.Update (SystemTag (..), archHelper, osHelper)

update/src/Pos/Update/Configuration.hs

@@ -7,8 +7,6 @@ module Pos.Update.Poll
        , module Pos.Update.Poll.Modifier
        , module Pos.Update.Poll.PollState
        , module Pos.Update.Poll.Pure
-       , module Pos.Update.Poll.RollTrans
-       , module Pos.Update.Poll.Trans
        , module Pos.Update.Poll.Types
        , module Pos.Update.Poll.Logic
        ) where
@@ -20,6 +18,4 @@ import           Pos.Update.Poll.Logic
 import           Pos.Update.Poll.Modifier
 import           Pos.Update.Poll.PollState
 import           Pos.Update.Poll.Pure
-import           Pos.Update.Poll.RollTrans
-import           Pos.Update.Poll.Trans
 import           Pos.Update.Poll.Types

update/src/Pos/Update/Poll.hs

@@ -1,25 +1,55 @@
+{-# LANGUAGE Rank2Types   #-}
 {-# LANGUAGE TypeFamilies #-}
 
 -- | Type classes for Poll abstraction.
 
 module Pos.Update.Poll.Class
        ( MonadPollRead (..)
        , MonadPoll (..)
+
+       -- Roll Transformer
+       , RollT
+       , runRollT
+       , execRollT
+
+       -- Poll Transformer
+       , PollT
+       , runPollT
+       , evalPollT
+       , execPollT
        ) where
 
-import           Universum
+import           Universum hiding (id)
 
+import           Control.Lens (uses, (%=), (.=))
 import           Control.Monad.Trans (MonadTrans)
-import           System.Wlog (WithLogger)
+import           Data.Default (def)
+import qualified Data.HashMap.Strict as HM
+import qualified Data.HashSet as HS
+import qualified Data.List as List (find)
+import qualified Ether
+import           System.Wlog (WithLogger, logWarning)
 
 import           Pos.Core (ApplicationName, BlockVersion, BlockVersionData,
                      ChainDifficulty, Coin, EpochIndex, NumSoftwareVersion,
-                     SlotId, SoftwareVersion, StakeholderId)
+                     SlotId, SoftwareVersion, StakeholderId, addressHash)
 import           Pos.Core.Slotting (SlottingData)
-import           Pos.Core.Update (UpId)
+import           Pos.Core.Update (SoftwareVersion (..), UpId,
+                     UpdateProposal (..))
+import           Pos.Crypto (hash)
+import           Pos.Update.BlockVersion (applyBVM)
+import           Pos.Update.Poll.Modifier (PollModifier (..), pmActivePropsL,
+                     pmAdoptedBVFullL, pmBVsL, pmConfirmedL, pmConfirmedPropsL,
+                     pmEpochProposersL, pmSlottingDataL)
 import           Pos.Update.Poll.Types (BlockVersionState,
-                     ConfirmedProposalState, DecidedProposalState,
-                     ProposalState, UndecidedProposalState)
+                     BlockVersionState (..), ConfirmedProposalState,
+                     DecidedProposalState (..), PrevValue, ProposalState (..),
+                     USUndo (..), UndecidedProposalState (..), bvsIsConfirmed,
+                     cpsSoftwareVersion, maybeToPrev, psProposal, unChangedBVL,
+                     unChangedConfPropsL, unChangedPropsL, unChangedSVL,
+                     unLastAdoptedBVL, unPrevProposersL, unSlottingDataL)
+import qualified Pos.Util.Modifier as MM
+import           Pos.Util.Util (ether)
 
 ----------------------------------------------------------------------------
 -- Read-only
@@ -137,3 +167,210 @@ instance {-# OVERLAPPABLE #-}
     deactivateProposal = lift . deactivateProposal
     setSlottingData = lift . setSlottingData
     setEpochProposers = lift . setEpochProposers
+
+----------------------------------------------------------------------------
+-- Roll Transformer
+----------------------------------------------------------------------------
+
+type RollT m = Ether.LazyStateT' USUndo m
+
+-- | Monad transformer which stores USUndo and implements writable
+-- MonadPoll. Its purpose is to collect data necessary for rollback.
+--
+-- [WARNING] This transformer uses StateT and is intended for
+-- single-threaded usage only.
+instance (MonadPoll m) => MonadPoll (RollT m) where
+    putBVState bv sv = ether $ do
+        insertIfNotExist bv unChangedBVL getBVState
+        putBVState bv sv
+
+    delBVState bv = ether $ do
+        insertIfNotExist bv unChangedBVL getBVState
+        delBVState bv
+
+    setAdoptedBV = setValueWrapper unLastAdoptedBVL getAdoptedBV setAdoptedBV
+
+    setLastConfirmedSV sv@SoftwareVersion{..} = ether $ do
+        insertIfNotExist svAppName unChangedSVL getLastConfirmedSV
+        setLastConfirmedSV sv
+
+    -- can't be called during apply
+    delConfirmedSV = lift . delConfirmedSV
+
+    addConfirmedProposal cps = ether $ do
+        confProps <- getConfirmedProposals
+        insertIfNotExist (cpsSoftwareVersion cps) unChangedConfPropsL (getter confProps)
+        addConfirmedProposal cps
+      where
+        getter confs sv = pure $ List.find (\x -> cpsSoftwareVersion x == sv) confs
+
+    -- can't be called during apply
+    delConfirmedProposal = lift . delConfirmedProposal
+
+    insertActiveProposal ps = ether $ do
+        whenNothingM_ (use unPrevProposersL) $ do
+            prev <- getEpochProposers
+            unPrevProposersL .= Just prev
+        insertIfNotExist (hash $ psProposal $ ps) unChangedPropsL getProposal
+        insertActiveProposal ps
+
+    deactivateProposal id = ether $ do
+        -- Proposer still can't propose new updates in the current epoch
+        -- even if his update was deactivated in the same epoch
+        insertIfNotExist id unChangedPropsL getProposal
+        deactivateProposal id
+
+    setSlottingData =
+        setValueWrapper unSlottingDataL getSlottingData setSlottingData
+    setEpochProposers =
+        setValueWrapper unPrevProposersL getEpochProposers setEpochProposers
+
+-- This is a convenient wrapper for functions which should set some
+-- value and this change should be recorded in USUndo. If change of
+-- such kind is already recorded in 'USUndo', then we don't record it
+-- and just propagate the new value to the underlying 'MonadPoll'. If
+-- it is not recorded, we put old value into 'USUndo' before
+-- propagating the new value.
+setValueWrapper ::
+       MonadPoll m
+    => Lens' USUndo (Maybe a)
+    -> m a
+    -> (a -> m ())
+    -> a
+    -> RollT m ()
+setValueWrapper lens getAction setAction value = ether $ do
+    whenNothingM_ (use lens) $ do
+        prev <- lift getAction
+        lens .= Just prev
+    lift (setAction value)
+
+insertIfNotExist
+    :: (Eq a, Hashable a, MonadState USUndo m)
+    => a
+    -> Lens' USUndo (HashMap a (PrevValue b))
+    -> (a -> m (Maybe b))
+    -> m ()
+insertIfNotExist id setter getter = do
+    whenNothingM_ (HM.lookup id <$> use setter) $ do
+        prev <- getter id
+        setter %= HM.insert id (maybeToPrev prev)
+
+runRollT :: RollT m a -> m (a, USUndo)
+runRollT = flip Ether.runLazyStateT def
+
+execRollT :: Monad m => RollT m a -> m USUndo
+execRollT = flip Ether.execLazyStateT def
+
+----------------------------------------------------------------------------
+-- PollT Transformer
+----------------------------------------------------------------------------
+
+-- | Monad transformer which stores PollModifier and implements
+-- writable MonadPoll.
+--
+-- [WARNING] This transformer uses StateT and is intended for
+-- single-threaded usage only.
+type PollT = Ether.LazyStateT' PollModifier
+
+runPollT :: PollModifier -> PollT m a -> m (a, PollModifier)
+runPollT = flip Ether.runLazyStateT
+
+evalPollT :: Monad m => PollModifier -> PollT m a -> m a
+evalPollT = flip Ether.evalLazyStateT
+
+execPollT :: Monad m => PollModifier -> PollT m a -> m PollModifier
+execPollT = flip Ether.execLazyStateT
+
+instance (MonadPollRead m) =>
+         MonadPollRead (PollT m) where
+    getBVState pv = ether $
+        MM.lookupM getBVState pv =<< use pmBVsL
+    getProposedBVs = ether $
+        MM.keysM getProposedBVs =<< use pmBVsL
+    getEpochProposers = ether $ do
+        new <- use pmEpochProposersL
+        maybe getEpochProposers pure new
+    getCompetingBVStates = ether $
+        filter (bvsIsConfirmed . snd) <$>
+        (MM.toListM getCompetingBVStates =<< use pmBVsL)
+    getAdoptedBVFull = ether $
+        maybe getAdoptedBVFull pure =<< use pmAdoptedBVFullL
+    getLastConfirmedSV appName = ether $
+        MM.lookupM getLastConfirmedSV appName =<< use pmConfirmedL
+    getProposal upId = ether $
+        MM.lookupM getProposal upId =<< use pmActivePropsL
+    getProposalsByApp app = ether $ do
+        let eqApp = (== app) . svAppName . upSoftwareVersion . psProposal . snd
+        props <- uses pmActivePropsL (filter eqApp . MM.insertions)
+        dbProps <- map (first (hash . psProposal) . join (,)) <$> getProposalsByApp app
+        pure . toList . HM.fromList $ dbProps ++ props -- squash props with same upId
+    getConfirmedProposals = ether $
+        MM.valuesM
+            (map (first cpsSoftwareVersion . join (,)) <$> getConfirmedProposals) =<<
+        use pmConfirmedPropsL
+    getEpochTotalStake = lift . getEpochTotalStake
+    getRichmanStake e = lift . getRichmanStake e
+    getOldProposals sl = ether $
+        map snd <$>
+        (MM.mapMaybeM getOldProposalPairs extractOld =<< use pmActivePropsL)
+      where
+        extractOld (PSUndecided ups)
+            | upsSlot ups <= sl = Just ups
+            | otherwise = Nothing
+        extractOld (PSDecided _) = Nothing
+        getOldProposalPairs =
+            map (\ups -> (hash $ upsProposal ups, ups)) <$> getOldProposals sl
+    getDeepProposals cd = ether $
+        map snd <$>
+        (MM.mapMaybeM getDeepProposalPairs extractDeep =<< use pmActivePropsL)
+      where
+        extractDeep (PSDecided dps)
+            | Just propDifficulty <- dpsDifficulty dps
+            , propDifficulty <= cd = Just dps
+            | otherwise = Nothing
+        extractDeep (PSUndecided _) = Nothing
+        getDeepProposalPairs =
+            map (\dps -> (hash $ upsProposal $ dpsUndecided dps, dps)) <$>
+            getDeepProposals cd
+    getBlockIssuerStake e = lift . getBlockIssuerStake e
+    getSlottingData = ether $ do
+        new <- gets pmSlottingData
+        maybe getSlottingData pure new
+
+{-# ANN module ("HLint: ignore Reduce duplication" :: Text) #-}
+
+instance (MonadPollRead m) =>
+         MonadPoll (PollT m) where
+    putBVState bv st = ether $ pmBVsL %= MM.insert bv st
+    delBVState bv = ether $ pmBVsL %= MM.delete bv
+    setAdoptedBV bv = ether $ do
+        bvs <- getBVState bv
+        adoptedBVD <- getAdoptedBVData
+        case bvs of
+            Nothing ->
+                logWarning $ "setAdoptedBV: unknown version " <> pretty bv -- can't happen actually
+            Just (bvsModifier -> bvm) ->
+                pmAdoptedBVFullL .= Just (bv, applyBVM bvm adoptedBVD)
+    setLastConfirmedSV SoftwareVersion {..} = ether $
+        pmConfirmedL %= MM.insert svAppName svNumber
+    delConfirmedSV appName = ether $
+        pmConfirmedL %= MM.delete appName
+    addConfirmedProposal cps = ether $
+        pmConfirmedPropsL %= MM.insert (cpsSoftwareVersion cps) cps
+    delConfirmedProposal sv = ether $
+        pmConfirmedPropsL %= MM.delete sv
+    insertActiveProposal ps = do
+        let up@UnsafeUpdateProposal{..} = psProposal ps
+            upId = hash up
+        whenNothingM_ (getProposal upId) $
+            setEpochProposers =<< (HS.insert (addressHash upFrom) <$> getEpochProposers)
+        ether $ pmActivePropsL %= MM.insert upId ps
+    -- Deactivate proposal doesn't change epoch proposers.
+    deactivateProposal id = do
+        prop <- getProposal id
+        whenJust prop $ \ps -> ether $ do
+            let up = psProposal ps
+                upId = hash up
+            pmActivePropsL %= MM.delete upId
+    setSlottingData sd = ether $ pmSlottingDataL .= Just sd
+    setEpochProposers ep = ether $ pmEpochProposersL .= Just ep