Add discord triggered restarting

.env.example

@@ -6,3 +6,4 @@ CATAPI_TOKEN=12345678-1234-1234-1234-123456789012
 EXEC_GROUP=123456789123456789
 MODERATOR_GROUP=321654987321654987
 SUPERUSER_GROUP=147258369147258369
+ALLOW_GIT_UPDATE=False

app/Main.hs

@@ -1,18 +1,28 @@
 module Main where
 
-import Control.Monad (forever)
+import Control.Concurrent.MVar (MVar, newMVar, swapMVar)
+import Control.Monad.Extra
 import Data.Maybe (fromMaybe)
 import Data.Text (pack)
 import LoadEnv (loadEnv)
 import System.Environment (getEnv, lookupEnv)
+import System.Process
 import Tablebot (runTablebot)
+import Tablebot.Internal.Administration
 import Tablebot.Plugins (plugins)
 
 -- @main@ runs forever. This allows bot reloading by fully shutting down the bot and letting it restart.
 main :: IO ()
-main = forever $ do
-  loadEnv
-  dToken <- pack <$> getEnv "DISCORD_TOKEN"
-  prefix <- pack . fromMaybe "!" <$> lookupEnv "PREFIX"
-  dbpath <- getEnv "SQLITE_FILENAME"
-  runTablebot dToken prefix dbpath plugins
+main = do
+  rFlag <- newMVar Reload :: IO (MVar ShutdownReason)
+  whileM $ do
+    _ <- swapMVar rFlag Reload
+    loadEnv
+    dToken <- pack <$> getEnv "DISCORD_TOKEN"
+    prefix <- pack . fromMaybe "!" <$> lookupEnv "PREFIX"
+    dbpath <- getEnv "SQLITE_FILENAME"
+    runTablebot dToken prefix dbpath (plugins rFlag)
+    exit <- swapMVar rFlag Reload
+    restartAction exit
+    pure $ not (restartIsTerminal exit)
+  putStrLn "Tablebot closed"

package.yaml

@@ -20,43 +20,46 @@ extra-source-files:
 description:         Please see the README on GitHub at <https://github.com/tagarople/tablebot#readme>
 
 dependencies:
-- base >= 4.7 && < 5
-- discord-haskell
-- emoji
-- text
-- text-icu
-- transformers
-- load-env
-- megaparsec
-- persistent
-- persistent-sqlite
-- persistent-template
-- random
-- esqueleto
-- monad-logger
-- time
-- aeson
-- bytestring
-- yaml
-- http-conduit
-- raw-strings-qq
-- template-haskell
-- timezone-olson
-- duckling
-- unordered-containers
-- bytestring
-- req
-- http-client
-- data-default
-- exception-transformers
-- resourcet
-- resource-pool
-- containers
-- th-printf
-- mtl
-- safe
-- edit-distance
-- unliftio
+  - base >= 4.7 && < 5
+  - extra
+  - discord-haskell
+  - emoji
+  - text
+  - text-icu
+  - transformers
+  - load-env
+  - megaparsec
+  - persistent
+  - persistent-sqlite
+  - persistent-template
+  - random
+  - esqueleto
+  - monad-logger
+  - time
+  - aeson
+  - bytestring
+  - yaml
+  - http-conduit
+  - raw-strings-qq
+  - template-haskell
+  - timezone-olson
+  - duckling
+  - unordered-containers
+  - bytestring
+  - req
+  - http-client
+  - data-default
+  - exception-transformers
+  - resourcet
+  - resource-pool
+  - containers
+  - th-printf
+  - mtl
+  - safe
+  - edit-distance
+  - unliftio
+  - process
+  - regex-pcre
 
 library:
   source-dirs: src

src/Tablebot.hs

@@ -41,9 +41,8 @@ import Tablebot.Handler (eventHandler, killCron, runCron)
 import Tablebot.Internal.Administration (adminMigration, currentBlacklist, removeBlacklisted)
 import Tablebot.Internal.Plugins
 import Tablebot.Internal.Types
+import Tablebot.Utility
 import Tablebot.Utility.Help
-import Tablebot.Utility.Types (TablebotCache (..))
-import Tablebot.Utility.Utils (debugPrint)
 
 -- | runTablebot @dToken@ @prefix@ @dbpath@ @plugins@ runs the bot using the
 -- given Discord API token @dToken@ and SQLite connection string @dbpath@. Only

