wip, code tossing

hbs2-git/hbs2-git-dashboard/GitDashBoard.hs

@@ -370,6 +370,7 @@ updateIndexPeriodially = do
 quit :: DashBoardPerks m => m ()
 quit = liftIO exitSuccess
 
+
 main :: IO ()
 main = do
   argz <- getArgs
@@ -382,42 +383,69 @@ main = do
 
           -- TODO: write-man-entries
 
-          entry $ bindMatch "--help" $ nil_ $ \case
+          myHelpEntry
-            HelpEntryBound what -> do
+          fixmeAllowEntry
-              helpEntry what
+          fixmeAllowDropEntry
-              quit
+          webEntry
-
+          portEntry
-            [StringLike s] -> helpList False (Just s) >> quit
+          developAssetsEntry
-
-            _ -> helpList False Nothing >> quit
-
-          entry $ bindMatch "develop-assets" $ nil_ \case
-            [StringLike s] -> do
-              pure ()
-
-            _ -> none
-
-          brief "allows fixme for given reflog" $
-            args [arg "public-key" "reflog"] $
-            examples [qc|
-              fixme-allow BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP
-            |]
-            $ entry $ bindMatch "fixme-allow" $ nil_ \case
-              [SignPubKeyLike what] -> do
-                lift $ insertFixmeAllowed (RepoRefLog (RefLogKey what))
-
-              _ -> throwIO $ BadFormException @C nil
-
-          entry $ bindMatch "port" $ nil_ \case
-            [LitIntVal n] -> do
-              tp <- lift $ asks _dashBoardHttpPort
-              atomically $ writeTVar tp (Just (fromIntegral n))
-
-            _ -> throwIO $ BadFormException @C nil
-
-          entry $ bindMatch "web" $ nil_ $ const do
-            lift runScotty
 
   void $ runDashBoardM $ run dict (conf <> cli)
 
+  where
+
+    myHelpEntry = do
+        entry $ bindMatch "--help" $ nil_ $ \case
+          HelpEntryBound what -> do
+            helpEntry what
+            quit
+
+          [StringLike s] -> helpList False (Just s) >> quit
+
+          _ -> helpList False Nothing >> quit
+
+    fixmeAllowEntry =  do
+      brief "allows fixme for given reflog" $
+        args [arg "public-key" "reflog"] $
+        examples [qc|
+          fixme-allow BTThPdHKF8XnEq4m6wzbKHKA6geLFK4ydYhBXAqBdHSP
+        |]
+        $ entry $ bindMatch "fixme-allow" $ nil_ \case
+          [SignPubKeyLike what] -> do
+            lift $ insertFixmeAllowed (RepoRefLog (RefLogKey what))
+
+          _ -> throwIO $ BadFormException @C nil
+
+
+    fixmeAllowDropEntry =  do
+      brief "drop all allowed fixme records" $
+        examples [qc|
+          fixme-allow:drop
+        |]
+        $ entry $ bindMatch "fixme-allow:drop" $ nil_ \case
+          [] -> do
+            lift $ deleteFixmeAllowed
+
+          _ -> throwIO $ BadFormException @C nil
+
+    webEntry = do
+      brief "run web interface" $
+        entry $ bindMatch "web" $ nil_ $ const do
+          lift runScotty
+
+    portEntry = do
+      brief "set http port for web interface" $
+        entry $ bindMatch "port" $ nil_ \case
+          [LitIntVal n] -> do
+            tp <- lift $ asks _dashBoardHttpPort
+            atomically $ writeTVar tp (Just (fromIntegral n))
+
+          _ -> throwIO $ BadFormException @C nil
+
+    developAssetsEntry = do
+      entry $ bindMatch "develop-assets" $ nil_ \case
+        [StringLike s] -> do
+          pure ()
+
+        _ -> none
 

hbs2-git/hbs2-git-dashboard/src/HBS2/Git/DashBoard/State.hs

@@ -942,6 +942,22 @@ insertFixmeAllowed  reflog = do
     insertOWKV (fromString o) mzero "$type" "fixme-allowed"
     insertOWKV (fromString o) mzero "value" v
 
+deleteFixmeAllowed :: ( DashBoardPerks m
+                      , MonadReader DashBoardEnv m
+                      )
+                   => m ()
+deleteFixmeAllowed = do
+
+  let sql = [qc|
+    with
+      s1 as (
+        select o from object where k = '$type' and json_extract(v, '$') = 'fixme-allowed'
+      )
+    delete from object where o in (select o from s1)
+    |]
+
+  withState $ S.insert_  sql
+
 checkFixmeAllowed :: (DashBoardPerks m, MonadReader DashBoardEnv m)
                   => RepoRefLog
                   -> m Bool