Add setCategoryNote and setCategoryInfo and setItemInfo (#227)

* Add setCategoryNote * Fix cache function * Fix style * Add setCategoryInfo * Fix instances, add throwErrorand unH * WIP * Add setItemHackage on old kind + commented new realisation * Refactor and fix bug * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Add a comment * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Types.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Update src/Guide/Api/Utils.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com> * Fix FromJSON ItemKind instance * Update src/Guide/Api/Methods.hs Co-Authored-By: willbasky <vladislav.sabanov@gmail.com>
2024-12-23 21:02:13 +03:00 · 2018-11-04 00:09:19 +05:00 · 2018-11-04 00:09:19 +05:00 · eafe87bd0a
commit eafe87bd0a
parent 3063a79830
7 changed files with 196 additions and 42 deletions
--- a/src/Guide/Api/Methods.hs
+++ b/src/Guide/Api/Methods.hs
@ -13,11 +13,13 @@ import Data.Text (Text)
 import Servant

 import Guide.Api.Types
+import Guide.Api.Utils
 import Guide.Cache
 import Guide.State
 import Guide.Types
 import Guide.Utils

+import qualified Data.Set as S
 import qualified Data.Text as T
 import qualified Guide.Search as Search

@ -44,6 +46,8 @@ getCategory db catId =
 -- category with this title exists already).
 createCategory :: DB -> Text -> Text -> Handler (Uid Category)
 createCategory db title' group' = do
+  when (T.null title') $ do throwError (err400 {errBody = "Title not provided"})
+  when (T.null group') $ do throwError (err400 {errBody = "Group' not provided"})
  -- If the category exists already, don't create it
  cats <- view categories <$> dbQuery db GetGlobalState
  let isDuplicate cat = T.toCaseFold (cat^.title) == T.toCaseFold title'
@ -58,9 +62,40 @@ createCategory db title' group' = do
      -- TODO addEdit edit
      return catId

+-- | Edit categoty's note.
+setCategoryNotes :: DB -> Uid Category -> Text -> Handler NoContent
+setCategoryNotes db catId note = uncache db (CacheCategoryNotes catId) $ do
+  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
+
+-- | Edit category's info (title, group, status, sections (pro/con, ecosystem, note)).
+setCategoryInfo :: DB -> Uid Category -> CCategoryInfoEdit -> Handler NoContent
+setCategoryInfo db catId CCategoryInfoEdit{..} = uncache db (CacheCategoryInfo catId) $ do
+  dbQuery db (GetCategoryMaybe catId) >>= \case
+    Nothing -> throwError (err404 {errBody = "Category not found"})
+    Just category -> do
+      -- TODO diff and merge
+      _ <- dbUpdate db $ SetCategoryTitle catId $ unH ccieTitle
+      _ <- dbUpdate db $ SetCategoryGroup catId $ unH ccieGroup
+      _ <- dbUpdate db $ SetCategoryStatus catId $ unH ccieStatus
+      let oldEnabledSections = category ^. enabledSections
+      let newEnabledSections = unH ccieSections
+      _ <- dbUpdate db $ ChangeCategoryEnabledSections catId
+          (newEnabledSections S.\\ oldEnabledSections)
+          (oldEnabledSections S.\\ newEnabledSections)
+      -- TODO record edits
+      pure NoContent
+
 -- | Delete a category.
 deleteCategory :: DB -> Uid Category -> Handler NoContent
 deleteCategory db catId = uncache db (CacheCategory catId) $ do
+  dbQuery db (GetCategoryMaybe catId) >>= \case
+    Nothing -> throwError (err404 {errBody = "Category not found"})
+    Just _ -> do
      _mbEdit <- dbUpdate db (DeleteCategory catId)
      pure NoContent
      -- TODO mapM_ addEdit mbEdit
@ -75,8 +110,11 @@ deleteCategory db catId = uncache db (CacheCategory catId) $ do
 -- with duplicated names.
 createItem :: DB -> Uid Category -> Text -> Handler (Uid Item)
 createItem db catId name' = do
-  -- TODO: do something if the category doesn't exist (e.g. has been
-  -- already deleted)
+  dbQuery db (GetCategoryMaybe catId) >>= \case
+    Nothing -> throwError (err404 {errBody = "Category not found"})
+    Just _ -> do
+      if T.null name' then throwError (err400 {errBody = "Name not provided"})
+      else do
        itemId <- randomShortUid
        -- If the item name looks like a Hackage library, assume it's a Hackage
        -- library.
@ -91,6 +129,19 @@ createItem db catId name' = do

 -- TODO: move an item

+-- | Set item's info
+setItemInfo :: DB -> Uid Item -> CItemInfo -> Handler NoContent
+setItemInfo db itemId CItemInfo{..} = uncache db (CacheItemInfo itemId) $ do
+  dbQuery db (GetItemMaybe itemId) >>= \case
+    Nothing -> throwError (err404 {errBody = "Item not found"})
+    Just _ -> do
+      -- TODO diff and merge
+      _ <- dbUpdate db $ SetItemName itemId $ unH ciiName
+      _ <- dbUpdate db $ SetItemGroup itemId $ unH ciiGroup
+      _ <- dbUpdate db $ SetItemLink itemId $ unH ciiLink
+      _ <- dbUpdate db $ SetItemKind itemId $ unH ciiKind
+      pure NoContent
+
 -- | Delete an item.
 deleteItem :: DB -> Uid Item -> Handler NoContent
 deleteItem db itemId = uncache db (CacheItem itemId) $ do
@ -107,6 +158,7 @@ deleteItem db itemId = uncache db (CacheItem itemId) $ do
 -- | Create a trait (pro/con).
 createTrait :: DB -> Uid Item -> TraitType -> Text -> Handler (Uid Trait)
 createTrait db itemId traitType text = do
+  when (T.null text) $ throwError (err400 {errBody = "Trait text not provided"})
  traitId <- randomShortUid
  (_edit, _newTrait) <- case traitType of
    Con -> dbUpdate db (AddCon itemId traitId text)
@ -119,6 +171,7 @@ createTrait db itemId traitType text = do
 setTrait :: DB -> Uid Item -> Uid Trait -> Text -> Handler NoContent
 setTrait db itemId traitId text = uncache db (CacheItemTraits itemId) $ do
  (_edit, _newTrait) <- dbUpdate db (SetTraitContent itemId traitId text)
+  -- TODO diff and merge
  pure NoContent

 -- | Delete a trait (pro/con).
--- a/src/Guide/Api/Server.hs
+++ b/src/Guide/Api/Server.hs
@ -38,11 +38,14 @@ apiServer db = Site
      { _getCategories    = getCategories db
      , _getCategory      = getCategory db
      , _createCategory   = createCategory db
+      , _setCategoryNotes = setCategoryNotes db
+      , _setCategoryInfo  = setCategoryInfo db
      , _deleteCategory   = deleteCategory db }
      :: CategorySite AsServer)

  , _itemSite = toServant (ItemSite
      { _createItem     = createItem db
+      , _setItemInfo    = setItemInfo db
      , _deleteItem     = deleteItem db }
      :: ItemSite AsServer)

