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>

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,10 +46,12 @@ 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'
-                     && T.toCaseFold (cat^.group_) == T.toCaseFold group'
+        && T.toCaseFold (cat^.group_) == T.toCaseFold group'
   case find isDuplicate cats of
     Just c  -> return (c^.uid)
     Nothing -> do
@@ -58,12 +62,43 @@ 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
-  _mbEdit <- dbUpdate db (DeleteCategory catId)
+  dbQuery db (GetCategoryMaybe catId) >>= \case
-  pure NoContent
+    Nothing -> throwError (err404 {errBody = "Category not found"})
-  -- TODO mapM_ addEdit mbEdit
+    Just _ -> do
+      _mbEdit <- dbUpdate db (DeleteCategory catId)
+      pure NoContent
+      -- TODO mapM_ addEdit mbEdit
 
 ----------------------------------------------------------------------------
 -- Items
@@ -75,22 +110,38 @@ 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
+  dbQuery db (GetCategoryMaybe catId) >>= \case
-  -- already deleted)
+    Nothing -> throwError (err404 {errBody = "Category not found"})
-  itemId <- randomShortUid
+    Just _ -> do
-  -- If the item name looks like a Hackage library, assume it's a Hackage
+      if T.null name' then throwError (err400 {errBody = "Name not provided"})
-  -- library.
+      else do
-  let isAllowedChar c = isAscii c && (isAlphaNum c || c == '-')
+        itemId <- randomShortUid
-      looksLikeLibrary = T.all isAllowedChar name'
+        -- If the item name looks like a Hackage library, assume it's a Hackage
-      kind' = if looksLikeLibrary then Library (Just name') else Other
+        -- library.
-  time <- liftIO getCurrentTime
+        let isAllowedChar c = isAscii c && (isAlphaNum c || c == '-')
-  (_edit, _newItem) <- dbUpdate db (AddItem catId itemId name' time kind')
+            looksLikeLibrary = T.all isAllowedChar name'
-  invalidateCache' db (CacheItem itemId)
+            kind' = if looksLikeLibrary then Library (Just name') else Other
-  -- TODO: addEdit edit
+        time <- liftIO getCurrentTime
-  pure itemId
+        (_edit, _newItem) <- dbUpdate db (AddItem catId itemId name' time kind')
+        invalidateCache' db (CacheItem itemId)
+        -- TODO: addEdit edit
+        pure itemId
 
 -- 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,19 +158,21 @@ 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
-    traitId <- randomShortUid
+  when (T.null text) $ throwError (err400 {errBody = "Trait text not provided"})
-    (_edit, _newTrait) <- case traitType of
+  traitId <- randomShortUid
-        Con -> dbUpdate db (AddCon itemId traitId text)
+  (_edit, _newTrait) <- case traitType of
-        Pro -> dbUpdate db (AddPro itemId traitId text)
+    Con -> dbUpdate db (AddCon itemId traitId text)
-    invalidateCache' db (CacheItemTraits itemId)
+    Pro -> dbUpdate db (AddPro itemId traitId text)
--- TODO: mapM_ addEdit mbEdit
+  invalidateCache' db (CacheItemTraits itemId)
-    pure traitId
+  -- TODO: mapM_ addEdit mbEdit
+  pure traitId
 
 -- | Update the text of a trait (pro/con).
 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)
+  (_edit, _newTrait) <- dbUpdate db (SetTraitContent itemId traitId text)
-    pure NoContent
+  -- TODO diff and merge
+  pure NoContent
 
 -- | Delete a trait (pro/con).
 deleteTrait :: DB -> Uid Item -> Uid Trait -> Handler NoContent

src/Guide/Api/Server.hs

@@ -35,14 +35,17 @@ import Data.Acid as Acid
 apiServer :: DB -> Site AsServer
 apiServer db = Site
   { _categorySite = toServant (CategorySite
-      { _getCategories  = getCategories db
+      { _getCategories    = getCategories db
-      , _getCategory    = getCategory db
+      , _getCategory      = getCategory db
-      , _createCategory = createCategory db
+      , _createCategory   = createCategory db
-      , _deleteCategory = deleteCategory 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)
 

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
 

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>

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!)
@@ -388,7 +392,8 @@ addItem catId itemId name' created' kind' = do
         _itemNotes       = let pref = "item-notes-" <> uidToText itemId <> "-"
                            in  toMarkdownTree pref "",
         _itemLink        = Nothing,
-        _itemKind        = kind' }
+        _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

src/Guide/Types/Core.hs

@@ -1,9 +1,10 @@
-{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE DeriveDataTypeable  #-}
-{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE FlexibleContexts    #-}
-{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE FlexibleInstances   #-}
-{-# LANGUAGE OverloadedStrings  #-}
+{-# LANGUAGE OverloadedStrings   #-}
-{-# LANGUAGE QuasiQuotes        #-}
+{-# LANGUAGE QuasiQuotes         #-}
-{-# LANGUAGE TypeFamilies       #-}
+{-# 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

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)’