Merge pull request #151 from Bongo50/refresh

Refresh

Author: Bongo50

.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