Refresh

.gitignore

@@ -3,7 +3,7 @@
 .env
 db.*
 database*
-*.cabal
-stack.yaml.lock
 .gitattributes
 .vscode
+dist-newstyle/
+cabal.project.local

Dockerfile

@@ -1,11 +1,10 @@
-# stack resolver 18.18 uses ghc 8.10.7
-FROM haskell:8.10.7 as build
+# stack resolver 24.10 uses ghc 9.10.2 - when upgrading LTS version in stack.yaml, check Haskell version on https://www.stackage.org/ and check which Debian release is available on https://hub.docker.com/_/haskell/
+FROM haskell:9.10.2-bullseye as build
 RUN mkdir -p /tablebot/build
 WORKDIR /tablebot/build
 
 # system lib dependencies
-RUN sed -i s/deb.debian.org/archive.debian.org/g /etc/apt/sources.list && \ 
-  apt-get update -qq && \
+RUN apt-get update -qq && \
   apt-get install -qq -y libpcre3-dev build-essential pkg-config libicu-dev --fix-missing --no-install-recommends && \
   apt-get clean && \
   rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
@@ -16,12 +15,12 @@ RUN stack build --system-ghc
 
 RUN mv "$(stack path --local-install-root --system-ghc)/bin" /tablebot/build/bin
 
-FROM haskell:8.10.7-slim as app
+# ensure this matches first FROM
+FROM haskell:9.10.2-slim-bullseye as app
 
