guide/lib/Guide.hs

{-# LANGUAGE
OverloadedStrings,
ScopedTypeVariables,
TypeFamilies,
DataKinds,
FlexibleContexts,
NoImplicitPrelude
  #-}


module Guide
(
  main,
  mainWith,
)
where


import BasePrelude hiding (Category)
-- Monads and monad transformers
import Control.Monad.Catch (MonadThrow)
import Control.Monad.State
import Control.Monad.Reader
import Control.Monad.Morph
-- Lenses
import Lens.Micro.Platform hiding ((&))
-- Containers
import qualified Data.Map as M
-- Text
import Data.Text.All (Text)
import qualified Data.Text.All as T
import qualified Data.Text.Lazy.All as TL
-- Paths
import System.FilePath ((</>))
-- Network
import Data.IP (IP)
-- Web
import Web.Spock hiding (head, get, text)
import qualified Web.Spock as Spock
import Web.Spock.Lucid
import Lucid hiding (for_)
import Network.Wai.Middleware.Static (staticPolicy, addBase)
import qualified Network.HTTP.Types.Status as HTTP
import qualified Network.Wai as Wai
-- 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
import qualified System.Remote.Monitoring as EKG
import qualified Network.Wai.Metrics      as EKG
import qualified System.Metrics.Gauge     as EKG.Gauge
-- acid-state
import Data.Acid as Acid
-- Time
import Data.Time
-- Deepseq
import Control.DeepSeq
-- IO
import System.IO
import qualified SlaveThread as Slave
-- Watching the templates directory
import qualified System.FSNotify as FSNotify

-- Local
import Config
import Types
import View
import JS (JS(..), allJSFunctions)
import Utils
import Markdown
import Cache
import Merge


{- Note [acid-state]
~~~~~~~~~~~~~~~~~~~~

This application doesn't use a database – instead, it uses acid-state. Acid-state works as follows:

  * Everything is stored as Haskell values (in particular, all data is stored in 'GlobalState').

  * All changes to the state (and all queries) have to be done by using 'dbUpdate'/'dbQuery' and types (GetItem, SetItemName, etc) from the Types.hs module.

  * When doing a 'dbUpdate', don't forget to 'invalidateCache'!

  * The data is kept in-memory, but all changes are logged to the disk (which lets us recover the state in case of a crash by reapplying the changes) and you can't access the state directly. When the application exits, it creates a snapshot of the state (called “checkpoint”) and writes it to the disk. Additionally, a checkpoint is created every hour (grep for “createCheckpoint”).

  * acid-state has a nasty feature – when the state hasn't changed, 'createCheckpoint' appends it to the previous checkpoint. When state doesn't change for a long time, it means that checkpoints can grow to 100 MB or more. So, we employ a dirty bit and use createCheckpoint' instead of createCheckpoint. The former only creates the checkpoint if the dirty bit is set, which is good.

  * When any type is changed, we have to write a migration function that would read the old version of the type and turn it into the new version. It's enough to keep just one old version (and even that isn't needed after the migration happened and a new checkpoint has been created). For examples, look at “instance Migrate” in Types.hs. Also, all types involved in acid-state (whether migrate-able or not) have to have a SafeCopy instance, which is generated by 'deriveSafeCopySimple'.

  * There are actually ways to access the state directly (GetGlobalState and SetGlobalState), but the latter should only be used when doing something one-off (e.g. if you need to migrate all IDs to a different ID scheme).

-}

-- | 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' 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]
itemVar = "item" <//> var

categoryVar :: Path '[Uid Category]
categoryVar = "category" <//> var

traitVar :: Path '[Uid Trait]
traitVar = "trait" <//> var

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

getDetails
  :: (MonadIO m, HasSpock (ActionCtxT ctx m))
  => ActionCtxT ctx m (UTCTime, Maybe IP, Maybe Text, Maybe Text)
getDetails = do
  time <- liftIO $ getCurrentTime
  mbForwardedFor <- liftA2 (<|>) (Spock.header "Forwarded-For")
                                 (Spock.header "X-Forwarded-For")
  mbIP <- case mbForwardedFor of
    Nothing -> sockAddrToIP . Wai.remoteHost <$> Spock.request
    Just ff -> case readMaybe (T.unpack ip) of
      Nothing -> error ("couldn't read Forwarded-For address: " ++
                        show ip ++ " (full header: " ++
                        show ff ++ ")")
      Just i  -> return (Just i)
      where
        addr = T.strip . snd . T.breakOnEnd "," $ ff
        ip -- [IPv6]:port
           | T.take 1 addr == "[" =
               T.drop 1 (T.takeWhile (/= ']') addr)
           -- IPv4 or IPv4:port
           | T.any (== '.') addr =
               T.takeWhile (/= ':') addr
           -- IPv6 without port
           | otherwise =
               addr
  mbReferrer <- Spock.header "Referer"
  mbUA       <- Spock.header "User-Agent"
  return (time, mbIP, mbReferrer, mbUA)