--- a/src/Guide/Api/Types.hs
+++ b/src/Guide/Api/Types.hs
@ -19,10 +19,10 @@ module Guide.Api.Types
  , SearchSite(..)
  , Site(..)
  , TraitSite(..)
-  , TraitType (..)

  -- * View types
  , CCategoryInfo(..), toCCategoryInfo
+  , CCategoryInfoEdit(..)
  , CCategoryFull(..), toCCategoryFull
  , CItemInfo(..), toCItemInfo
  , CItemFull(..), toCItemFull
@ -31,6 +31,9 @@ module Guide.Api.Types

  -- * Search
  , CSearchResult(..), toCSearchResult
+
+  -- * Other types
+  , TraitType (..)
  )
  where

@ -96,6 +99,7 @@ data CategorySite route = CategorySite
                     \If a category with the same title already exists \
                     \in the group, returns its ID instead."
      :> ErrorResponse 400 "'title' not provided"
+      :> ErrorResponse 400 "'group' not provided"
      :> "category"
      :> QueryParam' '[Required, Strict,
                       Description "Title of the newly created category"]
@ -105,6 +109,24 @@ data CategorySite route = CategorySite
           "group" Text
      :> Post '[JSON] (Uid Category)

+  , _setCategoryNotes :: route :-
+      Summary "Edit category's notes"
+      :> ErrorResponse 404 "Category not found"
+      :> "category"
+      :> Capture "id" (Uid Category)
+      :> "notes"
+      :> ReqBody '[JSON] Text
+      :> Put '[JSON] NoContent
+
+  , _setCategoryInfo :: route :-
+      Summary "Set category's fields"
+      :> ErrorResponse 404 "Category not found"
+      :> "category"
+      :> Capture "id" (Uid Category)
+      :> "info"
+      :> ReqBody '[JSON] CCategoryInfoEdit
+      :> Put '[JSON] NoContent
+
  , _deleteCategory :: route :-
      Summary "Delete a category"
      :> "category"
@ -124,6 +146,15 @@ data ItemSite route = ItemSite
      :> QueryParam' '[Required, Strict] "name" Text
      :> Post '[JSON] (Uid Item)

+  , _setItemInfo :: route :-
+      Summary "Set item's fields"
+      :> ErrorResponse 404 "Item not found"
+      :> "item"
+      :> Capture "item" (Uid Item)
+      :> "info"
+      :> ReqBody '[JSON] CItemInfo
+      :> Put '[JSON] NoContent
+
  , _deleteItem :: route :-
      Summary "Delete an item"
      :> "item"
