diff --git a/src/Guide/Api/Methods.hs b/src/Guide/Api/Methods.hs index 1b2d4f8..a017d69 100644 --- 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,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) - pure NoContent - -- TODO mapM_ addEdit mbEdit + 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 ---------------------------------------------------------------------------- -- 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 - -- already deleted) - itemId <- randomShortUid - -- If the item name looks like a Hackage library, assume it's a Hackage - -- library. - let isAllowedChar c = isAscii c && (isAlphaNum c || c == '-') - looksLikeLibrary = T.all isAllowedChar name' - kind' = if looksLikeLibrary then Library (Just name') else Other - time <- liftIO getCurrentTime - (_edit, _newItem) <- dbUpdate db (AddItem catId itemId name' time kind') - invalidateCache' db (CacheItem itemId) - -- TODO: addEdit edit - pure itemId + 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. + let isAllowedChar c = isAscii c && (isAlphaNum c || c == '-') + looksLikeLibrary = T.all isAllowedChar name' + kind' = if looksLikeLibrary then Library (Just name') else Other + time <- liftIO getCurrentTime + (_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 - (_edit, _newTrait) <- case traitType of - Con -> dbUpdate db (AddCon itemId traitId text) - Pro -> dbUpdate db (AddPro itemId traitId text) - invalidateCache' db (CacheItemTraits itemId) --- TODO: mapM_ addEdit mbEdit - pure traitId + 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) + Pro -> dbUpdate db (AddPro itemId traitId text) + invalidateCache' db (CacheItemTraits itemId) + -- 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) - pure NoContent + (_edit, _newTrait) <- dbUpdate db (SetTraitContent itemId traitId text) + -- TODO diff and merge + pure NoContent -- | Delete a trait (pro/con). deleteTrait :: DB -> Uid Item -> Uid Trait -> Handler NoContent diff --git a/src/Guide/Api/Server.hs b/src/Guide/Api/Server.hs index f3873ca..600114b 100644 --- a/src/Guide/Api/Server.hs +++ b/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 - , _getCategory = getCategory db - , _createCategory = createCategory db - , _deleteCategory = deleteCategory db } + { _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) diff --git a/src/Guide/Api/Types.hs b/src/Guide/Api/Types.hs index 29ed01e..c8aef1f 100644 --- 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 diff --git a/src/Guide/Api/Utils.hs b/src/Guide/Api/Utils.hs index b388dc4..eedcdfb 100644 --- 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 diff --git a/src/Guide/State.hs b/src/Guide/State.hs index 145b8ca..890db4b 100644 --- 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!) @@ -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 diff --git a/src/Guide/Types/Core.hs b/src/Guide/Types/Core.hs index 9212157..2fa3120 100644 --- a/src/Guide/Types/Core.hs +++ b/src/Guide/Types/Core.hs @@ -1,9 +1,10 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE FlexibleContexts #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE QuasiQuotes #-} -{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# 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 diff --git a/src/Guide/Utils.hs b/src/Guide/Utils.hs index dee8f53..7eacaa2 100644 --- 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)’