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 e0e8944..c934c84 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,17 +1,30 @@ # Changelog for haboli - -**Table of Contents** +## 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`) +- clean up project +- fix nick of example bot in readme +- remove `Haboli.Euphoria.Examples` module +- update `README.md` to reflect these changes -- [Changelog for haboli](#changelog-for-haboli) - - [0.2.0.0](#0200) - - [0.1.0.0](#0100) +## 0.3.1.0 +- 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 ## 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/README.md b/README.md index dd2c295..8758763 100644 --- a/README.md +++ b/README.md @@ -1 +1,70 @@ # haboli + +Haboli is a haskell library providing API bindings for +[the euphoria api](https://api.euphoria.io/). It can be used to create bots and +otherwise interact with the euphoria servers. + +## Basic concept + +This library is based around the custom `Client` monad. It is based on `IO` and +represents computations that happen while a connection to an euphoria server is +open. Once a `Client` finishes executing, the connection is automatically +closed. If the connection closes unexpectedly while the corresponding `Client` +is still running, it is notified and commands like `send` or `nick` will result +in an exception. The `Client` does not automatically reconnect. + +The `Client` monad supports exceptions via the `throw`, `catch` and `handle` +operations, as well as multiple threads via the `fork` and `wait` operations. It +supports all session and chat room commands listed in the +[api reference](https://api.euphoria.io/). + +For more information, see the haddock for the `Haboli.Euphoria.Client` and +`Haboli.Euphoria.Api` modules. + +## Bots + +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 () () +pingPongBot = forever $ do + event <- respondingToPing nextEvent + case event of + EventSnapshot _ -> void $ nick "PingPongBot" + EventSend e -> + let msg = sendMessage e + in when (msgContent msg == "!ping") $ + void $ reply msg "Pong!" + _ -> pure () +``` + +And here's how to run that bot: + +```haskell +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/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/app/Main.hs b/app/Main.hs deleted file mode 100644 index 683a8de..0000000 --- a/app/Main.hs +++ /dev/null @@ -1,4 +0,0 @@ -module Main where - -main :: IO () -main = putStrLn "Nothing to see here" diff --git a/haboli.cabal b/haboli.cabal new file mode 100644 index 0000000..6fca2d4 --- /dev/null +++ b/haboli.cabal @@ -0,0 +1,65 @@ +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: 3ce7165a468ff6ccd5e098638b16268df6af5b8dbd4f0ac2e5490a29f6f15a37 + +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 +extra-doc-files: + README.md + +source-repository head + type: git + location: https://github.com/Garmelon/haboli + +library + exposed-modules: + Haboli.Euphoria + Haboli.Euphoria.Api + Haboli.Euphoria.Botrulez + Haboli.Euphoria.Client + Haboli.Euphoria.Command + Haboli.Euphoria.Command.Megaparsec + Haboli.Euphoria.Command.Simple + Haboli.Euphoria.ExampleBot + Haboli.Euphoria.Lens + Haboli.Euphoria.Listing + Haboli.Euphoria.Util + other-modules: + Paths_haboli + hs-source-dirs: + src + build-depends: + aeson + , base >=4.7 && <5 + , containers + , megaparsec + , microlens + , microlens-th + , network + , stm + , template-haskell + , text + , time + , transformers + , unordered-containers + , websockets + , wuss + default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 1c3ad5e..8f1d9cb 100644 --- a/package.yaml +++ b/package.yaml @@ -1,57 +1,37 @@ -name: haboli -version: 0.2.0.0 -github: "Garmelon/haboli" -license: MIT -author: "Garmelon" -maintainer: "joscha@plugh.de" -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 extra-source-files: -- README.md + - README.md + - CHANGELOG.md + - LICENSE -# Metadata used when publishing your package -# synopsis: Short description of your package -# category: Web - -# To avoid duplicated efforts in documentation and dealing with the -# complications of embedding Haddock markup inside cabal files, it is -# common to point users to the README.md file. -description: Please see the README on GitHub at +extra-doc-files: + - README.md dependencies: -- base >= 4.7 && < 5 -- aeson -- containers -- network -- stm -- text -- time -- transformers -- unordered-containers -- websockets -- wuss + - base >= 4.7 && < 5 + - aeson + - containers + - megaparsec + - microlens + - microlens-th + - network + - stm + - template-haskell + - text + - time + - transformers + - unordered-containers + - websockets + - wuss library: source-dirs: src - -executables: - haboli-exe: - main: Main.hs - source-dirs: app - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - haboli - -tests: - haboli-test: - main: Spec.hs - source-dirs: test - ghc-options: - - -threaded - - -rtsopts - - -with-rtsopts=-N - dependencies: - - haboli diff --git a/src/Haboli/Euphoria.hs b/src/Haboli/Euphoria.hs new file mode 100644 index 0000000..656bf09 --- /dev/null +++ b/src/Haboli/Euphoria.hs @@ -0,0 +1,19 @@ +-- | This module reexports the most commonly used modules for convenience. For +-- more detail on how this library works, check the or the +-- "Haboli.Euphoria.Client" module's documentation. + +module Haboli.Euphoria + ( 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/Api.hs b/src/Haboli/Euphoria/Api.hs index 941adde..fb528bf 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -1,44 +1,107 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} + +-- | This module attempts to map the structure of the ephoria API to types. 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(..) @@ -75,6 +138,10 @@ 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 toJSONObject :: a -> Object @@ -94,8 +161,9 @@ toPacket packetType packetData = HMap.fromList {- Basic types -} +-- | A method of authenticating. data AuthOption = Passcode - deriving (Show) + deriving (Show, Eq) instance ToJSON AuthOption where toJSON Passcode = String "passcode" @@ -105,76 +173,9 @@ 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 - -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 . +-- integer. See . type Snowflake = T.Text -- | The type of session a client may have. @@ -189,15 +190,17 @@ 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 --- . +-- . data UserId = UserId { userType :: UserType , userSnowflake :: Snowflake - } deriving (Show, Eq) + } deriving (Show, Eq, Ord) + +makeLensesL ''UserId instance ToJSON UserId where toJSON uid = @@ -216,32 +219,114 @@ 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 -} +-- | See . data BounceEvent = BounceEvent { bounceReason :: Maybe T.Text , bounceAuthOption :: [AuthOption] } deriving (Show) +makeLensesL ''BounceEvent + instance FromJSON BounceEvent where parseJSON = fromPacket "bounce-event" $ \o -> BounceEvent - <$> o .: "reason" - <*> o .: "auth_options" + <$> o .:? "reason" + <*> o .:? "auth_options" .!= [] {- disconnect-event -} +-- | See . newtype DisconnectEvent = DisconnectEvent { disconnectReason :: T.Text } deriving (Show) +makeLensesL ''DisconnectEvent + instance FromJSON DisconnectEvent where parseJSON = fromPacket "disconnect-evnet" $ \o -> DisconnectEvent <$> o .: "reason" {- hello-event -} +-- | See . data HelloEvent = HelloEvent { helloAccount :: Maybe PersonalAccountView , helloSessionView :: SessionView @@ -251,9 +336,11 @@ data HelloEvent = HelloEvent , helloVersion :: T.Text } deriving (Show) +makeLensesL ''HelloEvent + instance FromJSON HelloEvent where parseJSON = fromPacket "hello-event" $ \o -> HelloEvent - <$> o .: "account" + <$> o .:? "account" <*> o .: "session" <*> o .:? "account_has_access" <*> o .:? "account_email_verified" @@ -262,26 +349,33 @@ instance FromJSON HelloEvent where {- join-event -} +-- | See . newtype JoinEvent = JoinEvent { joinSession :: SessionView } deriving (Show) +makeLensesL ''JoinEvent + instance FromJSON JoinEvent where parseJSON = fromPacket "join-event" $ \o -> JoinEvent <$> parseJSON (Object o) {- login-event -} +-- | See . newtype LoginEvent = LoginEvent { loginAccountId :: Snowflake } deriving (Show) +makeLensesL ''LoginEvent + instance FromJSON LoginEvent where parseJSON = fromPacket "login-event" $ \o -> LoginEvent <$> o .: "acount_id" {- logout-event -} +-- | See . data LogoutEvent = LogoutEvent deriving (Show) @@ -290,12 +384,15 @@ instance FromJSON LogoutEvent where {- network-event -} +-- | See . data NetworkEvent = NetworkEvent { networkType :: T.Text -- always "partition" , networkServerId :: T.Text , networkServerEra :: T.Text } deriving (Show) +makeLensesL ''NetworkEvent + instance FromJSON NetworkEvent where parseJSON = fromPacket "network-event" $ \o -> NetworkEvent <$> o .: "type" @@ -304,6 +401,7 @@ instance FromJSON NetworkEvent where {- nick-event -} +-- | See . data NickEvent = NickEvent { nickSessionId :: T.Text , nickId :: UserId @@ -311,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" @@ -320,11 +420,14 @@ instance FromJSON NickEvent where {- edit-message-event -} +-- | See . data EditMessageEvent = EditMessageEvent { editMessageMessage :: Message , editMessageEditId :: Snowflake } deriving (Show) +makeLensesL ''EditMessageEvent + instance FromJSON EditMessageEvent where parseJSON = fromPacket "EditMessageEvent" $ \o -> EditMessageEvent <$> parseJSON (Object o) @@ -332,21 +435,27 @@ instance FromJSON EditMessageEvent where {- part-event -} +-- | See . newtype PartEvent = PartEvent { partSession :: SessionView } deriving (Show) +makeLensesL ''PartEvent + instance FromJSON PartEvent where parseJSON = fromPacket "part-event" $ \o -> PartEvent <$> parseJSON (Object o) {- ping-event -} +-- | See . data PingEvent = PingEvent { pingTime :: UTCTime , pingNext :: UTCTime } deriving (Show) +makeLensesL ''PingEvent + instance FromJSON PingEvent where parseJSON = fromPacket "ping-event" $ \o -> PingEvent <$> (posixSecondsToUTCTime <$> o .: "time") @@ -354,6 +463,7 @@ instance FromJSON PingEvent where {- pm-initiate-event -} +-- | See . data PmInitiateEvent = PmInitiateEvent { pmInitiateFrom :: UserId , pmInitiateFromNick :: T.Text @@ -361,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" @@ -370,16 +482,20 @@ instance FromJSON PmInitiateEvent where {- send-event -} +-- | See . newtype SendEvent = SendEvent { sendMessage :: Message } deriving (Show) +makeLensesL ''SendEvent + instance FromJSON SendEvent where parseJSON = fromPacket "send-event" $ \o -> SendEvent <$> parseJSON (Object o) {- snapshot-event -} +-- | See . data SnapshotEvent = SnapshotEvent { snapshotIdentity :: UserId , snapshotSessionId :: T.Text @@ -391,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" @@ -406,6 +524,7 @@ instance FromJSON SnapshotEvent where {- auth -} +-- | See . newtype AuthCommand = AuthWithPasscode T.Text deriving (Show) @@ -415,6 +534,7 @@ instance ToJSONObject AuthCommand where , "passcode" .= password ] +-- | See . data AuthReply = AuthSuccessful | AuthFailed T.Text deriving (Show) @@ -429,6 +549,7 @@ instance FromJSON AuthReply where {- ping -} +-- | See . newtype PingCommand = PingCommand UTCTime deriving (Show) @@ -437,6 +558,7 @@ instance ToJSONObject PingCommand where [ "time" .= utcTimeToPOSIXSeconds time ] +-- | See . newtype PingReply = PingReply UTCTime deriving (Show) @@ -453,6 +575,7 @@ instance FromJSON PingReply where {- get-message -} +-- | See . newtype GetMessageCommand = GetMessageCommand Snowflake deriving (Show) @@ -461,6 +584,7 @@ instance ToJSONObject GetMessageCommand where [ "id" .= mId ] +-- | See . newtype GetMessageReply = GetMessageReply Message deriving (Show) @@ -470,6 +594,7 @@ instance FromJSON GetMessageReply where {- log -} +-- | See . data LogCommand = LogCommand Int (Maybe Snowflake) deriving (Show) @@ -482,6 +607,7 @@ instance ToJSONObject LogCommand where , "before" .= before ] +-- | See . data LogReply = LogReply [Message] (Maybe Snowflake) deriving (Show) @@ -492,6 +618,7 @@ instance FromJSON LogReply where {- nick -} +-- | See . newtype NickCommand = NickCommand T.Text deriving (Show) @@ -500,6 +627,7 @@ instance ToJSONObject NickCommand where [ "name" .= nick ] +-- | See . data NickReply = NickReply { nickReplySessionId :: T.Text , nickReplyId :: UserId @@ -516,6 +644,7 @@ instance FromJSON NickReply where {- pm-initiate -} +-- | See . newtype PmInitiateCommand = PmInitiateCommand UserId deriving (Show) @@ -524,6 +653,7 @@ instance ToJSONObject PmInitiateCommand where [ "user_id" .= userId ] +-- | See . data PmInitiateReply = PmInitiateReply Snowflake T.Text deriving (Show) @@ -534,6 +664,7 @@ instance FromJSON PmInitiateReply where {- send -} +-- | See . data SendCommand = SendCommand T.Text (Maybe Snowflake) deriving (Show) @@ -543,6 +674,7 @@ instance ToJSONObject SendCommand where toJSONObject (SendCommand content (Just parent)) = toPacket "send" $ object ["content" .= content, "parent" .= parent] +-- | See . newtype SendReply = SendReply Message deriving (Show) @@ -552,12 +684,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/Botrulez.hs b/src/Haboli/Euphoria/Botrulez.hs new file mode 100644 index 0000000..3f24d0d --- /dev/null +++ b/src/Haboli/Euphoria/Botrulez.hs @@ -0,0 +1,70 @@ +{-# 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 + , 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'@ 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 + let delta = diffUTCTime now since + void $ reply msg $ mconcat + [ "/me has been up since " + , formatUTCTime since + , " UTC (" + , formatNominalDiffTime delta + , ")" + ] + +-- | @'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" + throw $ "I was killed by " <> svNick (msgSender msg) diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index 4cc99c1..22b83c8 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -3,6 +3,18 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE RankNTypes #-} +-- | This library is based around the custom 'Client' monad. It is based on 'IO' +-- and represents computations that happen while a connection to an euphoria +-- server is open. Once a 'Client' finishes executing, the connection is +-- automatically closed. If the connection closes unexpectedly while the +-- corresponding 'Client' is still running, it is notified and commands like +-- 'send' or 'nick' will result in an exception. The 'Client' does not +-- automatically reconnect. +-- +-- The 'Client' monad supports exceptions via the 'throw', 'catch' and 'handle' +-- operations, as well as multiple threads via the 'fork' and 'wait' operations. +-- It supports all session and chat room commands listed in . + module Haboli.Euphoria.Client ( -- * The Client monad @@ -15,7 +27,6 @@ module Haboli.Euphoria.Client -- ** Event handling , Event(..) , nextEvent - , respondingToPing -- ** Exception handling , ClientException(..) , throw @@ -64,9 +75,9 @@ import qualified Wuss as WSS import Haboli.Euphoria.Api --- | This type represents a @'Reply' e r@ with arbitrary @r@ that has yet to be --- received. The @forall@ allows whoever creates the 'AwaitingReply' to decide --- on the type of @r@. +-- | This type represents a @Reply e r@ with arbitrary @r@ that has yet to be +-- received. The @forall@ allows whoever creates the AwaitingReply to decide on +-- the type of @r@. data AwaitingReply e = forall r. FromJSON r => AwaitingReply (TMVar (Reply e r)) @@ -121,8 +132,8 @@ closeConnectionOnInvalidMessage connection (WS.UnicodeException _) = closeConnectionOnInvalidMessage _ e = E.throwIO e -- | An exception handler that stops the client if any sort of --- 'WS.ConnectionException' occurs. It does this by setting 'ciStopped' to True --- and cancelling all 'AwaitingReply'-s in 'ciAwaiting'. +-- 'WS.ConnectionException' occurs. It does this by setting ciStopped to True +-- and cancelling all AwaitingReply-s in ciAwaiting. cancelAllReplies :: ClientInfo e -> WS.ConnectionException -> IO () cancelAllReplies info _ = atomically $ do writeTVar (ciStopped info) True @@ -172,33 +183,33 @@ runWebsocketThread info = parseAndSendReply value (ciAwaiting info) where connection = ciConnection info - pingInterval = cdPingInterval $ ciDetails info + pingInterval = confPingInterval $ ciDetails info {- Running the Client monad -} -- | Configuration for the websocket connection. The websocket connection always -- uses https. data ConnectionConfig = ConnectionConfig - { cdHost :: S.HostName - , cdPort :: S.PortNumber - , cdPath :: String - , cdPingInterval :: Int + { confHost :: S.HostName + , confPort :: S.PortNumber + , confPath :: String + , confPingInterval :: Int } deriving (Show) -- | A default configuration that points the bot to the room @&test@ at -- . defaultConfig :: ConnectionConfig defaultConfig = ConnectionConfig - { cdHost = "euphoria.io" - , cdPort = 443 - , cdPath = "/room/test/ws" - , cdPingInterval = 10 + { confHost = "euphoria.io" + , confPort = 443 + , confPath = "/room/test/ws" + , confPingInterval = 10 } --- | @'withRoom' roomname config@ modifies the 'cdPath' of @config@ to point to --- the room @roomname@. +-- | @'withRoom' roomname config@ modifies the 'confPath' of @config@ to point +-- to the room @roomname@. withRoom :: String -> ConnectionConfig -> ConnectionConfig -withRoom room config = config{cdPath = "/room/" ++ room ++ "/ws"} +withRoom room config = config{confPath = "/room/" ++ room ++ "/ws"} --TODO: Catch IO exceptions that occur when a connection could not be created -- | Execute a 'Client'. @@ -213,7 +224,7 @@ withRoom room config = config{cdPath = "/room/" ++ room ++ "/ws"} runClient :: ConnectionConfig -> Client e a -> IO (Either (ClientException e) a) runClient details (Client stack) = S.withSocketsDo $ - WSS.runSecureClient (cdHost details) (cdPort details) (cdPath details) $ \connection -> do + WSS.runSecureClient (confHost details) (confPort details) (confPath details) $ \connection -> do awaiting <- newTVarIO Map.empty eventChan <- newTChanIO packetId <- newTVarIO 0 @@ -268,12 +279,20 @@ data Event | EventSnapshot SnapshotEvent deriving (Show) ---TODO: Add all the events instance FromJSON Event where parseJSON v = foldr (<|>) mempty - [ EventJoin <$> parseJSON v + [ EventBounce <$> parseJSON v + , EventDisconnect <$> parseJSON v + , EventHello <$> parseJSON v + , EventJoin <$> parseJSON v + , EventLogin <$> parseJSON v + , EventLogout <$> parseJSON v + , EventNetwork <$> parseJSON v + , EventNick <$> parseJSON v + , EventEditMessage <$> parseJSON v , EventPart <$> parseJSON v , EventPing <$> parseJSON v + , EventPmInitiate <$> parseJSON v , EventSend <$> parseJSON v , EventSnapshot <$> parseJSON v ] @@ -296,18 +315,6 @@ nextEvent = do Left e -> throwRaw e Right e -> pure e --- | Respond to 'EventPing's according to the documentation (see --- ). This function is meant to be wrapped --- directly 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/Command.hs b/src/Haboli/Euphoria/Command.hs new file mode 100644 index 0000000..1c22893 --- /dev/null +++ b/src/Haboli/Euphoria/Command.hs @@ -0,0 +1,56 @@ +-- | This module provides an abstraction for bot commands. + +module Haboli.Euphoria.Command + ( Command + , cmdSequential + , cmdParallel + , respondingToCommand + ) where + +import Control.Monad + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client + +-- | 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 + +-- | 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 cmdSequential cs msg + +-- | 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 @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 <- respondingToCommand command nextEvent +respondingToCommand :: Client e (Command e) -> Client e Event -> Client e Event +respondingToCommand getCommand getEvent = do + event <- getEvent + command <- getCommand + case event of + EventSend e -> void $ command $ sendMessage e + _ -> pure () + pure event diff --git a/src/Haboli/Euphoria/Command/Megaparsec.hs b/src/Haboli/Euphoria/Command/Megaparsec.hs new file mode 100644 index 0000000..98bf252 --- /dev/null +++ b/src/Haboli/Euphoria/Command/Megaparsec.hs @@ -0,0 +1,26 @@ +-- | Bot commands based on the megaparsec library. + +module Haboli.Euphoria.Command.Megaparsec + ( cmdMega + , cmdMega' + ) where + +import qualified Data.Text as T +import Text.Megaparsec + +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 = 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 -> 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..49c8e5e --- /dev/null +++ b/src/Haboli/Euphoria/Command/Simple.hs @@ -0,0 +1,122 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | General and specific commands as described in the +-- [botrulez](https://github.com/jedevc/botrulez). + +module Haboli.Euphoria.Command.Simple + ( + -- * General commands + cmdGeneral + , cmdGeneral' + , cmdGeneralArgs + , cmdGeneralArgs' + -- * Specific commands + , cmdSpecific + , cmdSpecific' + , cmdSpecificArgs + , cmdSpecificArgs' + -- * Parsers for convenience + , pAnyCmd + , pCmd + , pAnyNick + , pNick + , pUntilEof + , pCmdGeneral + , pCmdSpecific + ) 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 + +-- | Parse any command of the form @!\@. +pAnyCmd :: (Ord e) => Parsec e T.Text T.Text +pAnyCmd = label "command" $ char '!' *> takeWhileP Nothing (not . isSpace) + +-- | @'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' + +-- | Parse any nick of the form @\@\@. +pAnyNick :: (Ord e) => Parsec e T.Text T.Text +pAnyNick = label "nick" $ do + void $ char '@' + takeWhile1P Nothing (not . isSpace) + +-- | @'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' 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' 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 +-- @!cmd@. +cmdGeneral :: T.Text -> (Message -> Client e ()) -> Command e +cmdGeneral cmd f = cmdGeneral' cmd $ \msg -> True <$ f msg + +-- | 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 :: Parsec () T.Text T.Text) + +-- | @'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 = cmdSpecific' cmd name $ \msg -> True <$ f msg + +-- | 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 :: Parsec () T.Text T.Text) diff --git a/src/Haboli/Euphoria/Example.hs b/src/Haboli/Euphoria/Example.hs deleted file mode 100644 index b0de6b2..0000000 --- a/src/Haboli/Euphoria/Example.hs +++ /dev/null @@ -1,75 +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.Api -import Haboli.Euphoria.Client - -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 () diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs new file mode 100644 index 0000000..5c25d2e --- /dev/null +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -0,0 +1,89 @@ +{-# 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 + ) where + +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 +import Lens.Micro +import Lens.Micro.TH + +import Haboli.Euphoria +import Haboli.Euphoria.Botrulez + +data BotState = BotState + { _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: +-- +-- > runClient defaultConfig $ exampleBot Nothing +exampleBot :: Maybe T.Text -> Client T.Text () +exampleBot mPasswd = do + startTime <- liftIO getCurrentTime + initialEvents <- untilConnected $ + respondingToBounce mPasswd $ + respondingToPing nextEvent + 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 <- respondingToCommand (getCommand stateVar) $ + respondingToPing nextEvent + updateFromEventVia botListing stateVar event + +getCommand :: MVar BotState -> Client e (Command T.Text) +getCommand stateVar = do + state <- liftIO $ readMVar stateVar + let name = state ^. botListing . lsSelfL . svNickL + pure $ cmdSequential + [ botrulezPingGeneral + , botrulezPingSpecific name + , 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 + , 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 + 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 = state ^. botListing . lsOthersL + nicks = sort $ map svNick $ Map.elems people + void $ reply msg $ T.intercalate "\n" nicks 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 diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs new file mode 100644 index 0000000..a9e6d7e --- /dev/null +++ b/src/Haboli/Euphoria/Listing.hs @@ -0,0 +1,116 @@ +{-# 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(..) + , lsSelfL + , lsOthersL + , newListing + , 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 'lsSelf') and a +-- map of all other clients currently connected to the room (accessible via +-- '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] + +-- | 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 + } + +-- | Set the bot's own nick to a new nick. +updateOwnNick :: T.Text -> Listing -> Listing +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 == 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. +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 + +-- | 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 = + 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 + 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) diff --git a/src/Haboli/Euphoria/Util.hs b/src/Haboli/Euphoria/Util.hs new file mode 100644 index 0000000..f49335f --- /dev/null +++ b/src/Haboli/Euphoria/Util.hs @@ -0,0 +1,154 @@ +{-# LANGUAGE MultiWayIf #-} +{-# LANGUAGE OverloadedStrings #-} + +-- | This module contains a few utility functions that don't deserve their own +-- modules. + +module Haboli.Euphoria.Util + ( + -- * Events + respondingToPing + , respondingToBounce + , respondingToBounce' + , untilConnected + , untilConnected' + -- * Nick + , nickMention + , nickNormalize + , nickEqual + -- * Time formatting + , formatUTCTime + , formatNominalDiffTime + ) 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 Data.Time + +import Haboli.Euphoria.Api +import Haboli.Euphoria.Client + +{- Events -} + +-- | 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 +-- '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 + +-- | 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 + 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 + +-- | 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 + 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 -} + +-- | 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 + | otherwise = name + where + 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" 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 diff --git a/test/Spec.hs b/test/Spec.hs deleted file mode 100644 index cd4753f..0000000 --- a/test/Spec.hs +++ /dev/null @@ -1,2 +0,0 @@ -main :: IO () -main = putStrLn "Test suite not yet implemented"