diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,1 @@ +Fix issues with intents. diff --git a/README.md b/README.md --- a/README.md +++ b/README.md @@ -1,25 +1,5 @@ ## Discord-register -### Verification bot for registers with full name and email - -Discord-register is an interactive verification bot for registers with full name, email and photo ID requirements. - -#### Features: -- All verification forms sent to a verification channel -- Messages configurable with Dhall (except most admin messages in English) -- Verification forms can be reset by those with admin role using a command giving a reason -- Parser for full names, supporting unicode and requiring an underscore if no surname. -- Sane defaults -- Low memory usage (high cpu/memory usage for compile however) -- Written in Haskell using Polysemy with Calamity effects -- No database needed - -To build run: -```stack build``` - -This build depends on `libtinfo-dev` for Ubuntu 20.04. - -The configuration is in ```config.dhall```, this needs to be copied and filled in from ```config.dhall.empty```. - -Bot tokens can be found in the Discord Developer Portal after creating a bot. +### Verification bot for registers with name and attachment -ID numbers, or Snowflakes, can be found in the UI by right clicking on something after enabling developer mode in Appearance under the settings. +This is a Discord bot for vetting new users, see config.json for an example. +It supports a name query followed by an attachment query. diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -1,5 +1,39 @@ module Main where +import Calamity +import Calamity.Cache.InMemory (runCacheInMemory) +import Calamity.Commands (useConstantPrefix) +import Calamity.Commands.Context (useLightContext) +import Calamity.Metrics.Noop (runMetricsNoop) +import Control.Lens +import Control.Monad (void) +import Data.Aeson (eitherDecodeFileStrict) +import Data.ByteString (readFile) +import Data.Flags (allFlags) +import qualified Data.HashMap.Strict as Map +import qualified Di (new) +import DiPolysemy (runDiToIO) +import GHC.Conc (newTVarIO) +import Kv import Lib +import Polysemy +import Polysemy.AtomicState +import Prelude hiding (readFile) -main = execBot +main = do + eitherDecodeFileStrict "./config.json" >>= \case + Left e -> print e + Right cfg -> do + emptyMap <- newTVarIO (Map.empty :: Map.HashMap (Snowflake User) Form) + Di.new \di -> -- logging continuation? this is strange + do + void . runFinal . embedToFinal . runCacheInMemory + . runDiToIO di -- logging + . runMetricsNoop -- no metrics + . useConstantPrefix "¬" + . runAtomicStateTVar emptyMap -- trying not to pollute IO + . runKVStoreAtomic + . useLightContext -- light command context + -- all intents + . runBotIO (BotToken $ cfg ^. #botToken) allFlags + $ program cfg diff --git a/config.dhall.empty b/config.dhall.empty deleted file mode 100644 --- a/config.dhall.empty +++ /dev/null @@ -1,20 +0,0 @@ -{ botID.fromSnowflake = 1, - adminID.fromSnowflake = 1, - adminRoleID.fromSnowflake = 1, - vchannelID.fromSnowflake = 1, - botToken = "botToken", - joinMsg = - "Welcome to this organisation. For safe guarding we must check each user is on the society register; for more information please message one of the admin(s) listed in the rules channel. What is your full name?", - faultyNameReciMsg = "Please enter a valid full name, if you have no surname please add an underscore seperated by a space.", - privacyMsg = "Privacy policy", - resetNeedsGuildMsg = "The reset command can only be entered in a guild.", - iveBeenResetMsg = "Your verification form has been reset, what is your full name?", - notAdminMsg = "This command is restricted to admins.", - nameReciMsg = "Thank you, what is your full email?", - emailReciMsg = "Thank you, please could you send photo ID as an attachment (at most 1 file)?", - finishedMsg = "That's all, for more information please type ¬info. For the privacy policy please type ¬info.", - noAtEmailMsg = "This email is invalid, there should be a single at symbol.", - noScreenshotMsg = "This message contains no attachments.", - screenshotReciMsg = "Thank you, that's all. Your information has been sent to a verification channel.", - infoMsg = "This is a bot to verify your full name, email and ID with the organisation's register.", -} diff --git a/discord-register.cabal b/discord-register.cabal --- a/discord-register.cabal +++ b/discord-register.cabal @@ -1,15 +1,13 @@ cabal-version: 1.12 --- This file has been generated from package.yaml by hpack version 0.33.0. +-- This file has been generated from package.yaml by hpack version 0.34.4. -- -- see: https://github.com/sol/hpack --- --- hash: cb0ee8652183daa53d0b461b96eb9cfd98ffb2c63c596c26700fe5112264e860 name: discord-register -version: 0.0.1 +version: 0.0.2 synopsis: Discord verification bot -description: This bot can send new server members a message on entry, ask for their full name (using a parser to check it is reasonable), email and a picture from them. Reset commands for improper forms are also implemented, as well as help, privacy and info commands. The default prefix is the negation symbol from mathematics. +description: This bot can send new server members a message on entry, ask for their name and an attachment. category: Web homepage: https://github.com/hgsipiere/discord-register#readme bug-reports: https://github.com/hgsipiere/discord-register/issues @@ -18,12 +16,13 @@ copyright: 2020 Hugh Sipiere license: MPL-2.0 license-file: LICENSE -tested-with: GHC == 8.8.4 build-type: Simple +tested-with: + GHC == 8.10.4 extra-source-files: LICENSE README.md - config.dhall.empty + ChangeLog.md source-repository head type: git @@ -31,30 +30,63 @@ library exposed-modules: + Kv Lib + Parser + Utils other-modules: Paths_discord_register hs-source-dirs: src - default-extensions: DataKinds FlexibleContexts GADTs LambdaCase PolyKinds RankNTypes ScopedTypeVariables TypeApplications TypeOperators TypeFamilies DeriveGeneric BlockArguments OverloadedLabels OverloadedStrings TemplateHaskell ConstraintKinds DefaultSignatures DeriveFunctor FlexibleInstances MultiParamTypeClasses MultiWayIf UndecidableInstances ViewPatterns NamedFieldPuns - ghc-options: -O2 -fplugin=Polysemy.Plugin + default-extensions: + DataKinds + FlexibleContexts + GADTs + LambdaCase + PolyKinds + ScopedTypeVariables + TypeOperators + TypeFamilies + DeriveGeneric + BlockArguments + OverloadedLabels + OverloadedStrings + TemplateHaskell + ConstraintKinds + DefaultSignatures + FlexibleInstances + MultiParamTypeClasses + MultiWayIf + UndecidableInstances + ViewPatterns + NamedFieldPuns + TemplateHaskell + PartialTypeSignatures + ConstraintKinds + LambdaCase + ghc-options: -fplugin=Polysemy.Plugin build-depends: - base >=4.7 && <5 - , calamity >=0.1.20.1 && <0.1.21 - , dhall >=1.35.0 && <1.36.1 - , di >=1.3 && <1.3.1 - , di-polysemy >=0.2.0.0 && <0.2.1 - , generic-lens >=2.0.0.0 && <2.0.1 - , hspec >=2.7.4 && <2.7.5 - , hspec-megaparsec >=2.1.0 && <2.1.1 - , megaparsec >=8.0.0 - , polysemy >=1.3.0.0 && <1.3.1 - , polysemy-plugin >=0.2.5.0 && <0.2.6 - , text >=1.2.4.0 && <1.2.5 - , text-show >=3.8.5 && <3.9.1 - , unboxing-vector >=0.1.1.0 - , unordered-containers >=0.2.10.0 && <0.2.13.0 - , vector >=0.12.1.2 && <0.12.2 + aeson + , base ==4.14.* + , binary + , bytestring + , calamity + , calamity-commands + , data-flags + , di + , di-polysemy + , generic-lens + , hashable + , hedis + , lens + , megaparsec + , polysemy + , polysemy-plugin + , regex-tdfa + , text + , text-show + , unboxing-vector + , unordered-containers default-language: Haskell2010 executable discord-register-exe @@ -63,50 +95,53 @@ Paths_discord_register hs-source-dirs: app - build-depends: - base >=4.7 && <5 - , calamity >=0.1.20.1 && <0.1.21 - , dhall >=1.35.0 && <1.36.1 - , di >=1.3 && <1.3.1 - , di-polysemy >=0.2.0.0 && <0.2.1 - , discord-register - , generic-lens >=2.0.0.0 && <2.0.1 - , hspec >=2.7.4 && <2.7.5 - , hspec-megaparsec >=2.1.0 && <2.1.1 - , megaparsec >=8.0.0 - , polysemy >=1.3.0.0 && <1.3.1 - , polysemy-plugin >=0.2.5.0 && <0.2.6 - , text >=1.2.4.0 && <1.2.5 - , text-show >=3.8.5 && <3.9.1 - , unboxing-vector >=0.1.1.0 - , unordered-containers >=0.2.10.0 && <0.2.13.0 - , vector >=0.12.1.2 && <0.12.2 - default-language: Haskell2010 - -test-suite discord-register-test - type: exitcode-stdio-1.0 - main-is: Spec.hs - other-modules: - Paths_discord_register - hs-source-dirs: - test - ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-extensions: + DataKinds + FlexibleContexts + GADTs + LambdaCase + PolyKinds + ScopedTypeVariables + TypeOperators + TypeFamilies + DeriveGeneric + BlockArguments + OverloadedLabels + OverloadedStrings + TemplateHaskell + ConstraintKinds + DefaultSignatures + FlexibleInstances + MultiParamTypeClasses + MultiWayIf + UndecidableInstances + ViewPatterns + NamedFieldPuns + TemplateHaskell + PartialTypeSignatures + ConstraintKinds + LambdaCase build-depends: - base >=4.7 && <5 - , calamity >=0.1.20.1 && <0.1.21 - , dhall >=1.35.0 && <1.36.1 - , di >=1.3 && <1.3.1 - , di-polysemy >=0.2.0.0 && <0.2.1 + aeson + , base ==4.14.* + , binary + , bytestring + , calamity + , calamity-commands + , data-flags + , di + , di-polysemy , discord-register - , generic-lens >=2.0.0.0 && <2.0.1 - , hspec >=2.7.4 && <2.7.5 - , hspec-megaparsec >=2.1.0 && <2.1.1 - , megaparsec >=8.0.0 - , polysemy >=1.3.0.0 && <1.3.1 - , polysemy-plugin >=0.2.5.0 && <0.2.6 - , text >=1.2.4.0 && <1.2.5 - , text-show >=3.8.5 && <3.9.1 - , unboxing-vector >=0.1.1.0 - , unordered-containers >=0.2.10.0 && <0.2.13.0 - , vector >=0.12.1.2 && <0.12.2 + , generic-lens + , hashable + , hedis + , lens + , megaparsec + , polysemy + , polysemy-plugin + , regex-tdfa + , text + , text-show + , unboxing-vector + , unordered-containers default-language: Haskell2010 diff --git a/src/Kv.hs b/src/Kv.hs new file mode 100644 --- /dev/null +++ b/src/Kv.hs @@ -0,0 +1,36 @@ +module Kv where + +import Control.Monad +import Data.Either +import Data.HashMap.Strict as Map +import Data.Hashable (Hashable) +import Data.Maybe +import Polysemy +import Polysemy.AtomicState + +data KVStore k v m a where + Kvset :: k -> v -> KVStore k v m () + Kvget :: k -> KVStore k v m (Maybe v) + Kvdel :: k -> KVStore k v m () + +makeSem ''KVStore -- template haskell + +-- we use atomic operations to be thread safe in concurrency +runKVStoreAtomic :: + ( Member (AtomicState (HashMap k v)) r, + Eq k, + Hashable k + ) => + Sem (KVStore k v ': r) a -> + Sem r a +runKVStoreAtomic = interpret $ \case + Kvset k v -> atomicModify' $ Map.insert k v + Kvget k -> atomicGets $ Map.lookup k + Kvdel k -> atomicModify' $ Map.delete k + +kvgets :: + (Member (KVStore k v) r, Eq k, Hashable k) => + (v -> a) -> + k -> + Sem r (Maybe a) +kvgets f k = fmap f <$> kvget k diff --git a/src/Lib.hs b/src/Lib.hs --- a/src/Lib.hs +++ b/src/Lib.hs @@ -1,156 +1,113 @@ +{-# LANGUAGE TypeApplications #-} + module Lib where -import Calamity hiding (author) -import Calamity.Cache.InMemory -import Calamity.Commands -import Calamity.Metrics.Noop +import Calamity as Cal hiding (Embed, Member, author, embed) +import Calamity.Commands (addCommands, command, helpCommand) +import Calamity.Commands.Context (ctxUserID) +import qualified Calamity.HTTP.Channel as HttpChan import qualified Calamity.HTTP.Guild -import Calamity.Types.Model.Channel.Message as M - -import Data.Generics.Internal.VL ((^.)) -import Control.Monad (void) - -import qualified Data.HashMap.Strict as Map (insert, empty, lookup, HashMap) -import Data.Maybe (isNothing) -import qualified Data.Text as T -import Data.Text.Lazy as TL (Text, pack, intercalate, unpack, foldl', append, any, singleton) - -import qualified Dhall (input, auto, FromDhall) - -import qualified Di (new) -import DiPolysemy (runDiToIO, info) - -import GHC.Generics - -import qualified Polysemy as P -import qualified Polysemy.AtomicState as P - -import TextShow - -import Text.Megaparsec.Byte (space, string) - +import qualified Calamity.Types.Model.Channel.Attachment as Attachm +import Calamity.Types.Model.Channel.Message as Messg +import Calamity.Types.Upgradeable (upgrade) +import Control.Lens +import Control.Monad (mapM_, void) +import Data.Aeson (FromJSON, ToJSON) +import Data.List (foldl') +import Data.Maybe (isJust) +import qualified Data.Text as TS +import Data.Text.Lazy as TL (Text, any, append, intercalate, pack, unpack, unwords) +import Data.Text.Lazy.IO (writeFile) import qualified Data.Vector.Unboxing as V (elem) +import GHC.Generics (Generic) +import Kv +import Parser (parseFullName) -- get rid of this +import Polysemy +import Text.Regex.TDFA ((=~)) +import Utils (EssentialEnv) +import Prelude hiding (any, intercalate, readFile, unwords, writeFile) -import Data.Void +data InfoCmd = InfoCmd {cmd_name :: TS.Text, info :: Text} deriving (Generic) -import Text.Megaparsec -import Text.Megaparsec.Char as C -import qualified Text.Megaparsec.Char.Lexer as CL +data Query = Query {incorrect_response :: Text, correct_response :: Text} deriving (Generic) --- similar to mccarthy conditional -if' True a _ = a -if' False _ b = b +data Cfg = Cfg + { botToken :: Text, + botID :: Snowflake User, + vChannelID :: Snowflake Channel, + joinMsg :: Text, + infoCommands :: [InfoCmd], + name_query :: Query, + screenshot_query :: Query, + done :: Text + } + deriving (Generic) --- parser for full name, the underscore --- is to handle the edge case of a single name, full name -type ParserStr = Parsec Void String +-- this allows us to use a configuration file +instance FromJSON Query -preLexeme, lexeme :: ParserStr a -> ParserStr a -lexeme = CL.lexeme C.space -preLexeme = (*>) C.space +instance FromJSON InfoCmd -nameOrUnderscore', fullName :: ParserStr String -nameOrUnderscore' = (some letterChar) <|> (fmap pure . char $ '_') -fullName = do - firstName <- preLexeme nameOrUnderscore' - restNames <- lexeme . some . preLexeme $ nameOrUnderscore' - pure $ foldl (\z s -> z ++ " " ++ s) firstName restNames +instance FromJSON Cfg -data Settings = Settings { - botToken :: Text, botID :: Snowflake User, adminID :: Snowflake User, vchannelID :: Snowflake Channel, - adminRoleID :: Snowflake Role, - joinMsg :: Text, faultyNameReciMsg :: Text, nameReciMsg :: Text, emailReciMsg :: Text, screenshotReciMsg :: Text, - noAtEmailMsg :: Text, noScreenshotMsg :: Text, finishedMsg :: Text, - privacyMsg :: Text, infoMsg :: Text, - iveBeenResetMsg :: Text, resetNeedsGuildMsg :: Text, notAdminMsg :: Text -} deriving (Generic, Show) +data Form = NoDetails | Named Text | Finished -instance Dhall.FromDhall (Snowflake a) -instance Dhall.FromDhall Settings -data Form = Empty | Named Text | NamedEmailed Text Text | Finished +-- proposition that a value is a program with key value store +type Env r c = + ( EssentialEnv r c, + Member (KVStore (Snowflake User) Form) r + ) -mentionUser :: Snowflake User -> Text -> Text -> CreateMessageOptions -mentionUser sUser preMention content = CreateMessageOptions - (Just . T.pack . TL.unpack $ - -- discord lets you type <@uid> to mention someone where uid is their discord user id - preMention `append` "<@" `append` showtl sUser `append` ">" `append` content) - Nothing Nothing Nothing Nothing -- no nonce, tts, file, embed - (Just (AllowedMentions [AllowedMentionUsers] [] [sUser])) +messageCreateAction :: Env r c => Cfg -> Message -> Sem r () +messageCreateAction cfg msg@Message {author, Messg.content = response, attachments} = + -- check the bot would be replying to itself or a non-personal message + -- this should also avoid replying to a command too, todo later + if author == cfg ^. #botID || isJust (msg ^. #guildID) + then pure () + else + kvget author >>= \case + Nothing -> grabName cfg author response -- nothing stored about them + Just NoDetails -> grabName cfg author response -- they gave no details + Just (Named name) -> grabScreenshot cfg author name attachments + Just Finished -> void . tell author $ cfg ^. #done -grabName cfg msg = - case runParser fullName "" (unpack response) of - -- we don't give back parser error messages because they don't tell how to terminate a parse - -- but rather how to let the combinators continue, this is very confusing - Left error -> void $ tell author $ cfg ^. #faultyNameReciMsg +grabName :: Env r c => Cfg -> Snowflake User -> Text -> Sem r () +-- this should parse inline so we can remove megaparsec as dependency +grabName cfg author response = case parseFullName response of + Left _ -> void $ tell author $ cfg ^. #name_query ^. #incorrect_response Right name -> do - current <- P.atomicGet - _ <- P.atomicPut $ Map.insert author (Named $ showtl name) current - void $ tell author $ cfg ^. #nameReciMsg - where author = msg ^. #author - response = msg ^. #content - -grabEmail cfg name msg = - case (TL.foldl' (\n c -> if' (c == '@') (n+1) n) 0 response) == 1 of - False -> void $ tell author $ cfg ^. #noAtEmailMsg - True -> do - current <- P.atomicGet - _ <- P.atomicPut $ Map.insert author (NamedEmailed name response) current - void $ tell author $ cfg ^. #emailReciMsg - where response = msg ^. #content - author = msg ^. #author - -grabScreenshot cfg name email msg = - let author = msg ^. #author in - case msg ^. #attachments of - files@(x:_) -> do - current <- P.atomicGet - _ <- P.atomicPut $ Map.insert author Finished current - void . tell (cfg ^. #vchannelID) . mentionUser author "Discord ID: " $ - -- library bug means we don't embed the picture, instead a URL - "\nName: " <> name <> "\nEmail: " <> email <> "\nAttachment: " <> (x ^. #url) - void $ tell @Text author $ cfg ^. #screenshotReciMsg - [] -> void $ tell @Text author $ cfg ^. #noScreenshotMsg - --- the bot responding to its messages counts as an event, so ignore that to prevent looping -messageCreateAction cfg = \msg@Message{author, M.content = response} -> do - case author /= cfg ^. #botID && isNothing (msg ^. #guildID) && (not $ TL.any (== '¬') response) of - False -> pure () - True -> do - current <- P.atomicGet - case Map.lookup author current of - Nothing -> grabName cfg msg - Just Empty -> grabName cfg msg - Just (Named name) -> grabEmail cfg name msg - Just (NamedEmailed name email) -> grabScreenshot cfg name email msg - Just Finished -> void $ tell author $ cfg ^. #finishedMsg + kvset author (Named name) + void $ tell author $ cfg ^. #name_query ^. #correct_response -resetCommand cfg = command @'[Snowflake User, [Text]] "reset" \ctx sUser reason -> - case ctx ^. #member of - -- more intentional and simpler to do in a server channel so other people can see - Nothing -> void $ tell @Text ctx $ cfg ^. #resetNeedsGuildMsg - Just mem -> if V.elem (cfg ^. #adminRoleID) (mem ^. #roles) then - do - current <- P.atomicGet - _ <- P.atomicPut $ Map.insert sUser Empty current - void $ tell @Text sUser $ TL.intercalate " " reason - void $ tell sUser $ cfg ^. #iveBeenResetMsg - else void $ tell ctx $ cfg ^. #notAdminMsg +grabScreenshot :: + Env r c => + Cfg -> + Snowflake User -> + Text -> + [Attachm.Attachment] -> + Sem r () +grabScreenshot cfg author _ [] = + void . tell author $ cfg ^. #screenshot_query ^. #incorrect_response +grabScreenshot cfg author name (file : _) = do + kvset author Finished + tell author $ cfg ^. #screenshot_query ^. #correct_response + void . tell (cfg ^. #vChannelID) $ + "Discord ID: " <> mention author <> "\n" + <> "Name: " + <> name + <> "\n" + <> "Attachment: " + <> file ^. #url -commandsAdded cfg = addCommands $ do +addedCommands :: Env r c => Cfg -> Sem r () +addedCommands cfg = void . addCommands $ do helpCommand - command @'[] "info" \ctx -> void $ tell ctx $ cfg ^. #infoMsg - command @'[] "privacy" \ctx -> void $ tell ctx $ cfg ^. #privacyMsg - resetCommand cfg - -program cfg = - (react @'GuildMemberAddEvt \ctx -> void $ tell ctx $ cfg ^. #joinMsg) >> - (react @'MessageCreateEvt $ messageCreateAction cfg) >> - commandsAdded cfg + mapM_ -- add all the information commands, e.g. info, privacy etc... + (\(InfoCmd cmdName info) -> command @'[] cmdName $ \ctx -> void $ tell ctx info) + $ cfg ^. #infoCommands -execBot :: IO () -execBot = do - cfg <- Dhall.input Dhall.auto "./config.dhall" :: IO Settings - Di.new \di -> do - void . P.runFinal . P.embedToFinal. runCacheInMemory . runDiToIO di. runMetricsNoop. useConstantPrefix "¬" . - -- if run without IO, the state is localised, ignore final state via fmap - fmap snd . P.atomicStateToIO Map.empty . runBotIO (BotToken $ cfg ^. #botToken) $ program cfg +program :: Env r c => Cfg -> Sem r () +program cfg = do + addedCommands cfg + react @'GuildMemberAddEvt $ \ctx -> void . tell ctx $ cfg ^. #joinMsg + void . react @'MessageCreateEvt $ messageCreateAction cfg diff --git a/src/Parser.hs b/src/Parser.hs new file mode 100644 --- /dev/null +++ b/src/Parser.hs @@ -0,0 +1,38 @@ +module Parser where + +-- i think this whole file can be replaced +-- with about 12 characters of code less than +-- a line with a regular expression +-- the benefit of a parser's error messages +-- we never use because, interpreting parser combinator +-- error messages is not useful as the error +-- messages are why it can't continue not why +-- it doesnt end parsing + +import Data.List (intercalate) +import qualified Data.Text.Lazy as TL (Text, unpack) +import Data.Void (Void) +import Text.Megaparsec (Parsec, runParser, some, (<|>)) +import Text.Megaparsec.Byte (space, string) +import Text.Megaparsec.Char as C (char, letterChar, space) +import qualified Text.Megaparsec.Char.Lexer as CL +import TextShow (showtl) + +--import Db + +-- parser for full name, the underscore +-- is to handle the edge case of a single name, full name +type ParserStr = Parsec Void String + +preLexeme, lexeme :: ParserStr a -> ParserStr a +lexeme = CL.lexeme C.space +preLexeme = (*>) C.space + +nameOrUnderscore', fullName :: ParserStr String +nameOrUnderscore' = some letterChar <|> (fmap pure . char $ '_') +fullName = do + firstName <- preLexeme nameOrUnderscore' + restNames <- lexeme . some . preLexeme $ nameOrUnderscore' + pure . intercalate " " $ firstName : restNames + +parseFullName content = showtl <$> (runParser fullName "" (TL.unpack content)) diff --git a/src/Utils.hs b/src/Utils.hs new file mode 100644 --- /dev/null +++ b/src/Utils.hs @@ -0,0 +1,21 @@ +-- this file provides utilities such as type aliases + +module Utils where + +import Calamity +import Calamity.Commands.Context (CalamityCommandContext) +import Calamity.Commands.Types (CommandContext) +import Calamity.Types.Model.Channel.Message (Message) +import CalamityCommands.Context (ConstructContext) +import CalamityCommands.ParsePrefix (ParsePrefix) +import Data.Typeable (Typeable) +import Polysemy (Members) + +type EssentialEnv r c = + ( BotC r, + Typeable c, + Tellable c, + CommandContext c, + CalamityCommandContext c, + Members '[ParsePrefix Message, ConstructContext Message c IO ()] r + ) diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 --- a/test/Spec.hs +++ /dev/null @@ -1,14 +0,0 @@ -import Test.Hspec -import Test.Hspec.Megaparsec - -import Text.Megaparsec - -import Lib - -main = hspec.parallel $ describe "parsing" $ do - it "parse K as name or underscore" (parse nameOrUnderscore' "" "K" `shouldParse` "K") - it "attempt to parse 2 as name or underscore" (parse nameOrUnderscore' "" `shouldFailOn` "2") - it "parse _ as name or underscore" (parse nameOrUnderscore' "" "_" `shouldParse` "_") - it "attempt to parse Kelly as full name" (parse fullName "" `shouldFailOn` "Kelly") - it "parse Kelly Bloggs as full name" (parse fullName "" "Kelly Bloggs" `shouldParse` "Kelly Bloggs") - it "parse Kelly _ as full name" (parse fullName "" "Kelly _" `shouldParse` "Kelly _")