aelve/guide

{-# LANGUAGE FlexibleContexts  #-}


-- | 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,
  dbUpdate,
  dbQuery,

  -- * Edits
  addEdit,
  undoEdit,

  -- * Handler helpers
  itemVar,
  categoryVar,
  traitVar,
)
where


import Imports

-- Web
import Web.Routing.Combinators (PathState (..))
import Web.Spock hiding (get, head, text)
-- acid-state
import Data.Acid as Acid

import Guide.Config
import Guide.Markdown
import Guide.State
import Guide.Types
import Guide.Utils
import Guide.Uid

import qualified Web.Spock as Spock


-- | Global state of the site.
data ServerState = ServerState {
  _config :: Config,                -- ^ Config (doesn't change in runtime)
  _db     :: DB                     -- ^ DB connection
  }

-- | Get config in a Spock monad.
getConfig :: (Monad m, HasSpock m, SpockState m ~ ServerState)
          => m Config
getConfig = _config <$> Spock.getState

-- | Update something in the database.
--
-- Example: @dbUpdate (DeleteCategory catId)@
--
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.
--
-- Example: @dbQuery (GetCategory catId)@.
--
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

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

-- | Do an action that would undo an edit. 'Left' signifies failure.
--
-- 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 (EditAddCategory catId _ _) = do
  void <$> dbUpdate (DeleteCategory catId)
undoEdit (EditAddItem _catId itemId _) = do
  void <$> dbUpdate (DeleteItem itemId)
undoEdit (EditAddPro itemId traitId _) = do
  void <$> dbUpdate (DeleteTrait itemId traitId)
undoEdit (EditAddCon itemId traitId _) = do
  void <$> dbUpdate (DeleteTrait itemId traitId)
undoEdit (EditSetCategoryTitle catId old new) = do
  now <- categoryTitle <$> dbQuery (GetCategory catId)
  if now /= new
    then return (Left "title has been changed further")
    else Right () <$ dbUpdate (SetCategoryTitle catId old)
undoEdit (EditSetCategoryGroup catId old new) = do
  now <- categoryGroup <$> dbQuery (GetCategory catId)
  if now /= new
    then return (Left "group has been changed further")
    else Right () <$ dbUpdate (SetCategoryGroup catId old)
undoEdit (EditSetCategoryStatus catId old new) = do
  now <- categoryStatus <$> dbQuery (GetCategory catId)
  if now /= new
    then return (Left "status has been changed further")
    else Right () <$ dbUpdate (SetCategoryStatus catId old)
undoEdit (EditChangeCategoryEnabledSections catId toEnable toDisable) = do
  enabledNow <- categoryEnabledSections <$> dbQuery (GetCategory catId)
  if any (`elem` enabledNow) toDisable || any (`notElem` enabledNow) toEnable
    then return (Left "enabled-sections has been changed further")
    else Right () <$ dbUpdate (ChangeCategoryEnabledSections catId toDisable toEnable)
undoEdit (EditSetCategoryNotes catId old new) = do
  now <- markdownBlockSource . categoryNotes <$> dbQuery (GetCategory catId)
  if now /= new
    then return (Left "notes have been changed further")
    else Right () <$ dbUpdate (SetCategoryNotes catId old)
undoEdit (EditSetItemName itemId old new) = do
  now <- itemName <$> dbQuery (GetItem itemId)
  if now /= new
    then return (Left "name has been changed further")
    else Right () <$ dbUpdate (SetItemName itemId old)
undoEdit (EditSetItemLink itemId old new) = do
  now <- itemLink <$> dbQuery (GetItem itemId)
  if now /= new
    then return (Left "link has been changed further")
    else Right () <$ dbUpdate (SetItemLink itemId old)
undoEdit EditSetItemGroup{} = do
  return (Left "groups are not supported anymore")
undoEdit (EditSetItemHackage itemId old new) = do
  now <- itemHackage <$> dbQuery (GetItem itemId)
  if now /= new
    then return (Left "Hackage name has been changed further")
    else Right () <$ dbUpdate (SetItemHackage itemId old)
undoEdit (EditSetItemSummary itemId old new) = do
  now <- markdownBlockSource . itemSummary <$> dbQuery (GetItem itemId)
  if now /= new
    then return (Left "description has been changed further")
    else Right () <$ dbUpdate (SetItemSummary itemId old)
undoEdit (EditSetItemNotes itemId old new) = do
  now <- markdownTreeSource . itemNotes <$> dbQuery (GetItem itemId)
  if now /= new
    then return (Left "notes have been changed further")
    else Right () <$ dbUpdate (SetItemNotes itemId old)
undoEdit (EditSetItemEcosystem itemId old new) = do
  now <- markdownBlockSource . itemEcosystem <$> dbQuery (GetItem itemId)
  if now /= new
    then return (Left "ecosystem has been changed further")
    else Right () <$ dbUpdate (SetItemEcosystem itemId old)
undoEdit (EditSetTraitContent itemId traitId old new) = do
  now <- markdownInlineSource . traitContent <$> dbQuery (GetTrait itemId traitId)
  if now /= new
    then return (Left "trait has been changed further")
    else Right () <$ dbUpdate (SetTraitContent itemId traitId old)
undoEdit (EditDeleteCategory catId pos) = do
  dbUpdate (RestoreCategory catId pos)
undoEdit (EditDeleteItem itemId pos) = do
  dbUpdate (RestoreItem itemId pos)
undoEdit (EditDeleteTrait itemId traitId pos) = do
  dbUpdate (RestoreTrait itemId traitId pos)
undoEdit (EditMoveItem itemId direction) = do
  Right () <$ dbUpdate (MoveItem itemId (not direction))
undoEdit (EditMoveTrait itemId traitId direction) = do
  Right () <$ dbUpdate (MoveTrait itemId traitId (not direction))

----------------------------------------------------------------------------
-- Handler helpers
----------------------------------------------------------------------------

-- | A path piece for items
itemVar :: Path '[Uid Item] 'Open
itemVar = "item" <//> var

-- | A path piece for categories
categoryVar :: Path '[Uid Category] 'Open
categoryVar = "category" <//> var

-- | A path pieces for traits
traitVar :: Path '[Uid Trait] 'Open
traitVar = "trait" <//> var