From 076feaf37f769f35da7585638d9962272dc768be Mon Sep 17 00:00:00 2001 From: Artyom Date: Tue, 31 Jan 2017 00:33:13 +0300 Subject: [PATCH] Split handlers out of Guide.Server --- guide.cabal | 2 + src/Guide/Handlers.hs | 427 +++++++++++++++++++++++++ src/Guide/Server.hs | 657 +-------------------------------------- src/Guide/ServerStuff.hs | 330 ++++++++++++++++++++ 4 files changed, 762 insertions(+), 654 deletions(-) create mode 100644 src/Guide/Handlers.hs create mode 100644 src/Guide/ServerStuff.hs diff --git a/guide.cabal b/guide.cabal index 9a83c97..1a49628 100644 --- a/guide.cabal +++ b/guide.cabal @@ -45,6 +45,7 @@ executable guide library exposed-modules: Guide.Server + Guide.ServerStuff Guide.Config Guide.State Guide.Types @@ -52,6 +53,7 @@ library Guide.Types.Core Guide.Types.Edit Guide.Types.Action + Guide.Handlers Guide.Utils Guide.Merge Guide.Cache diff --git a/src/Guide/Handlers.hs b/src/Guide/Handlers.hs new file mode 100644 index 0000000..866bf6b --- /dev/null +++ b/src/Guide/Handlers.hs @@ -0,0 +1,427 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE ScopedTypeVariables #-} + + +module Guide.Handlers +( + methods, + adminMethods, +) +where + + +import Imports + +-- Containers +import qualified Data.Map as M +-- Feeds +import qualified Text.Feed.Types as Feed +import qualified Text.Feed.Util as Feed +import qualified Text.Atom.Feed as Atom +-- Text +import qualified Data.Text.All as T +import qualified Data.Text.Lazy.All as TL +-- Web +import Web.Spock hiding (head, get, text) +import qualified Web.Spock as Spock +import Web.Spock.Lucid +import Lucid hiding (for_) +import qualified Network.HTTP.Types.Status as HTTP + +import Guide.ServerStuff +import Guide.Config +import Guide.Cache +import Guide.Merge +import Guide.Markdown +import Guide.State +import Guide.Types +import Guide.Utils +import Guide.View + + +methods :: SpockM () () ServerState () +methods = do + renderMethods + setMethods + addMethods + otherMethods + +renderMethods :: SpockM () () ServerState () +renderMethods = Spock.subcomponent "render" $ do + -- Notes for a category + Spock.get (categoryVar "notes") $ \catId -> do + category <- dbQuery (GetCategory catId) + lucidIO $ renderCategoryNotes category + -- Item colors + Spock.get (itemVar "colors") $ \itemId -> do + item <- dbQuery (GetItem itemId) + category <- dbQuery (GetCategoryByItem itemId) + let hue = getItemHue category item + json $ M.fromList [("light" :: Text, hueToLightColor hue), + ("dark" :: Text, hueToDarkColor hue)] + -- Item info + Spock.get (itemVar "info") $ \itemId -> do + item <- dbQuery (GetItem itemId) + category <- dbQuery (GetCategoryByItem itemId) + lucidIO $ renderItemInfo category item + -- Item description + Spock.get (itemVar "description") $ \itemId -> do + item <- dbQuery (GetItem itemId) + lucidIO $ renderItemDescription item + -- Item ecosystem + Spock.get (itemVar "ecosystem") $ \itemId -> do + item <- dbQuery (GetItem itemId) + lucidIO $ renderItemEcosystem item + -- Item notes + Spock.get (itemVar "notes") $ \itemId -> do + item <- dbQuery (GetItem itemId) + category <- dbQuery (GetCategoryByItem itemId) + lucidIO $ renderItemNotes category item + +setMethods :: SpockM () () ServerState () +setMethods = Spock.subcomponent "set" $ do + Spock.post (categoryVar "info") $ \catId -> do + -- TODO: [easy] add a cross-link saying where the form is handled in the + -- code and other notes saying where stuff is rendered, etc + title' <- T.strip <$> param' "title" + group' <- T.strip <$> param' "group" + prosConsEnabled' <- (Just ("on" :: Text) ==) <$> + param "pros-cons-enabled" + ecosystemEnabled' <- (Just ("on" :: Text) ==) <$> + param "ecosystem-enabled" + notesEnabled' <- (Just ("on" :: Text) ==) <$> + param "notes-enabled" + status' <- do + statusName :: Text <- param' "status" + return $ case statusName of + "finished" -> CategoryFinished + "wip" -> CategoryWIP + "stub" -> CategoryStub + other -> error ("unknown category status: " ++ show other) + -- Modify the category + -- TODO: actually validate the form and report errors + uncache (CacheCategoryInfo catId) $ do + unless (T.null title') $ do + (edit, _) <- dbUpdate (SetCategoryTitle catId title') + addEdit edit + unless (T.null group') $ do + (edit, _) <- dbUpdate (SetCategoryGroup catId group') + addEdit edit + do (edit, _) <- dbUpdate (SetCategoryStatus catId status') + addEdit edit + do (edit, _) <- dbUpdate $ + SetCategoryProsConsEnabled catId prosConsEnabled' + addEdit edit + do (edit, _) <- dbUpdate $ + SetCategoryEcosystemEnabled catId ecosystemEnabled' + addEdit edit + do (edit, _) <- dbUpdate $ + SetCategoryNotesEnabled catId notesEnabled' + addEdit edit + -- After all these edits we can render the category header + category <- dbQuery (GetCategory catId) + lucidIO $ renderCategoryInfo category + -- Notes for a category + Spock.post (categoryVar "notes") $ \catId -> do + original <- param' "original" + content' <- param' "content" + modified <- view (notes.mdText) <$> dbQuery (GetCategory catId) + if modified == original + then do + category <- uncache (CacheCategoryNotes catId) $ do + (edit, category) <- dbUpdate (SetCategoryNotes catId content') + addEdit edit + return category + lucidIO $ renderCategoryNotes category + else do + setStatus HTTP.status409 + json $ M.fromList [ + ("modified" :: Text, modified), + ("merged" :: Text, merge original content' modified)] + -- Item info + Spock.post (itemVar "info") $ \itemId -> do + -- TODO: [easy] add a cross-link saying where the form is handled in the + -- code and other notes saying where stuff is rendered, etc + name' <- T.strip <$> param' "name" + link' <- T.strip <$> param' "link" + kind' <- do + kindName :: Text <- param' "kind" + hackageName' <- (\x -> if T.null x then Nothing else Just x) <$> + param' "hackage-name" + return $ case kindName of + "library" -> Library hackageName' + "tool" -> Tool hackageName' + _ -> Other + group' <- do + groupField <- param' "group" + customGroupField <- param' "custom-group" + return $ case groupField of + "-" -> Nothing + "" -> Just customGroupField + _ -> Just groupField + -- Modify the item + -- TODO: actually validate the form and report errors + -- (don't forget to check that custom-group ≠ "") + uncache (CacheItemInfo itemId) $ do + unless (T.null name') $ do + (edit, _) <- dbUpdate (SetItemName itemId name') + addEdit edit + case (T.null link', sanitiseUrl link') of + (True, _) -> do + (edit, _) <- dbUpdate (SetItemLink itemId Nothing) + addEdit edit + (_, Just l) -> do + (edit, _) <- dbUpdate (SetItemLink itemId (Just l)) + addEdit edit + _otherwise -> + return () + do (edit, _) <- dbUpdate (SetItemKind itemId kind') + addEdit edit + -- This does all the work of assigning new colors, etc. automatically + do (edit, _) <- dbUpdate (SetItemGroup itemId group') + addEdit edit + -- After all these edits we can render the item + item <- dbQuery (GetItem itemId) + category <- dbQuery (GetCategoryByItem itemId) + lucidIO $ renderItemInfo category item + -- Item description + Spock.post (itemVar "description") $ \itemId -> do + original <- param' "original" + content' <- param' "content" + modified <- view (description.mdText) <$> dbQuery (GetItem itemId) + if modified == original + then do + item <- uncache (CacheItemDescription itemId) $ do + (edit, item) <- dbUpdate (SetItemDescription itemId content') + addEdit edit + return item + lucidIO $ renderItemDescription item + else do + setStatus HTTP.status409 + json $ M.fromList [ + ("modified" :: Text, modified), + ("merged" :: Text, merge original content' modified)] + -- Item ecosystem + Spock.post (itemVar "ecosystem") $ \itemId -> do + original <- param' "original" + content' <- param' "content" + modified <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId) + if modified == original + then do + item <- uncache (CacheItemEcosystem itemId) $ do + (edit, item) <- dbUpdate (SetItemEcosystem itemId content') + addEdit edit + return item + lucidIO $ renderItemEcosystem item + else do + setStatus HTTP.status409 + json $ M.fromList [ + ("modified" :: Text, modified), + ("merged" :: Text, merge original content' modified)] + -- Item notes + Spock.post (itemVar "notes") $ \itemId -> do + original <- param' "original" + content' <- param' "content" + modified <- view (notes.mdText) <$> dbQuery (GetItem itemId) + if modified == original + then do + item <- uncache (CacheItemNotes itemId) $ do + (edit, item) <- dbUpdate (SetItemNotes itemId content') + addEdit edit + return item + category <- dbQuery (GetCategoryByItem itemId) + lucidIO $ renderItemNotes category item + else do + setStatus HTTP.status409 + json $ M.fromList [ + ("modified" :: Text, modified), + ("merged" :: Text, merge original content' modified)] + -- Trait + Spock.post (itemVar traitVar) $ \itemId traitId -> do + original <- param' "original" + content' <- param' "content" + modified <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId) + if modified == original + then do + trait <- uncache (CacheItemTraits itemId) $ do + (edit, trait) <- dbUpdate (SetTraitContent itemId traitId content') + addEdit edit + return trait + lucidIO $ renderTrait itemId trait + else do + setStatus HTTP.status409 + json $ M.fromList [ + ("modified" :: Text, modified), + ("merged" :: Text, merge original content' modified)] + +addMethods :: SpockM () () ServerState () +addMethods = Spock.subcomponent "add" $ do + -- New category + Spock.post "category" $ do + title' <- param' "content" + -- If the category exists already, don't create it + cats <- view categories <$> dbQuery GetGlobalState + let hasSameTitle cat = T.toCaseFold (cat^.title) == T.toCaseFold title' + category <- case find hasSameTitle cats of + Just c -> return c + Nothing -> do + catId <- randomShortUid + time <- liftIO getCurrentTime + (edit, newCategory) <- dbUpdate (AddCategory catId title' time) + invalidateCache' (CacheCategory catId) + addEdit edit + return newCategory + -- And now send the URL of the new (or old) category + Spock.text ("/haskell/" <> categorySlug category) + + -- New item in a category + Spock.post (categoryVar "item") $ \catId -> do + name' <- param' "name" + -- 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 (AddItem catId itemId name' time kind') + invalidateCache' (CacheItem itemId) + addEdit edit + category <- dbQuery (GetCategory catId) + lucidIO $ renderItem category newItem + -- Pro (argument in favor of an item) + Spock.post (itemVar "pro") $ \itemId -> do + content' <- param' "content" + traitId <- randomLongUid + (edit, newTrait) <- dbUpdate (AddPro itemId traitId content') + invalidateCache' (CacheItemTraits itemId) + addEdit edit + lucidIO $ renderTrait itemId newTrait + -- Con (argument against an item) + Spock.post (itemVar "con") $ \itemId -> do + content' <- param' "content" + traitId <- randomLongUid + (edit, newTrait) <- dbUpdate (AddCon itemId traitId content') + invalidateCache' (CacheItemTraits itemId) + addEdit edit + lucidIO $ renderTrait itemId newTrait + +otherMethods :: SpockM () () ServerState () +otherMethods = do + -- Moving things + Spock.subcomponent "move" $ do + -- Move item + Spock.post itemVar $ \itemId -> do + direction :: Text <- param' "direction" + uncache (CacheItem itemId) $ do + edit <- dbUpdate (MoveItem itemId (direction == "up")) + addEdit edit + -- Move trait + Spock.post (itemVar traitVar) $ \itemId traitId -> do + direction :: Text <- param' "direction" + uncache (CacheItemTraits itemId) $ do + edit <- dbUpdate (MoveTrait itemId traitId (direction == "up")) + addEdit edit + + -- Deleting things + Spock.subcomponent "delete" $ do + -- Delete category + Spock.post categoryVar $ \catId -> + uncache (CacheCategory catId) $ do + mbEdit <- dbUpdate (DeleteCategory catId) + mapM_ addEdit mbEdit + -- Delete item + Spock.post itemVar $ \itemId -> + uncache (CacheItem itemId) $ do + mbEdit <- dbUpdate (DeleteItem itemId) + mapM_ addEdit mbEdit + -- Delete trait + Spock.post (itemVar traitVar) $ \itemId traitId -> + uncache (CacheItemTraits itemId) $ do + mbEdit <- dbUpdate (DeleteTrait itemId traitId) + mapM_ addEdit mbEdit + + -- Feeds + -- TODO: this link shouldn't be absolute [absolute-links] + baseUrl <- ( "haskell") . T.unpack . _baseUrl <$> getConfig + Spock.subcomponent "feed" $ do + -- Feed for items in a category + Spock.get categoryVar $ \catId -> do + category <- dbQuery (GetCategory catId) + let sortedItems = reverse $ sortBy cmp (category^.items) + where cmp = comparing (^.created) <> comparing (^.uid) + let route = "feed" categoryVar + -- We use ++ instead of because the rendered route already has ‘/’ + -- in front of it, and if we used it'd just skip baseUrl + let feedUrl = baseUrl ++ T.unpack (renderRoute route (category^.uid)) + feedTitle = Atom.TextString (T.unpack (category^.title) ++ + " – Haskell – Aelve Guide") + feedLastUpdate = case sortedItems of + (item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created) + _ -> "" + let feedBase = Atom.nullFeed feedUrl feedTitle feedLastUpdate + entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems + atomFeed $ feedBase { + Atom.feedEntries = entries, + Atom.feedLinks = [Atom.nullLink feedUrl] } + +adminMethods :: SpockM () () ServerState () +adminMethods = Spock.subcomponent "admin" $ do + -- Accept an edit + Spock.post ("edit" var "accept") $ \n -> do + dbUpdate (RemovePendingEdit n) + return () + -- Undo an edit + Spock.post ("edit" var "undo") $ \n -> do + (edit, _) <- dbQuery (GetEdit n) + res <- undoEdit edit + case res of + Left err -> Spock.text (T.pack err) + Right () -> do invalidateCacheForEdit edit + dbUpdate (RemovePendingEdit n) + Spock.text "" + -- Accept a range of edits + Spock.post ("edits" var var "accept") $ \m n -> do + dbUpdate (RemovePendingEdits m n) + -- Undo a range of edits + Spock.post ("edits" var var "undo") $ \m n -> do + edits <- dbQuery (GetEdits m n) + s <- dbQuery GetGlobalState + failed <- fmap catMaybes $ for edits $ \(edit, details) -> do + res <- undoEdit edit + case res of + Left err -> return (Just ((edit, details), Just err)) + Right () -> do invalidateCacheForEdit edit + dbUpdate (RemovePendingEdit (editId details)) + return Nothing + case failed of + [] -> Spock.text "" + _ -> lucidIO $ renderEdits s failed + -- Create a checkpoint + Spock.post "create-checkpoint" $ do + db <- _db <$> Spock.getState + createCheckpoint' db + +---------------------------------------------------------------------------- +-- Utils +---------------------------------------------------------------------------- + +itemToFeedEntry + :: (MonadIO m) + => String -> Category -> Item -> m Atom.Entry +itemToFeedEntry baseUrl category item = do + entryContent <- Lucid.renderTextT (renderItemForFeed category item) + return entryBase { + Atom.entryLinks = [Atom.nullLink entryLink], + Atom.entryContent = Just (Atom.HTMLContent (TL.unpack entryContent)) } + where + entryLink = baseUrl + T.unpack (T.format "{}#item-{}" + (categorySlug category, item^.uid)) + entryBase = Atom.nullEntry + (T.unpack (uidToText (item^.uid))) + (Atom.TextString (T.unpack (item^.name))) + (Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)) diff --git a/src/Guide/Server.hs b/src/Guide/Server.hs index 8041fe1..7920efd 100644 --- a/src/Guide/Server.hs +++ b/src/Guide/Server.hs @@ -16,24 +16,16 @@ import Imports -- Monads and monad transformers import Control.Monad.Morph --- Containers -import qualified Data.Map as M -- Text import qualified Data.Text.All as T -import qualified Data.Text.Lazy.All as TL -- Web import Web.Spock hiding (head, get, text) import qualified Web.Spock as Spock import Web.Spock.Config -import Web.Routing.Combinators (PathState(..)) import Web.Spock.Lucid import Lucid hiding (for_) import Network.Wai.Middleware.Static (staticPolicy, addBase) import qualified Network.HTTP.Types.Status as HTTP --- Feeds -import qualified Text.Feed.Types as Feed -import qualified Text.Feed.Util as Feed -import qualified Text.Atom.Feed as Atom -- Highlighting import CMark.Highlight (styleToCss, pygments) -- Monitoring @@ -48,15 +40,15 @@ import qualified SlaveThread as Slave -- Watching the templates directory import qualified System.FSNotify as FSNotify +import Guide.ServerStuff +import Guide.Handlers import Guide.Config import Guide.State import Guide.Types import Guide.View import Guide.JS (JS(..), allJSFunctions) import Guide.Utils -import Guide.Markdown import Guide.Cache -import Guide.Merge {- Note [acid-state] @@ -100,637 +92,6 @@ acid-state. Acid-state works as follows: -} --- | A pointer to an open acid-state database (allows making queries/updates, --- creating checkpoints, etc). -type DB = AcidState GlobalState - --- | Update something in the database. Don't forget to 'invalidateCache' or --- use 'uncache' when you update something that is cached. -dbUpdate :: (MonadIO m, HasSpock m, SpockState m ~ ServerState, - EventState event ~ GlobalState, UpdateEvent event) - => event -> m (EventResult event) -dbUpdate x = do - db <- _db <$> Spock.getState - liftIO $ do - Acid.update db SetDirty - Acid.update db x - --- | Read something from the database. -dbQuery :: (MonadIO m, HasSpock m, SpockState m ~ ServerState, - EventState event ~ GlobalState, QueryEvent event) - => event -> m (EventResult event) -dbQuery x = do - db <- _db <$> Spock.getState - liftIO $ Acid.query db x - ------------------------------------------------------------------------------- --- Server state ------------------------------------------------------------------------------- - -data ServerState = ServerState { - _config :: Config, - _db :: DB } - -getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState) - => m Config -getConfig = _config <$> Spock.getState - -itemVar :: Path '[Uid Item] 'Open -itemVar = "item" var - -categoryVar :: Path '[Uid Category] 'Open -categoryVar = "category" var - -traitVar :: Path '[Uid Trait] 'Open -traitVar = "trait" var - --- | Do a database-modifying action and invalidate the cache /afterwards/. --- --- To invalidate the cache properly, we use global state – for instance, if --- item X belongs to category Y, and the item is deleted, we have to --- invalidate the cache for the category (and for that we need to look at the --- global state and find out which category has item X). However, we have to --- use the state from /before/ the item is deleted – otherwise we'll think --- that no category had the item. --- --- Note: if you delete or modify something, wrap it into 'uncache'. However, --- if you /add/ something, use 'invalidateCache'': --- --- >>> addItem --- >>> invalidateCache' (CacheItem ...) -uncache - :: (MonadIO m, HasSpock (ActionCtxT ctx m), - SpockState (ActionCtxT ctx m) ~ ServerState) - => CacheKey -> ActionCtxT ctx m a -> ActionCtxT ctx m a -uncache key act = do - gs <- dbQuery GetGlobalState - x <- act - invalidateCache gs key - return x - -invalidateCache' - :: (MonadIO m, HasSpock (ActionCtxT ctx m), - SpockState (ActionCtxT ctx m) ~ ServerState) - => CacheKey -> ActionCtxT ctx m () -invalidateCache' key = do - gs <- dbQuery GetGlobalState - invalidateCache gs key - --- | Remember an edit. --- --- Call this whenever any user-made change is applied to the database. -addEdit :: (MonadIO m, HasSpock (ActionCtxT ctx m), - SpockState (ActionCtxT ctx m) ~ ServerState) - => Edit -> ActionCtxT ctx m () -addEdit ed = do - (time, mbIP, mbReferrer, mbUA) <- getRequestDetails - unless (isVacuousEdit ed) $ do - dbUpdate (RegisterEdit ed mbIP time) - baseUrl <- _baseUrl <$> getConfig - dbUpdate (RegisterAction (Action'Edit ed) - mbIP time baseUrl mbReferrer mbUA) - -invalidateCacheForEdit - :: (MonadIO m, HasSpock m, SpockState m ~ ServerState) - => Edit -> m () -invalidateCacheForEdit ed = do - gs <- dbQuery GetGlobalState - mapM_ (invalidateCache gs) $ case ed of - Edit'AddCategory catId _ -> - [CacheCategory catId] - -- Normally invalidateCache should invalidate item's category - -- automatically, but in this case it's *maybe* possible that the item - -- has already been moved somewhere else and so we invalidate both just - -- in case. - Edit'AddItem catId itemId _ -> - [CacheCategory catId, CacheItem itemId] - Edit'AddPro itemId _ _ -> - [CacheItemTraits itemId] - Edit'AddCon itemId _ _ -> - [CacheItemTraits itemId] - Edit'SetCategoryTitle catId _ _ -> - [CacheCategoryInfo catId] - Edit'SetCategoryGroup catId _ _ -> - [CacheCategoryInfo catId] - Edit'SetCategoryStatus catId _ _ -> - [CacheCategoryInfo catId] - Edit'SetCategoryProsConsEnabled catId _ _ -> - [CacheCategoryInfo catId] - Edit'SetCategoryEcosystemEnabled catId _ _ -> - [CacheCategoryInfo catId] - Edit'SetCategoryNotesEnabled catId _ _ -> - [CacheCategoryInfo catId] - Edit'SetCategoryNotes catId _ _ -> - [CacheCategoryNotes catId] - Edit'SetItemName itemId _ _ -> - [CacheItemInfo itemId] - Edit'SetItemLink itemId _ _ -> - [CacheItemInfo itemId] - Edit'SetItemGroup itemId _ _ -> - [CacheItemInfo itemId] - Edit'SetItemKind itemId _ _ -> - [CacheItemInfo itemId] - Edit'SetItemDescription itemId _ _ -> - [CacheItemDescription itemId] - Edit'SetItemNotes itemId _ _ -> - [CacheItemNotes itemId] - Edit'SetItemEcosystem itemId _ _ -> - [CacheItemEcosystem itemId] - Edit'SetTraitContent itemId _ _ _ -> - [CacheItemTraits itemId] - Edit'DeleteCategory catId _ -> - [CacheCategory catId] - Edit'DeleteItem itemId _ -> - [CacheItem itemId] - Edit'DeleteTrait itemId _ _ -> - [CacheItemTraits itemId] - Edit'MoveItem itemId _ -> - [CacheItem itemId] - Edit'MoveTrait itemId _ _ -> - [CacheItemTraits itemId] - --- | Do an action that would undo an edit. --- --- 'Left' signifies failure. --- --- This doesn't do cache invalidation (you have to do it at the call site --- using 'invalidateCacheForEdit'). --- --- TODO: make this do cache invalidation. --- --- TODO: many of these don't work when the changed category/item/etc has been --- deleted; this should change. -undoEdit :: (MonadIO m, HasSpock m, SpockState m ~ ServerState) - => Edit -> m (Either String ()) -undoEdit (Edit'AddCategory catId _) = do - void <$> dbUpdate (DeleteCategory catId) -undoEdit (Edit'AddItem _catId itemId _) = do - void <$> dbUpdate (DeleteItem itemId) -undoEdit (Edit'AddPro itemId traitId _) = do - void <$> dbUpdate (DeleteTrait itemId traitId) -undoEdit (Edit'AddCon itemId traitId _) = do - void <$> dbUpdate (DeleteTrait itemId traitId) -undoEdit (Edit'SetCategoryTitle catId old new) = do - now <- view title <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "title has been changed further") - else Right () <$ dbUpdate (SetCategoryTitle catId old) -undoEdit (Edit'SetCategoryGroup catId old new) = do - now <- view group_ <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "group has been changed further") - else Right () <$ dbUpdate (SetCategoryGroup catId old) -undoEdit (Edit'SetCategoryStatus catId old new) = do - now <- view status <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "status has been changed further") - else Right () <$ dbUpdate (SetCategoryStatus catId old) -undoEdit (Edit'SetCategoryProsConsEnabled catId old new) = do - now <- view prosConsEnabled <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "pros-cons-enabled has been changed further") - else Right () <$ dbUpdate (SetCategoryProsConsEnabled catId old) -undoEdit (Edit'SetCategoryEcosystemEnabled catId old new) = do - now <- view ecosystemEnabled <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "ecosystem-enabled has been changed further") - else Right () <$ dbUpdate (SetCategoryEcosystemEnabled catId old) -undoEdit (Edit'SetCategoryNotesEnabled catId old new) = do - now <- view notesEnabled <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "notes-enabled has been changed further") - else Right () <$ dbUpdate (SetCategoryNotesEnabled catId old) -undoEdit (Edit'SetCategoryNotes catId old new) = do - now <- view (notes.mdText) <$> dbQuery (GetCategory catId) - if now /= new - then return (Left "notes have been changed further") - else Right () <$ dbUpdate (SetCategoryNotes catId old) -undoEdit (Edit'SetItemName itemId old new) = do - now <- view name <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "name has been changed further") - else Right () <$ dbUpdate (SetItemName itemId old) -undoEdit (Edit'SetItemLink itemId old new) = do - now <- view link <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "link has been changed further") - else Right () <$ dbUpdate (SetItemLink itemId old) -undoEdit (Edit'SetItemGroup itemId old new) = do - now <- view group_ <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "group has been changed further") - else Right () <$ dbUpdate (SetItemGroup itemId old) -undoEdit (Edit'SetItemKind itemId old new) = do - now <- view kind <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "kind has been changed further") - else Right () <$ dbUpdate (SetItemKind itemId old) -undoEdit (Edit'SetItemDescription itemId old new) = do - now <- view (description.mdText) <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "description has been changed further") - else Right () <$ dbUpdate (SetItemDescription itemId old) -undoEdit (Edit'SetItemNotes itemId old new) = do - now <- view (notes.mdText) <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "notes have been changed further") - else Right () <$ dbUpdate (SetItemNotes itemId old) -undoEdit (Edit'SetItemEcosystem itemId old new) = do - now <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId) - if now /= new - then return (Left "ecosystem has been changed further") - else Right () <$ dbUpdate (SetItemEcosystem itemId old) -undoEdit (Edit'SetTraitContent itemId traitId old new) = do - now <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId) - if now /= new - then return (Left "trait has been changed further") - else Right () <$ dbUpdate (SetTraitContent itemId traitId old) -undoEdit (Edit'DeleteCategory catId pos) = do - dbUpdate (RestoreCategory catId pos) -undoEdit (Edit'DeleteItem itemId pos) = do - dbUpdate (RestoreItem itemId pos) -undoEdit (Edit'DeleteTrait itemId traitId pos) = do - dbUpdate (RestoreTrait itemId traitId pos) -undoEdit (Edit'MoveItem itemId direction) = do - Right () <$ dbUpdate (MoveItem itemId (not direction)) -undoEdit (Edit'MoveTrait itemId traitId direction) = do - Right () <$ dbUpdate (MoveTrait itemId traitId (not direction)) - -renderMethods :: SpockM () () ServerState () -renderMethods = Spock.subcomponent "render" $ do - -- Notes for a category - Spock.get (categoryVar "notes") $ \catId -> do - category <- dbQuery (GetCategory catId) - lucidIO $ renderCategoryNotes category - -- Item colors - Spock.get (itemVar "colors") $ \itemId -> do - item <- dbQuery (GetItem itemId) - category <- dbQuery (GetCategoryByItem itemId) - let hue = getItemHue category item - json $ M.fromList [("light" :: Text, hueToLightColor hue), - ("dark" :: Text, hueToDarkColor hue)] - -- Item info - Spock.get (itemVar "info") $ \itemId -> do - item <- dbQuery (GetItem itemId) - category <- dbQuery (GetCategoryByItem itemId) - lucidIO $ renderItemInfo category item - -- Item description - Spock.get (itemVar "description") $ \itemId -> do - item <- dbQuery (GetItem itemId) - lucidIO $ renderItemDescription item - -- Item ecosystem - Spock.get (itemVar "ecosystem") $ \itemId -> do - item <- dbQuery (GetItem itemId) - lucidIO $ renderItemEcosystem item - -- Item notes - Spock.get (itemVar "notes") $ \itemId -> do - item <- dbQuery (GetItem itemId) - category <- dbQuery (GetCategoryByItem itemId) - lucidIO $ renderItemNotes category item - -setMethods :: SpockM () () ServerState () -setMethods = Spock.subcomponent "set" $ do - Spock.post (categoryVar "info") $ \catId -> do - -- TODO: [easy] add a cross-link saying where the form is handled in the - -- code and other notes saying where stuff is rendered, etc - title' <- T.strip <$> param' "title" - group' <- T.strip <$> param' "group" - prosConsEnabled' <- (Just ("on" :: Text) ==) <$> - param "pros-cons-enabled" - ecosystemEnabled' <- (Just ("on" :: Text) ==) <$> - param "ecosystem-enabled" - notesEnabled' <- (Just ("on" :: Text) ==) <$> - param "notes-enabled" - status' <- do - statusName :: Text <- param' "status" - return $ case statusName of - "finished" -> CategoryFinished - "wip" -> CategoryWIP - "stub" -> CategoryStub - other -> error ("unknown category status: " ++ show other) - -- Modify the category - -- TODO: actually validate the form and report errors - uncache (CacheCategoryInfo catId) $ do - unless (T.null title') $ do - (edit, _) <- dbUpdate (SetCategoryTitle catId title') - addEdit edit - unless (T.null group') $ do - (edit, _) <- dbUpdate (SetCategoryGroup catId group') - addEdit edit - do (edit, _) <- dbUpdate (SetCategoryStatus catId status') - addEdit edit - do (edit, _) <- dbUpdate $ - SetCategoryProsConsEnabled catId prosConsEnabled' - addEdit edit - do (edit, _) <- dbUpdate $ - SetCategoryEcosystemEnabled catId ecosystemEnabled' - addEdit edit - do (edit, _) <- dbUpdate $ - SetCategoryNotesEnabled catId notesEnabled' - addEdit edit - -- After all these edits we can render the category header - category <- dbQuery (GetCategory catId) - lucidIO $ renderCategoryInfo category - -- Notes for a category - Spock.post (categoryVar "notes") $ \catId -> do - original <- param' "original" - content' <- param' "content" - modified <- view (notes.mdText) <$> dbQuery (GetCategory catId) - if modified == original - then do - category <- uncache (CacheCategoryNotes catId) $ do - (edit, category) <- dbUpdate (SetCategoryNotes catId content') - addEdit edit - return category - lucidIO $ renderCategoryNotes category - else do - setStatus HTTP.status409 - json $ M.fromList [ - ("modified" :: Text, modified), - ("merged" :: Text, merge original content' modified)] - -- Item info - Spock.post (itemVar "info") $ \itemId -> do - -- TODO: [easy] add a cross-link saying where the form is handled in the - -- code and other notes saying where stuff is rendered, etc - name' <- T.strip <$> param' "name" - link' <- T.strip <$> param' "link" - kind' <- do - kindName :: Text <- param' "kind" - hackageName' <- (\x -> if T.null x then Nothing else Just x) <$> - param' "hackage-name" - return $ case kindName of - "library" -> Library hackageName' - "tool" -> Tool hackageName' - _ -> Other - group' <- do - groupField <- param' "group" - customGroupField <- param' "custom-group" - return $ case groupField of - "-" -> Nothing - "" -> Just customGroupField - _ -> Just groupField - -- Modify the item - -- TODO: actually validate the form and report errors - -- (don't forget to check that custom-group ≠ "") - uncache (CacheItemInfo itemId) $ do - unless (T.null name') $ do - (edit, _) <- dbUpdate (SetItemName itemId name') - addEdit edit - case (T.null link', sanitiseUrl link') of - (True, _) -> do - (edit, _) <- dbUpdate (SetItemLink itemId Nothing) - addEdit edit - (_, Just l) -> do - (edit, _) <- dbUpdate (SetItemLink itemId (Just l)) - addEdit edit - _otherwise -> - return () - do (edit, _) <- dbUpdate (SetItemKind itemId kind') - addEdit edit - -- This does all the work of assigning new colors, etc. automatically - do (edit, _) <- dbUpdate (SetItemGroup itemId group') - addEdit edit - -- After all these edits we can render the item - item <- dbQuery (GetItem itemId) - category <- dbQuery (GetCategoryByItem itemId) - lucidIO $ renderItemInfo category item - -- Item description - Spock.post (itemVar "description") $ \itemId -> do - original <- param' "original" - content' <- param' "content" - modified <- view (description.mdText) <$> dbQuery (GetItem itemId) - if modified == original - then do - item <- uncache (CacheItemDescription itemId) $ do - (edit, item) <- dbUpdate (SetItemDescription itemId content') - addEdit edit - return item - lucidIO $ renderItemDescription item - else do - setStatus HTTP.status409 - json $ M.fromList [ - ("modified" :: Text, modified), - ("merged" :: Text, merge original content' modified)] - -- Item ecosystem - Spock.post (itemVar "ecosystem") $ \itemId -> do - original <- param' "original" - content' <- param' "content" - modified <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId) - if modified == original - then do - item <- uncache (CacheItemEcosystem itemId) $ do - (edit, item) <- dbUpdate (SetItemEcosystem itemId content') - addEdit edit - return item - lucidIO $ renderItemEcosystem item - else do - setStatus HTTP.status409 - json $ M.fromList [ - ("modified" :: Text, modified), - ("merged" :: Text, merge original content' modified)] - -- Item notes - Spock.post (itemVar "notes") $ \itemId -> do - original <- param' "original" - content' <- param' "content" - modified <- view (notes.mdText) <$> dbQuery (GetItem itemId) - if modified == original - then do - item <- uncache (CacheItemNotes itemId) $ do - (edit, item) <- dbUpdate (SetItemNotes itemId content') - addEdit edit - return item - category <- dbQuery (GetCategoryByItem itemId) - lucidIO $ renderItemNotes category item - else do - setStatus HTTP.status409 - json $ M.fromList [ - ("modified" :: Text, modified), - ("merged" :: Text, merge original content' modified)] - -- Trait - Spock.post (itemVar traitVar) $ \itemId traitId -> do - original <- param' "original" - content' <- param' "content" - modified <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId) - if modified == original - then do - trait <- uncache (CacheItemTraits itemId) $ do - (edit, trait) <- dbUpdate (SetTraitContent itemId traitId content') - addEdit edit - return trait - lucidIO $ renderTrait itemId trait - else do - setStatus HTTP.status409 - json $ M.fromList [ - ("modified" :: Text, modified), - ("merged" :: Text, merge original content' modified)] - -addMethods :: SpockM () () ServerState () -addMethods = Spock.subcomponent "add" $ do - -- New category - Spock.post "category" $ do - title' <- param' "content" - -- If the category exists already, don't create it - cats <- view categories <$> dbQuery GetGlobalState - let hasSameTitle cat = T.toCaseFold (cat^.title) == T.toCaseFold title' - category <- case find hasSameTitle cats of - Just c -> return c - Nothing -> do - catId <- randomShortUid - time <- liftIO getCurrentTime - (edit, newCategory) <- dbUpdate (AddCategory catId title' time) - invalidateCache' (CacheCategory catId) - addEdit edit - return newCategory - -- And now send the URL of the new (or old) category - Spock.text ("/haskell/" <> categorySlug category) - - -- New item in a category - Spock.post (categoryVar "item") $ \catId -> do - name' <- param' "name" - -- 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 (AddItem catId itemId name' time kind') - invalidateCache' (CacheItem itemId) - addEdit edit - category <- dbQuery (GetCategory catId) - lucidIO $ renderItem category newItem - -- Pro (argument in favor of an item) - Spock.post (itemVar "pro") $ \itemId -> do - content' <- param' "content" - traitId <- randomLongUid - (edit, newTrait) <- dbUpdate (AddPro itemId traitId content') - invalidateCache' (CacheItemTraits itemId) - addEdit edit - lucidIO $ renderTrait itemId newTrait - -- Con (argument against an item) - Spock.post (itemVar "con") $ \itemId -> do - content' <- param' "content" - traitId <- randomLongUid - (edit, newTrait) <- dbUpdate (AddCon itemId traitId content') - invalidateCache' (CacheItemTraits itemId) - addEdit edit - lucidIO $ renderTrait itemId newTrait - -adminMethods :: SpockM () () ServerState () -adminMethods = Spock.subcomponent "admin" $ do - -- Accept an edit - Spock.post ("edit" var "accept") $ \n -> do - dbUpdate (RemovePendingEdit n) - return () - -- Undo an edit - Spock.post ("edit" var "undo") $ \n -> do - (edit, _) <- dbQuery (GetEdit n) - res <- undoEdit edit - case res of - Left err -> Spock.text (T.pack err) - Right () -> do invalidateCacheForEdit edit - dbUpdate (RemovePendingEdit n) - Spock.text "" - -- Accept a range of edits - Spock.post ("edits" var var "accept") $ \m n -> do - dbUpdate (RemovePendingEdits m n) - -- Undo a range of edits - Spock.post ("edits" var var "undo") $ \m n -> do - edits <- dbQuery (GetEdits m n) - s <- dbQuery GetGlobalState - failed <- fmap catMaybes $ for edits $ \(edit, details) -> do - res <- undoEdit edit - case res of - Left err -> return (Just ((edit, details), Just err)) - Right () -> do invalidateCacheForEdit edit - dbUpdate (RemovePendingEdit (editId details)) - return Nothing - case failed of - [] -> Spock.text "" - _ -> lucidIO $ renderEdits s failed - -- Create a checkpoint - Spock.post "create-checkpoint" $ do - db <- _db <$> Spock.getState - createCheckpoint' db - -otherMethods :: SpockM () () ServerState () -otherMethods = do - -- Moving things - Spock.subcomponent "move" $ do - -- Move item - Spock.post itemVar $ \itemId -> do - direction :: Text <- param' "direction" - uncache (CacheItem itemId) $ do - edit <- dbUpdate (MoveItem itemId (direction == "up")) - addEdit edit - -- Move trait - Spock.post (itemVar traitVar) $ \itemId traitId -> do - direction :: Text <- param' "direction" - uncache (CacheItemTraits itemId) $ do - edit <- dbUpdate (MoveTrait itemId traitId (direction == "up")) - addEdit edit - - -- Deleting things - Spock.subcomponent "delete" $ do - -- Delete category - Spock.post categoryVar $ \catId -> - uncache (CacheCategory catId) $ do - mbEdit <- dbUpdate (DeleteCategory catId) - mapM_ addEdit mbEdit - -- Delete item - Spock.post itemVar $ \itemId -> - uncache (CacheItem itemId) $ do - mbEdit <- dbUpdate (DeleteItem itemId) - mapM_ addEdit mbEdit - -- Delete trait - Spock.post (itemVar traitVar) $ \itemId traitId -> - uncache (CacheItemTraits itemId) $ do - mbEdit <- dbUpdate (DeleteTrait itemId traitId) - mapM_ addEdit mbEdit - - -- Feeds - -- TODO: this link shouldn't be absolute [absolute-links] - baseUrl <- ( "haskell") . T.unpack . _baseUrl <$> getConfig - Spock.subcomponent "feed" $ do - -- Feed for items in a category - Spock.get categoryVar $ \catId -> do - category <- dbQuery (GetCategory catId) - let sortedItems = reverse $ sortBy cmp (category^.items) - where cmp = comparing (^.created) <> comparing (^.uid) - let route = "feed" categoryVar - -- We use ++ instead of because the rendered route already has ‘/’ - -- in front of it, and if we used it'd just skip baseUrl - let feedUrl = baseUrl ++ T.unpack (renderRoute route (category^.uid)) - feedTitle = Atom.TextString (T.unpack (category^.title) ++ - " – Haskell – Aelve Guide") - feedLastUpdate = case sortedItems of - (item:_) -> Feed.toFeedDateStringUTC Feed.AtomKind (item^.created) - _ -> "" - let feedBase = Atom.nullFeed feedUrl feedTitle feedLastUpdate - entries <- liftIO $ mapM (itemToFeedEntry baseUrl category) sortedItems - atomFeed $ feedBase { - Atom.feedEntries = entries, - Atom.feedLinks = [Atom.nullLink feedUrl] } - -itemToFeedEntry - :: (MonadIO m) - => String -> Category -> Item -> m Atom.Entry -itemToFeedEntry baseUrl category item = do - entryContent <- Lucid.renderTextT (renderItemForFeed category item) - return entryBase { - Atom.entryLinks = [Atom.nullLink entryLink], - Atom.entryContent = Just (Atom.HTMLContent (TL.unpack entryContent)) } - where - entryLink = baseUrl - T.unpack (T.format "{}#item-{}" - (categorySlug category, item^.uid)) - entryBase = Atom.nullEntry - (T.unpack (uidToText (item^.uid))) - (Atom.TextString (T.unpack (item^.name))) - (Feed.toFeedDateStringUTC Feed.AtomKind (item^.created)) - -- TODO: rename GlobalState to DB, and DB to AcidDB lucidWithConfig @@ -741,15 +102,6 @@ lucidWithConfig x = do cfg <- getConfig lucidIO (hoist (flip runReaderT cfg) x) --- | Like 'createCheckpoint', but doesn't create a checkpoint if there were --- no changes made. -createCheckpoint' :: MonadIO m => DB -> m () -createCheckpoint' db = liftIO $ do - wasDirty <- Acid.update db UnsetDirty - when wasDirty $ do - createArchive db - createCheckpoint db - ---------------------------------------------------------------------------- -- The entry point ---------------------------------------------------------------------------- @@ -904,10 +256,7 @@ mainWith config = do -- categories, changed items, etc) so that the Javascript part could -- take them and inject into the page. We don't want to duplicate -- rendering on server side and on client side. - renderMethods - setMethods - addMethods - otherMethods + methods adminHook :: ActionCtxT ctx (WebStateM () () ServerState) () adminHook = do diff --git a/src/Guide/ServerStuff.hs b/src/Guide/ServerStuff.hs new file mode 100644 index 0000000..6496f23 --- /dev/null +++ b/src/Guide/ServerStuff.hs @@ -0,0 +1,330 @@ +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE OverloadedStrings #-} + + +-- | Spock state, functions for manipulating it, handler helpers, and so on. +-- +-- TODO: this is not the best name for a module. Really. +module Guide.ServerStuff +( + ServerState(..), + getConfig, + DB, + dbUpdate, + dbQuery, + + -- * Cache + uncache, + invalidateCache', + + -- * Edits + addEdit, + undoEdit, + invalidateCacheForEdit, + + -- * Handler helpers + itemVar, + categoryVar, + traitVar, + + -- * Other helpers + createCheckpoint', +) +where + + +import Imports + +-- Web +import Web.Spock hiding (head, get, text) +import qualified Web.Spock as Spock +import Web.Routing.Combinators (PathState(..)) +-- acid-state +import Data.Acid as Acid + +import Guide.Config +import Guide.State +import Guide.Types +import Guide.Cache +import Guide.Utils +import Guide.Markdown + + +data ServerState = ServerState { + _config :: Config, + _db :: DB } + +getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState) + => m Config +getConfig = _config <$> Spock.getState + +-- | A pointer to an open acid-state database (allows making queries/updates, +-- creating checkpoints, etc). +type DB = AcidState GlobalState + +-- | Update something in the database. Don't forget to 'invalidateCache' or +-- use 'uncache' when you update something that is cached. +dbUpdate :: (MonadIO m, HasSpock m, SpockState m ~ ServerState, + EventState event ~ GlobalState, UpdateEvent event) + => event -> m (EventResult event) +dbUpdate x = do + db <- _db <$> Spock.getState + liftIO $ do + Acid.update db SetDirty + Acid.update db x + +-- | Read something from the database. +dbQuery :: (MonadIO m, HasSpock m, SpockState m ~ ServerState, + EventState event ~ GlobalState, QueryEvent event) + => event -> m (EventResult event) +dbQuery x = do + db <- _db <$> Spock.getState + liftIO $ Acid.query db x + +---------------------------------------------------------------------------- +-- Cache +---------------------------------------------------------------------------- + +-- | Do a database-modifying action and invalidate the cache /afterwards/. +-- +-- To invalidate the cache properly, we use global state – for instance, if +-- item X belongs to category Y, and the item is deleted, we have to +-- invalidate the cache for the category (and for that we need to look at the +-- global state and find out which category has item X). However, we have to +-- use the state from /before/ the item is deleted – otherwise we'll think +-- that no category had the item. +-- +-- Note: if you delete or modify something, wrap it into 'uncache'. However, +-- if you /add/ something, use 'invalidateCache'': +-- +-- >>> addItem +-- >>> invalidateCache' (CacheItem ...) +uncache + :: (MonadIO m, HasSpock (ActionCtxT ctx m), + SpockState (ActionCtxT ctx m) ~ ServerState) + => CacheKey -> ActionCtxT ctx m a -> ActionCtxT ctx m a +uncache key act = do + gs <- dbQuery GetGlobalState + x <- act + invalidateCache gs key + return x + +invalidateCache' + :: (MonadIO m, HasSpock (ActionCtxT ctx m), + SpockState (ActionCtxT ctx m) ~ ServerState) + => CacheKey -> ActionCtxT ctx m () +invalidateCache' key = do + gs <- dbQuery GetGlobalState + invalidateCache gs key + +---------------------------------------------------------------------------- +-- Edits +---------------------------------------------------------------------------- + +-- | Remember an edit. +-- +-- Call this whenever any user-made change is applied to the database. +addEdit :: (MonadIO m, HasSpock (ActionCtxT ctx m), + SpockState (ActionCtxT ctx m) ~ ServerState) + => Edit -> ActionCtxT ctx m () +addEdit ed = do + (time, mbIP, mbReferrer, mbUA) <- getRequestDetails + unless (isVacuousEdit ed) $ do + dbUpdate (RegisterEdit ed mbIP time) + baseUrl <- _baseUrl <$> getConfig + dbUpdate (RegisterAction (Action'Edit ed) + mbIP time baseUrl mbReferrer mbUA) + +-- | Do an action that would undo an edit. +-- +-- 'Left' signifies failure. +-- +-- This doesn't do cache invalidation (you have to do it at the call site +-- using 'invalidateCacheForEdit'). +-- +-- TODO: make this do cache invalidation. +-- +-- TODO: many of these don't work when the changed category/item/etc has been +-- deleted; this should change. +undoEdit :: (MonadIO m, HasSpock m, SpockState m ~ ServerState) + => Edit -> m (Either String ()) +undoEdit (Edit'AddCategory catId _) = do + void <$> dbUpdate (DeleteCategory catId) +undoEdit (Edit'AddItem _catId itemId _) = do + void <$> dbUpdate (DeleteItem itemId) +undoEdit (Edit'AddPro itemId traitId _) = do + void <$> dbUpdate (DeleteTrait itemId traitId) +undoEdit (Edit'AddCon itemId traitId _) = do + void <$> dbUpdate (DeleteTrait itemId traitId) +undoEdit (Edit'SetCategoryTitle catId old new) = do + now <- view title <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "title has been changed further") + else Right () <$ dbUpdate (SetCategoryTitle catId old) +undoEdit (Edit'SetCategoryGroup catId old new) = do + now <- view group_ <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "group has been changed further") + else Right () <$ dbUpdate (SetCategoryGroup catId old) +undoEdit (Edit'SetCategoryStatus catId old new) = do + now <- view status <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "status has been changed further") + else Right () <$ dbUpdate (SetCategoryStatus catId old) +undoEdit (Edit'SetCategoryProsConsEnabled catId old new) = do + now <- view prosConsEnabled <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "pros-cons-enabled has been changed further") + else Right () <$ dbUpdate (SetCategoryProsConsEnabled catId old) +undoEdit (Edit'SetCategoryEcosystemEnabled catId old new) = do + now <- view ecosystemEnabled <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "ecosystem-enabled has been changed further") + else Right () <$ dbUpdate (SetCategoryEcosystemEnabled catId old) +undoEdit (Edit'SetCategoryNotesEnabled catId old new) = do + now <- view notesEnabled <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "notes-enabled has been changed further") + else Right () <$ dbUpdate (SetCategoryNotesEnabled catId old) +undoEdit (Edit'SetCategoryNotes catId old new) = do + now <- view (notes.mdText) <$> dbQuery (GetCategory catId) + if now /= new + then return (Left "notes have been changed further") + else Right () <$ dbUpdate (SetCategoryNotes catId old) +undoEdit (Edit'SetItemName itemId old new) = do + now <- view name <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "name has been changed further") + else Right () <$ dbUpdate (SetItemName itemId old) +undoEdit (Edit'SetItemLink itemId old new) = do + now <- view link <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "link has been changed further") + else Right () <$ dbUpdate (SetItemLink itemId old) +undoEdit (Edit'SetItemGroup itemId old new) = do + now <- view group_ <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "group has been changed further") + else Right () <$ dbUpdate (SetItemGroup itemId old) +undoEdit (Edit'SetItemKind itemId old new) = do + now <- view kind <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "kind has been changed further") + else Right () <$ dbUpdate (SetItemKind itemId old) +undoEdit (Edit'SetItemDescription itemId old new) = do + now <- view (description.mdText) <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "description has been changed further") + else Right () <$ dbUpdate (SetItemDescription itemId old) +undoEdit (Edit'SetItemNotes itemId old new) = do + now <- view (notes.mdText) <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "notes have been changed further") + else Right () <$ dbUpdate (SetItemNotes itemId old) +undoEdit (Edit'SetItemEcosystem itemId old new) = do + now <- view (ecosystem.mdText) <$> dbQuery (GetItem itemId) + if now /= new + then return (Left "ecosystem has been changed further") + else Right () <$ dbUpdate (SetItemEcosystem itemId old) +undoEdit (Edit'SetTraitContent itemId traitId old new) = do + now <- view (content.mdText) <$> dbQuery (GetTrait itemId traitId) + if now /= new + then return (Left "trait has been changed further") + else Right () <$ dbUpdate (SetTraitContent itemId traitId old) +undoEdit (Edit'DeleteCategory catId pos) = do + dbUpdate (RestoreCategory catId pos) +undoEdit (Edit'DeleteItem itemId pos) = do + dbUpdate (RestoreItem itemId pos) +undoEdit (Edit'DeleteTrait itemId traitId pos) = do + dbUpdate (RestoreTrait itemId traitId pos) +undoEdit (Edit'MoveItem itemId direction) = do + Right () <$ dbUpdate (MoveItem itemId (not direction)) +undoEdit (Edit'MoveTrait itemId traitId direction) = do + Right () <$ dbUpdate (MoveTrait itemId traitId (not direction)) + +invalidateCacheForEdit + :: (MonadIO m, HasSpock m, SpockState m ~ ServerState) + => Edit -> m () +invalidateCacheForEdit ed = do + gs <- dbQuery GetGlobalState + mapM_ (invalidateCache gs) $ case ed of + Edit'AddCategory catId _ -> + [CacheCategory catId] + -- Normally invalidateCache should invalidate item's category + -- automatically, but in this case it's *maybe* possible that the item + -- has already been moved somewhere else and so we invalidate both just + -- in case. + Edit'AddItem catId itemId _ -> + [CacheCategory catId, CacheItem itemId] + Edit'AddPro itemId _ _ -> + [CacheItemTraits itemId] + Edit'AddCon itemId _ _ -> + [CacheItemTraits itemId] + Edit'SetCategoryTitle catId _ _ -> + [CacheCategoryInfo catId] + Edit'SetCategoryGroup catId _ _ -> + [CacheCategoryInfo catId] + Edit'SetCategoryStatus catId _ _ -> + [CacheCategoryInfo catId] + Edit'SetCategoryProsConsEnabled catId _ _ -> + [CacheCategoryInfo catId] + Edit'SetCategoryEcosystemEnabled catId _ _ -> + [CacheCategoryInfo catId] + Edit'SetCategoryNotesEnabled catId _ _ -> + [CacheCategoryInfo catId] + Edit'SetCategoryNotes catId _ _ -> + [CacheCategoryNotes catId] + Edit'SetItemName itemId _ _ -> + [CacheItemInfo itemId] + Edit'SetItemLink itemId _ _ -> + [CacheItemInfo itemId] + Edit'SetItemGroup itemId _ _ -> + [CacheItemInfo itemId] + Edit'SetItemKind itemId _ _ -> + [CacheItemInfo itemId] + Edit'SetItemDescription itemId _ _ -> + [CacheItemDescription itemId] + Edit'SetItemNotes itemId _ _ -> + [CacheItemNotes itemId] + Edit'SetItemEcosystem itemId _ _ -> + [CacheItemEcosystem itemId] + Edit'SetTraitContent itemId _ _ _ -> + [CacheItemTraits itemId] + Edit'DeleteCategory catId _ -> + [CacheCategory catId] + Edit'DeleteItem itemId _ -> + [CacheItem itemId] + Edit'DeleteTrait itemId _ _ -> + [CacheItemTraits itemId] + Edit'MoveItem itemId _ -> + [CacheItem itemId] + Edit'MoveTrait itemId _ _ -> + [CacheItemTraits itemId] + +---------------------------------------------------------------------------- +-- Handler helpers +---------------------------------------------------------------------------- + +itemVar :: Path '[Uid Item] 'Open +itemVar = "item" var + +categoryVar :: Path '[Uid Category] 'Open +categoryVar = "category" var + +traitVar :: Path '[Uid Trait] 'Open +traitVar = "trait" var + +---------------------------------------------------------------------------- +-- Other helpers +---------------------------------------------------------------------------- + +-- | Like 'createCheckpoint', but doesn't create a checkpoint if there were +-- no changes made. +createCheckpoint' :: MonadIO m => DB -> m () +createCheckpoint' db = liftIO $ do + wasDirty <- Acid.update db UnsetDirty + when wasDirty $ do + createArchive db + createCheckpoint db