-- | Call this whenever a user edits 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) <- getDetails
  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'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'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
    invalidateCache' (CacheCategoryInfo catId)
    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"
    status' <- do
      statusName :: Text <- param' "status"
      return $ case statusName of
        "finished"    -> CategoryFinished
        "mostly-done" -> CategoryMostlyDone
        "wip"         -> CategoryWIP
        "stub"        -> CategoryStub
        other         -> error ("unknown category status: " ++ show other)
    -- Modify the category
    -- TODO: actually validate the form and report errors
    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
    -- 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
        invalidateCache' (CacheCategoryNotes catId)
        (edit, category) <- dbUpdate (SetCategoryNotes catId content')
        addEdit edit
        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
    invalidateCache' (CacheItemInfo itemId)
    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 ≠ "")
    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
        invalidateCache' (CacheItemDescription itemId)
        (edit, item) <- dbUpdate (SetItemDescription itemId content')
        addEdit edit
        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
        invalidateCache' (CacheItemEcosystem itemId)
        (edit, item) <- dbUpdate (SetItemEcosystem itemId content')
        addEdit edit
        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
        invalidateCache' (CacheItemNotes itemId)
        (edit, item) <- dbUpdate (SetItemNotes itemId content')
        addEdit edit
        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
        invalidateCache' (CacheItemTraits itemId)
        (edit, trait) <- dbUpdate (SetTraitContent itemId traitId content')
        addEdit edit
        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.
    time <- liftIO getCurrentTime
    (edit, newItem) <-
      if T.all (\c -> isAscii c && (isAlphaNum c || c == '-')) name'
        then dbUpdate (AddItem catId itemId name' time (Library (Just name')))
        else dbUpdate (AddItem catId itemId name' time Other)
    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"
      edit <- dbUpdate (MoveItem itemId (direction == "up"))
      invalidateCache' (CacheItem itemId)
      addEdit edit
    -- Move trait
    Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
      direction :: Text <- param' "direction"
      edit <- dbUpdate (MoveTrait itemId traitId (direction == "up"))
      invalidateCache' (CacheItemTraits itemId)
      addEdit edit

  -- Deleting things
  Spock.subcomponent "delete" $ do
    -- Delete category
    Spock.post categoryVar $ \catId -> do
      invalidateCache' (CacheCategory catId)
      mbEdit <- dbUpdate (DeleteCategory catId)
      mapM_ addEdit mbEdit
    -- Delete item
    Spock.post itemVar $ \itemId -> do
      invalidateCache' (CacheItem itemId)
      mbEdit <- dbUpdate (DeleteItem itemId)
      mapM_ addEdit mbEdit
    -- Delete trait
    Spock.post (itemVar <//> traitVar) $ \itemId traitId -> do
      invalidateCache' (CacheItemTraits itemId)
      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, MonadThrow 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
  :: (MonadIO m, HasSpock (ActionCtxT cxt m),
      SpockState (ActionCtxT cxt m) ~ ServerState)
  => HtmlT (ReaderT Config IO) a -> ActionCtxT cxt m a
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

main :: IO ()
main = do
  config <- readConfig
  mainWith config

mainWith :: Config -> IO ()
mainWith config = do
  -- Emptying the cache is needed because during development (i.e. in REPL)
  -- 'main' can be started many times and if the cache isn't cleared changes
  -- won't be visible
  emptyCache
  Slave.fork $ FSNotify.withManager $ \mgr -> do
    FSNotify.watchTree mgr "templates/" (const True) $ \_ -> do
      emptyCache
    forever $ threadDelay 1000000
  let emptyState = GlobalState {
        _categories = [],
        _categoriesDeleted = [],
        _actions = [],
        _pendingEdits = [],
        _editIdCounter = 0,
        _dirty = True }
  do args <- getArgs
     when (args == ["--dry-run"]) $ do
       db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
       putStrLn "loaded the database successfully"
       closeAcidState db
       exitSuccess
  -- When we run in GHCi and we exit the main thread, the EKG thread (that
  -- runs the localhost:5050 server which provides statistics) may keep
  -- running. This makes running this in GHCi annoying, because you have to
  -- restart GHCi before every run. So, we kill the thread in the finaliser.
  ekgId <- newIORef Nothing
  -- See Note [acid-state] for the explanation of 'openLocalStateFrom',
  -- 'createCheckpoint', etc
  let prepare = openLocalStateFrom "state/" emptyState
      finalise db = do
        createCheckpoint' db
        closeAcidState db
        mapM_ killThread =<< readIORef ekgId
  bracket prepare finalise $ \db -> do
    hSetBuffering stdout NoBuffering
    -- Create a checkpoint every six hours. Note: if nothing was changed, the
    -- checkpoint won't be created, which saves us some space.
    Slave.fork $ forever $ do
      createCheckpoint' db
      threadDelay (1000000 * 3600 * 6)
    -- EKG metrics
    ekg <- EKG.forkServer "localhost" 5050
    writeIORef ekgId (Just (EKG.serverThreadId ekg))
    waiMetrics <- EKG.registerWaiMetrics (EKG.serverMetricStore ekg)
    categoryGauge <- EKG.getGauge "db.categories" ekg
    itemGauge <- EKG.getGauge "db.items" ekg
    Slave.fork $ forever $ do
      globalState <- Acid.query db GetGlobalState
      let allCategories = globalState^.categories
      let allItems = allCategories^..each.items.each
      EKG.Gauge.set categoryGauge (fromIntegral (length allCategories))
      EKG.Gauge.set itemGauge (fromIntegral (length allItems))
      threadDelay (1000000 * 60)
    -- Run the server
    let serverState = ServerState {
          _config = config,
          _db     = db }
    let spockConfig = (defaultSpockCfg () PCNoDatabase serverState) {
          spc_maxRequestSize = Just (1024*1024) }
    when (_prerender config) $ do
      putStr "Prerendering pages to be cached... "
      globalState <- liftIO $ Acid.query db GetGlobalState
      for_ (globalState^.categories) $ \cat -> do
        putStr "|"
        evaluate . force =<<
          renderBST (hoist (flip runReaderT config) (renderCategoryPage cat))
      putStrLn " done"
    runSpock 8080 $ spock spockConfig $ do
      middleware (EKG.metrics waiMetrics)
      middleware (staticPolicy (addBase "static"))
      -- Javascript
      Spock.get "/js.js" $ do
        setHeader "Content-Type" "application/javascript; charset=utf-8"
        js <- getJS
        Spock.bytes $ T.encodeUtf8 (fromJS allJSFunctions <> js)
      -- CSS
      Spock.get "/highlight.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        Spock.bytes $ T.encodeUtf8 (T.pack (styleToCss pygments))
      Spock.get "/css.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        css <- getCSS
        Spock.bytes $ T.encodeUtf8 css
      Spock.get "/admin.css" $ do
        setHeader "Content-Type" "text/css; charset=utf-8"
        css <- getCSS
        admincss <- liftIO $ T.readFile "static/admin.css"
        Spock.bytes $ T.encodeUtf8 (css <> admincss)

      -- Main page
      Spock.get root $
        lucidWithConfig $ renderRoot

      -- Admin page
      prehook adminHook $ do
        Spock.get "admin" $ do
          s <- dbQuery GetGlobalState
          lucidIO $ renderAdmin s
        adminMethods

      -- Donation page
      Spock.get "donate" $
        lucidWithConfig $ renderDonate

      -- Static pages
      Spock.get "unwritten-rules" $ lucidWithConfig $
        renderStaticMd "Unwritten rules" "unwritten-rules.md"
      Spock.get "markdown" $ lucidWithConfig $
        renderStaticMd "Markdown" "markdown.md"
      Spock.get "license" $ lucidWithConfig $
        renderStaticMd "License" "license.md"

      -- Haskell
      Spock.subcomponent "haskell" $ do
        Spock.get root $ do
          s <- dbQuery GetGlobalState
          q <- param "q"
          (time, mbIP, mbReferrer, mbUA) <- getDetails
          let act = case q of
                Nothing -> Action'MainPageVisit
                Just x  -> Action'Search x
          baseUrl <- _baseUrl <$> getConfig
          dbUpdate (RegisterAction act mbIP time baseUrl mbReferrer mbUA)
          lucidWithConfig $ renderHaskellRoot s q
        -- Category pages
        Spock.get var $ \path -> do
          -- The links look like /parsers-gao238b1 (because it's nice when
          -- you can find out where a link leads just by looking at it)
          let (_, catId) = T.breakOnEnd "-" path
          when (T.null catId) $
            Spock.jumpNext
          mbCategory <- dbQuery (GetCategoryMaybe (Uid catId))
          case mbCategory of
            Nothing -> Spock.jumpNext
            Just category -> do
              (time, mbIP, mbReferrer, mbUA) <- getDetails
              baseUrl <- _baseUrl <$> getConfig
              dbUpdate $ RegisterAction (Action'CategoryVisit (Uid catId))
                           mbIP time baseUrl mbReferrer mbUA
              -- If the slug in the url is old (i.e. if it doesn't match the
              -- one we would've generated now), let's do a redirect
              when (categorySlug category /= path) $
                -- TODO: this link shouldn't be absolute [absolute-links]
                Spock.redirect ("/haskell/" <> categorySlug category)
              lucidWithConfig $ renderCategoryPage category
        -- The add/set methods return rendered parts of the structure (added
        -- 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

adminHook :: ActionCtxT ctx (WebStateM () () ServerState) ()
adminHook = do
  adminPassword <- _adminPassword <$> getConfig
  unless (adminPassword == "") $ do
    let check user pass =
          unless (user == "admin" && pass == adminPassword) $ do
            Spock.setStatus HTTP.status401
            Spock.text "Wrong password!"
    Spock.requireBasicAuth "Authenticate (login = admin)" check return

-- TODO: a function to find all links to Hackage that have version in them

-- TODO: page titles in Google have “artyom.me” in them, that's bad