[admin] Button to create a checkpoint

src/JS.hs

@@ -54,10 +54,9 @@ allJSFunctions = JS . T.unlines . map fromJS $ [
   moveTraitUp, moveTraitDown, deleteTrait,
   moveItemUp, moveItemDown, deleteItem,
   -- Admin things
-  acceptEdit,
-  undoEdit,
-  acceptBlock,
-  undoBlock ]
+  acceptEdit, undoEdit,
+  acceptBlock, undoBlock,
+  createCheckpoint ]
 
 -- | A class for things that can be converted to Javascript syntax.
 class ToJS a where toJS :: a -> JS
@@ -514,6 +513,16 @@ undoBlock =
      });
   |]
 
+createCheckpoint :: JSFunction a => a
+createCheckpoint =
+  makeJSFunction "createCheckpoint" ["buttonNode"]
+  [text|
+    $.post("/admin/create-checkpoint")
+     .done(function () {
+        fadeIn(buttonNode);
+     });
+  |]
+
 deleteItem :: JSFunction a => a
 deleteItem =
   makeJSFunction "deleteItem" ["itemId", "itemNode"]

src/Main.hs

@@ -383,6 +383,41 @@ addMethods = Spock.subcomponent "add" $ do
     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 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 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
+    liftIO $ createCheckpoint db
+
 otherMethods :: SpockM () () ServerState ()
 otherMethods = do
   -- Moving things
@@ -529,36 +564,12 @@ main = do
         lucidWithConfig $ renderRoot
 
       -- Admin page
-      prehook adminHook $
-        Spock.subcomponent "admin" $ do
-          Spock.get root $ do
-            edits <- view pendingEdits <$> dbQuery GetGlobalState
-            s <- dbQuery GetGlobalState
-            lucidIO $ renderAdmin s edits
-          Spock.post ("edit" <//> var <//> "accept") $ \n -> do
-            dbUpdate (RemovePendingEdit n)
-            return ()
-          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 dbUpdate (RemovePendingEdit n)
-                             Spock.text ""
-          Spock.post ("edits" <//> var <//> var <//> "accept") $ \m n -> do
-            dbUpdate (RemovePendingEdits m n)
-          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 dbUpdate (RemovePendingEdit (editId details))
-                               return Nothing
-            case failed of
-              [] -> Spock.text ""
-              _  -> lucidIO $ renderEdits s failed
+      prehook adminHook $ do
+        Spock.get "admin" $ do
+          edits <- view pendingEdits <$> dbQuery GetGlobalState
+          s <- dbQuery GetGlobalState
+          lucidIO $ renderAdmin s edits
+        adminMethods
 
       -- Donation page
       Spock.get "donate" $

src/Types.hs

@@ -565,8 +565,6 @@ instance Migrate EditDetails where
     editDate = editDate_v1,
     editId = editId_v1 }
 
--- TODO: add a function to create a checkpoint to the admin panel?
-
 -- See Note [acid-state]
 
 data GlobalState = GlobalState {

src/View.hs

@@ -163,6 +163,10 @@ renderAdmin globalState edits = do
            content_ "width=device-width, initial-scale=1.0, user-scalable=yes"]
 
   body_ $ do
+    h1_ "Miscellaneous"
+    buttonUid <- randomLongUid
+    button "Create checkpoint" [uid_ buttonUid] $
+      JS.createCheckpoint [JS.selectUid buttonUid]
     h1_ "Pending edits"
     renderEdits globalState (map (,Nothing) edits)