src/Tablebot/Internal/Administration.hs

@@ -14,11 +14,17 @@ module Tablebot.Internal.Administration
   )
 where
 
+import Control.Monad.Cont (void, when)
+import Data.Maybe (fromMaybe)
 import Data.Text (Text, pack)
 import Database.Persist
 import Database.Persist.Sqlite (SqlPersistM)
 import Database.Persist.TH
+import Extra (lower, trim)
+import System.Environment (getEnv, lookupEnv)
+import System.Process
 import Tablebot.Internal.Types
+import Text.Regex.PCRE
 
 share
   [mkPersist sqlSettings, mkMigrate "adminMigration"]
@@ -40,3 +46,31 @@ removeBlacklisted :: [Text] -> [CompiledPlugin] -> [CompiledPlugin]
 removeBlacklisted bl = filter isNotBlacklisted
   where
     isNotBlacklisted p' = compiledName p' `notElem` bl
+
+data ShutdownReason = Halt | Reload | Restart | GitUpdate
+
+restartAction :: ShutdownReason -> IO ()
+restartAction GitUpdate = do
+  putStrLn "Git Update Requested"
+  updateGit
+  void $ spawnProcess "stack" ["run"]
+restartAction Restart = do
+  putStrLn "Restart Requested"
+  void $ spawnProcess "stack" ["run"]
+restartAction _ = return ()
+
+restartIsTerminal :: ShutdownReason -> Bool
+restartIsTerminal Reload = False
+restartIsTerminal _ = True
+
+updateGit :: IO ()
+updateGit = do
+  maybeEnabled <- lookupEnv "ALLOW_GIT_UPDATE"
+  let enabled = maybe False ((== "true") . lower . trim) maybeEnabled
+  when enabled $ do
+    status <- readProcess "git" ["status"] ""
+    let pattern :: String
+        pattern = "working directory clean"
+        clean :: Bool
+        clean = status =~ pattern
+    if clean then callProcess "git" ["pull"] else pure ()

src/Tablebot/Plugins.hs

@@ -14,6 +14,8 @@ module Tablebot.Plugins
   )
 where
 
+import Control.Concurrent.MVar (MVar)
+import Tablebot.Internal.Administration (ShutdownReason)
 import Tablebot.Internal.Plugins (compilePlugin)
 import Tablebot.Internal.Types (CompiledPlugin)
 import Tablebot.Plugins.Administration (administrationPlugin)
@@ -30,9 +32,10 @@ import Tablebot.Plugins.Shibe (shibePlugin)
 import Tablebot.Plugins.Welcome (welcomePlugin)
 
 -- Use long list format to make additions and removals non-conflicting on git PRs
-plugins :: [CompiledPlugin]
-plugins =
+plugins :: MVar ShutdownReason -> [CompiledPlugin]
+plugins rFlag =
   addAdministrationPlugin
+    rFlag
     [ compilePlugin pingPlugin,
       compilePlugin basicPlugin,
       compilePlugin catPlugin,
@@ -47,5 +50,5 @@ plugins =
     ]
 
 -- | @addAdministrationPlugin@ is needed to allow the administration plugin to be aware of the list of current plugins
-addAdministrationPlugin :: [CompiledPlugin] -> [CompiledPlugin]
-addAdministrationPlugin cps = compilePlugin (administrationPlugin cps) : cps
+addAdministrationPlugin :: MVar ShutdownReason -> [CompiledPlugin] -> [CompiledPlugin]
+addAdministrationPlugin rFlag cps = compilePlugin (administrationPlugin rFlag cps) : cps

src/Tablebot/Plugins/Administration.hs

@@ -9,9 +9,11 @@
 -- Commands that manage the loading and reloading of plugins
 module Tablebot.Plugins.Administration (administrationPlugin) where
 
--- import from handler is unorthodox, but I don't want other plugins messing with that table...
+-- import from internal is unorthodox, but I don't want other plugins messing with that table...
 
+import Control.Concurrent.MVar (MVar, swapMVar)
 import Control.Monad (when)
+import Control.Monad.Cont (liftIO)
 import Control.Monad.Trans.Reader (ask)
 import Data.Text (Text, pack)
 import qualified Data.Text as T
