From 7854cc06fdbb873f3ac124204792f05385bcb118 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 22 Jan 2020 21:40:30 +0000 Subject: [PATCH 01/23] Fix nick of example bot in readme --- CHANGELOG.md | 3 +++ README.md | 2 +- 2 files changed, 4 insertions(+), 1 deletion(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 77d17d8..535c6a4 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,5 +1,8 @@ # Changelog for haboli +## upcoming +* fix nick of example bot in readme + ## 0.3.1.0 * add `Haboli.Euphoria` module * add proper README diff --git a/README.md b/README.md index b50dd81..cbe340e 100644 --- a/README.md +++ b/README.md @@ -30,7 +30,7 @@ pingPongBot :: Client () () pingPongBot = forever $ do event <- respondingToPing nextEvent case event of - EventSnapshot _ -> void $ nick "TreeBot" + EventSnapshot _ -> void $ nick "PingPongBot" EventSend e -> let msg = sendMessage e in when (msgContent msg == "!ping") $ From c4a05d59802624c8841eee1d9d66482f603d55b2 Mon Sep 17 00:00:00 2001 From: Joscha Date: Mon, 6 Apr 2020 14:57:45 +0000 Subject: [PATCH 02/23] Clean up project and update resolver to 15.7 --- .gitignore | 3 +- CHANGELOG.md | 21 +++++------ Setup.hs | 2 -- haboli.cabal | 53 ++++++++++++++++++++++++++++ package.yaml | 17 ++++----- src/Haboli/Euphoria/Client.hs | 1 - stack.yaml | 65 +---------------------------------- stack.yaml.lock | 8 ++--- 8 files changed, 79 insertions(+), 91 deletions(-) delete mode 100644 Setup.hs create mode 100644 haboli.cabal diff --git a/.gitignore b/.gitignore index 64af04d..76467e6 100644 --- a/.gitignore +++ b/.gitignore @@ -1,3 +1,2 @@ .stack-work/ -haboli.cabal -*~ \ No newline at end of file +*~ diff --git a/CHANGELOG.md b/CHANGELOG.md index 535c6a4..a070433 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,21 +1,22 @@ # Changelog for haboli ## upcoming -* fix nick of example bot in readme +- clean up project +- fix nick of example bot in readme ## 0.3.1.0 -* add `Haboli.Euphoria` module -* add proper README -* clean up package structure -* update documentation +- add `Haboli.Euphoria` module +- add proper README +- clean up package structure +- update documentation ## 0.3.0.0 -* fix Client not receiving all kinds of server events -* rename ConnectionConfig record accessors +- fix Client not receiving all kinds of server events +- rename ConnectionConfig record accessors ## 0.2.0.0 -* add all session and chat room commands -* modify `send` command so it also returns the old nick +- add all session and chat room commands +- modify `send` command so it also returns the old nick ## 0.1.0.0 -* create project +- create project diff --git a/Setup.hs b/Setup.hs deleted file mode 100644 index 9a994af..0000000 --- a/Setup.hs +++ /dev/null @@ -1,2 +0,0 @@ -import Distribution.Simple -main = defaultMain diff --git a/haboli.cabal b/haboli.cabal new file mode 100644 index 0000000..cbd7951 --- /dev/null +++ b/haboli.cabal @@ -0,0 +1,53 @@ +cabal-version: 1.12 + +-- This file has been generated from package.yaml by hpack version 0.31.2. +-- +-- see: https://github.com/sol/hpack +-- +-- hash: 9b4e31fd51c5402b511dfcd2fa3dd52e562b202b1583f6639a0e193920e0d02c + +name: haboli +version: 0.3.1.0 +synopsis: API bindings for https://euphoria.io/ +description: Please see the README on GitHub at +homepage: https://github.com/Garmelon/haboli#readme +bug-reports: https://github.com/Garmelon/haboli/issues +author: Garmelon +maintainer: Garmelon +copyright: 2020 Garmelon +license: MIT +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + CHANGELOG.md + LICENSE + +source-repository head + type: git + location: https://github.com/Garmelon/haboli + +library + exposed-modules: + Haboli.Euphoria + Haboli.Euphoria.Api + Haboli.Euphoria.Client + Haboli.Euphoria.Example + Haboli.Euphoria.WegaBorad + other-modules: + Paths_haboli + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , containers + , network + , stm + , text + , time + , transformers + , unordered-containers + , websockets + , wuss + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index bf0c8d6..5e8ffaa 100644 --- a/package.yaml +++ b/package.yaml @@ -1,16 +1,17 @@ -name: haboli -version: 0.3.1.0 -license: MIT -author: "Garmelon " -copyright: "2020 Garmelon" +name: haboli +version: 0.3.1.0 +license: MIT +author: Garmelon +copyright: 2020 Garmelon -synopsis: API bindings for https://euphoria.io/ -description: Please see the README on GitHub at -github: "Garmelon/haboli" +synopsis: API bindings for https://euphoria.io/ +description: Please see the README on GitHub at +github: Garmelon/haboli extra-source-files: - README.md - CHANGELOG.md + - LICENSE dependencies: - base >= 4.7 && < 5 diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index f535394..ded43dc 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -280,7 +280,6 @@ data Event | EventSnapshot SnapshotEvent deriving (Show) ---TODO: Add all the events instance FromJSON Event where parseJSON v = foldr (<|>) mempty [ EventBounce <$> parseJSON v diff --git a/stack.yaml b/stack.yaml index 0961eec..c895dad 100644 --- a/stack.yaml +++ b/stack.yaml @@ -1,66 +1,3 @@ -# This file was automatically generated by 'stack init' -# -# Some commonly used options have been documented as comments in this file. -# For advanced use and comprehensive documentation of the format, please see: -# https://docs.haskellstack.org/en/stable/yaml_configuration/ - -# Resolver to choose a 'specific' stackage snapshot or a compiler version. -# A snapshot resolver dictates the compiler version and the set of packages -# to be used for project dependencies. For example: -# -# resolver: lts-3.5 -# resolver: nightly-2015-09-21 -# resolver: ghc-7.10.2 -# -# The location of a snapshot can be provided as a file or url. Stack assumes -# a snapshot provided as a file might change, whereas a url resource does not. -# -# resolver: ./custom-snapshot.yaml -# resolver: https://example.com/snapshots/2018-01-01.yaml -resolver: lts-14.19 - -# User packages to be built. -# Various formats can be used as shown in the example below. -# -# packages: -# - some-directory -# - https://example.com/foo/bar/baz-0.0.2.tar.gz -# subdirs: -# - auto-update -# - wai +resolver: lts-15.7 packages: - . -# Dependency packages to be pulled from upstream that are not in the resolver. -# These entries can reference officially published versions as well as -# forks / in-progress versions pinned to a git hash. For example: -# -# extra-deps: -# - acme-missiles-0.3 -# - git: https://github.com/commercialhaskell/stack.git -# commit: e7b331f14bcffb8367cd58fbfc8b40ec7642100a -# -# extra-deps: [] - -# Override default flag values for local packages and extra-deps -# flags: {} - -# Extra package databases containing global packages -# extra-package-dbs: [] - -# Control whether we use the GHC we find on the path -# system-ghc: true -# -# Require a specific version of stack, using version ranges -# require-stack-version: -any # Default -# require-stack-version: ">=2.1" -# -# Override the architecture used by stack, especially useful on Windows -# arch: i386 -# arch: x86_64 -# -# Extra directories used by stack for building -# extra-include-dirs: [/path/to/dir] -# extra-lib-dirs: [/path/to/dir] -# -# Allow a newer minor version of GHC than the snapshot specifies -# compiler-check: newer-minor diff --git a/stack.yaml.lock b/stack.yaml.lock index 16e6de6..860760a 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 524155 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/19.yaml - sha256: 9f79f6494473c9b46911364b94c4b5ef19ca8d35ebf62e46697cf651f198ee19 - original: lts-14.19 + size: 491389 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/7.yaml + sha256: 92ab6303fe20ec928461c82ce0980b4d17c06f4e66205a2967e476474f686c17 + original: lts-15.7 From fd4ae38eb1d3c3933f492ab69ab9ecedfeee03df Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 7 Apr 2020 18:39:42 +0000 Subject: [PATCH 03/23] Add abstraction for bot commands --- CHANGELOG.md | 1 + haboli.cabal | 3 +- src/Haboli/Euphoria/Client.hs | 7 ++-- src/Haboli/Euphoria/Command.hs | 66 ++++++++++++++++++++++++++++++++++ 4 files changed, 74 insertions(+), 3 deletions(-) create mode 100644 src/Haboli/Euphoria/Command.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index a070433..0d72c89 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,7 @@ # Changelog for haboli ## upcoming +- add `Haboli.Euphoria.Command` module - clean up project - fix nick of example bot in readme diff --git a/haboli.cabal b/haboli.cabal index cbd7951..9c730ed 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9b4e31fd51c5402b511dfcd2fa3dd52e562b202b1583f6639a0e193920e0d02c +-- hash: bcd1c482ca0554443e9e0523bf9eb0cc65354ef37c4aec33570b5ab9a22502bf name: haboli version: 0.3.1.0 @@ -32,6 +32,7 @@ library Haboli.Euphoria Haboli.Euphoria.Api Haboli.Euphoria.Client + Haboli.Euphoria.Command Haboli.Euphoria.Example Haboli.Euphoria.WegaBorad other-modules: diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index ded43dc..d6f54ea 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -317,8 +317,11 @@ nextEvent = do Right e -> pure e -- | Respond to 'EventPing's according to the documentation (see --- ). This function is meant to be wrapped --- directly around 'nextEvent': +-- ). Passes through all events unmodified. +-- +-- This utility function is meant to be wrapped directly or indirectly around +-- 'nextEvent': +-- -- > event <- respondingToPing nextEvent respondingToPing :: Client e Event -> Client e Event respondingToPing holdingEvent = do diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs new file mode 100644 index 0000000..09f402c --- /dev/null +++ b/src/Haboli/Euphoria/Command.hs @@ -0,0 +1,66 @@ +{-# LANGUAGE ExistentialQuantification #-} +{-# LANGUAGE MultiParamTypeClasses #-} + +-- | This module provides an abstraction for bot commands in the form of the +-- 'Hook' type class and the 'Command' type. + +module Haboli.Euphoria.Command + ( Hook(..) + , Command + , cmd + , runCommand + , runCommands + , respondingToCommands + ) where + +import Control.Monad + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client + +-- | A hook is a way to react to new messages in a room. These typically don't +-- include the messages sent by the client itself. +class Hook h where + -- | @reel h msg@ applies the hook @h@ to the 'Message' @msg@. If no further + -- hooks should be applied to this message, it should return 'True'. + -- Otherwise, it should return 'False'. + reel :: h e -> Message -> Client e Bool + +-- | A wrapper around hooks that allows for heterogenous lists of hooks. In +-- other words, it lets you combine different 'Hook' instances into a single +-- list. +data Command e = forall h. (Hook h) => Command (h e) + +-- | Wrap a hook. Notice how the @h@ type disappears: This function can convert +-- different 'Hook' instances into the same type. +cmd :: (Hook h) => h e -> Command e +cmd = Command + +-- | Apply a 'Command' to a 'Message'. For more information, see 'reel'. +runCommand :: Command e -> Message -> Client e Bool +runCommand (Command h) = reel h + +-- | Apply multiple 'Command's to a 'Message' in order until one returns 'True'. +-- All commands following that one are not applied. +runCommands :: [Command e] -> Message -> Client e Bool +runCommands [] _ = pure False +runCommands (c:cs) msg = do + abort <- runCommand c msg + if abort + then pure True + else runCommands cs msg + +-- | Run a list of 'Command's on all 'EventSend's. Passes through all events +-- unmodified. +-- +-- This utility function is meant to be wrapped directly or indirectly around +-- 'nextEvent': +-- +-- > event <- respondingToCommands commands nextEvent +respondingToCommands :: [Command e] -> Client e Event -> Client e Event +respondingToCommands cmds holdingEvent = do + event <- holdingEvent + case event of + EventSend e -> void $ runCommands cmds $ sendMessage e + _ -> pure () + pure event From 644ebcefc958354a0e352ee7df58e7d686b46c66 Mon Sep 17 00:00:00 2001 From: Joscha Date: Tue, 7 Apr 2020 18:59:13 +0000 Subject: [PATCH 04/23] Simplify command system MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit All that type class and language extension madness was completely and utterly unnecessary, but I only noticed it after I had already pushed the implementation. Oh well ¯\_(ツ)_/¯ --- src/Haboli/Euphoria/Command.hs | 37 ++++++---------------------------- 1 file changed, 6 insertions(+), 31 deletions(-) diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs index 09f402c..fd0e27c 100644 --- a/src/Haboli/Euphoria/Command.hs +++ b/src/Haboli/Euphoria/Command.hs @@ -1,14 +1,7 @@ -{-# LANGUAGE ExistentialQuantification #-} -{-# LANGUAGE MultiParamTypeClasses #-} - --- | This module provides an abstraction for bot commands in the form of the --- 'Hook' type class and the 'Command' type. +-- | This module provides an abstraction for bot commands. module Haboli.Euphoria.Command - ( Hook(..) - , Command - , cmd - , runCommand + ( Command , runCommands , respondingToCommands ) where @@ -18,34 +11,16 @@ import Control.Monad import Haboli.Euphoria.Api import Haboli.Euphoria.Client --- | A hook is a way to react to new messages in a room. These typically don't --- include the messages sent by the client itself. -class Hook h where - -- | @reel h msg@ applies the hook @h@ to the 'Message' @msg@. If no further - -- hooks should be applied to this message, it should return 'True'. - -- Otherwise, it should return 'False'. - reel :: h e -> Message -> Client e Bool - --- | A wrapper around hooks that allows for heterogenous lists of hooks. In --- other words, it lets you combine different 'Hook' instances into a single --- list. -data Command e = forall h. (Hook h) => Command (h e) - --- | Wrap a hook. Notice how the @h@ type disappears: This function can convert --- different 'Hook' instances into the same type. -cmd :: (Hook h) => h e -> Command e -cmd = Command - --- | Apply a 'Command' to a 'Message'. For more information, see 'reel'. -runCommand :: Command e -> Message -> Client e Bool -runCommand (Command h) = reel h +-- | If a command should block any further commands from executing on a message, +-- it should return 'True'. Otherwise. it should return 'False'. +type Command e = Message -> Client e Bool -- | Apply multiple 'Command's to a 'Message' in order until one returns 'True'. -- All commands following that one are not applied. runCommands :: [Command e] -> Message -> Client e Bool runCommands [] _ = pure False runCommands (c:cs) msg = do - abort <- runCommand c msg + abort <- c msg if abort then pure True else runCommands cs msg From ca06a7fbef722feb59246d3743790f2191250593 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 11:54:01 +0000 Subject: [PATCH 05/23] Remove example module Also removes the 'WegaBoard' module that accidentally snuck into haboli.cabal --- CHANGELOG.md | 1 + haboli.cabal | 4 +- src/Haboli/Euphoria/Example.hs | 74 ---------------------------------- 3 files changed, 2 insertions(+), 77 deletions(-) delete mode 100644 src/Haboli/Euphoria/Example.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 0d72c89..fdc31e0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ - add `Haboli.Euphoria.Command` module - clean up project - fix nick of example bot in readme +- remove `Haboli.Euphoria.Examples` module ## 0.3.1.0 - add `Haboli.Euphoria` module diff --git a/haboli.cabal b/haboli.cabal index 9c730ed..e663342 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: bcd1c482ca0554443e9e0523bf9eb0cc65354ef37c4aec33570b5ab9a22502bf +-- hash: 93e0477ebf814906c7ad7dcd56922b71fa3189833865db6f5d4442811983b1c7 name: haboli version: 0.3.1.0 @@ -33,8 +33,6 @@ library Haboli.Euphoria.Api Haboli.Euphoria.Client Haboli.Euphoria.Command - Haboli.Euphoria.Example - Haboli.Euphoria.WegaBorad other-modules: Paths_haboli hs-source-dirs: diff --git a/src/Haboli/Euphoria/Example.hs b/src/Haboli/Euphoria/Example.hs deleted file mode 100644 index 1435fe9..0000000 --- a/src/Haboli/Euphoria/Example.hs +++ /dev/null @@ -1,74 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - --- | This module contains a few basic example bots. -module Haboli.Euphoria.Example where - -import Control.Concurrent -import Control.Monad -import Control.Monad.IO.Class -import Data.Foldable -import Haboli.Euphoria - -printAllEventsBot :: Client () () -printAllEventsBot = forever $ do - liftIO $ putStrLn "\nWaiting for the next event...\n" - liftIO . print =<< respondingToPing nextEvent - -setNickAndThenWaitBot :: Client () () -setNickAndThenWaitBot = forever $ do - event <- respondingToPing nextEvent - case event of - EventSnapshot _ -> void $ nick "HaboliTestBot" - _ -> pure () - -throwCustomExceptionBot :: Client String () -throwCustomExceptionBot = throw "Hello world" - -immediatelyDisconnectBot :: Client () () -immediatelyDisconnectBot = pure () - -sendMessagesUntilThrottledBot :: Client () () -sendMessagesUntilThrottledBot = forever $ do - event <- respondingToPing nextEvent - case event of - EventSnapshot _ -> do - void $ nick "SpamBot" - msg <- send "start thread" - void $ fork $ handle (\_ -> reply msg "got throttled") $ - forever $ reply msg "continue thread" - _ -> pure () - -sendMessagesThreadedBot :: Client () () -sendMessagesThreadedBot = forever $ do - event <- respondingToPing nextEvent - case event of - EventSnapshot _ -> void $ nick "TreeBot" - EventSend e -> - let msg = sendMessage e - in when (msgContent msg == "!tree") $ - void $ fork $ buildTree msg - _ -> pure () - where - buildTree msg = do - t1 <- fork $ reply msg "subtree 1" - t2 <- fork $ reply msg "subtree 2" - subtree1 <- wait t1 - subtree2 <- wait t2 - t3 <- fork $ reply subtree1 "subtree 1.1" - t4 <- fork $ reply subtree1 "subtree 1.2" - t5 <- fork $ reply subtree2 "subtree 2.1" - t6 <- fork $ reply subtree2 "subtree 2.2" - for_ [t3, t4, t5, t6] wait - reply msg "tree done" - -cloneItselfBot :: Client () () -cloneItselfBot = forever $ do - event <- respondingToPing nextEvent - case event of - EventSnapshot _ -> void $ nick "CloneBot" - EventSend e - | msgContent (sendMessage e) == "!clone" -> do - config <- getConnectionConfig - void $ liftIO $ forkIO $ void $ runClient config cloneItselfBot - | otherwise -> pure () - _ -> pure () From be818ae05fed0ecc747da9c6d01adc4382582759 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 11:58:12 +0000 Subject: [PATCH 06/23] Add a few utility functions --- CHANGELOG.md | 1 + haboli.cabal | 3 +- src/Haboli/Euphoria/Client.hs | 16 ------ src/Haboli/Euphoria/Util.hs | 97 +++++++++++++++++++++++++++++++++++ 4 files changed, 100 insertions(+), 17 deletions(-) create mode 100644 src/Haboli/Euphoria/Util.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index fdc31e0..eaab4e7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,7 @@ ## upcoming - add `Haboli.Euphoria.Command` module +- add `Haboli.Euphoria.Util` module and move `respondingToPing` there - clean up project - fix nick of example bot in readme - remove `Haboli.Euphoria.Examples` module diff --git a/haboli.cabal b/haboli.cabal index e663342..5abf0b3 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 93e0477ebf814906c7ad7dcd56922b71fa3189833865db6f5d4442811983b1c7 +-- hash: e4041146c275e14c632860cfd7af7b3ac3fe6bf5493f57168143777df245a1cf name: haboli version: 0.3.1.0 @@ -33,6 +33,7 @@ library Haboli.Euphoria.Api Haboli.Euphoria.Client Haboli.Euphoria.Command + Haboli.Euphoria.Util other-modules: Paths_haboli hs-source-dirs: diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index d6f54ea..22b83c8 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -27,7 +27,6 @@ module Haboli.Euphoria.Client -- ** Event handling , Event(..) , nextEvent - , respondingToPing -- ** Exception handling , ClientException(..) , throw @@ -316,21 +315,6 @@ nextEvent = do Left e -> throwRaw e Right e -> pure e --- | Respond to 'EventPing's according to the documentation (see --- ). Passes through all events unmodified. --- --- This utility function is meant to be wrapped directly or indirectly around --- 'nextEvent': --- --- > event <- respondingToPing nextEvent -respondingToPing :: Client e Event -> Client e Event -respondingToPing holdingEvent = do - event <- holdingEvent - case event of - EventPing e -> pingReply (pingTime e) - _ -> pure () - pure event - {- Exception handling -} -- | The type of exceptions in the 'Client' monad. diff --git a/src/Haboli/Euphoria/Util.hs b/src/Haboli/Euphoria/Util.hs new file mode 100644 index 0000000..1da51a8 --- /dev/null +++ b/src/Haboli/Euphoria/Util.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.Util + ( + -- * Events + respondingToPing + , respondingToBounce + , respondingToBounce' + , untilConnected + , untilConnected' + -- * Nick + , nickMention + , nickNormalize + , nickEqual + ) where + +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import Data.Char +import Data.Function +import qualified Data.Set as Set +import qualified Data.Text as T + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client + +{- Events -} + +-- | Respond to 'EventPing's according to the documentation (see +-- ). Passes through all events unmodified. +-- +-- This utility function is meant to be wrapped directly or indirectly around +-- 'nextEvent': +-- +-- > event <- respondingToPing nextEvent +respondingToPing :: Client e Event -> Client e Event +respondingToPing getEvent = do + event <- getEvent + case event of + EventPing e -> pingReply (pingTime e) + _ -> pure () + pure event + +respondingToBounce :: Maybe T.Text -> Client T.Text Event -> Client T.Text Event +respondingToBounce = respondingToBounce' id + +respondingToBounce' :: (T.Text -> e) -> Maybe T.Text -> Client e Event -> Client e Event +respondingToBounce' onError mPasswd getEvent = do + event <- getEvent + case event of + EventBounce e + | Passcode `elem` bounceAuthOption e -> case mPasswd of + Nothing -> throw $ onError "Password required but no password given" + Just passwd -> do + response <- auth passwd + case response of + Left msg -> throw $ onError $ "Could not authenticate: " <> msg + Right () -> pure () + _ -> pure () + pure event + +untilConnected :: Client T.Text Event -> Client T.Text (HelloEvent, SnapshotEvent) +untilConnected = untilConnected' id + +untilConnected' :: (T.Text -> e) -> Client e Event -> Client e (HelloEvent, SnapshotEvent) +untilConnected' onError getEvent = evalStateT helper (Nothing, Nothing) + where + helper = do + event <- lift getEvent + case event of + EventPing _ -> pure () + EventBounce _ -> pure () + EventHello e -> modify $ \(_, s) -> (Just e, s) + EventSnapshot e -> modify $ \(h, _) -> (h, Just e) + _ -> lift $ throw $ onError "Received disallowed packet while connecting" + receivedEvents <- get + case receivedEvents of + (Just h, Just s) -> pure (h, s) + _ -> helper + +{- Nick -} + +nickMention :: T.Text -> T.Text +nickMention name + | T.length name > 1 = T.filter isMentionChar name + | otherwise = name + where + isMentionChar c = not $ isSpace c || c `Set.member` terminatingChars + terminatingChars = Set.fromList ",.!?;&<'\"" + +nickNormalize :: T.Text -> T.Text +nickNormalize name + | T.length name > 1 = T.toCaseFold $ T.filter (not . isSpace) name + | otherwise = T.toCaseFold name + +nickEqual :: T.Text -> T.Text -> Bool +nickEqual = (==) `on` nickNormalize From 3e2120f970588ea205b07796200a3010a6c0b5bc Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 12:01:01 +0000 Subject: [PATCH 07/23] Add listing module --- CHANGELOG.md | 1 + haboli.cabal | 3 +- src/Haboli/Euphoria/Api.hs | 4 +- src/Haboli/Euphoria/Listing.hs | 67 ++++++++++++++++++++++++++++++++++ 4 files changed, 72 insertions(+), 3 deletions(-) create mode 100644 src/Haboli/Euphoria/Listing.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index eaab4e7..1959bb1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,7 @@ ## upcoming - add `Haboli.Euphoria.Command` module +- add `Haboli.Euphoria.Listing` module - add `Haboli.Euphoria.Util` module and move `respondingToPing` there - clean up project - fix nick of example bot in readme diff --git a/haboli.cabal b/haboli.cabal index 5abf0b3..1e8b7ff 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: e4041146c275e14c632860cfd7af7b3ac3fe6bf5493f57168143777df245a1cf +-- hash: 67a0b5c2b39acab50a31b3d9efa3e4a48e13f1edd28bdbb23b99fc1c8c30bd3b name: haboli version: 0.3.1.0 @@ -33,6 +33,7 @@ library Haboli.Euphoria.Api Haboli.Euphoria.Client Haboli.Euphoria.Command + Haboli.Euphoria.Listing Haboli.Euphoria.Util other-modules: Paths_haboli diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index 783bb48..b85f24d 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -194,7 +194,7 @@ data UserType -- ^ The client has none of the other user types. While this value does not -- occur nowadays, some messages in the room logs are still from a time before -- the distinction of user types were introduced. - deriving (Show, Eq) + deriving (Show, Eq, Ord) -- | A 'UserId' identifies a user. It consists of two parts: The type of -- session, and a unique value for that type of session. See @@ -202,7 +202,7 @@ data UserType data UserId = UserId { userType :: UserType , userSnowflake :: Snowflake - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) instance ToJSON UserId where toJSON uid = diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs new file mode 100644 index 0000000..af4896b --- /dev/null +++ b/src/Haboli/Euphoria/Listing.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.Listing + ( Listing + , newListing + , self + , others + , updateOwnNick + , updateFromList + , updateFromEvent + ) where + +import qualified Data.Map.Strict as Map +import Data.Maybe +import qualified Data.Text as T + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client + +data Listing = Listing + { lsSelf :: SessionView + , lsOthers :: Map.Map UserId SessionView + } deriving (Show) + +othersFromList :: [SessionView] -> Map.Map UserId SessionView +othersFromList sessions = Map.fromList [(svId sv, sv) | sv <- sessions] + +newListing :: (HelloEvent, SnapshotEvent) -> Listing +newListing (h, s) = Listing + { lsSelf = helloSessionView h + , lsOthers = othersFromList $ snapshotListing s + } + +self :: Listing -> SessionView +self = lsSelf + +others :: Listing -> Map.Map UserId SessionView +others = lsOthers + +updateOwnNick :: T.Text -> Listing -> Listing +updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}} + +updateFromList :: [SessionView] -> Listing -> Listing +updateFromList sessions listing = + let ownId = svId $ lsSelf listing + others' = othersFromList sessions + newSelf = fromMaybe (lsSelf listing) $ others' Map.!? ownId + newOthers = Map.filterWithKey (\k _ -> k /= ownId) others' + in Listing newSelf newOthers + +onJoin :: SessionView -> Listing -> Listing +onJoin sv listing = listing{lsOthers = Map.insert (svId sv) sv $ lsOthers listing} + +onPart :: SessionView -> Listing -> Listing +onPart sv listing = listing{lsOthers = Map.delete (svId sv) $ lsOthers listing} + +updateFromEvent :: Event -> Listing -> Listing +updateFromEvent (EventJoin e) listing = onJoin (joinSession e) listing +updateFromEvent (EventPart e) listing = onPart (partSession e) listing +updateFromEvent (EventNetwork e) listing | networkType e == "partition" = + let sId = networkServerId e + sEra = networkServerEra e + isAffected sv = svServerId sv == sId && svServerEra sv == sEra + others' = Map.filter (not . isAffected) $ lsOthers listing + in listing{lsOthers = others'} +updateFromEvent _ listing = listing + From c4854045288e72411650a9256b6fda4bea1b4636 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 12:03:57 +0000 Subject: [PATCH 08/23] Add command submodules --- CHANGELOG.md | 2 +- haboli.cabal | 5 ++- package.yaml | 1 + src/Haboli/Euphoria/Command/Megaparsec.hs | 15 ++++++++ src/Haboli/Euphoria/Command/Simple.hs | 44 +++++++++++++++++++++++ 5 files changed, 65 insertions(+), 2 deletions(-) create mode 100644 src/Haboli/Euphoria/Command/Megaparsec.hs create mode 100644 src/Haboli/Euphoria/Command/Simple.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 1959bb1..69329a1 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,7 +1,7 @@ # Changelog for haboli ## upcoming -- add `Haboli.Euphoria.Command` module +- add `Haboli.Euphoria.Command` module and submodules - add `Haboli.Euphoria.Listing` module - add `Haboli.Euphoria.Util` module and move `respondingToPing` there - clean up project diff --git a/haboli.cabal b/haboli.cabal index 1e8b7ff..34ce92c 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 67a0b5c2b39acab50a31b3d9efa3e4a48e13f1edd28bdbb23b99fc1c8c30bd3b +-- hash: 9151d30bacf2317670dc6ff817bd66ca13bd3798142b0b8ad8fceb78461b4ab1 name: haboli version: 0.3.1.0 @@ -33,6 +33,8 @@ library Haboli.Euphoria.Api Haboli.Euphoria.Client Haboli.Euphoria.Command + Haboli.Euphoria.Command.Megaparsec + Haboli.Euphoria.Command.Simple Haboli.Euphoria.Listing Haboli.Euphoria.Util other-modules: @@ -43,6 +45,7 @@ library aeson , base >=4.7 && <5 , containers + , megaparsec , network , stm , text diff --git a/package.yaml b/package.yaml index 5e8ffaa..29a8bf7 100644 --- a/package.yaml +++ b/package.yaml @@ -17,6 +17,7 @@ dependencies: - base >= 4.7 && < 5 - aeson - containers + - megaparsec - network - stm - text diff --git a/src/Haboli/Euphoria/Command/Megaparsec.hs b/src/Haboli/Euphoria/Command/Megaparsec.hs new file mode 100644 index 0000000..c0767a3 --- /dev/null +++ b/src/Haboli/Euphoria/Command/Megaparsec.hs @@ -0,0 +1,15 @@ +module Haboli.Euphoria.Command.Megaparsec + ( cmdMega + ) where + +import qualified Data.Text as T +import Text.Megaparsec + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client +import Haboli.Euphoria.Command + +cmdMega :: Parsec e' T.Text a -> (Message -> a -> Client e ()) -> Command e +cmdMega parser f msg = case parse parser "" $ msgContent msg of + Left _ -> pure False + Right a -> True <$ f msg a diff --git a/src/Haboli/Euphoria/Command/Simple.hs b/src/Haboli/Euphoria/Command/Simple.hs new file mode 100644 index 0000000..215fdef --- /dev/null +++ b/src/Haboli/Euphoria/Command/Simple.hs @@ -0,0 +1,44 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.Command.Simple + ( cmdGeneral + , cmdSpecific + ) where + +import Control.Monad +import Data.Char +import qualified Data.Text as T +import Text.Megaparsec +import Text.Megaparsec.Char + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client +import Haboli.Euphoria.Command +import Haboli.Euphoria.Command.Megaparsec +import Haboli.Euphoria.Util + +type Parser = Parsec () T.Text + +pCmd :: T.Text -> Parser () +pCmd cmd = void $ label "command" $ char '!' *> string cmd + +pNick :: T.Text -> Parser () +pNick name = label "nick" $ do + void $ char '@' + name' <- takeWhile1P Nothing (not . isSpace) + guard $ nickEqual name name' + +pUntilEof :: Parser T.Text +pUntilEof = takeWhileP Nothing (const True) + +pCmdGeneral :: T.Text -> Parser T.Text +pCmdGeneral cmd = pCmd cmd *> space *> pUntilEof + +cmdGeneral :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e +cmdGeneral cmd = cmdMega $ pCmdGeneral cmd + +pCmdSpecific :: T.Text -> T.Text -> Parser T.Text +pCmdSpecific cmd name = pCmd cmd *> space1 *> pNick name *> space *> pUntilEof + +cmdSpecific :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e +cmdSpecific name cmd = cmdMega $ pCmdSpecific cmd name From 6c00d76af6147731289ade3af927ae820f5aeb21 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 14:36:58 +0000 Subject: [PATCH 09/23] Add example bot --- CHANGELOG.md | 1 + haboli.cabal | 3 +- src/Haboli/Euphoria/Command/Simple.hs | 24 +++++++++++--- src/Haboli/Euphoria/ExampleBot.hs | 46 +++++++++++++++++++++++++++ src/Haboli/Euphoria/Listing.hs | 8 +++++ 5 files changed, 76 insertions(+), 6 deletions(-) create mode 100644 src/Haboli/Euphoria/ExampleBot.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 69329a1..501024a 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -4,6 +4,7 @@ - add `Haboli.Euphoria.Command` module and submodules - add `Haboli.Euphoria.Listing` module - add `Haboli.Euphoria.Util` module and move `respondingToPing` there +- add example bot (`Haboli.Euphoria.ExampleBot`) - clean up project - fix nick of example bot in readme - remove `Haboli.Euphoria.Examples` module diff --git a/haboli.cabal b/haboli.cabal index 34ce92c..772eb06 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 9151d30bacf2317670dc6ff817bd66ca13bd3798142b0b8ad8fceb78461b4ab1 +-- hash: 15fd0a6cea4710f753e56b5d0232a7986b434e5fab8fee7855e81e311f87499c name: haboli version: 0.3.1.0 @@ -35,6 +35,7 @@ library Haboli.Euphoria.Command Haboli.Euphoria.Command.Megaparsec Haboli.Euphoria.Command.Simple + Haboli.Euphoria.ExampleBot Haboli.Euphoria.Listing Haboli.Euphoria.Util other-modules: diff --git a/src/Haboli/Euphoria/Command/Simple.hs b/src/Haboli/Euphoria/Command/Simple.hs index 215fdef..d8eb2ad 100644 --- a/src/Haboli/Euphoria/Command/Simple.hs +++ b/src/Haboli/Euphoria/Command/Simple.hs @@ -2,7 +2,9 @@ module Haboli.Euphoria.Command.Simple ( cmdGeneral + , cmdGeneral' , cmdSpecific + , cmdSpecific' ) where import Control.Monad @@ -34,11 +36,23 @@ pUntilEof = takeWhileP Nothing (const True) pCmdGeneral :: T.Text -> Parser T.Text pCmdGeneral cmd = pCmd cmd *> space *> pUntilEof -cmdGeneral :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e -cmdGeneral cmd = cmdMega $ pCmdGeneral cmd - pCmdSpecific :: T.Text -> T.Text -> Parser T.Text pCmdSpecific cmd name = pCmd cmd *> space1 *> pNick name *> space *> pUntilEof -cmdSpecific :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e -cmdSpecific name cmd = cmdMega $ pCmdSpecific cmd name +pWithoutArgs :: Parser T.Text -> Parser () +pWithoutArgs p = do + args <- p + guard $ T.null args + +cmdGeneral :: T.Text -> (Message -> Client e ()) -> Command e +cmdGeneral cmd f = cmdMega (pWithoutArgs $ pCmdGeneral cmd) $ \msg _ -> f msg + +cmdGeneral' :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e +cmdGeneral' cmd = cmdMega $ pCmdGeneral cmd + +cmdSpecific :: T.Text -> T.Text -> (Message -> Client e ()) -> Command e +cmdSpecific cmd name f = + cmdMega (pWithoutArgs $ pCmdSpecific cmd name) $ \msg _ -> f msg + +cmdSpecific' :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e +cmdSpecific' cmd name = cmdMega $ pCmdSpecific cmd name diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs new file mode 100644 index 0000000..6d1148f --- /dev/null +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -0,0 +1,46 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.ExampleBot + ( BotState(..) + , exampleBot + ) where + +import Control.Monad +import Control.Monad.Trans.Class +import Control.Monad.Trans.State +import qualified Data.Text as T + +import Haboli.Euphoria +import Haboli.Euphoria.Command +import Haboli.Euphoria.Command.Simple +import Haboli.Euphoria.Listing +import Haboli.Euphoria.Util + +newtype BotState = BotState + { botListing :: Listing + } deriving (Show) + +type Bot = StateT BotState (Client T.Text) + +exampleBot :: Maybe T.Text -> Client T.Text () +exampleBot mPasswd = do + initialEvents <- untilConnected $ + respondingToBounce mPasswd $ + respondingToPing nextEvent + listing <- preferNick "ExampleBot" $ newListing initialEvents + void $ runStateT botMain $ BotState listing + +botMain :: Bot () +botMain = forever $ do + s <- get + let name = svNick $ self $ botListing s + lift $ respondingToCommands + [ cmdGeneral "ping" $ \msg -> void $ reply msg "Pong!" + , cmdSpecific "ping" name $ \msg -> void $ reply msg "Pong!" + , cmdSpecific "help" name $ \msg -> + void $ reply msg "I am an example bot for https://github.com/Garmelon/haboli/." + , cmdSpecific "kill" name $ \msg -> do + void $ reply msg "/me dies" + throw $ "I was killed by " <> svNick (msgSender msg) + ] $ respondingToPing nextEvent + diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs index af4896b..0e53fa4 100644 --- a/src/Haboli/Euphoria/Listing.hs +++ b/src/Haboli/Euphoria/Listing.hs @@ -6,6 +6,7 @@ module Haboli.Euphoria.Listing , self , others , updateOwnNick + , preferNick , updateFromList , updateFromEvent ) where @@ -40,6 +41,13 @@ others = lsOthers updateOwnNick :: T.Text -> Listing -> Listing updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}} +preferNick :: T.Text -> Listing -> Client e Listing +preferNick name listing + | name == svNick (self listing) = pure listing + | otherwise = do + (_, newNick) <- nick name + pure $ updateOwnNick newNick listing + updateFromList :: [SessionView] -> Listing -> Listing updateFromList sessions listing = let ownId = svId $ lsSelf listing From eabfe0fd75826396d64b9b5001cd1312855899b1 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 15:53:52 +0000 Subject: [PATCH 10/23] Add some documentation --- src/Haboli/Euphoria/Api.hs | 40 +++++++++++++++++++++++++++---- src/Haboli/Euphoria/ExampleBot.hs | 10 ++++++-- 2 files changed, 44 insertions(+), 6 deletions(-) diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index b85f24d..02664d7 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -112,7 +112,7 @@ instance FromJSON AuthOption where -- | A 'Message' is a node in a room’s log. It corresponds to a chat message, or -- a post, or any broadcasted event in a room that should appear in the log. See --- . +-- . data Message = Message { msgId :: Snowflake , msgParent :: Maybe Snowflake @@ -139,6 +139,8 @@ instance FromJSON Message where <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") <*> o .:? "truncated" .!= False +-- | A 'PersonalAccountView' contains information about an euphoria account. See +-- . data PersonalAccountView = PersonalAccountView { pavId :: Snowflake , pavName :: T.Text @@ -152,7 +154,7 @@ instance FromJSON PersonalAccountView where <*> o .: "email" -- | A 'SessionView' describes a session and its identity. See --- . +-- . data SessionView = SessionView { svId :: UserId , svNick :: T.Text @@ -179,7 +181,7 @@ instance FromJSON SessionView where -- | A snowflake is a 13-character string, usually used as a unique identifier -- for some type of object. It is the base-36 encoding of an unsigned, 64-bit --- integer. See . +-- integer. See . type Snowflake = T.Text -- | The type of session a client may have. @@ -198,7 +200,7 @@ data UserType -- | A 'UserId' identifies a user. It consists of two parts: The type of -- session, and a unique value for that type of session. See --- . +-- . data UserId = UserId { userType :: UserType , userSnowflake :: Snowflake @@ -225,6 +227,7 @@ instance FromJSON UserId where {- bounce-event -} +-- | See . data BounceEvent = BounceEvent { bounceReason :: Maybe T.Text , bounceAuthOption :: [AuthOption] @@ -237,6 +240,7 @@ instance FromJSON BounceEvent where {- disconnect-event -} +-- | See . newtype DisconnectEvent = DisconnectEvent { disconnectReason :: T.Text } deriving (Show) @@ -247,6 +251,7 @@ instance FromJSON DisconnectEvent where {- hello-event -} +-- | See . data HelloEvent = HelloEvent { helloAccount :: Maybe PersonalAccountView , helloSessionView :: SessionView @@ -267,6 +272,7 @@ instance FromJSON HelloEvent where {- join-event -} +-- | See . newtype JoinEvent = JoinEvent { joinSession :: SessionView } deriving (Show) @@ -277,6 +283,7 @@ instance FromJSON JoinEvent where {- login-event -} +-- | See . newtype LoginEvent = LoginEvent { loginAccountId :: Snowflake } deriving (Show) @@ -287,6 +294,7 @@ instance FromJSON LoginEvent where {- logout-event -} +-- | See . data LogoutEvent = LogoutEvent deriving (Show) @@ -295,6 +303,7 @@ instance FromJSON LogoutEvent where {- network-event -} +-- | See . data NetworkEvent = NetworkEvent { networkType :: T.Text -- always "partition" , networkServerId :: T.Text @@ -309,6 +318,7 @@ instance FromJSON NetworkEvent where {- nick-event -} +-- | See . data NickEvent = NickEvent { nickSessionId :: T.Text , nickId :: UserId @@ -325,6 +335,7 @@ instance FromJSON NickEvent where {- edit-message-event -} +-- | See . data EditMessageEvent = EditMessageEvent { editMessageMessage :: Message , editMessageEditId :: Snowflake @@ -337,6 +348,7 @@ instance FromJSON EditMessageEvent where {- part-event -} +-- | See . newtype PartEvent = PartEvent { partSession :: SessionView } deriving (Show) @@ -347,6 +359,7 @@ instance FromJSON PartEvent where {- ping-event -} +-- | See . data PingEvent = PingEvent { pingTime :: UTCTime , pingNext :: UTCTime @@ -359,6 +372,7 @@ instance FromJSON PingEvent where {- pm-initiate-event -} +-- | See . data PmInitiateEvent = PmInitiateEvent { pmInitiateFrom :: UserId , pmInitiateFromNick :: T.Text @@ -375,6 +389,7 @@ instance FromJSON PmInitiateEvent where {- send-event -} +-- | See . newtype SendEvent = SendEvent { sendMessage :: Message } deriving (Show) @@ -385,6 +400,7 @@ instance FromJSON SendEvent where {- snapshot-event -} +-- | See . data SnapshotEvent = SnapshotEvent { snapshotIdentity :: UserId , snapshotSessionId :: T.Text @@ -411,6 +427,7 @@ instance FromJSON SnapshotEvent where {- auth -} +-- | See . newtype AuthCommand = AuthWithPasscode T.Text deriving (Show) @@ -420,6 +437,7 @@ instance ToJSONObject AuthCommand where , "passcode" .= password ] +-- | See . data AuthReply = AuthSuccessful | AuthFailed T.Text deriving (Show) @@ -434,6 +452,7 @@ instance FromJSON AuthReply where {- ping -} +-- | See . newtype PingCommand = PingCommand UTCTime deriving (Show) @@ -442,6 +461,7 @@ instance ToJSONObject PingCommand where [ "time" .= utcTimeToPOSIXSeconds time ] +-- | See . newtype PingReply = PingReply UTCTime deriving (Show) @@ -458,6 +478,7 @@ instance FromJSON PingReply where {- get-message -} +-- | See . newtype GetMessageCommand = GetMessageCommand Snowflake deriving (Show) @@ -466,6 +487,7 @@ instance ToJSONObject GetMessageCommand where [ "id" .= mId ] +-- | See . newtype GetMessageReply = GetMessageReply Message deriving (Show) @@ -475,6 +497,7 @@ instance FromJSON GetMessageReply where {- log -} +-- | See . data LogCommand = LogCommand Int (Maybe Snowflake) deriving (Show) @@ -487,6 +510,7 @@ instance ToJSONObject LogCommand where , "before" .= before ] +-- | See . data LogReply = LogReply [Message] (Maybe Snowflake) deriving (Show) @@ -497,6 +521,7 @@ instance FromJSON LogReply where {- nick -} +-- | See . newtype NickCommand = NickCommand T.Text deriving (Show) @@ -505,6 +530,7 @@ instance ToJSONObject NickCommand where [ "name" .= nick ] +-- | See . data NickReply = NickReply { nickReplySessionId :: T.Text , nickReplyId :: UserId @@ -521,6 +547,7 @@ instance FromJSON NickReply where {- pm-initiate -} +-- | See . newtype PmInitiateCommand = PmInitiateCommand UserId deriving (Show) @@ -529,6 +556,7 @@ instance ToJSONObject PmInitiateCommand where [ "user_id" .= userId ] +-- | See . data PmInitiateReply = PmInitiateReply Snowflake T.Text deriving (Show) @@ -539,6 +567,7 @@ instance FromJSON PmInitiateReply where {- send -} +-- | See . data SendCommand = SendCommand T.Text (Maybe Snowflake) deriving (Show) @@ -548,6 +577,7 @@ instance ToJSONObject SendCommand where toJSONObject (SendCommand content (Just parent)) = toPacket "send" $ object ["content" .= content, "parent" .= parent] +-- | See . newtype SendReply = SendReply Message deriving (Show) @@ -557,12 +587,14 @@ instance FromJSON SendReply where {- who -} +-- | See . data WhoCommand = WhoCommand deriving (Show) instance ToJSONObject WhoCommand where toJSONObject WhoCommand = toPacket "who" $ object [] +-- | See . newtype WhoReply = WhoReply [SessionView] deriving (Show) diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index 6d1148f..bee6152 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -1,8 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} +-- | This module contains an example implementation of a small bot. It is a good +-- starting point if you want to create your own bot. + module Haboli.Euphoria.ExampleBot - ( BotState(..) - , exampleBot + ( exampleBot ) where import Control.Monad @@ -22,6 +24,10 @@ newtype BotState = BotState type Bot = StateT BotState (Client T.Text) +-- | A small example bot. Takes a room password as its first argument. You can +-- run this bot in [&test](https://euphoria.io/room/test) like this: +-- +-- > runClient defaultConfig $ exampleBot Nothing exampleBot :: Maybe T.Text -> Client T.Text () exampleBot mPasswd = do initialEvents <- untilConnected $ From 30f00fda399e2eea44412caae033c48581e2d5e1 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 17:15:02 +0000 Subject: [PATCH 11/23] Change naming scheme of cmd functions Also add documentation for the existing command modules --- src/Haboli/Euphoria/Command/Megaparsec.hs | 15 +++++- src/Haboli/Euphoria/Command/Simple.hs | 64 ++++++++++++++++++----- 2 files changed, 64 insertions(+), 15 deletions(-) diff --git a/src/Haboli/Euphoria/Command/Megaparsec.hs b/src/Haboli/Euphoria/Command/Megaparsec.hs index c0767a3..98bf252 100644 --- a/src/Haboli/Euphoria/Command/Megaparsec.hs +++ b/src/Haboli/Euphoria/Command/Megaparsec.hs @@ -1,5 +1,8 @@ +-- | Bot commands based on the megaparsec library. + module Haboli.Euphoria.Command.Megaparsec ( cmdMega + , cmdMega' ) where import qualified Data.Text as T @@ -9,7 +12,15 @@ import Haboli.Euphoria.Api import Haboli.Euphoria.Client import Haboli.Euphoria.Command +-- | Turn a megaparsec parser into a bot command. Applies the parser to the +-- content of the message. If the parser fails to parse the message content, the +-- command fails. cmdMega :: Parsec e' T.Text a -> (Message -> a -> Client e ()) -> Command e -cmdMega parser f msg = case parse parser "" $ msgContent msg of +cmdMega parser f = cmdMega' parser $ \msg a -> True <$ f msg a + +-- | A version of 'cmdMega' that allows the command function to decide whether +-- the command was successful or not. +cmdMega' :: Parsec e' T.Text a -> (Message -> a -> Client e Bool) -> Command e +cmdMega' parser f msg = case parse parser "" $ msgContent msg of Left _ -> pure False - Right a -> True <$ f msg a + Right a -> f msg a diff --git a/src/Haboli/Euphoria/Command/Simple.hs b/src/Haboli/Euphoria/Command/Simple.hs index d8eb2ad..13ef6c2 100644 --- a/src/Haboli/Euphoria/Command/Simple.hs +++ b/src/Haboli/Euphoria/Command/Simple.hs @@ -1,10 +1,20 @@ {-# LANGUAGE OverloadedStrings #-} +-- | General and specific commands as described in the +-- [botrulez](https://github.com/jedevc/botrulez). + module Haboli.Euphoria.Command.Simple - ( cmdGeneral + ( + -- * General commands + cmdGeneral , cmdGeneral' + , cmdGeneralArgs + , cmdGeneralArgs' + -- * Specific commands , cmdSpecific , cmdSpecific' + , cmdSpecificArgs + , cmdSpecificArgs' ) where import Control.Monad @@ -39,20 +49,48 @@ pCmdGeneral cmd = pCmd cmd *> space *> pUntilEof pCmdSpecific :: T.Text -> T.Text -> Parser T.Text pCmdSpecific cmd name = pCmd cmd *> space1 *> pNick name *> space *> pUntilEof -pWithoutArgs :: Parser T.Text -> Parser () -pWithoutArgs p = do - args <- p - guard $ T.null args - +-- | @'cmdGeneral' cmd f' is a general command with no arguments in the form of +-- @!cmd@. cmdGeneral :: T.Text -> (Message -> Client e ()) -> Command e -cmdGeneral cmd f = cmdMega (pWithoutArgs $ pCmdGeneral cmd) $ \msg _ -> f msg +cmdGeneral cmd f = cmdGeneral' cmd $ \msg -> True <$ f msg -cmdGeneral' :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e -cmdGeneral' cmd = cmdMega $ pCmdGeneral cmd +-- | A version of 'cmdGeneral' that allows the command function to decide +-- whether the command was successful or not. +cmdGeneral' :: T.Text -> (Message -> Client e Bool) -> Command e +cmdGeneral' cmd f = cmdGeneralArgs' cmd $ \msg args -> if T.null args + then f msg + else pure False +-- | @'cmdGeneralArgs' cmd f' is a general command with arguments in the form of +-- @!cmd args@. @f@ is called with the source message and the arguments as +-- 'T.Text'. +cmdGeneralArgs :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e +cmdGeneralArgs cmd f = cmdGeneralArgs' cmd $ \msg args -> True <$ f msg args + +-- | A version of 'cmdGeneralArgs' that allows the command function to decide +-- whether the command was successful or not. +cmdGeneralArgs' :: T.Text -> (Message -> T.Text -> Client e Bool) -> Command e +cmdGeneralArgs' cmd = cmdMega' $ pCmdGeneral cmd + +-- | @'cmdSpecific' cmd nick f@ is a specific command with no arguments in the +-- form of @!cmd \@nick@. cmdSpecific :: T.Text -> T.Text -> (Message -> Client e ()) -> Command e -cmdSpecific cmd name f = - cmdMega (pWithoutArgs $ pCmdSpecific cmd name) $ \msg _ -> f msg +cmdSpecific cmd name f = cmdSpecific' cmd name $ \msg -> True <$ f msg -cmdSpecific' :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e -cmdSpecific' cmd name = cmdMega $ pCmdSpecific cmd name +-- | A version of 'cmdSpecific' that allows the command function to decide +-- whether the command was successful or not. +cmdSpecific' :: T.Text -> T.Text -> (Message -> Client e Bool) -> Command e +cmdSpecific' cmd name f = cmdSpecificArgs' cmd name $ \msg args -> if T.null args + then f msg + else pure False + +-- | @'cmdSpecificArgs' cmd nick f@ is a specific command with arguments in the +-- form of @!cmd \@nick args@. @f@ is called with the source message and the +-- arguments as 'T.Text'. +cmdSpecificArgs :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e +cmdSpecificArgs cmd name f = cmdSpecificArgs' cmd name $ \msg args -> True <$ f msg args + +-- | A version of 'cmdSpecificArgs' that allows the command function to decide +-- whether the command was successful or not. +cmdSpecificArgs' :: T.Text -> T.Text -> (Message -> T.Text -> Client e Bool) -> Command e +cmdSpecificArgs' cmd name = cmdMega' $ pCmdSpecific cmd name From 9df9280f5fe3a5ce996639eee78eb0ab837e3e61 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 17:27:45 +0000 Subject: [PATCH 12/23] Update reexports in Haboli.Euphoria module --- src/Haboli/Euphoria.hs | 16 ++++++++++++---- src/Haboli/Euphoria/ExampleBot.hs | 6 +----- 2 files changed, 13 insertions(+), 9 deletions(-) diff --git a/src/Haboli/Euphoria.hs b/src/Haboli/Euphoria.hs index 968c565..aa3e32f 100644 --- a/src/Haboli/Euphoria.hs +++ b/src/Haboli/Euphoria.hs @@ -1,11 +1,19 @@ --- | This module just reexports all euphoria-related modules for convenience. --- For more detail on how this library works, check the "Haboli.Euphoria.Client" +-- | This module reexports the most commonly used modules for convenience. For +-- more detail on how this library works, check the "Haboli.Euphoria.Client" -- module's documentation. module Haboli.Euphoria - ( module Haboli.Euphoria.Client - , module Haboli.Euphoria.Api + ( module Haboli.Euphoria.Api + , module Haboli.Euphoria.Client + , module Haboli.Euphoria.Command + , module Haboli.Euphoria.Command.Simple + , module Haboli.Euphoria.Listing + , module Haboli.Euphoria.Util ) where import Haboli.Euphoria.Api import Haboli.Euphoria.Client +import Haboli.Euphoria.Command +import Haboli.Euphoria.Command.Simple +import Haboli.Euphoria.Listing +import Haboli.Euphoria.Util diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index bee6152..3929499 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -10,13 +10,9 @@ module Haboli.Euphoria.ExampleBot import Control.Monad import Control.Monad.Trans.Class import Control.Monad.Trans.State -import qualified Data.Text as T +import qualified Data.Text as T import Haboli.Euphoria -import Haboli.Euphoria.Command -import Haboli.Euphoria.Command.Simple -import Haboli.Euphoria.Listing -import Haboli.Euphoria.Util newtype BotState = BotState { botListing :: Listing From 15cd6724d2e8e983d693564bb6a0055e1a6c1263 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 18:32:48 +0000 Subject: [PATCH 13/23] Implement some botrulez --- CHANGELOG.md | 1 + haboli.cabal | 3 +- src/Haboli/Euphoria/Botrulez.hs | 54 +++++++++++++++++++++++++++++++ src/Haboli/Euphoria/ExampleBot.hs | 27 ++++++++++------ src/Haboli/Euphoria/Util.hs | 22 +++++++++++-- 5 files changed, 94 insertions(+), 13 deletions(-) create mode 100644 src/Haboli/Euphoria/Botrulez.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index 501024a..f6c14b0 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,6 +1,7 @@ # Changelog for haboli ## upcoming +- add `Haboli.Euphoria.Botrulez` module - add `Haboli.Euphoria.Command` module and submodules - add `Haboli.Euphoria.Listing` module - add `Haboli.Euphoria.Util` module and move `respondingToPing` there diff --git a/haboli.cabal b/haboli.cabal index 772eb06..52f2eac 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 15fd0a6cea4710f753e56b5d0232a7986b434e5fab8fee7855e81e311f87499c +-- hash: ae5e8a6e8abe1ff515797a54dfa9acd185df7699102b31190d569ccfe3a693f8 name: haboli version: 0.3.1.0 @@ -31,6 +31,7 @@ library exposed-modules: Haboli.Euphoria Haboli.Euphoria.Api + Haboli.Euphoria.Botrulez Haboli.Euphoria.Client Haboli.Euphoria.Command Haboli.Euphoria.Command.Megaparsec diff --git a/src/Haboli/Euphoria/Botrulez.hs b/src/Haboli/Euphoria/Botrulez.hs new file mode 100644 index 0000000..09deb05 --- /dev/null +++ b/src/Haboli/Euphoria/Botrulez.hs @@ -0,0 +1,54 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.Botrulez + ( botrulezPingGeneral + , botrulezPingSpecific + , botrulezHelpGeneral + , botrulezHelpSpecific + , botrulezUptimeSpecific + , botrulezKillSpecific + ) where + +import Control.Monad +import Control.Monad.IO.Class +import qualified Data.Text as T +import Data.Time + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client +import Haboli.Euphoria.Command +import Haboli.Euphoria.Command.Simple +import Haboli.Euphoria.Util + +botrulezPingGeneral :: Command e +botrulezPingGeneral = cmdGeneral "ping" $ \msg -> + void $ reply msg "Pong!" + +botrulezPingSpecific :: T.Text -> Command e +botrulezPingSpecific name = cmdSpecific "ping" name $ \msg -> + void $ reply msg "Pong!" + +botrulezHelpGeneral :: T.Text -> Command e +botrulezHelpGeneral help = cmdGeneral "help" $ \msg -> + void $ reply msg help + +botrulezHelpSpecific :: T.Text -> T.Text -> Command e +botrulezHelpSpecific name help = cmdSpecific "help" name $ \msg -> + void $ reply msg help + +botrulezUptimeSpecific :: T.Text -> UTCTime -> Command e +botrulezUptimeSpecific name since = cmdSpecific "uptime" name $ \msg -> do + now <- liftIO getCurrentTime + let delta = diffUTCTime now since + void $ reply msg $ mconcat + [ "/me has been up since " + , formatUTCTime since + , " UTC (" + , formatNominalDiffTime delta + , ")" + ] + +botrulezKillSpecific :: T.Text -> Command T.Text +botrulezKillSpecific name = cmdSpecific "kill" name $ \msg -> do + void $ reply msg "/me dies" + throw $ "I was killed by " <> svNick (msgSender msg) diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index 3929499..cc69862 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -8,14 +8,18 @@ module Haboli.Euphoria.ExampleBot ) where import Control.Monad +import Control.Monad.IO.Class import Control.Monad.Trans.Class import Control.Monad.Trans.State import qualified Data.Text as T +import Data.Time import Haboli.Euphoria +import Haboli.Euphoria.Botrulez -newtype BotState = BotState - { botListing :: Listing +data BotState = BotState + { botStartTime :: UTCTime + , botListing :: Listing } deriving (Show) type Bot = StateT BotState (Client T.Text) @@ -26,23 +30,26 @@ type Bot = StateT BotState (Client T.Text) -- > runClient defaultConfig $ exampleBot Nothing exampleBot :: Maybe T.Text -> Client T.Text () exampleBot mPasswd = do + startTime <- liftIO getCurrentTime initialEvents <- untilConnected $ respondingToBounce mPasswd $ respondingToPing nextEvent listing <- preferNick "ExampleBot" $ newListing initialEvents - void $ runStateT botMain $ BotState listing + void $ runStateT botMain $ BotState startTime listing botMain :: Bot () botMain = forever $ do s <- get let name = svNick $ self $ botListing s lift $ respondingToCommands - [ cmdGeneral "ping" $ \msg -> void $ reply msg "Pong!" - , cmdSpecific "ping" name $ \msg -> void $ reply msg "Pong!" - , cmdSpecific "help" name $ \msg -> - void $ reply msg "I am an example bot for https://github.com/Garmelon/haboli/." - , cmdSpecific "kill" name $ \msg -> do - void $ reply msg "/me dies" - throw $ "I was killed by " <> svNick (msgSender msg) + [ botrulezPingGeneral + , botrulezPingSpecific name + , botrulezHelpSpecific name "I am an example bot for https://github.com/Garmelon/haboli/." + , botrulezUptimeSpecific name $ botStartTime s + , botrulezKillSpecific name + , cmdGeneral "hello" $ \msg -> + void $ reply msg $ "Hi there, " <> nickMention (svNick $ msgSender msg) <> "!" + , cmdSpecific "hug" name $ \msg -> + void $ reply msg "/me hugs back" ] $ respondingToPing nextEvent diff --git a/src/Haboli/Euphoria/Util.hs b/src/Haboli/Euphoria/Util.hs index 1da51a8..95cd835 100644 --- a/src/Haboli/Euphoria/Util.hs +++ b/src/Haboli/Euphoria/Util.hs @@ -1,9 +1,10 @@ {-# LANGUAGE OverloadedStrings #-} module Haboli.Euphoria.Util - ( + ( formatUTCTime + , formatNominalDiffTime -- * Events - respondingToPing + , respondingToPing , respondingToBounce , respondingToBounce' , untilConnected @@ -20,10 +21,27 @@ import Data.Char import Data.Function import qualified Data.Set as Set import qualified Data.Text as T +import Data.Time import Haboli.Euphoria.Api import Haboli.Euphoria.Client +formatUTCTime :: UTCTime -> T.Text +formatUTCTime t = T.pack $ formatTime defaultTimeLocale "%F %T" t + +formatNominalDiffTime :: NominalDiffTime -> T.Text +formatNominalDiffTime t = T.intercalate " " $ map T.pack $ concat + [ [show days ++ "d" | days /= 0] + , [show hours ++ "h" | hours /= 0] + , [show minutes ++ "m" | minutes /= 0] + , [show seconds ++ "s"] + ] + where + totalSeconds = round $ nominalDiffTimeToSeconds t :: Integer + (days, secondsAfterDays) = totalSeconds `quotRem` (60 * 60 * 24) + (hours, secondsAfterHours) = secondsAfterDays `quotRem` (60 * 60) + (minutes, seconds) = secondsAfterHours `quotRem` 60 + {- Events -} -- | Respond to 'EventPing's according to the documentation (see From d2d07eb15aa050ba500fda92f901e19ccd3c6e52 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 19:23:27 +0000 Subject: [PATCH 14/23] Change how the example bot handles state --- src/Haboli/Euphoria/Command.hs | 9 +++++---- src/Haboli/Euphoria/ExampleBot.hs | 33 ++++++++++++++++--------------- 2 files changed, 22 insertions(+), 20 deletions(-) diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs index fd0e27c..33685d6 100644 --- a/src/Haboli/Euphoria/Command.hs +++ b/src/Haboli/Euphoria/Command.hs @@ -32,10 +32,11 @@ runCommands (c:cs) msg = do -- 'nextEvent': -- -- > event <- respondingToCommands commands nextEvent -respondingToCommands :: [Command e] -> Client e Event -> Client e Event -respondingToCommands cmds holdingEvent = do - event <- holdingEvent +respondingToCommands :: Client e Event -> Client e [Command e] -> Client e Event +respondingToCommands getEvent getCommands = do + event <- getEvent + commands <- getCommands case event of - EventSend e -> void $ runCommands cmds $ sendMessage e + EventSend e -> void $ runCommands commands $ sendMessage e _ -> pure () pure event diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index cc69862..28fcbd8 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -7,11 +7,10 @@ module Haboli.Euphoria.ExampleBot ( exampleBot ) where +import Control.Concurrent import Control.Monad import Control.Monad.IO.Class -import Control.Monad.Trans.Class -import Control.Monad.Trans.State -import qualified Data.Text as T +import qualified Data.Text as T import Data.Time import Haboli.Euphoria @@ -22,8 +21,6 @@ data BotState = BotState , botListing :: Listing } deriving (Show) -type Bot = StateT BotState (Client T.Text) - -- | A small example bot. Takes a room password as its first argument. You can -- run this bot in [&test](https://euphoria.io/room/test) like this: -- @@ -35,21 +32,25 @@ exampleBot mPasswd = do respondingToBounce mPasswd $ respondingToPing nextEvent listing <- preferNick "ExampleBot" $ newListing initialEvents - void $ runStateT botMain $ BotState startTime listing + stateVar <- liftIO $ newMVar $ BotState startTime listing + botMain stateVar -botMain :: Bot () -botMain = forever $ do - s <- get - let name = svNick $ self $ botListing s - lift $ respondingToCommands +botMain :: MVar BotState -> Client T.Text () +botMain stateVar = forever $ respondingToPing $ respondingToCommands nextEvent $ do + state <- liftIO $ readMVar stateVar + let name = svNick $ self $ botListing state + pure [ botrulezPingGeneral , botrulezPingSpecific name , botrulezHelpSpecific name "I am an example bot for https://github.com/Garmelon/haboli/." - , botrulezUptimeSpecific name $ botStartTime s + , botrulezUptimeSpecific name $ botStartTime state , botrulezKillSpecific name + , cmdSpecific "hug" name $ \msg -> void $ reply msg "/me hugs back" , cmdGeneral "hello" $ \msg -> void $ reply msg $ "Hi there, " <> nickMention (svNick $ msgSender msg) <> "!" - , cmdSpecific "hug" name $ \msg -> - void $ reply msg "/me hugs back" - ] $ respondingToPing nextEvent - + , cmdSpecificArgs "nick" name $ \msg args -> do + s <- liftIO $ takeMVar stateVar + listing' <- preferNick args $ botListing s + liftIO $ putMVar stateVar s{botListing = listing'} + void $ reply msg "Is this better?" + ] From 2d9491d2fb58d490cc4cbcc107ab41953e70cd2d Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 21:23:25 +0000 Subject: [PATCH 15/23] Fix time formatting and add documentation --- src/Haboli/Euphoria/Util.hs | 79 +++++++++++++++++++++++++++---------- 1 file changed, 59 insertions(+), 20 deletions(-) diff --git a/src/Haboli/Euphoria/Util.hs b/src/Haboli/Euphoria/Util.hs index 95cd835..f49335f 100644 --- a/src/Haboli/Euphoria/Util.hs +++ b/src/Haboli/Euphoria/Util.hs @@ -1,10 +1,13 @@ +{-# LANGUAGE MultiWayIf #-} {-# LANGUAGE OverloadedStrings #-} +-- | This module contains a few utility functions that don't deserve their own +-- modules. + module Haboli.Euphoria.Util - ( formatUTCTime - , formatNominalDiffTime + ( -- * Events - , respondingToPing + respondingToPing , respondingToBounce , respondingToBounce' , untilConnected @@ -13,6 +16,9 @@ module Haboli.Euphoria.Util , nickMention , nickNormalize , nickEqual + -- * Time formatting + , formatUTCTime + , formatNominalDiffTime ) where import Control.Monad.Trans.Class @@ -26,25 +32,9 @@ import Data.Time import Haboli.Euphoria.Api import Haboli.Euphoria.Client -formatUTCTime :: UTCTime -> T.Text -formatUTCTime t = T.pack $ formatTime defaultTimeLocale "%F %T" t - -formatNominalDiffTime :: NominalDiffTime -> T.Text -formatNominalDiffTime t = T.intercalate " " $ map T.pack $ concat - [ [show days ++ "d" | days /= 0] - , [show hours ++ "h" | hours /= 0] - , [show minutes ++ "m" | minutes /= 0] - , [show seconds ++ "s"] - ] - where - totalSeconds = round $ nominalDiffTimeToSeconds t :: Integer - (days, secondsAfterDays) = totalSeconds `quotRem` (60 * 60 * 24) - (hours, secondsAfterHours) = secondsAfterDays `quotRem` (60 * 60) - (minutes, seconds) = secondsAfterHours `quotRem` 60 - {- Events -} --- | Respond to 'EventPing's according to the documentation (see +-- | Respond to 'EventPing's according to the euphoria documentation (see -- ). Passes through all events unmodified. -- -- This utility function is meant to be wrapped directly or indirectly around @@ -59,9 +49,19 @@ respondingToPing getEvent = do _ -> pure () pure event +-- | Respond to 'EventBounce's according to the euphoria documentation. If no +-- password is provided but an 'EventBounce' is encountered, throw a 'T.Text' +-- exception. +-- +-- This utility function is meant to be wrapped directly or indirectly around +-- 'nextEvent': +-- +-- > event <- respondingToBounce (Just passwd) nextEvent respondingToBounce :: Maybe T.Text -> Client T.Text Event -> Client T.Text Event respondingToBounce = respondingToBounce' id +-- | A variant of 'respondingToBounce' that allows wrapping the exception into a +-- custom type. respondingToBounce' :: (T.Text -> e) -> Maybe T.Text -> Client e Event -> Client e Event respondingToBounce' onError mPasswd getEvent = do event <- getEvent @@ -77,9 +77,15 @@ respondingToBounce' onError mPasswd getEvent = do _ -> pure () pure event +-- | Receive events until both an 'EventHello' and 'EventSnapshot' were +-- received, then return those. Throw a 'T.Text' exception if an invalid 'Event' +-- was encountered. Valid events are 'EventPing', 'EventBounce', 'EventHello' +-- and 'EventSnapshot'. untilConnected :: Client T.Text Event -> Client T.Text (HelloEvent, SnapshotEvent) untilConnected = untilConnected' id +-- | A variant of 'untilConnected' that allows wrapping the exception into a +-- custom type. untilConnected' :: (T.Text -> e) -> Client e Event -> Client e (HelloEvent, SnapshotEvent) untilConnected' onError getEvent = evalStateT helper (Nothing, Nothing) where @@ -98,6 +104,8 @@ untilConnected' onError getEvent = evalStateT helper (Nothing, Nothing) {- Nick -} +-- | Modify a nick such that — when prepended with an @\@@ — it will (hopefully) +-- ping the person with that nick on euphoria. nickMention :: T.Text -> T.Text nickMention name | T.length name > 1 = T.filter isMentionChar name @@ -106,10 +114,41 @@ nickMention name isMentionChar c = not $ isSpace c || c `Set.member` terminatingChars terminatingChars = Set.fromList ",.!?;&<'\"" +-- | Normalize nicks (for nick comparison purposes) by removing all space +-- characters and converting the rest into a case-insensitive representation. nickNormalize :: T.Text -> T.Text nickNormalize name | T.length name > 1 = T.toCaseFold $ T.filter (not . isSpace) name | otherwise = T.toCaseFold name +-- | Check two nicks for equality by comparing their normalized versions. nickEqual :: T.Text -> T.Text -> Bool nickEqual = (==) `on` nickNormalize + +{- Time formatting -} + +-- | Convert a 'UTCTime' into the format @yyyy-mm-dd HH:MM:SS@. +formatUTCTime :: UTCTime -> T.Text +formatUTCTime t = T.pack $ formatTime defaultTimeLocale "%F %T" t + +-- | Convert a 'NominalDiffTime' into the format @[[[\d ]\h +-- ]\m ]\s@ where the square brackets denote optional parts. +-- Only those parts required to fully display the time span are output. If the +-- 'NominalDiffTime' is negative, a @-@ is prefixed. +formatNominalDiffTime :: NominalDiffTime -> T.Text +formatNominalDiffTime t = (sign <>) $ T.intercalate " " $ map T.pack $ if + | days /= 0 -> [fDays, fHours, fMinutes, fSeconds] + | hours /= 0 -> [ fHours, fMinutes, fSeconds] + | minutes /= 0 -> [ fMinutes, fSeconds] + | otherwise -> [ fSeconds] + where + diffSeconds = round $ nominalDiffTimeToSeconds t :: Integer + sign = if diffSeconds < 0 then "-" else "" + totalSeconds = abs diffSeconds + (days, secondsAfterDays) = totalSeconds `quotRem` (60 * 60 * 24) + (hours, secondsAfterHours) = secondsAfterDays `quotRem` (60 * 60) + (minutes, seconds) = secondsAfterHours `quotRem` 60 + fDays = show days ++ "d" + fHours = show hours ++ "h" + fMinutes = show minutes ++ "m" + fSeconds = show seconds ++ "s" From 0e0596765eb8d6ebbaad3a12f2f8d6a96f66bd3a Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 21:53:16 +0000 Subject: [PATCH 16/23] Add botrulez documentation --- src/Haboli/Euphoria/Botrulez.hs | 16 ++++++++++++++++ src/Haboli/Euphoria/Command.hs | 10 +++++++--- 2 files changed, 23 insertions(+), 3 deletions(-) diff --git a/src/Haboli/Euphoria/Botrulez.hs b/src/Haboli/Euphoria/Botrulez.hs index 09deb05..3f24d0d 100644 --- a/src/Haboli/Euphoria/Botrulez.hs +++ b/src/Haboli/Euphoria/Botrulez.hs @@ -1,5 +1,9 @@ {-# LANGUAGE OverloadedStrings #-} +-- | This module implements a few commands defined in the +-- [botrulez](https://github.com/jedevc/botrulez). If you need more advanced +-- behaviour, it should be pretty easy to reimplement the commands as necessary. + module Haboli.Euphoria.Botrulez ( botrulezPingGeneral , botrulezPingSpecific @@ -20,22 +24,32 @@ import Haboli.Euphoria.Command import Haboli.Euphoria.Command.Simple import Haboli.Euphoria.Util +-- | @'botrulezPingGeneral'@ replies to commands of the form @!ping@ with +-- @Pong!@. botrulezPingGeneral :: Command e botrulezPingGeneral = cmdGeneral "ping" $ \msg -> void $ reply msg "Pong!" +-- | @'botrulezPingSpecific' nick@ replies to commands of the form @!ping +-- \@nick@ with @Pong!@. botrulezPingSpecific :: T.Text -> Command e botrulezPingSpecific name = cmdSpecific "ping" name $ \msg -> void $ reply msg "Pong!" +-- | @'botrulezHelpGeneral' helpText@ replies to commands of the form @!help@ +-- with @helpText@. botrulezHelpGeneral :: T.Text -> Command e botrulezHelpGeneral help = cmdGeneral "help" $ \msg -> void $ reply msg help +-- | @'botrulezHelpSpecific' nick helpText@ replies to commands of the form +-- @!help \@nick@ with @helpText@. botrulezHelpSpecific :: T.Text -> T.Text -> Command e botrulezHelpSpecific name help = cmdSpecific "help" name $ \msg -> void $ reply msg help +-- | @'botrulezUptimeSpecific' nick startTime@ replies to commands of the form +-- @!uptime \@nick@ with the time since @startTime@. botrulezUptimeSpecific :: T.Text -> UTCTime -> Command e botrulezUptimeSpecific name since = cmdSpecific "uptime" name $ \msg -> do now <- liftIO getCurrentTime @@ -48,6 +62,8 @@ botrulezUptimeSpecific name since = cmdSpecific "uptime" name $ \msg -> do , ")" ] +-- | @'botrulezKillSpecific' nick@ replies to commands of the form @!kill +-- \@nick@ with @/me dies@. It then throws an exception. botrulezKillSpecific :: T.Text -> Command T.Text botrulezKillSpecific name = cmdSpecific "kill" name $ \msg -> do void $ reply msg "/me dies" diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs index 33685d6..0ebeb50 100644 --- a/src/Haboli/Euphoria/Command.hs +++ b/src/Haboli/Euphoria/Command.hs @@ -25,13 +25,17 @@ runCommands (c:cs) msg = do then pure True else runCommands cs msg --- | Run a list of 'Command's on all 'EventSend's. Passes through all events --- unmodified. +-- | @'respondingToCommands' getEvent getCommands@ runs a list of 'Command's on +-- all 'EventSend's. It passes through all events unmodified. +-- +-- The @getEvent@ action is used to obtain the next 'Event'. The @getCommands@ +-- action is used to obtain the currently available commands. @getCommands@ is +-- called directly after a new 'Event' becomes available through @getEvent@. -- -- This utility function is meant to be wrapped directly or indirectly around -- 'nextEvent': -- --- > event <- respondingToCommands commands nextEvent +-- > event <- respondingToCommands nextEvent commands respondingToCommands :: Client e Event -> Client e [Command e] -> Client e Event respondingToCommands getEvent getCommands = do event <- getEvent From eafa00cc2a32994cd0fccb6c5bada0f684457f13 Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 21:53:41 +0000 Subject: [PATCH 17/23] Fix example bot and revert argument order of respondingToCommands --- src/Haboli/Euphoria/Command.hs | 8 +++--- src/Haboli/Euphoria/ExampleBot.hs | 42 +++++++++++++++++++++++++------ 2 files changed, 38 insertions(+), 12 deletions(-) diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs index 0ebeb50..fcea112 100644 --- a/src/Haboli/Euphoria/Command.hs +++ b/src/Haboli/Euphoria/Command.hs @@ -25,7 +25,7 @@ runCommands (c:cs) msg = do then pure True else runCommands cs msg --- | @'respondingToCommands' getEvent getCommands@ runs a list of 'Command's on +-- | @'respondingToCommands' getCommands getEvent@ runs a list of 'Command's on -- all 'EventSend's. It passes through all events unmodified. -- -- The @getEvent@ action is used to obtain the next 'Event'. The @getCommands@ @@ -35,9 +35,9 @@ runCommands (c:cs) msg = do -- This utility function is meant to be wrapped directly or indirectly around -- 'nextEvent': -- --- > event <- respondingToCommands nextEvent commands -respondingToCommands :: Client e Event -> Client e [Command e] -> Client e Event -respondingToCommands getEvent getCommands = do +-- > event <- respondingToCommands commands nextEvent +respondingToCommands :: Client e [Command e] -> Client e Event -> Client e Event +respondingToCommands getCommands getEvent = do event <- getEvent commands <- getCommands case event of diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index 28fcbd8..9012eab 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -10,6 +10,8 @@ module Haboli.Euphoria.ExampleBot import Control.Concurrent import Control.Monad import Control.Monad.IO.Class +import Data.List +import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Time @@ -36,7 +38,15 @@ exampleBot mPasswd = do botMain stateVar botMain :: MVar BotState -> Client T.Text () -botMain stateVar = forever $ respondingToPing $ respondingToCommands nextEvent $ do +botMain stateVar = forever $ do + event <- respondingToCommands (getCommands stateVar) $ + respondingToPing nextEvent + -- Update the listing + liftIO $ modifyMVar_ stateVar $ \state -> + pure state{botListing = updateFromEvent event $ botListing state} + +getCommands :: MVar BotState -> Client e [Command T.Text] +getCommands stateVar = do state <- liftIO $ readMVar stateVar let name = svNick $ self $ botListing state pure @@ -46,11 +56,27 @@ botMain stateVar = forever $ respondingToPing $ respondingToCommands nextEvent $ , botrulezUptimeSpecific name $ botStartTime state , botrulezKillSpecific name , cmdSpecific "hug" name $ \msg -> void $ reply msg "/me hugs back" - , cmdGeneral "hello" $ \msg -> - void $ reply msg $ "Hi there, " <> nickMention (svNick $ msgSender msg) <> "!" - , cmdSpecificArgs "nick" name $ \msg args -> do - s <- liftIO $ takeMVar stateVar - listing' <- preferNick args $ botListing s - liftIO $ putMVar stateVar s{botListing = listing'} - void $ reply msg "Is this better?" + , cmdHello + , cmdNick stateVar name + , cmdWho stateVar ] + +cmdHello :: Command e +cmdHello = cmdGeneral "hello" $ \msg -> do + let mention = nickMention $ svNick $ msgSender msg + void $ reply msg $ "Hi there, @" <> mention <> "!" + +cmdNick :: MVar BotState -> T.Text -> Command e +cmdNick stateVar name = cmdSpecificArgs "nick" name $ \msg args -> do + -- Update the listing while updating the nick + state <- liftIO $ takeMVar stateVar + listing' <- preferNick args $ botListing state + liftIO $ putMVar stateVar state{botListing = listing'} + void $ reply msg "Is this better?" + +cmdWho :: MVar BotState -> Command e +cmdWho stateVar = cmdGeneral "who" $ \msg -> do + state <- liftIO $ readMVar stateVar + let people = others $ botListing state + nicks = sort $ map svNick $ Map.elems people + void $ reply msg $ T.intercalate "\n" nicks From 8ec2d582b08eed597c2a2f42375062bdd2846bfb Mon Sep 17 00:00:00 2001 From: Joscha Date: Wed, 8 Apr 2020 22:12:32 +0000 Subject: [PATCH 18/23] Document listing --- src/Haboli/Euphoria/Listing.hs | 19 +++++++++++++++++++ 1 file changed, 19 insertions(+) diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs index 0e53fa4..4f65218 100644 --- a/src/Haboli/Euphoria/Listing.hs +++ b/src/Haboli/Euphoria/Listing.hs @@ -1,5 +1,8 @@ {-# LANGUAGE OverloadedStrings #-} +-- | A 'Listing' helps keep track of a bot's own 'SessionView' as well as all +-- other clients connected to a room. It must be kept up-to-date manually. + module Haboli.Euphoria.Listing ( Listing , newListing @@ -18,6 +21,9 @@ import qualified Data.Text as T import Haboli.Euphoria.Api import Haboli.Euphoria.Client +-- | A listing contains a bot's own 'SessionView' (accessible via 'self') and a +-- map of all other clients currently connected to the room (accessible via +-- 'others'). The latter never includes the bot itself. data Listing = Listing { lsSelf :: SessionView , lsOthers :: Map.Map UserId SessionView @@ -26,21 +32,29 @@ data Listing = Listing othersFromList :: [SessionView] -> Map.Map UserId SessionView othersFromList sessions = Map.fromList [(svId sv, sv) | sv <- sessions] +-- | Create a new 'Listing' based on a 'HelloEvent' and a 'SnapshotEvent'. newListing :: (HelloEvent, SnapshotEvent) -> Listing newListing (h, s) = Listing { lsSelf = helloSessionView h , lsOthers = othersFromList $ snapshotListing s } +-- | The 'SessionView' describing the bot itself. self :: Listing -> SessionView self = lsSelf +-- | The 'SessionView's describing the other clients connected to the current +-- room. Does not include the bot's own 'SessionView' (use 'self' to access +-- that). others :: Listing -> Map.Map UserId SessionView others = lsOthers +-- | Set the bot's own nick to a new nick. updateOwnNick :: T.Text -> Listing -> Listing updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}} +-- | Set the bot's nick and update the 'Listing' with the server's reply in one +-- go. preferNick :: T.Text -> Listing -> Client e Listing preferNick name listing | name == svNick (self listing) = pure listing @@ -48,6 +62,9 @@ preferNick name listing (_, newNick) <- nick name pure $ updateOwnNick newNick listing +-- | Update a 'Listing' from a list of sessions currently connected to the room. +-- Afterwards, the 'Listing' will contain only those sessions present in the +-- list. updateFromList :: [SessionView] -> Listing -> Listing updateFromList sessions listing = let ownId = svId $ lsSelf listing @@ -62,6 +79,8 @@ onJoin sv listing = listing{lsOthers = Map.insert (svId sv) sv $ lsOthers listin onPart :: SessionView -> Listing -> Listing onPart sv listing = listing{lsOthers = Map.delete (svId sv) $ lsOthers listing} +-- | Update a 'Listing' based on an 'Event'. Follows the euphoria documentation +-- for 'JoinEvent', 'PartEvent' and 'NetworkEvent'. updateFromEvent :: Event -> Listing -> Listing updateFromEvent (EventJoin e) listing = onJoin (joinSession e) listing updateFromEvent (EventPart e) listing = onPart (partSession e) listing From 9a476d93712421f265f7f946e06f86eb2fc20920 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 10:39:59 +0000 Subject: [PATCH 19/23] Add lenses to most API types --- CHANGELOG.md | 1 + haboli.cabal | 6 +- package.yaml | 3 + src/Haboli/Euphoria/Api.hs | 241 +++++++++++++++++++++++++----------- src/Haboli/Euphoria/Lens.hs | 13 ++ 5 files changed, 191 insertions(+), 73 deletions(-) create mode 100644 src/Haboli/Euphoria/Lens.hs diff --git a/CHANGELOG.md b/CHANGELOG.md index f6c14b0..ac9e2cf 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -3,6 +3,7 @@ ## upcoming - add `Haboli.Euphoria.Botrulez` module - add `Haboli.Euphoria.Command` module and submodules +- add `Haboli.Euphoria.Lens` and add lenses to a few types - add `Haboli.Euphoria.Listing` module - add `Haboli.Euphoria.Util` module and move `respondingToPing` there - add example bot (`Haboli.Euphoria.ExampleBot`) diff --git a/haboli.cabal b/haboli.cabal index 52f2eac..4a27c41 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: ae5e8a6e8abe1ff515797a54dfa9acd185df7699102b31190d569ccfe3a693f8 +-- hash: 35dc75bb1fd8534c4476115b165d0e969a579affaa05a419abe6f7e3ab749082 name: haboli version: 0.3.1.0 @@ -37,6 +37,7 @@ library Haboli.Euphoria.Command.Megaparsec Haboli.Euphoria.Command.Simple Haboli.Euphoria.ExampleBot + Haboli.Euphoria.Lens Haboli.Euphoria.Listing Haboli.Euphoria.Util other-modules: @@ -48,8 +49,11 @@ library , base >=4.7 && <5 , containers , megaparsec + , microlens + , microlens-th , network , stm + , template-haskell , text , time , transformers diff --git a/package.yaml b/package.yaml index 29a8bf7..1185334 100644 --- a/package.yaml +++ b/package.yaml @@ -18,8 +18,11 @@ dependencies: - aeson - containers - megaparsec + - microlens + - microlens-th - network - stm + - template-haskell - text - time - transformers diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index 02664d7..fb528bf 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -1,4 +1,5 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module attempts to map the structure of the ephoria API to types. @@ -6,41 +7,101 @@ module Haboli.Euphoria.Api ( ToJSONObject(..) -- * Basic types , AuthOption(..) - , Message(..) - , PersonalAccountView(..) - , SessionView(..) , Snowflake , UserType(..) , UserId(..) + , userTypeL + , userSnowflakeL + , SessionView(..) + , svIdL + , svNickL + , svServerIdL + , svServerEraL + , svSessionIdL + , svIsStaffL + , svIsManagerL + , svClientAddressL + , svRealClientAddressL + , Message(..) + , msgIdL + , msgParentL + , msgPreviousEditIdL + , msgTimeL + , msgSenderL + , msgContentL + , msgEncryptionKeyIdL + , msgEditedL + , msgDeletedL + , msgTruncatedL + , PersonalAccountView(..) + , pavIdL + , pavNameL + , pavEmailL -- * Asynchronous events -- ** bounce-event , BounceEvent(..) + , bounceReasonL + , bounceAuthOptionL -- ** disconnect-event , DisconnectEvent(..) + , disconnectReasonL -- ** hello-event , HelloEvent(..) + , helloAccountL + , helloSessionViewL + , helloAccountHasAccessL + , helloAccountEmailVerifiedL + , helloRoomIsPrivateL + , helloVersionL -- ** join-event , JoinEvent(..) + , joinSessionL -- ** login-event , LoginEvent(..) + , loginAccountIdL -- ** logout-event , LogoutEvent(..) -- ** network-event , NetworkEvent(..) + , networkTypeL + , networkServerIdL + , networkServerEraL -- ** nick-event , NickEvent(..) + , nickSessionIdL + , nickIdL + , nickFromL + , nickToL -- ** edit-message-event , EditMessageEvent(..) + , editMessageMessageL + , editMessageEditIdL -- ** part-event , PartEvent(..) + , partSessionL -- ** ping-event , PingEvent(..) + , pingTimeL + , pingNextL -- ** pm-initiate-event , PmInitiateEvent(..) + , pmInitiateFromL + , pmInitiateFromNickL + , pmInitiateFromRoomL + , pmInitiatePmIdL -- ** send-event , SendEvent(..) + , sendMessageL -- ** snapshot-event , SnapshotEvent(..) + , snapshotIdentityL + , snapshotSessionIdL + , snapshotVersionL + , snapshotListingL + , snapshotLogL + , snapshotNickL + , snapshotPmWithNickL + , snapshotPmWithUserIdL -- * Session commands -- ** auth , AuthCommand(..) @@ -77,6 +138,8 @@ import qualified Data.Text as T import Data.Time import Data.Time.Clock.POSIX +import Haboli.Euphoria.Lens + -- | A class for all types that can be converted into an -- 'Data.Aeson.Types.Object'. Similar to 'ToJSON', but more restrictive. class ToJSONObject a where @@ -110,75 +173,6 @@ instance FromJSON AuthOption where parseJSON (String _) = fail "invalid value" parseJSON v = typeMismatch "String" v --- | A 'Message' is a node in a room’s log. It corresponds to a chat message, or --- a post, or any broadcasted event in a room that should appear in the log. See --- . -data Message = Message - { msgId :: Snowflake - , msgParent :: Maybe Snowflake - , msgPreviousEditId :: Maybe Snowflake - , msgTime :: UTCTime - , msgSender :: SessionView - , msgContent :: T.Text - , msgEncryptionKeyId :: Maybe T.Text - , msgEdited :: Maybe UTCTime - , msgDeleted :: Maybe UTCTime - , msgTruncated :: Bool - } deriving (Show) - -instance FromJSON Message where - parseJSON v = parseJSON v >>= \o -> Message - <$> o .: "id" - <*> o .:? "parent" - <*> o .:? "previous_edit_id" - <*> (posixSecondsToUTCTime <$> o .: "time") - <*> o .: "sender" - <*> o .: "content" - <*> o .:? "encryption_key_id" - <*> o .:? "edited" - <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") - <*> o .:? "truncated" .!= False - --- | A 'PersonalAccountView' contains information about an euphoria account. See --- . -data PersonalAccountView = PersonalAccountView - { pavId :: Snowflake - , pavName :: T.Text - , pavEmail :: T.Text - } deriving (Show) - -instance FromJSON PersonalAccountView where - parseJSON v = parseJSON v >>= \o -> PersonalAccountView - <$> o .: "id" - <*> o .: "name" - <*> o .: "email" - --- | A 'SessionView' describes a session and its identity. See --- . -data SessionView = SessionView - { svId :: UserId - , svNick :: T.Text - , svServerId :: T.Text - , svServerEra :: T.Text - , svSessionId :: T.Text - , svIsStaff :: Bool - , svIsManager :: Bool - , svClientAddress :: Maybe T.Text - , svRealClientAddress :: Maybe T.Text - } deriving (Show) - -instance FromJSON SessionView where - parseJSON v = parseJSON v >>= \o -> SessionView - <$> o .: "id" - <*> o .: "name" - <*> o .: "server_id" - <*> o .: "server_era" - <*> o .: "session_id" - <*> o .:? "is_staff" .!= False - <*> o .:? "is_manager" .!= False - <*> o .:? "client_address" - <*> o .:? "real_client_address" - -- | A snowflake is a 13-character string, usually used as a unique identifier -- for some type of object. It is the base-36 encoding of an unsigned, 64-bit -- integer. See . @@ -206,6 +200,8 @@ data UserId = UserId , userSnowflake :: Snowflake } deriving (Show, Eq, Ord) +makeLensesL ''UserId + instance ToJSON UserId where toJSON uid = let prefix = case userType uid of @@ -223,6 +219,81 @@ instance FromJSON UserId where ("bot", snowflake) -> pure $ UserId Bot $ T.drop 1 snowflake _ -> fail "invalid user id label" +-- | A 'SessionView' describes a session and its identity. See +-- . +data SessionView = SessionView + { svId :: UserId + , svNick :: T.Text + , svServerId :: T.Text + , svServerEra :: T.Text + , svSessionId :: T.Text + , svIsStaff :: Bool + , svIsManager :: Bool + , svClientAddress :: Maybe T.Text + , svRealClientAddress :: Maybe T.Text + } deriving (Show) + +makeLensesL ''SessionView + +instance FromJSON SessionView where + parseJSON v = parseJSON v >>= \o -> SessionView + <$> o .: "id" + <*> o .: "name" + <*> o .: "server_id" + <*> o .: "server_era" + <*> o .: "session_id" + <*> o .:? "is_staff" .!= False + <*> o .:? "is_manager" .!= False + <*> o .:? "client_address" + <*> o .:? "real_client_address" + +-- | A 'Message' is a node in a room’s log. It corresponds to a chat message, or +-- a post, or any broadcasted event in a room that should appear in the log. See +-- . +data Message = Message + { msgId :: Snowflake + , msgParent :: Maybe Snowflake + , msgPreviousEditId :: Maybe Snowflake + , msgTime :: UTCTime + , msgSender :: SessionView + , msgContent :: T.Text + , msgEncryptionKeyId :: Maybe T.Text + , msgEdited :: Maybe UTCTime + , msgDeleted :: Maybe UTCTime + , msgTruncated :: Bool + } deriving (Show) + +makeLensesL ''Message + +instance FromJSON Message where + parseJSON v = parseJSON v >>= \o -> Message + <$> o .: "id" + <*> o .:? "parent" + <*> o .:? "previous_edit_id" + <*> (posixSecondsToUTCTime <$> o .: "time") + <*> o .: "sender" + <*> o .: "content" + <*> o .:? "encryption_key_id" + <*> o .:? "edited" + <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") + <*> o .:? "truncated" .!= False + +-- | A 'PersonalAccountView' contains information about an euphoria account. See +-- . +data PersonalAccountView = PersonalAccountView + { pavId :: Snowflake + , pavName :: T.Text + , pavEmail :: T.Text + } deriving (Show) + +makeLensesL ''PersonalAccountView + +instance FromJSON PersonalAccountView where + parseJSON v = parseJSON v >>= \o -> PersonalAccountView + <$> o .: "id" + <*> o .: "name" + <*> o .: "email" + {- Asynchronous events -} {- bounce-event -} @@ -233,6 +304,8 @@ data BounceEvent = BounceEvent , bounceAuthOption :: [AuthOption] } deriving (Show) +makeLensesL ''BounceEvent + instance FromJSON BounceEvent where parseJSON = fromPacket "bounce-event" $ \o -> BounceEvent <$> o .:? "reason" @@ -245,6 +318,8 @@ newtype DisconnectEvent = DisconnectEvent { disconnectReason :: T.Text } deriving (Show) +makeLensesL ''DisconnectEvent + instance FromJSON DisconnectEvent where parseJSON = fromPacket "disconnect-evnet" $ \o -> DisconnectEvent <$> o .: "reason" @@ -261,6 +336,8 @@ data HelloEvent = HelloEvent , helloVersion :: T.Text } deriving (Show) +makeLensesL ''HelloEvent + instance FromJSON HelloEvent where parseJSON = fromPacket "hello-event" $ \o -> HelloEvent <$> o .:? "account" @@ -277,6 +354,8 @@ newtype JoinEvent = JoinEvent { joinSession :: SessionView } deriving (Show) +makeLensesL ''JoinEvent + instance FromJSON JoinEvent where parseJSON = fromPacket "join-event" $ \o -> JoinEvent <$> parseJSON (Object o) @@ -288,6 +367,8 @@ newtype LoginEvent = LoginEvent { loginAccountId :: Snowflake } deriving (Show) +makeLensesL ''LoginEvent + instance FromJSON LoginEvent where parseJSON = fromPacket "login-event" $ \o -> LoginEvent <$> o .: "acount_id" @@ -310,6 +391,8 @@ data NetworkEvent = NetworkEvent , networkServerEra :: T.Text } deriving (Show) +makeLensesL ''NetworkEvent + instance FromJSON NetworkEvent where parseJSON = fromPacket "network-event" $ \o -> NetworkEvent <$> o .: "type" @@ -326,6 +409,8 @@ data NickEvent = NickEvent , nickTo :: T.Text } deriving (Show) +makeLensesL ''NickEvent + instance FromJSON NickEvent where parseJSON = fromPacket "nick-event" $ \o -> NickEvent <$> o .: "session_id" @@ -341,6 +426,8 @@ data EditMessageEvent = EditMessageEvent , editMessageEditId :: Snowflake } deriving (Show) +makeLensesL ''EditMessageEvent + instance FromJSON EditMessageEvent where parseJSON = fromPacket "EditMessageEvent" $ \o -> EditMessageEvent <$> parseJSON (Object o) @@ -353,6 +440,8 @@ newtype PartEvent = PartEvent { partSession :: SessionView } deriving (Show) +makeLensesL ''PartEvent + instance FromJSON PartEvent where parseJSON = fromPacket "part-event" $ \o -> PartEvent <$> parseJSON (Object o) @@ -365,6 +454,8 @@ data PingEvent = PingEvent , pingNext :: UTCTime } deriving (Show) +makeLensesL ''PingEvent + instance FromJSON PingEvent where parseJSON = fromPacket "ping-event" $ \o -> PingEvent <$> (posixSecondsToUTCTime <$> o .: "time") @@ -380,6 +471,8 @@ data PmInitiateEvent = PmInitiateEvent , pmInitiatePmId :: Snowflake } deriving (Show) +makeLensesL ''PmInitiateEvent + instance FromJSON PmInitiateEvent where parseJSON = fromPacket "pm-initiate-event" $ \o -> PmInitiateEvent <$> o .: "from" @@ -394,6 +487,8 @@ newtype SendEvent = SendEvent { sendMessage :: Message } deriving (Show) +makeLensesL ''SendEvent + instance FromJSON SendEvent where parseJSON = fromPacket "send-event" $ \o -> SendEvent <$> parseJSON (Object o) @@ -412,6 +507,8 @@ data SnapshotEvent = SnapshotEvent , snapshotPmWithUserId :: Maybe UserId } deriving (Show) +makeLensesL ''SnapshotEvent + instance FromJSON SnapshotEvent where parseJSON = fromPacket "snapshot-event" $ \o -> SnapshotEvent <$> o .: "identity" diff --git a/src/Haboli/Euphoria/Lens.hs b/src/Haboli/Euphoria/Lens.hs new file mode 100644 index 0000000..7116784 --- /dev/null +++ b/src/Haboli/Euphoria/Lens.hs @@ -0,0 +1,13 @@ +module Haboli.Euphoria.Lens + ( makeLensesL + ) where + +import Language.Haskell.TH +import Lens.Micro.TH +import Lens.Micro + +rename :: Name -> [Name] -> Name -> [DefName] +rename _ _ name = [TopName $ mkName $ nameBase name ++ "L"] + +makeLensesL :: Name -> DecsQ +makeLensesL = makeLensesWith $ lensRules & lensField .~ rename From 822bb9efadae6949e89f49bd5a0ab7c0de514e8e Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 10:40:24 +0000 Subject: [PATCH 20/23] Add lenses to listing and use them in the example bot --- src/Haboli/Euphoria/ExampleBot.hs | 37 +++++++++------- src/Haboli/Euphoria/Listing.hs | 74 ++++++++++++++++++++----------- 2 files changed, 70 insertions(+), 41 deletions(-) diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index 9012eab..f4059d8 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -1,7 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains an example implementation of a small bot. It is a good -- starting point if you want to create your own bot. +-- +-- The example bot uses lenses for its state because they vastly reduce the +-- amount of code required to update the 'Listing' inside the state. It is +-- entirely possible to use haboli without lenses though, should you want to do +-- that. module Haboli.Euphoria.ExampleBot ( exampleBot @@ -14,15 +20,19 @@ import Data.List import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Time +import Lens.Micro +import Lens.Micro.TH import Haboli.Euphoria import Haboli.Euphoria.Botrulez data BotState = BotState - { botStartTime :: UTCTime - , botListing :: Listing + { _botStartTime :: UTCTime + , _botListing :: Listing } deriving (Show) +makeLenses ''BotState + -- | A small example bot. Takes a room password as its first argument. You can -- run this bot in [&test](https://euphoria.io/room/test) like this: -- @@ -33,27 +43,27 @@ exampleBot mPasswd = do initialEvents <- untilConnected $ respondingToBounce mPasswd $ respondingToPing nextEvent - listing <- preferNick "ExampleBot" $ newListing initialEvents - stateVar <- liftIO $ newMVar $ BotState startTime listing + let initialState = BotState startTime $ newListing initialEvents + stateVar <- liftIO $ newMVar initialState + preferNickVia botListing stateVar "ExampleBot" botMain stateVar botMain :: MVar BotState -> Client T.Text () botMain stateVar = forever $ do event <- respondingToCommands (getCommands stateVar) $ respondingToPing nextEvent - -- Update the listing - liftIO $ modifyMVar_ stateVar $ \state -> - pure state{botListing = updateFromEvent event $ botListing state} + updateFromEventVia botListing stateVar event getCommands :: MVar BotState -> Client e [Command T.Text] getCommands stateVar = do state <- liftIO $ readMVar stateVar - let name = svNick $ self $ botListing state + let name = state ^. botListing . lsSelfL . svNickL pure [ botrulezPingGeneral , botrulezPingSpecific name - , botrulezHelpSpecific name "I am an example bot for https://github.com/Garmelon/haboli/." - , botrulezUptimeSpecific name $ botStartTime state + , botrulezHelpSpecific name + "I am an example bot for https://github.com/Garmelon/haboli/." + , botrulezUptimeSpecific name $ state ^. botStartTime , botrulezKillSpecific name , cmdSpecific "hug" name $ \msg -> void $ reply msg "/me hugs back" , cmdHello @@ -68,15 +78,12 @@ cmdHello = cmdGeneral "hello" $ \msg -> do cmdNick :: MVar BotState -> T.Text -> Command e cmdNick stateVar name = cmdSpecificArgs "nick" name $ \msg args -> do - -- Update the listing while updating the nick - state <- liftIO $ takeMVar stateVar - listing' <- preferNick args $ botListing state - liftIO $ putMVar stateVar state{botListing = listing'} + preferNickVia botListing stateVar args void $ reply msg "Is this better?" cmdWho :: MVar BotState -> Command e cmdWho stateVar = cmdGeneral "who" $ \msg -> do state <- liftIO $ readMVar stateVar - let people = others $ botListing state + let people = state ^. botListing . lsOthersL nicks = sort $ map svNick $ Map.elems people void $ reply msg $ T.intercalate "\n" nicks diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs index 4f65218..a9e6d7e 100644 --- a/src/Haboli/Euphoria/Listing.hs +++ b/src/Haboli/Euphoria/Listing.hs @@ -1,34 +1,49 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} -- | A 'Listing' helps keep track of a bot's own 'SessionView' as well as all -- other clients connected to a room. It must be kept up-to-date manually. module Haboli.Euphoria.Listing - ( Listing + ( Listing(..) + , lsSelfL + , lsOthersL , newListing - , self - , others , updateOwnNick , preferNick + , preferNickVia , updateFromList + , updateFromListVia , updateFromEvent + , updateFromEventVia ) where +import Control.Concurrent +import Control.Monad.IO.Class import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T +import Lens.Micro import Haboli.Euphoria.Api import Haboli.Euphoria.Client +import Haboli.Euphoria.Lens --- | A listing contains a bot's own 'SessionView' (accessible via 'self') and a +-- | A listing contains a bot's own 'SessionView' (accessible via 'lsSelf') and a -- map of all other clients currently connected to the room (accessible via --- 'others'). The latter never includes the bot itself. +-- 'lsOthers'). The latter never includes the bot itself. data Listing = Listing { lsSelf :: SessionView + -- ^ The 'SessionView' describing the bot itself. , lsOthers :: Map.Map UserId SessionView + -- ^ The 'SessionView's describing the other clients connected to the current + -- room. Does not include the bot's own 'SessionView' (use 'lsSelf' to access + -- that). } deriving (Show) +makeLensesL ''Listing + othersFromList :: [SessionView] -> Map.Map UserId SessionView othersFromList sessions = Map.fromList [(svId sv, sv) | sv <- sessions] @@ -39,29 +54,28 @@ newListing (h, s) = Listing , lsOthers = othersFromList $ snapshotListing s } --- | The 'SessionView' describing the bot itself. -self :: Listing -> SessionView -self = lsSelf - --- | The 'SessionView's describing the other clients connected to the current --- room. Does not include the bot's own 'SessionView' (use 'self' to access --- that). -others :: Listing -> Map.Map UserId SessionView -others = lsOthers - -- | Set the bot's own nick to a new nick. updateOwnNick :: T.Text -> Listing -> Listing -updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}} +updateOwnNick name = lsSelfL . svNickL .~ name -- | Set the bot's nick and update the 'Listing' with the server's reply in one -- go. preferNick :: T.Text -> Listing -> Client e Listing preferNick name listing - | name == svNick (self listing) = pure listing + | name == listing ^. lsSelfL . svNickL = pure listing | otherwise = do (_, newNick) <- nick name pure $ updateOwnNick newNick listing +-- | Like 'preferNick', but updates a 'Listing' inside a data type inside an +-- 'MVar'. +preferNickVia :: Lens' a Listing -> MVar a -> T.Text -> Client e () +preferNickVia field mvar name = do + a <- liftIO $ takeMVar mvar + listing' <- preferNick name $ a ^. field + let a' = a & field .~ listing' + liftIO $ putMVar mvar a' + -- | Update a 'Listing' from a list of sessions currently connected to the room. -- Afterwards, the 'Listing' will contain only those sessions present in the -- list. @@ -73,22 +87,30 @@ updateFromList sessions listing = newOthers = Map.filterWithKey (\k _ -> k /= ownId) others' in Listing newSelf newOthers -onJoin :: SessionView -> Listing -> Listing -onJoin sv listing = listing{lsOthers = Map.insert (svId sv) sv $ lsOthers listing} - -onPart :: SessionView -> Listing -> Listing -onPart sv listing = listing{lsOthers = Map.delete (svId sv) $ lsOthers listing} +-- | Like 'updateFromList', but updates a 'Listing' inside a data type inside an +-- 'MVar'. +updateFromListVia :: Lens' a Listing -> MVar a -> [SessionView] -> Client e () +updateFromListVia field mvar list = + liftIO $ modifyMVar_ mvar $ pure . (field %~ updateFromList list) -- | Update a 'Listing' based on an 'Event'. Follows the euphoria documentation -- for 'JoinEvent', 'PartEvent' and 'NetworkEvent'. updateFromEvent :: Event -> Listing -> Listing -updateFromEvent (EventJoin e) listing = onJoin (joinSession e) listing -updateFromEvent (EventPart e) listing = onPart (partSession e) listing +updateFromEvent (EventJoin e) listing = + let sv = joinSession e + in listing & lsOthersL %~ Map.insert (svId sv) sv +updateFromEvent (EventPart e) listing = + let sv = partSession e + in listing & lsOthersL %~ Map.delete (svId sv) updateFromEvent (EventNetwork e) listing | networkType e == "partition" = let sId = networkServerId e sEra = networkServerEra e isAffected sv = svServerId sv == sId && svServerEra sv == sEra - others' = Map.filter (not . isAffected) $ lsOthers listing - in listing{lsOthers = others'} + in listing & lsOthersL %~ Map.filter (not . isAffected) updateFromEvent _ listing = listing +-- | Like 'updateFromEvent', but updates a 'Listing' inside a data type inside +-- an 'MVar'. +updateFromEventVia :: Lens' a Listing -> MVar a -> Event -> Client e () +updateFromEventVia field mvar event = + liftIO $ modifyMVar_ mvar $ pure . (field %~ updateFromEvent event) From 1313d220565a8840e5aa2b686531a82951b4fba9 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 18:54:41 +0000 Subject: [PATCH 21/23] Export parsers for simple commands --- src/Haboli/Euphoria/Command/Simple.hs | 54 ++++++++++++++++++++------- 1 file changed, 40 insertions(+), 14 deletions(-) diff --git a/src/Haboli/Euphoria/Command/Simple.hs b/src/Haboli/Euphoria/Command/Simple.hs index 13ef6c2..49c8e5e 100644 --- a/src/Haboli/Euphoria/Command/Simple.hs +++ b/src/Haboli/Euphoria/Command/Simple.hs @@ -15,6 +15,14 @@ module Haboli.Euphoria.Command.Simple , cmdSpecific' , cmdSpecificArgs , cmdSpecificArgs' + -- * Parsers for convenience + , pAnyCmd + , pCmd + , pAnyNick + , pNick + , pUntilEof + , pCmdGeneral + , pCmdSpecific ) where import Control.Monad @@ -29,27 +37,45 @@ import Haboli.Euphoria.Command import Haboli.Euphoria.Command.Megaparsec import Haboli.Euphoria.Util -type Parser = Parsec () T.Text +-- | Parse any command of the form @!\@. +pAnyCmd :: (Ord e) => Parsec e T.Text T.Text +pAnyCmd = label "command" $ char '!' *> takeWhileP Nothing (not . isSpace) -pCmd :: T.Text -> Parser () -pCmd cmd = void $ label "command" $ char '!' *> string cmd +-- | @'pCmd' a@ parses commands of the form @!\@ where @cmd@ is equivalent +-- to @a@. +pCmd :: (Ord e) => T.Text -> Parsec e T.Text T.Text +pCmd cmd = do + cmd' <- pAnyCmd + guard $ cmd == cmd' + pure cmd' -pNick :: T.Text -> Parser () -pNick name = label "nick" $ do +-- | Parse any nick of the form @\@\@. +pAnyNick :: (Ord e) => Parsec e T.Text T.Text +pAnyNick = label "nick" $ do void $ char '@' - name' <- takeWhile1P Nothing (not . isSpace) - guard $ nickEqual name name' + takeWhile1P Nothing (not . isSpace) -pUntilEof :: Parser T.Text +-- | @'pNick' a@ parses nicks of the form @\@\@ where @name@ is +-- equivalent (but not necessarily equal) to @a@. +pNick :: (Ord e) => T.Text -> Parsec e T.Text T.Text +pNick name = do + name' <- pAnyNick + guard $ nickEqual name name' + pure name' + +-- | Consume the rest of the input. This parser should never fail. +pUntilEof :: (Ord e) => Parsec e T.Text T.Text pUntilEof = takeWhileP Nothing (const True) -pCmdGeneral :: T.Text -> Parser T.Text +-- | @'pCmdGeneral' cmd@ parses a general command of the form @!\@. +pCmdGeneral :: (Ord e) => T.Text -> Parsec e T.Text T.Text pCmdGeneral cmd = pCmd cmd *> space *> pUntilEof -pCmdSpecific :: T.Text -> T.Text -> Parser T.Text +-- | @'pCmdSpecific' cmd name@ parses a specific command of the form @!\ \@\@. +pCmdSpecific :: (Ord e) => T.Text -> T.Text -> Parsec e T.Text T.Text pCmdSpecific cmd name = pCmd cmd *> space1 *> pNick name *> space *> pUntilEof --- | @'cmdGeneral' cmd f' is a general command with no arguments in the form of +-- | @'cmdGeneral' cmd f@ is a general command with no arguments in the form of -- @!cmd@. cmdGeneral :: T.Text -> (Message -> Client e ()) -> Command e cmdGeneral cmd f = cmdGeneral' cmd $ \msg -> True <$ f msg @@ -61,7 +87,7 @@ cmdGeneral' cmd f = cmdGeneralArgs' cmd $ \msg args -> if T.null args then f msg else pure False --- | @'cmdGeneralArgs' cmd f' is a general command with arguments in the form of +-- | @'cmdGeneralArgs' cmd f@ is a general command with arguments in the form of -- @!cmd args@. @f@ is called with the source message and the arguments as -- 'T.Text'. cmdGeneralArgs :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e @@ -70,7 +96,7 @@ cmdGeneralArgs cmd f = cmdGeneralArgs' cmd $ \msg args -> True <$ f msg args -- | A version of 'cmdGeneralArgs' that allows the command function to decide -- whether the command was successful or not. cmdGeneralArgs' :: T.Text -> (Message -> T.Text -> Client e Bool) -> Command e -cmdGeneralArgs' cmd = cmdMega' $ pCmdGeneral cmd +cmdGeneralArgs' cmd = cmdMega' (pCmdGeneral cmd :: Parsec () T.Text T.Text) -- | @'cmdSpecific' cmd nick f@ is a specific command with no arguments in the -- form of @!cmd \@nick@. @@ -93,4 +119,4 @@ cmdSpecificArgs cmd name f = cmdSpecificArgs' cmd name $ \msg args -> True <$ f -- | A version of 'cmdSpecificArgs' that allows the command function to decide -- whether the command was successful or not. cmdSpecificArgs' :: T.Text -> T.Text -> (Message -> T.Text -> Client e Bool) -> Command e -cmdSpecificArgs' cmd name = cmdMega' $ pCmdSpecific cmd name +cmdSpecificArgs' cmd name = cmdMega' (pCmdSpecific cmd name :: Parsec () T.Text T.Text) From 46dc9242cf643b59a3f9f3b2cad3dfd538f44898 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 19:15:39 +0000 Subject: [PATCH 22/23] Simplify command system --- src/Haboli/Euphoria/Command.hs | 44 +++++++++++++++++++------------ src/Haboli/Euphoria/ExampleBot.hs | 8 +++--- 2 files changed, 31 insertions(+), 21 deletions(-) diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs index fcea112..1c22893 100644 --- a/src/Haboli/Euphoria/Command.hs +++ b/src/Haboli/Euphoria/Command.hs @@ -2,8 +2,9 @@ module Haboli.Euphoria.Command ( Command - , runCommands - , respondingToCommands + , cmdSequential + , cmdParallel + , respondingToCommand ) where import Control.Monad @@ -15,32 +16,41 @@ import Haboli.Euphoria.Client -- it should return 'True'. Otherwise. it should return 'False'. type Command e = Message -> Client e Bool --- | Apply multiple 'Command's to a 'Message' in order until one returns 'True'. --- All commands following that one are not applied. -runCommands :: [Command e] -> Message -> Client e Bool -runCommands [] _ = pure False -runCommands (c:cs) msg = do +-- | Try out multiple 'Command's in order until one returns 'True'. All commands +-- following that one are not applied. Returns 'True' if any of the commands +-- returned 'True'. Returns 'False' otherwise. +cmdSequential :: [Command e] -> Command e +cmdSequential [] _ = pure False +cmdSequential (c:cs) msg = do abort <- c msg if abort then pure True - else runCommands cs msg + else cmdSequential cs msg --- | @'respondingToCommands' getCommands getEvent@ runs a list of 'Command's on --- all 'EventSend's. It passes through all events unmodified. +-- | Apply multiple 'Command's in order. Each command will be applied. Returns +-- 'True' if at least one of the commands returned 'True'. Returns 'False' +-- otherwise. +cmdParallel :: [Command e] -> Command e +cmdParallel commands msg = do + results <- traverse ($msg) commands + pure $ or results + +-- | @'respondingToCommand' getCommand getEvent@ runs a 'Command' on all +-- 'EventSend's. It passes through all events unmodified. -- --- The @getEvent@ action is used to obtain the next 'Event'. The @getCommands@ --- action is used to obtain the currently available commands. @getCommands@ is +-- The @getEvent@ action is used to obtain the next 'Event'. The @getCommand@ +-- action is used to obtain the currently available command. @getCommand@ is -- called directly after a new 'Event' becomes available through @getEvent@. -- -- This utility function is meant to be wrapped directly or indirectly around -- 'nextEvent': -- --- > event <- respondingToCommands commands nextEvent -respondingToCommands :: Client e [Command e] -> Client e Event -> Client e Event -respondingToCommands getCommands getEvent = do +-- > event <- respondingToCommand command nextEvent +respondingToCommand :: Client e (Command e) -> Client e Event -> Client e Event +respondingToCommand getCommand getEvent = do event <- getEvent - commands <- getCommands + command <- getCommand case event of - EventSend e -> void $ runCommands commands $ sendMessage e + EventSend e -> void $ command $ sendMessage e _ -> pure () pure event diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index f4059d8..5c25d2e 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -50,15 +50,15 @@ exampleBot mPasswd = do botMain :: MVar BotState -> Client T.Text () botMain stateVar = forever $ do - event <- respondingToCommands (getCommands stateVar) $ + event <- respondingToCommand (getCommand stateVar) $ respondingToPing nextEvent updateFromEventVia botListing stateVar event -getCommands :: MVar BotState -> Client e [Command T.Text] -getCommands stateVar = do +getCommand :: MVar BotState -> Client e (Command T.Text) +getCommand stateVar = do state <- liftIO $ readMVar stateVar let name = state ^. botListing . lsSelfL . svNickL - pure + pure $ cmdSequential [ botrulezPingGeneral , botrulezPingSpecific name , botrulezHelpSpecific name From a1cae8be03afa4f3a22aa6b0a4cec774b9a17262 Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 21:15:35 +0000 Subject: [PATCH 23/23] Add more detail to readme --- CHANGELOG.md | 1 + README.md | 28 ++++++++++++++++++++++++++-- haboli.cabal | 6 ++++-- package.yaml | 3 +++ src/Haboli/Euphoria.hs | 4 ++-- 5 files changed, 36 insertions(+), 6 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index ac9e2cf..c934c84 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -10,6 +10,7 @@ - clean up project - fix nick of example bot in readme - remove `Haboli.Euphoria.Examples` module +- update `README.md` to reflect these changes ## 0.3.1.0 - add `Haboli.Euphoria` module diff --git a/README.md b/README.md index cbe340e..8758763 100644 --- a/README.md +++ b/README.md @@ -21,9 +21,25 @@ supports all session and chat room commands listed in the For more information, see the haddock for the `Haboli.Euphoria.Client` and `Haboli.Euphoria.Api` modules. -## Example bot +## Bots -Here is a very basic example bot that replies to `!ping` with `Pong!`: +The library is built with flexibility and composability in mind. Because of +this, there is no special `Bot` monad — bots also run inside the `Client` monad. +However, there are a few convenience modules that make development of bots +easier. + +The convenience modules are built on top of the `Client` monad. None of the +convenience modules are necessary to create a functioning bot. When creating a +new bot, you can freely choose which modules to use and which to ignore or +replace with your own creations. + +For an example bot structure using the convenience modules, here is an +[example bot](src/Haboli/Euphoria/ExampleBot.hs). + +## Example client + +Here is a very basic example bot that replies to `!ping` with `Pong!`. It does +not use any of the provided convenience modules. ```haskell pingPongBot :: Client () () @@ -44,3 +60,11 @@ And here's how to run that bot: main :: IO () main = void $ runClient defaultConfig pingPongBot ``` + +## Lenses + +Haboli exports lenses for a few data types. The lenses are named like the record +accessors but suffixed with a `L`. For example, the lens corresponding to +`svNick` from `SessionView` is named `svNickL`. Lenses are not required to use +the libary. They are provided for the convenience of those who like using +lenses. diff --git a/haboli.cabal b/haboli.cabal index 4a27c41..6fca2d4 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -1,10 +1,10 @@ -cabal-version: 1.12 +cabal-version: 1.18 -- This file has been generated from package.yaml by hpack version 0.31.2. -- -- see: https://github.com/sol/hpack -- --- hash: 35dc75bb1fd8534c4476115b165d0e969a579affaa05a419abe6f7e3ab749082 +-- hash: 3ce7165a468ff6ccd5e098638b16268df6af5b8dbd4f0ac2e5490a29f6f15a37 name: haboli version: 0.3.1.0 @@ -22,6 +22,8 @@ extra-source-files: README.md CHANGELOG.md LICENSE +extra-doc-files: + README.md source-repository head type: git diff --git a/package.yaml b/package.yaml index 1185334..8f1d9cb 100644 --- a/package.yaml +++ b/package.yaml @@ -13,6 +13,9 @@ extra-source-files: - CHANGELOG.md - LICENSE +extra-doc-files: + - README.md + dependencies: - base >= 4.7 && < 5 - aeson diff --git a/src/Haboli/Euphoria.hs b/src/Haboli/Euphoria.hs index aa3e32f..656bf09 100644 --- a/src/Haboli/Euphoria.hs +++ b/src/Haboli/Euphoria.hs @@ -1,6 +1,6 @@ -- | This module reexports the most commonly used modules for convenience. For --- more detail on how this library works, check the "Haboli.Euphoria.Client" --- module's documentation. +-- more detail on how this library works, check the or the +-- "Haboli.Euphoria.Client" module's documentation. module Haboli.Euphoria ( module Haboli.Euphoria.Api