Add diff and merge to 'setCategoryNotes' and 'setTrait' (#241)

* Add diff to setCategoryNote

* Add diff to setTrait

* Fix merge conflicts

* Add merged

* Rename fields

src/Guide/Api/Methods.hs

@@ -9,11 +9,14 @@ module Guide.Api.Methods where
 import Imports
 
 import Data.Acid as Acid
+import Data.Aeson (encode)
 import Data.Text (Text)
 import Servant
 
 import Guide.Api.Types
 import Guide.Api.Utils
+import Guide.Diff (merge)
+import Guide.Markdown (MarkdownBlock (..), MarkdownInline (..))
 import Guide.State
 import Guide.Types
 import Guide.Utils
@@ -61,14 +64,26 @@ createCategory db title' group' = do
       return catId
 
 -- | Edit categoty's note.
-setCategoryNotes :: DB -> Uid Category -> Text -> Handler NoContent
-setCategoryNotes db catId note =
+setCategoryNotes :: DB -> Uid Category -> CTextEdit -> Handler NoContent
+setCategoryNotes db catId CTextEdit{..} =
   dbQuery db (GetCategoryMaybe catId) >>= \case
     Nothing -> throwError (err404 {errBody = "Category not found"})
-    Just _ -> do
-      (_edit, _newCategory) <- dbUpdate db (SetCategoryNotes catId note)
-      -- TODO diff and merge
-      pure NoContent
+    Just Category{..} -> do
+      let serverModified = markdownBlockMdSource _categoryNotes
+      let original = unH cteOriginal
+      let modified = unH cteModified
+      if original /= serverModified then do
+        let merged = merge original modified serverModified
+        let conflict = CMergeConflict
+                { cmcOriginal = cteOriginal
+                , cmcModified = cteModified
+                , cmcServerModified = H serverModified
+                , cmcMerged = H merged
+                }
+        throwError (err409 {errBody = encode conflict})
+      else do
+        (_edit, _newCategory) <- dbUpdate db (SetCategoryNotes catId modified)
+        pure NoContent
 
 -- | Edit category's info (title, group, status, sections (pro/con, ecosystem, note)).
 setCategoryInfo :: DB -> Uid Category -> CCategoryInfoEdit -> Handler NoContent
@@ -164,11 +179,29 @@ createTrait db itemId traitType text = do
   pure traitId
 
 -- | Update the text of a trait (pro/con).
-setTrait :: DB -> Uid Item -> Uid Trait -> Text -> Handler NoContent
-setTrait db itemId traitId text = do
-  (_edit, _newTrait) <- dbUpdate db (SetTraitContent itemId traitId text)
-  -- TODO diff and merge
-  pure NoContent
+setTrait :: DB -> Uid Item -> Uid Trait -> CTextEdit -> Handler NoContent
+setTrait db itemId traitId CTextEdit{..} = do
+  dbQuery db (GetItemMaybe itemId) >>= \case
+    Nothing -> throwError (err404 {errBody = "Item not found"})
+    Just _ -> do
+      dbQuery db (GetTraitMaybe itemId traitId) >>= \case
+        Nothing -> throwError (err404 {errBody = "Trait not found"})
+        Just Trait{..} -> do
+          let serverModified = markdownInlineMdSource _traitContent
+          let original = unH cteOriginal
+          let modified = unH cteModified
+          if original /= serverModified then do
+            let merged = merge original modified serverModified
+            let conflict = CMergeConflict
+                    { cmcOriginal = cteOriginal
+                    , cmcModified = cteModified
+                    , cmcServerModified = H serverModified
+                    , cmcMerged = H merged
+                    }
+            throwError (err409 {errBody = encode conflict})
+          else do
+            (_edit, _newCategory) <- dbUpdate db (SetTraitContent itemId traitId modified)
+            pure NoContent
 
 -- | Delete a trait (pro/con).
 deleteTrait :: DB -> Uid Item -> Uid Trait -> Handler NoContent

src/Guide/Api/Types.hs

@@ -34,6 +34,8 @@ module Guide.Api.Types
 
   -- * Other types
   , TraitType (..)
+  , CTextEdit (..)
+  , CMergeConflict (..)
   )
   where
 
@@ -115,7 +117,8 @@ data CategorySite route = CategorySite
       :> "category"
       :> Capture "id" (Uid Category)
       :> "notes"
