Only create a checkpoint when there were changes

src/Main.hs

@@ -81,6 +81,8 @@ This application doesn't use a database – instead, it uses acid-state. Acid-st
 
   * 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 surprise – 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 (which doesn't create the checkpoint if the dirty bit isn't set).
+
   * 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 (like migrating all IDs to a different ID scheme, or whatever).
@@ -97,7 +99,9 @@ dbUpdate :: (MonadIO m, HasSpock m, SpockState m ~ ServerState,
          => event -> m (EventResult event)
 dbUpdate x = do
   db <- _db <$> Spock.getState
-  liftIO $ Acid.update db x
+  liftIO $ do
+    Acid.update db SetDirty
+    Acid.update db x
 
 -- | Read something from the database.
 dbQuery :: (MonadIO m, HasSpock m, SpockState m ~ ServerState,
@@ -533,7 +537,7 @@ adminMethods = Spock.subcomponent "admin" $ do
   -- Create a checkpoint
   Spock.post "create-checkpoint" $ do
     db <- _db <$> Spock.getState
-    liftIO $ createCheckpoint db
+    createCheckpoint' db
 
 otherMethods :: SpockM () () ServerState ()
 otherMethods = do
@@ -618,6 +622,15 @@ 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
@@ -626,7 +639,8 @@ main = do
         _categoriesDeleted = [],
         _actions = [],
         _pendingEdits = [],
-        _editIdCounter = 0 }
+        _editIdCounter = 0,
+        _dirty = True }
   do args <- getArgs
      when (args == ["--dry-run"]) $ do
        db :: DB <- openLocalStateFrom "state/" (error "couldn't load state")
@@ -642,16 +656,15 @@ main = do
   -- 'createCheckpoint', etc
   let prepare = openLocalStateFrom "state/" emptyState
       finalise db = do
-        createCheckpoint db
+        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,
-    -- acid-state overwrites the previous checkpoint, which saves us some
-    -- space.
+    -- Create a checkpoint every six hours. Note: if nothing was changed, the
+    -- checkpoint won't be created, which saves us some space.
     forkOS $ forever $ do
-      createCheckpoint db
+      createCheckpoint' db
       threadDelay (1000000 * 3600 * 6)
     -- EKG metrics
     ekg <- EKG.forkServer "localhost" 5050

src/Types.hs

@@ -120,6 +120,7 @@ module Types
   RestoreCategory(..),
   RestoreItem(..),
   RestoreTrait(..),
+  SetDirty(..), UnsetDirty(..),
   )
 where
 
@@ -698,28 +699,32 @@ data GlobalState = GlobalState {
   -- | Pending edits, newest first
   _pendingEdits :: [(Edit, EditDetails)],
   -- | ID of next edit that will be made
-  _editIdCounter :: Int }
+  _editIdCounter :: Int,
+  -- | The dirty bit (needed to choose whether to make a checkpoint or not)
+  _dirty :: Bool }
   deriving (Show)
 
-deriveSafeCopySimple 4 'extension ''GlobalState
+deriveSafeCopySimple 5 'extension ''GlobalState
 makeLenses ''GlobalState
 
-data GlobalState_v3 = GlobalState_v3 {
-  _categories_v3 :: [Category],
-  _categoriesDeleted_v3 :: [Category],
-  _pendingEdits_v3 :: [(Edit, EditDetails)],
-  _editIdCounter_v3 :: Int }
+data GlobalState_v4 = GlobalState_v4 {
+  _categories_v4 :: [Category],
+  _categoriesDeleted_v4 :: [Category],
+  _actions_v4 :: [(Action, ActionDetails)],
+  _pendingEdits_v4 :: [(Edit, EditDetails)],
+  _editIdCounter_v4 :: Int }
 
-deriveSafeCopySimple 3 'base ''GlobalState_v3
+deriveSafeCopySimple 4 'base ''GlobalState_v4
 
 instance Migrate GlobalState where
-  type MigrateFrom GlobalState = GlobalState_v3
-  migrate GlobalState_v3{..} = GlobalState {
-    _categories = _categories_v3,
-    _categoriesDeleted = _categoriesDeleted_v3,
-    _actions = [],
-    _pendingEdits = _pendingEdits_v3,
-    _editIdCounter = _editIdCounter_v3 }
+  type MigrateFrom GlobalState = GlobalState_v4
+  migrate GlobalState_v4{..} = GlobalState {
+    _categories = _categories_v4,
+    _categoriesDeleted = _categoriesDeleted_v4,
+    _actions = _actions_v4,
+    _pendingEdits = _pendingEdits_v4,
+    _editIdCounter = _editIdCounter_v4,
+    _dirty = True }
 
 addGroupIfDoesNotExist :: Text -> Map Text Hue -> Map Text Hue
 addGroupIfDoesNotExist g gs
@@ -1208,6 +1213,12 @@ registerAction act ip date baseUrl ref ua = do
         actionUserAgent = ua }
   actions %= ((act, details) :)
 
+setDirty :: Acid.Update GlobalState ()
+setDirty = dirty .= True
+
+unsetDirty :: Acid.Update GlobalState Bool
+unsetDirty = dirty <<.= False
+
 makeAcidic ''GlobalState [
   -- queries
   'getGlobalState,
@@ -1238,5 +1249,6 @@ makeAcidic ''GlobalState [
   'registerAction,
   -- other
   'moveItem, 'moveTrait,
-  'restoreCategory, 'restoreItem, 'restoreTrait
+  'restoreCategory, 'restoreItem, 'restoreTrait,
+  'setDirty, 'unsetDirty
   ]