@@ -119,23 +121,63 @@ listBlacklist m = requirePermission Superuser m $ do
 ```|]
           (T.concat $ map (<> ("\n" :: Text)) l)
 
--- | @restart@ reloads the bot with any new configuration changes.
-reload :: EnvCommand SS
-reload = Command "reload" restartCommand []
+-- | @botcontrol@ reloads the bot with any new configuration changes.
+botControl :: MVar ShutdownReason -> EnvCommand SS
+botControl rFlag = Command "botcontrol" noCommand [reload rFlag, restart rFlag, halt rFlag]
+  where
+    noCommand :: Parser (Message -> EnvDatabaseDiscord SS ())
+    noCommand = noArguments $ \m -> requirePermission Superuser m $ do
+      sendMessage m "Please enter a subcommand"
+
+-- | @reload@ reloads the bot with any new configuration changes.
+reload :: MVar ShutdownReason -> EnvCommand SS
+reload rFlag = Command "reload" restartCommand []
   where
     restartCommand :: Parser (Message -> EnvDatabaseDiscord SS ())
     restartCommand = noArguments $ \m -> requirePermission Superuser m $ do
       sendMessage m "Reloading bot..."
+      _ <- liftIO $ swapMVar rFlag Reload
+      liftDiscord $ stopDiscord
+
+-- | @reload@ reloads the bot with any new configuration changes.
+restart :: MVar ShutdownReason -> EnvCommand SS
+restart rFlag = Command "restart" restartCommand []
+  where
+    restartCommand :: Parser (Message -> EnvDatabaseDiscord SS ())
+    restartCommand = noArguments $ \m -> requirePermission Superuser m $ do
+      sendMessage m "Restarting bot... (this may take some time)"
+      _ <- liftIO $ swapMVar rFlag Restart
+      liftDiscord $ stopDiscord
+
+-- | @halt@ stops the bot.
+halt :: MVar ShutdownReason -> EnvCommand SS
+halt rFlag = Command "halt" restartCommand []
+  where
+    restartCommand :: Parser (Message -> EnvDatabaseDiscord SS ())
+    restartCommand = noArguments $ \m -> requirePermission Superuser m $ do
+      sendMessage m "Halting bot! (Goodnight, cruel world)"
+      _ <- liftIO $ swapMVar rFlag Halt
       liftDiscord $ stopDiscord
 
+botControlHelp :: HelpPage
+botControlHelp =
+  HelpPage
+    "botcontrol"
+    []
+    "administrative commands"
+    [r|**Bot Control**
+General management commands for superuser use|]
+    [reloadHelp]
+    Superuser
+
 reloadHelp :: HelpPage
 reloadHelp =
   HelpPage
     "reload"
     []
     "reload the bot"
-    [r|**Restart**
-Restart the bot
+    [r|**Reload**
+Restart the bot without recompiling
 
 *Usage:* `reload`|]
     []
@@ -200,5 +242,5 @@ adminStartup cps =
 
 -- | @administrationPlugin@ assembles the commands into a plugin.
 -- Note the use of an underscore in the name, this prevents the plugin being disabled.
-administrationPlugin :: [CompiledPlugin] -> EnvPlugin SS
-administrationPlugin cps = (envPlug "_admin" $ adminStartup cps) {commands = [reload, blacklist], helpPages = [reloadHelp, blacklistHelp]}
+administrationPlugin :: MVar ShutdownReason -> [CompiledPlugin] -> EnvPlugin SS
+administrationPlugin rFlag cps = (envPlug "_admin" $ adminStartup cps) {commands = [botControl rFlag, blacklist], helpPages = [botControlHelp, blacklistHelp]}

src/Tablebot/Utility.hs

@@ -11,7 +11,9 @@
 -- are ever updated. You should always import this over "Tablebot.Plugin.Types".
 module Tablebot.Utility
   ( module Types,
+    module Utils,
   )
 where
 
 import Tablebot.Utility.Types as Types hiding (Pl)
+import Tablebot.Utility.Utils as Utils

src/Tablebot/Utility/Utils.hs

@@ -42,3 +42,8 @@ standardise :: Text -> Text
 standardise x = filter (not . property Diacritic) normalizedText
   where
     normalizedText = normalize NFD $ toLower x
+
+newtype DebugString = DStr String
+
+instance Show DebugString where
+  show (DStr a) = a