-      :> ReqBody '[JSON] Text
+      :> ReqBody '[JSON] CTextEdit
+      :> ErrorResponse 409 "Merge conflict occured"
       :> Put '[JSON] NoContent
 
   , _setCategoryInfo :: route :-
@@ -178,11 +181,14 @@ data TraitSite route = TraitSite
 
   , _setTrait :: route :-
       Summary "Update a trait in the given item"
+      :> ErrorResponse 404 "Item not found"
+      :> ErrorResponse 404 "Trait not found"
       :> "item"
       :> Capture "item" (Uid Item)
       :> "trait"
       :> Capture "id" (Uid Trait)
-      :> ReqBody '[JSON] Text
+      :> ReqBody '[JSON] CTextEdit
+      :> ErrorResponse 409 "Merge conflict occured"
       :> Put '[JSON] NoContent
 
   , _deleteTrait :: route :-
@@ -463,6 +469,35 @@ toCHeading h = CHeading
   , chSlug    = H $ headingSlug h
   }
 
+-- | Frontend sends this type to edit notes or descriptions.
+data CTextEdit = CTextEdit
+  { cteOriginal :: Text ? "State of base before editing"
+  , cteModified :: Text ? "Modified text"
+  } deriving (Show, Generic)
+
+instance A.ToJSON CTextEdit where
+  toJSON = A.genericToJSON jsonOptions
+
+instance A.FromJSON CTextEdit where
+  parseJSON = A.genericParseJSON jsonOptions
+
+instance ToSchema CTextEdit where
+  declareNamedSchema = genericDeclareNamedSchema schemaOptions
+
+-- | Backend returns this type if there is conflict between state of base before and after editing.
+data CMergeConflict = CMergeConflict
+  { cmcOriginal       :: Text ? "State of base before editing"
+  , cmcModified       :: Text ? "Modified text"
+  , cmcServerModified :: Text ? "State of base after editing. (Base changed from another source)"
+  , cmcMerged         :: Text ? "Merged text"
+  } deriving (Eq, Show, Generic)
+
+instance A.ToJSON CMergeConflict where
+  toJSON = A.genericToJSON jsonOptions
+
+instance ToSchema CMergeConflict where
+  declareNamedSchema = genericDeclareNamedSchema schemaOptions
+
 ----------------------------------------------------------------------------
 -- Search client types
 ----------------------------------------------------------------------------

src/Guide/Api/Utils.hs

@@ -44,7 +44,7 @@ schemaOptions = fromAesonOptions jsonOptions
 
 -- | A way to provide descriptions for record fields.
 newtype (?) (field :: *) (help :: Symbol) = H field
-  deriving (Generic, Show)
+  deriving (Eq, Generic, Show)
 
 instance ToJSON field => ToJSON (field ? help) where
   toJSON (H a) = toJSON a

src/Guide/Main.hs

@@ -189,7 +189,7 @@ mainWith config@Config{..} = do
     mWaiMetrics <- if _ekg
         then do
           ekg <- do
-            say $ format "EKG is running on port " _portEkg
+            say $ format "EKG is running on port {}" _portEkg
             EKG.forkServer "localhost" _portEkg
           writeIORef ekgId (Just (EKG.serverThreadId ekg))
           waiMetrics <- EKG.registerWaiMetrics (EKG.serverMetricStore ekg)

src/Guide/State.hs

@@ -35,7 +35,7 @@ module Guide.State
   GetCategory(..), GetCategoryMaybe(..),
   GetCategoryByItem(..),
   GetItem(..), GetItemMaybe (..),
-  GetTrait(..),
+  GetTrait(..), GetTraitMaybe (..),
 
   -- ** add
   AddCategory(..),
@@ -343,6 +343,9 @@ getItemMaybe uid' = preview (itemById uid')
 getTrait :: Uid Item -> Uid Trait -> Acid.Query GlobalState Trait
 getTrait itemId traitId = view (itemById itemId . traitById traitId)
 
+getTraitMaybe :: Uid Item -> Uid Trait -> Acid.Query GlobalState (Maybe Trait)
+getTraitMaybe itemId traitId = preview (itemById itemId . traitById traitId)
+
 -- add
 
 addCategory
@@ -886,7 +889,7 @@ makeAcidic ''GlobalState [
   'getCategory, 'getCategoryMaybe,
   'getCategoryByItem,
   'getItem, 'getItemMaybe,
-  'getTrait,
+  'getTrait, 'getTraitMaybe,
   -- add
   'addCategory,
   'addItem,