@ -178,6 +209,10 @@ data SearchSite route = SearchSite

 type Api = ToServant Site AsApi

+--------------------------------------------------------------------------
+-- Additional types for routes
+--------------------------------------------------------------------------
+
 -- | Trait type (Pro/Con) and instances.
 data TraitType = Pro | Con
    deriving (Show, Generic)
@ -265,7 +300,30 @@ toCCategoryFull Category{..} = CCategoryFull
  , ccfStatus      = H $ _categoryStatus
  }

-- | A lightweight info type about an 'Item'
+-- | Client type to edit meta category information.
+data CCategoryInfoEdit = CCategoryInfoEdit
+    { ccieTitle    :: Text            ? "Category title"
+    , ccieGroup    :: Text            ? "Category group ('grandcategory')"
+    , ccieStatus   :: CategoryStatus  ? "Status (done, in progress, ...)"
+    , ccieSections :: Set ItemSection ? "Enabled item sections"
+    }
+    deriving (Show, Generic)
+
+instance A.ToJSON CCategoryInfoEdit where
+  toJSON = A.genericToJSON jsonOptions
+
+instance A.FromJSON CCategoryInfoEdit where
+  parseJSON = A.genericParseJSON jsonOptions
+
+instance ToSchema CCategoryInfoEdit where
+  declareNamedSchema = genericDeclareNamedSchema schemaOptions
+
+instance ToSchema ItemSection where
+  declareNamedSchema = genericDeclareNamedSchema schemaOptions
+
+-- | A lightweight info type about an 'Item'.
+--
+-- When updating it, don't forget to also update 'setItemInfo'.
 data CItemInfo = CItemInfo
  { ciiUid     :: Uid Item   ? "Item ID"
  , ciiName    :: Text       ? "Item name"
@ -278,6 +336,9 @@ data CItemInfo = CItemInfo
 instance A.ToJSON CItemInfo where
  toJSON = A.genericToJSON jsonOptions

+instance A.FromJSON CItemInfo where
+  parseJSON = A.genericParseJSON jsonOptions
+
 instance ToSchema CItemInfo where
  declareNamedSchema = genericDeclareNamedSchema schemaOptions

--- a/src/Guide/Api/Utils.hs
+++ b/src/Guide/Api/Utils.hs
@ -12,6 +12,7 @@ module Guide.Api.Utils
  ( jsonOptions
  , schemaOptions
  , type (?)(..)
+  , unH
  , BranchTag
  ) where

@ -48,6 +49,9 @@ newtype (?) (field :: *) (help :: Symbol) = H field
 instance ToJSON field => ToJSON (field ? help) where
  toJSON (H a) = toJSON a

+instance FromJSON field => FromJSON (field ? help) where
+    parseJSON f = H <$> parseJSON f
+
 instance (KnownSymbol help, ToSchema a) => ToSchema (a ? help) where
  declareNamedSchema _ = do
    NamedSchema _ s <- declareNamedSchema (Proxy @a)
@ -58,6 +62,10 @@ instance (KnownSymbol help, ToSchema a) => ToSchema (a ? help) where
 instance {-# OVERLAPPING #-} (KnownSymbol help, Selector s, ToSchema c) => GToSchema (S1 s (K1 i (Maybe c ? help))) where
  gdeclareNamedSchema opts _ = fmap unnamed . withFieldSchema opts (Proxy2 :: Proxy2 s (K1 i (Maybe c ? help))) False

+-- | Unwrapper for @field '?' help@
+unH :: forall field help . (field ? help) -> field
+unH (H field) = field
+
 -- | A way to name branches of Swagger API.
 --
 -- Taken from <https://github.com/haskell-servant/servant-swagger/issues/73>
--- a/src/Guide/State.hs
+++ b/src/Guide/State.hs
@ -34,7 +34,7 @@ module Guide.State
  GetCategories(..),
  GetCategory(..), GetCategoryMaybe(..),
  GetCategoryByItem(..),
-  GetItem(..),
+  GetItem(..), GetItemMaybe (..),
  GetTrait(..),

  -- ** add
@ -56,6 +56,7 @@ module Guide.State
  SetItemLink(..),
  SetItemGroup(..),
  SetItemKind(..),
+--   SetItemHackage(..),
  SetItemDescription(..),
  SetItemNotes(..),
  SetItemEcosystem(..),
@ -333,6 +334,9 @@ getCategoryByItem uid' = findCategoryByItem uid' <$> ask
 getItem :: Uid Item -> Acid.Query GlobalState Item
 getItem uid' = view (itemById uid')

+getItemMaybe :: Uid Item -> Acid.Query GlobalState (Maybe Item)
+getItemMaybe uid' = preview (itemById uid')
+
 -- TODO: this doesn't need the item id, but then we have to be a bit cleverer
 -- and store a (TraitId -> ItemId) map in global state (and update it
 -- accordingly whenever anything happens, so perhaps let's not do it!)
@ -389,6 +393,7 @@ addItem catId itemId name' created' kind' = do
                           in  toMarkdownTree pref "",
        _itemLink        = Nothing,
        _itemKind        = kind'}
+        -- _itemHackage     = Nothing }
  categoryById catId . items %= (++ [newItem])
  let edit = Edit'AddItem catId itemId name'
  return (edit, newItem)
