aelve/guide
1
1
Fork 0
mirror of https://github.com/aelve/guide.git synced 2024-11-23 04:07:14 +03:00
Code Issues Projects Releases Wiki Activity

Split handlers out of Guide.Server

Browse Source
This commit is contained in:
Artyom 2017-01-31 00:33:13 +03:00
parent 4ad0f0f8f9
commit 076feaf37f
No known key found for this signature in database
GPG Key ID: B8E35A33FF522710
4 changed files with 762 additions and 654 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
guide.cabal
View File

@ -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

427
src/Guide/Handlers.hs Normal file
View File

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

657
src/Guide/Server.hs
View File

@ -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

330
src/Guide/ServerStuff.hs Normal file
View File

@ -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