packages feed

discord-register 0.0.1 → 0.0.2

raw patch · 10 files changed

+332/−264 lines, 10 filesdep +aesondep +binarydep +bytestringdep −dhalldep −hspecdep −hspec-megaparsecdep ~basedep ~calamitydep ~di

Dependencies added: aeson, binary, bytestring, calamity-commands, data-flags, hashable, hedis, lens, regex-tdfa

Dependencies removed: dhall, hspec, hspec-megaparsec, vector

Dependency ranges changed: base, calamity, di, di-polysemy, generic-lens, megaparsec, polysemy, polysemy-plugin, text, text-show, unboxing-vector, unordered-containers

Files

+ ChangeLog.md view
@@ -0,0 +1,1 @@+Fix issues with intents.
README.md view
@@ -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.
app/Main.hs view
@@ -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
− config.dhall.empty 
@@ -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.",-}
discord-register.cabal view
@@ -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
+ src/Kv.hs view
@@ -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
src/Lib.hs view
@@ -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
+ src/Parser.hs view
@@ -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))
+ src/Utils.hs view
@@ -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+  )
− test/Spec.hs 
@@ -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 _")