-# system runtime deps
-RUN sed -i s/deb.debian.org/archive.debian.org/g /etc/apt/sources.list && \ 
-  apt-get update -qq && \
-  apt-get install -qq -y libpcre3 libicu63 --fix-missing --no-install-recommends && \
+# system runtime deps - if this command fails, check libicu version (https://packages.debian.org/index) and upgrade if necessary
+RUN apt-get update -qq && \
+  apt-get install -qq -y libpcre3 libicu67 --fix-missing --no-install-recommends && \
   apt-get clean && \
   rm -rf /var/lib/apt/lists/* /tmp/* /var/tmp/*
 

cabal.project

@@ -0,0 +1,11 @@
+packages: .
+
+source-repository-package
+  type: git
+  location: [email protected]:L0neGamer/haskell-distribution.git
+  tag: 569d6452e4bffedb2c0d3795885fccdb22a4d29d
+
+source-repository-package
+  type: git
+  location: [email protected]:L0neGamer/duckling.git
+  tag: f22e3cdd7b77977fe3e9ec75fccd9a0f79c47f97

package.yaml

@@ -100,6 +100,7 @@ library:
     - TypeOperators
     - RankNTypes
     - BangPatterns
+    - ViewPatterns
   ghc-options:
     - -Wall
 

src/Tablebot.hs

@@ -27,7 +27,6 @@ import Data.Map as M (empty)
 import Data.Maybe (fromMaybe)
 import Data.Text (Text, pack)
 import qualified Data.Text as T
-import Data.Text.Encoding (encodeUtf8)
 import Database.Persist.Sqlite
   ( runMigration,
     runSqlPool,
@@ -38,7 +37,6 @@ import Discord.Internal.Rest
 import LoadEnv (loadEnv)
 import Paths_tablebot (version)
 import System.Environment (getEnv, lookupEnv)
-import System.Exit (die)
 import Tablebot.Handler (eventHandler, killCron, runCron, submitApplicationCommands)
 import Tablebot.Internal.Administration
   ( ShutdownReason (Reload),
@@ -144,13 +142,8 @@ runTablebot vinfo dToken prefix dbpath plugins config =
     activityStatus =
       UpdateStatusOpts
         { updateStatusOptsSince = Nothing,
-          updateStatusOptsGame =
-            Just
-              ( def
-                  { activityName = gamePlaying config prefix,
-                    activityType = ActivityTypeGame
-                  }
-              ),
+          updateStatusOptsActivities =
+            [mkActivity (gamePlaying config prefix) ActivityTypeGame],
           updateStatusOptsNewStatus = UpdateStatusOnline,
           updateStatusOptsAFK = False
         }

src/Tablebot/Handler.hs

@@ -127,7 +127,7 @@ submitApplicationCommands compiledAppComms cacheMVar =
         Nothing -> pure ()
         Just serverIdStr -> do
           serverId <- readServerStr serverIdStr
-          aid <- partialApplicationID . cacheApplication <$> readCache
+          aid <- fullApplicationID . cacheApplication <$> readCache
           applicationCommands <-
             mapM
               ( \(CApplicationCommand cac action) -> do

src/Tablebot/Internal/Administration.hs

@@ -14,7 +14,8 @@ module Tablebot.Internal.Administration
   )
 where
 
-import Control.Monad.Cont (MonadIO, void, when)
+import Control.Monad (void, when)
+import Control.Monad.IO.Class (MonadIO)
 import Data.List.Extra (isInfixOf, lower, trim)
 import Data.Text (Text, pack)
 import Database.Persist

src/Tablebot/Internal/Alias.hs

@@ -10,22 +10,21 @@
 module Tablebot.Internal.Alias where
 
 import Control.Monad.Exception (MonadException (catch), SomeException)
-import Data.Text
+import qualified Data.Text as T
 import Database.Persist.Sqlite (BackendKey (SqlBackendKey))
 import qualified Database.Persist.Sqlite as Sql
 import Database.Persist.TH
 import Discord.Types
 import Tablebot.Internal.Administration (currentBlacklist)
 import Tablebot.Internal.Types
-import Tablebot.Utility.Database (liftSql, selectList)
-import Tablebot.Utility.Types (EnvDatabaseDiscord)
+import Tablebot.Utility.Types (EnvDatabaseDiscord, liftSql)
 
 share
   [mkPersist sqlSettings, mkMigrate "aliasMigration"]
   [persistLowerCase|
 Alias
-    alias Text
-    command Text
+    alias T.Text
+    command T.Text
     type AliasType
     UniqueAlias alias type
     deriving Show
@@ -38,5 +37,5 @@ getAliases uid = do
   if "alias" `elem` blacklist
     then return Nothing
     else
-      (Just . fmap Sql.entityVal <$> selectList [AliasType Sql.<-. [AliasPublic, AliasPrivate uid]] [])
+      liftSql (Just . fmap Sql.entityVal <$> Sql.selectList [AliasType Sql.<-. [AliasPublic, AliasPrivate uid]] [])
         `catch` (\(_ :: SomeException) -> return Nothing)

src/Tablebot/Internal/Handler/Command.hs

@@ -17,6 +17,7 @@ module Tablebot.Internal.Handler.Command
   )
 where
 
+import qualified Data.Functor as Functor
 import Data.List (find)
 import qualified Data.List.NonEmpty as NE
 import Data.Maybe (catMaybes)
@@ -125,18 +126,17 @@ instance ShowErrorComponent ReadableError where
 
 makeBundleReadable :: ParseErrorBundle Text Void -> (ParseErrorBundle Text ReadableError, String)
 makeBundleReadable (ParseErrorBundle errs state) =
-  let (errors, title) = NE.unzip $ NE.map makeReadable errs
+  let (errors, title) = Functor.unzip $ NE.map makeReadable errs
    in (ParseErrorBundle errors state, getTitle $ NE.toList title)
   where
     getTitle :: [Maybe String] -> String
     -- Safety proof for application of `head`: we filter by `not . null` so each element is nonempty.
     getTitle titles = case filter (not . null) $ catMaybes titles of
       -- therefore, `x` is nonempty, so `lines x` is nonempty, meaning that `head (lines x)` is fine,
       -- since `lines x` is nonempty for nonempty input.
-      (x : xs) ->
-        let title = head (lines x)
-         in if null xs then title else title ++ " (and " ++ show (length xs) ++ " more)"
-      [] -> "Parser Error!"
+      ((NE.nonEmpty . lines -> Just (title NE.:| _)) : xs) ->
+        if null xs then title else title ++ " (and " ++ show (length xs) ++ " more)"
+      _ -> "Parser Error!"
 
 -- | Transform our errors into more useful ones.
 -- This uses the Label hidden within each error to build an error message,

src/Tablebot/Internal/Types.hs

@@ -127,7 +127,7 @@ instance PersistField AliasType where
   toPersistValue AliasPublic = PersistInt64 (-1)
   fromPersistValue = \case
     PersistInt64 (-1) -> Right AliasPublic
-    PersistInt64 i -> Right $ AliasPrivate (fromIntegral i)
+    PersistInt64 i -> Right $ AliasPrivate (DiscordId (Snowflake (fromIntegral i)))
     _ -> Left "AliasType: fromPersistValue: Invalid value"
 
 instance PersistFieldSql AliasType where

src/Tablebot/Plugins/Administration.hs

@@ -13,20 +13,20 @@ module Tablebot.Plugins.Administration (administrationPlugin) where
 
 import Control.Concurrent.MVar (MVar, swapMVar)
 import Control.Monad (when)
-import Control.Monad.Cont (liftIO)
+import Control.Monad.IO.Class (liftIO)
 import Control.Monad.Trans.Reader (ask)
 import Data.Text (Text, pack)
 import qualified Data.Text as T
 import Data.Version (showVersion)
 import Database.Persist (Entity, Filter, entityVal, (==.))
+import qualified Database.Persist.Sqlite as Sql
 import Discord (stopDiscord)
 import Discord.Types
 import Language.Haskell.Printf (s)
 import Tablebot.Internal.Administration
 import Tablebot.Internal.Cache (getVersionInfo)
 import Tablebot.Internal.Types (CompiledPlugin (compiledName))
 import Tablebot.Utility
-import Tablebot.Utility.Database
 import Tablebot.Utility.Discord (sendMessage)
 import Tablebot.Utility.Permission (requirePermission)
 import Tablebot.Utility.SmartParser
@@ -60,27 +60,27 @@ addBlacklist pLabel m = requirePermission Superuser m $ do
   -- It's not an error to add an unknown plugin (so that you can pre-disable a plugin you know you're about to add),
   -- but emmit a warning so people know if it wasn't deliberate
   when (pack pLabel `notElem` known) $ sendMessage m "Warning, unknown plugin"
-  extant <- exists [PluginBlacklistLabel ==. pLabel]
+  extant <- liftSql $ Sql.exists [PluginBlacklistLabel ==. pLabel]
   if not extant
     then do
-      _ <- insert $ PluginBlacklist pLabel
+      _ <- liftSql $ Sql.insert $ PluginBlacklist pLabel
       sendMessage m "Plugin added to blacklist. Please reload for it to take effect"
     else sendMessage m "Plugin already in blacklist"
 
 removeBlacklist :: String -> Message -> EnvDatabaseDiscord SS ()
 removeBlacklist pLabel m = requirePermission Superuser m $ do
-  extant <- selectKeysList [PluginBlacklistLabel ==. pLabel] []
-  if not $ null extant
-    then do
-      _ <- delete (head extant)
+  extant <- liftSql $ Sql.selectKeysList [PluginBlacklistLabel ==. pLabel] []
+  case extant of
+    x : _ -> do
+      _ <- liftSql $ Sql.delete x
       sendMessage m "Plugin removed from blacklist. Please reload for it to take effect"
-    else sendMessage m "Plugin not in blacklist"
+    _ -> sendMessage m "Plugin not in blacklist"
 
 -- | @listBlacklist@ shows a list of the plugins eligible for disablement (those not starting with _),
 --  along with their current status.
 listBlacklist :: Message -> EnvDatabaseDiscord SS ()
 listBlacklist m = requirePermission Superuser m $ do
-  bl <- selectList allBlacklisted []
+  bl <- liftSql $ Sql.selectList allBlacklisted []
   pl <- ask
   sendMessage m (format pl (blacklisted bl))
   where

src/Tablebot/Plugins/Alias.hs

@@ -18,7 +18,6 @@ import Discord.Types
 import Tablebot.Internal.Alias
 import Tablebot.Internal.Types (AliasType (..))
 import Tablebot.Utility
-import Tablebot.Utility.Database (deleteBy, exists)
 import Tablebot.Utility.Discord (sendMessage)
 import Tablebot.Utility.Permission (requirePermission)
 import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (..), WithError (..))
@@ -157,9 +156,9 @@ aliasDeleteCommand =
 aliasDelete :: Text -> AliasType -> Message -> DatabaseDiscord ()
 aliasDelete a at m = do
   let toDelete = UniqueAlias a at
-  itemExists <- exists [AliasAlias Sql.==. a, AliasType Sql.==. at]
+  itemExists <- liftSql $ Sql.exists [AliasAlias Sql.==. a, AliasType Sql.==. at]
   if itemExists
-    then deleteBy toDelete >> sendMessage m ("Deleted alias `" <> a <> "`")
+    then liftSql (Sql.deleteBy toDelete) >> sendMessage m ("Deleted alias `" <> a <> "`")
     else sendMessage m ("No such alias `" <> a <> "`")
 
 aliasDeleteHelp :: HelpPage

src/Tablebot/Plugins/Flip.hs

@@ -28,9 +28,9 @@ flip = Command "flip" flipcomm []
     flipcomm = do
       args <- (try quoted <|> nonSpaceWord) `sepBy` some space
       return $ \m -> do
-        c <- case length args of
-          0 -> liftIO $ chooseOneWithDefault "" ["Heads", "Tails"]
-          _ -> liftIO $ chooseOneWithDefault (head args) args
+        c <- case args of
+          [] -> liftIO $ chooseOneWithDefault "" ["Heads", "Tails"]
+          a : _ -> liftIO $ chooseOneWithDefault a args
         sendMessage m $ pack c
 
 flipHelp :: HelpPage

src/Tablebot/Plugins/Netrunner/Command/BanList.hs

@@ -19,7 +19,7 @@ where
 
 import Data.List (nubBy)
 import Data.Map (keys)
-import Data.Maybe (fromMaybe, mapMaybe)
+import Data.Maybe (fromMaybe, listToMaybe, mapMaybe)
 import Data.Text (Text, intercalate, isInfixOf, toLower, unpack)
 import qualified Data.Text as T (length, take)
 import Tablebot.Plugins.Netrunner.Type.BanList (BanList (active, affectedCards, listId, name), CardBan (..))
@@ -81,9 +81,7 @@ listAffectedCards api b =
    in (pre, map format cCards, map format rCards)
   where
     find :: Text -> Maybe Card
-    find cCode = case filter ((Just cCode ==) . code) $ cards api of
-      [] -> Nothing
-      xs -> Just $ head xs
+    find cCode = listToMaybe $ filter ((Just cCode ==) . code) $ cards api
     format :: Card -> Text
     format card = symbol (toMwlStatus api b card) <> " " <> condense (fromMaybe "?" $ title card)
     condense :: Text -> Text

src/Tablebot/Plugins/Netrunner/Command/Search.hs

@@ -126,7 +126,7 @@ fixSearch api = mapMaybe fix
     -- format ("r", sep, v) =
     format ("u", sep, v) = Just $ QBool "u" sep uniqueness v
     format ("b", _, []) = Nothing
-    format ("b", sep, v) = Just $ QBan "b" sep $ fixBan $ head v
+    format ("b", sep, v : _) = Just $ QBan "b" sep $ fixBan v
     -- format ("z", sep, v) =
     format _ = Nothing
     cycleIndex :: Card -> Maybe Int

src/Tablebot/Plugins/Netrunner/Plugin.hs

@@ -29,9 +29,9 @@ import Tablebot.Plugins.Netrunner.Utility.Card (toText)
 import Tablebot.Plugins.Netrunner.Utility.Embed
 import Tablebot.Plugins.Netrunner.Utility.NrApi (getNrApi)
 import Tablebot.Utility
-import Tablebot.Utility.Discord (formatFromEmojiName, sendEmbedMessage, sendMessage)
+import Tablebot.Utility.Discord (formatFromEmojiName, inlineCommandHelper, sendEmbedMessage, sendMessage)
 import Tablebot.Utility.Embed (addColour)
-import Tablebot.Utility.Parser (inlineCommandHelper, keyValue, keyValuesSepOn)
+import Tablebot.Utility.Parser (keyValue, keyValuesSepOn)
 import Tablebot.Utility.SmartParser (PComm (parseComm), Quoted (Qu), RestOfInput (ROI), RestOfInput1 (ROI1), WithError (WErr))
 import Tablebot.Utility.Types ()
 import Text.Megaparsec (anySingleBut, some)