@ -511,6 +516,12 @@ setItemKind itemId kind' = do
  let edit = Edit'SetItemKind itemId oldKind kind'
  (edit,) <$> use (itemById itemId)

+-- setItemHackage :: Uid Item -> Maybe Text -> Acid.Update GlobalState (Edit, Item)
+-- setItemHackage itemId hackage' = do
+--     oldName <- itemById itemId . hackage <<.= hackage'
+--     let edit = Edit'SetItemHackage itemId oldName hackage'
+--     (edit,) <$> use (itemById itemId)
+
 setItemDescription :: Uid Item -> Text -> Acid.Update GlobalState (Edit, Item)
 setItemDescription itemId description' = do
  oldDescr <- itemById itemId . description <<.=
@ -874,7 +885,7 @@ makeAcidic ''GlobalState [
  'getCategories,
  'getCategory, 'getCategoryMaybe,
  'getCategoryByItem,
-  'getItem,
+  'getItem, 'getItemMaybe,
  'getTrait,
  -- add
  'addCategory,
@ -884,7 +895,7 @@ makeAcidic ''GlobalState [
  'setGlobalState,
  'setCategoryTitle, 'setCategoryGroup, 'setCategoryNotes, 'setCategoryStatus,
    'changeCategoryEnabledSections,
-  'setItemName, 'setItemLink, 'setItemGroup, 'setItemKind,
+  'setItemName, 'setItemLink, 'setItemGroup, 'setItemKind, --'setItemHackage,
    'setItemDescription, 'setItemNotes, 'setItemEcosystem,
  'setTraitContent,
  -- delete
--- a/src/Guide/Types/Core.hs
+++ b/src/Guide/Types/Core.hs
@ -3,6 +3,7 @@
 {-# LANGUAGE FlexibleInstances   #-}
 {-# LANGUAGE OverloadedStrings   #-}
 {-# LANGUAGE QuasiQuotes         #-}
+{-# LANGUAGE ScopedTypeVariables #-}
 {-# LANGUAGE TypeFamilies        #-}


@ -131,6 +132,14 @@ instance A.ToJSON ItemKind where
  toJSON Other = A.object [
    "tag"      A..= ("Other" :: Text) ]

+instance A.FromJSON ItemKind where
+  parseJSON = A.withObject "ItemKind" $ \o ->
+      o A..: "tag" >>= \case
+        ("Library" :: Text) -> Library <$> o A..: "contents"
+        "Tool"    -> Tool <$> o A..: "contents"
+        "Other"   -> pure Other
+        tag       -> fail ("unknown tag " ++ show tag)
+
 data ItemKind_v2
  = Library_v2 (Maybe Text)
  | Tool_v2 (Maybe Text)
@ -158,6 +167,9 @@ deriveSafeCopySimple 0 'base ''ItemSection
 instance A.ToJSON ItemSection where
  toJSON = A.genericToJSON A.defaultOptions

+instance A.FromJSON ItemSection where
+  parseJSON = A.genericParseJSON A.defaultOptions
+
 -- TODO: add a field like “people to ask on IRC about this library if you
 -- need help”

@ -206,6 +218,9 @@ deriveSafeCopySimple 2 'extension ''CategoryStatus
 instance A.ToJSON CategoryStatus where
  toJSON = A.genericToJSON A.defaultOptions

+instance A.FromJSON CategoryStatus where
+  parseJSON = A.genericParseJSON A.defaultOptions
+
 data CategoryStatus_v1
  = CategoryStub_v1
  | CategoryWIP_v1
--- a/src/Guide/Utils.hs
+++ b/src/Guide/Utils.hs
@ -315,6 +315,9 @@ newtype Uid a = Uid {uidToText :: Text}
 instance A.ToJSON (Uid a) where
  toJSON = A.toJSON . uidToText

+instance A.FromJSON (Uid a) where
+  parseJSON a = Uid <$> A.parseJSON a
+
 -- This instance is written manually because otherwise it produces a warning:
 --     • Redundant constraint: SafeCopy a
 --     • In the instance declaration for ‘SafeCopy (Uid a)’