.gitignore

@@ -1,2 +1,3 @@
 .stack-work/
+haboli.cabal
 *~

CHANGELOG.md

@@ -1,30 +1,17 @@
 # Changelog for haboli
 
-## upcoming
+<!-- markdown-toc start - Don't edit this section. Run M-x markdown-toc-refresh-toc -->
-- add `Haboli.Euphoria.Botrulez` module
+**Table of Contents**
-- 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
 
-## 0.3.1.0
+- [Changelog for haboli](#changelog-for-haboli)
-- add `Haboli.Euphoria` module
+    - [0.2.0.0](#0200)
-- add proper README
+    - [0.1.0.0](#0100)
-- clean up package structure
-- update documentation
 
-## 0.3.0.0
+<!-- markdown-toc end -->
-- fix Client not receiving all kinds of server events
-- rename ConnectionConfig record accessors
 
 ## 0.2.0.0
-- add all session and chat room commands
+* add all session and chat room commands
-- modify `send` command so it also returns the old nick
+* modify `send` command so it also returns the old nick
 
 ## 0.1.0.0
-- create project
+* create project

README.md

@@ -1,70 +1 @@
 # 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.

Setup.hs

@@ -0,0 +1,2 @@
+import Distribution.Simple
+main = defaultMain

app/Main.hs

@@ -0,0 +1,4 @@
+module Main where
+
+main :: IO ()
+main = putStrLn "Nothing to see here"

haboli.cabal

@@ -1,65 +0,0 @@
-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 <https://github.com/Garmelon/haboli#readme>
-homepage:       https://github.com/Garmelon/haboli#readme
-bug-reports:    https://github.com/Garmelon/haboli/issues
-author:         Garmelon <joscha@plugh.de>
-maintainer:     Garmelon <joscha@plugh.de>
-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

package.yaml

@@ -1,37 +1,57 @@
 name:                haboli
-version: 0.3.1.0
+version:             0.2.0.0
+github:              "Garmelon/haboli"
 license:             MIT
-author: Garmelon <joscha@plugh.de>
+author:              "Garmelon"
-copyright: 2020 Garmelon
+maintainer:          "joscha@plugh.de"
-
+copyright:           "2020 Garmelon"
-synopsis: API bindings for https://euphoria.io/
-description: Please see the README on GitHub at <https://github.com/Garmelon/haboli#readme>
-github: Garmelon/haboli
 
 extra-source-files:
-  - README.md
+- README.md
-  - CHANGELOG.md
-  - LICENSE
 
-extra-doc-files:
+# Metadata used when publishing your package
-  - README.md
+# 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 <https://github.com/Garmelon/haboli#readme>
 
 dependencies:
-  - base >= 4.7 && < 5
+- base >= 4.7 && < 5
-  - aeson
+- aeson
-  - containers
+- containers
-  - megaparsec
+- network
-  - microlens
+- stm
-  - microlens-th
+- text
-  - network
+- time
-  - stm
+- transformers
-  - template-haskell
+- unordered-containers
-  - text
+- websockets
-  - time
+- wuss
-  - 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

src/Haboli/Euphoria.hs

@@ -1,19 +0,0 @@
--- | This module reexports the most commonly used modules for convenience. For
--- more detail on how this library works, check the <README.md> 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

src/Haboli/Euphoria/Api.hs

@@ -1,107 +1,44 @@
 {-# 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(..)
@@ -138,10 +75,6 @@ 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
 
@@ -161,9 +94,8 @@ toPacket packetType packetData = HMap.fromList
 
 {- Basic types -}
 
--- | A method of authenticating.
 data AuthOption = Passcode
-  deriving (Show, Eq)
+  deriving (Show)
 
 instance ToJSON AuthOption where
   toJSON Passcode = String "passcode"
@@ -173,9 +105,76 @@ 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
+-- <http://api.euphoria.io/#message>.
+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
+-- <http://api.euphoria.io/#sessionview>.
+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 <https://api.euphoria.io/#snowflake>.
+-- integer. See <http://api.euphoria.io/#snowflake>.
 type Snowflake = T.Text
 
 -- | The type of session a client may have.
@@ -190,17 +189,15 @@ 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, Ord)
+  deriving (Show, Eq)
 
 -- | A 'UserId' identifies a user. It consists of two parts: The type of
 -- session, and a unique value for that type of session. See
--- <https://api.euphoria.io/#userid>.
+-- <http://api.euphoria.io/#userid>.
 data UserId = UserId
   { userType      :: UserType
   , userSnowflake :: Snowflake
-  } deriving (Show, Eq, Ord)
+  } deriving (Show, Eq)
-
-makeLensesL ''UserId
 
 instance ToJSON UserId where
   toJSON uid =
@@ -219,114 +216,32 @@ 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
--- <https://api.euphoria.io/#sessionview>.
-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
--- <https://api.euphoria.io/#message>.
-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
--- <https://api.euphoria.io/#personalaccountview>.
-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 <https://api.euphoria.io/#bounce-event>.
 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 .: "reason"
-    <*> o .:? "auth_options" .!= []
+    <*> o .: "auth_options"
 
 {- disconnect-event -}
 
--- | See <https://api.euphoria.io/#disconnect-event>.
 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 <https://api.euphoria.io/#hello-event>.
 data HelloEvent = HelloEvent
   { helloAccount              :: Maybe PersonalAccountView
   , helloSessionView          :: SessionView
@@ -336,11 +251,9 @@ 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"
@@ -349,33 +262,26 @@ instance FromJSON HelloEvent where
 
 {- join-event -}
 
--- | See <https://api.euphoria.io/#join-event>.
 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 <https://api.euphoria.io/#login-event>.
 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 <https://api.euphoria.io/#logout-event>.
 data LogoutEvent = LogoutEvent
   deriving (Show)
 
@@ -384,15 +290,12 @@ instance FromJSON LogoutEvent where
 
 {- network-event -}
 
--- | See <https://api.euphoria.io/#network-event>.
 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"
@@ -401,7 +304,6 @@ instance FromJSON NetworkEvent where
 
 {- nick-event -}
 
--- | See <https://api.euphoria.io/#nick-event>.
 data NickEvent = NickEvent
   { nickSessionId :: T.Text
   , nickId        :: UserId
@@ -409,8 +311,6 @@ data NickEvent = NickEvent
   , nickTo        :: T.Text
   } deriving (Show)
 
-makeLensesL ''NickEvent
-
 instance FromJSON NickEvent where
   parseJSON = fromPacket "nick-event" $ \o -> NickEvent
     <$> o .: "session_id"
@@ -420,14 +320,11 @@ instance FromJSON NickEvent where
 
 {- edit-message-event -}
 
--- | See <https://api.euphoria.io/#edit-message-event>.
 data EditMessageEvent = EditMessageEvent
   { editMessageMessage :: Message
   , editMessageEditId  :: Snowflake
   } deriving (Show)
 
-makeLensesL ''EditMessageEvent
-
 instance FromJSON EditMessageEvent where
   parseJSON = fromPacket "EditMessageEvent" $ \o -> EditMessageEvent
     <$> parseJSON (Object o)
@@ -435,27 +332,21 @@ instance FromJSON EditMessageEvent where
 
 {- part-event -}
 
--- | See <https://api.euphoria.io/#part-event>.
 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 <https://api.euphoria.io/#ping-event>.
 data PingEvent = PingEvent
   { pingTime :: UTCTime
   , pingNext :: UTCTime
   } deriving (Show)
 
-makeLensesL ''PingEvent
-
 instance FromJSON PingEvent where
   parseJSON = fromPacket "ping-event" $ \o -> PingEvent
     <$> (posixSecondsToUTCTime <$> o .: "time")
@@ -463,7 +354,6 @@ instance FromJSON PingEvent where
 
 {- pm-initiate-event -}
 
--- | See <https://api.euphoria.io/#pm-initiate-event>.
 data PmInitiateEvent = PmInitiateEvent
   { pmInitiateFrom     :: UserId
   , pmInitiateFromNick :: T.Text
@@ -471,8 +361,6 @@ data PmInitiateEvent = PmInitiateEvent
   , pmInitiatePmId     :: Snowflake
   } deriving (Show)
 
-makeLensesL ''PmInitiateEvent
-
 instance FromJSON PmInitiateEvent where
   parseJSON = fromPacket "pm-initiate-event" $ \o -> PmInitiateEvent
     <$> o .: "from"
@@ -482,20 +370,16 @@ instance FromJSON PmInitiateEvent where
 
 {- send-event -}
 
--- | See <https://api.euphoria.io/#send-event>.
 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 <https://api.euphoria.io/#snapshot-event>.
 data SnapshotEvent = SnapshotEvent
   { snapshotIdentity     :: UserId
   , snapshotSessionId    :: T.Text
@@ -507,8 +391,6 @@ data SnapshotEvent = SnapshotEvent
   , snapshotPmWithUserId :: Maybe UserId
   } deriving (Show)
 
-makeLensesL ''SnapshotEvent
-
 instance FromJSON SnapshotEvent where
   parseJSON = fromPacket "snapshot-event" $ \o -> SnapshotEvent
     <$> o .: "identity"
@@ -524,7 +406,6 @@ instance FromJSON SnapshotEvent where
 
 {- auth -}
 
--- | See <https://api.euphoria.io/#auth>.
 newtype AuthCommand = AuthWithPasscode T.Text
   deriving (Show)
 
@@ -534,7 +415,6 @@ instance ToJSONObject AuthCommand where
     , "passcode" .= password
     ]
 
--- | See <https://api.euphoria.io/#auth>.
 data AuthReply = AuthSuccessful | AuthFailed T.Text
   deriving (Show)
 
@@ -549,7 +429,6 @@ instance FromJSON AuthReply where
 
 {- ping -}
 
--- | See <https://api.euphoria.io/#ping>.
 newtype PingCommand = PingCommand UTCTime
   deriving (Show)
 
@@ -558,7 +437,6 @@ instance ToJSONObject PingCommand where
     [ "time" .= utcTimeToPOSIXSeconds time
     ]
 
--- | See <https://api.euphoria.io/#ping>.
 newtype PingReply = PingReply UTCTime
   deriving (Show)
 
@@ -575,7 +453,6 @@ instance FromJSON PingReply where
 
 {- get-message -}
 
--- | See <https://api.euphoria.io/#get-message>.
 newtype GetMessageCommand = GetMessageCommand Snowflake
   deriving (Show)
 
@@ -584,7 +461,6 @@ instance ToJSONObject GetMessageCommand where
     [ "id" .= mId
     ]
 
--- | See <https://api.euphoria.io/#get-message>.
 newtype GetMessageReply = GetMessageReply Message
   deriving (Show)
 
@@ -594,7 +470,6 @@ instance FromJSON GetMessageReply where
 
 {- log -}
 
--- | See <https://api.euphoria.io/#log>.
 data LogCommand = LogCommand Int (Maybe Snowflake)
   deriving (Show)
 
@@ -607,7 +482,6 @@ instance ToJSONObject LogCommand where
     , "before" .= before
     ]
 
--- | See <https://api.euphoria.io/#log>.
 data LogReply = LogReply [Message] (Maybe Snowflake)
   deriving (Show)
 
@@ -618,7 +492,6 @@ instance FromJSON LogReply where
 
 {- nick -}
 
--- | See <https://api.euphoria.io/#nick>.
 newtype NickCommand = NickCommand T.Text
   deriving (Show)
 
@@ -627,7 +500,6 @@ instance ToJSONObject NickCommand where
     [ "name" .= nick
     ]
 
--- | See <https://api.euphoria.io/#nick>.
 data NickReply = NickReply
   { nickReplySessionId :: T.Text
   , nickReplyId        :: UserId
@@ -644,7 +516,6 @@ instance FromJSON NickReply where
 
 {- pm-initiate -}
 
--- | See <https://api.euphoria.io/#pm-initiate>.
 newtype PmInitiateCommand = PmInitiateCommand UserId
   deriving (Show)
 
@@ -653,7 +524,6 @@ instance ToJSONObject PmInitiateCommand where
     [ "user_id" .= userId
     ]
 
--- | See <https://api.euphoria.io/#pm-initiate>.
 data PmInitiateReply = PmInitiateReply Snowflake T.Text
   deriving (Show)
 
@@ -664,7 +534,6 @@ instance FromJSON PmInitiateReply where
 
 {- send -}
 
--- | See <https://api.euphoria.io/#send>.
 data SendCommand = SendCommand T.Text (Maybe Snowflake)
   deriving (Show)
 
@@ -674,7 +543,6 @@ instance ToJSONObject SendCommand where
   toJSONObject (SendCommand content (Just parent)) =
     toPacket "send" $ object ["content" .= content, "parent" .= parent]
 
--- | See <https://api.euphoria.io/#send>.
 newtype SendReply = SendReply Message
   deriving (Show)
 
@@ -684,14 +552,12 @@ instance FromJSON SendReply where
 
 {- who -}
 
--- | See <https://api.euphoria.io/#who>.
 data WhoCommand = WhoCommand
   deriving (Show)
 
 instance ToJSONObject WhoCommand where
   toJSONObject WhoCommand = toPacket "who" $ object []
 
--- | See <https://api.euphoria.io/#who>.
 newtype WhoReply = WhoReply [SessionView]
   deriving (Show)
 

src/Haboli/Euphoria/Botrulez.hs

@@ -1,70 +0,0 @@
-{-# 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)

src/Haboli/Euphoria/Client.hs

@@ -3,18 +3,6 @@
 {-# 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 <api.euphoria.io>.
-
 module Haboli.Euphoria.Client
   (
   -- * The Client monad
@@ -27,6 +15,7 @@ module Haboli.Euphoria.Client
   -- ** Event handling
   , Event(..)
   , nextEvent
+  , respondingToPing
   -- ** Exception handling
   , ClientException(..)
   , throw
@@ -75,9 +64,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
+-- | 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
+-- received. The @forall@ allows whoever creates the 'AwaitingReply' to decide
--- the type of @r@.
+-- on the type of @r@.
 data AwaitingReply e
   = forall r. FromJSON r => AwaitingReply (TMVar (Reply e r))
 
@@ -132,8 +121,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
+-- 'WS.ConnectionException' occurs. It does this by setting 'ciStopped' to True
--- and cancelling all AwaitingReply-s in ciAwaiting.
+-- and cancelling all 'AwaitingReply'-s in 'ciAwaiting'.
 cancelAllReplies :: ClientInfo e -> WS.ConnectionException -> IO ()
 cancelAllReplies info _ = atomically $ do
   writeTVar (ciStopped info) True
@@ -183,33 +172,33 @@ runWebsocketThread info =
         parseAndSendReply value (ciAwaiting info)
   where
     connection = ciConnection info
-    pingInterval = confPingInterval $ ciDetails info
+    pingInterval = cdPingInterval $ ciDetails info
 
 {- Running the Client monad -}
 
 -- | Configuration for the websocket connection. The websocket connection always
 -- uses https.
 data ConnectionConfig = ConnectionConfig
-  { confHost         :: S.HostName
+  { cdHost         :: S.HostName
-  , confPort         :: S.PortNumber
+  , cdPort         :: S.PortNumber
-  , confPath         :: String
+  , cdPath         :: String
-  , confPingInterval :: Int
+  , cdPingInterval :: Int
   } deriving (Show)
 
 -- | A default configuration that points the bot to the room @&test@ at
 -- <https://euphoria.io/room/test>.
 defaultConfig :: ConnectionConfig
 defaultConfig = ConnectionConfig
-  { confHost = "euphoria.io"
+  { cdHost = "euphoria.io"
-  , confPort = 443
+  , cdPort = 443
-  , confPath = "/room/test/ws"
+  , cdPath = "/room/test/ws"
-  , confPingInterval = 10
+  , cdPingInterval = 10
   }
 
--- | @'withRoom' roomname config@ modifies the 'confPath' of @config@ to point
+-- | @'withRoom' roomname config@ modifies the 'cdPath' of @config@ to point to
--- to the room @roomname@.
+-- the room @roomname@.
 withRoom :: String -> ConnectionConfig -> ConnectionConfig
-withRoom room config = config{confPath = "/room/" ++ room ++ "/ws"}
+withRoom room config = config{cdPath = "/room/" ++ room ++ "/ws"}
 
 --TODO: Catch IO exceptions that occur when a connection could not be created
 -- | Execute a 'Client'.
@@ -224,7 +213,7 @@ withRoom room config = config{confPath = "/room/" ++ room ++ "/ws"}
 runClient :: ConnectionConfig -> Client e a -> IO (Either (ClientException e) a)
 runClient details (Client stack) =
   S.withSocketsDo $
-  WSS.runSecureClient (confHost details) (confPort details) (confPath details) $ \connection -> do
+  WSS.runSecureClient (cdHost details) (cdPort details) (cdPath details) $ \connection -> do
     awaiting <- newTVarIO Map.empty
     eventChan <- newTChanIO
     packetId <- newTVarIO 0
@@ -279,20 +268,12 @@ data Event
   | EventSnapshot SnapshotEvent
   deriving (Show)
 
+--TODO: Add all the events
 instance FromJSON Event where
   parseJSON v = foldr (<|>) mempty
-    [ EventBounce <$> parseJSON v
+    [ EventJoin <$> 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
     ]
@@ -315,6 +296,18 @@ nextEvent = do
     Left e  -> throwRaw e
     Right e -> pure e
 
+-- | Respond to 'EventPing's according to the documentation (see
+-- <http://api.euphoria.io/#ping-event>). 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.

src/Haboli/Euphoria/Command.hs

@@ -1,56 +0,0 @@
--- | 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

src/Haboli/Euphoria/Command/Megaparsec.hs

@@ -1,26 +0,0 @@
--- | 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

src/Haboli/Euphoria/Command/Simple.hs

@@ -1,122 +0,0 @@
-{-# 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 @!\<non-space character\>@.
-pAnyCmd :: (Ord e) => Parsec e T.Text T.Text
-pAnyCmd = label "command" $ char '!' *> takeWhileP Nothing (not . isSpace)
-
--- | @'pCmd' a@ parses commands of the form @!\<cmd\>@ 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 @\@\<non-space character\>@.
-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 @\@\<name\>@ 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 @!\<cmd\>@.
-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 @!\<cmd\> \@\<name\>@.
-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)

src/Haboli/Euphoria/Example.hs

@@ -0,0 +1,75 @@
+{-# 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 ()

src/Haboli/Euphoria/ExampleBot.hs

@@ -1,89 +0,0 @@
-{-# 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

src/Haboli/Euphoria/Lens.hs

@@ -1,13 +0,0 @@
-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

src/Haboli/Euphoria/Listing.hs

@@ -1,116 +0,0 @@
-{-# 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)

src/Haboli/Euphoria/Util.hs

@@ -1,154 +0,0 @@
-{-# 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
--- <http://api.euphoria.io/#ping-event>). 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 @[[[\<days\>d ]\<hours\>h
--- ]\<minutes\>m ]\<seconds\>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"

stack.yaml

@@ -1,3 +1,66 @@
-resolver: lts-15.7
+# 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
 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

stack.yaml.lock

@@ -6,7 +6,7 @@
 packages: []
 snapshots:
 - completed:
-    size: 491389
+    size: 524155
-    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/7.yaml
+    url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/19.yaml
-    sha256: 92ab6303fe20ec928461c82ce0980b4d17c06f4e66205a2967e476474f686c17
+    sha256: 9f79f6494473c9b46911364b94c4b5ef19ca8d35ebf62e46697cf651f198ee19
-  original: lts-15.7
+  original: lts-14.19

test/Spec.hs

@@ -0,0 +1,2 @@
+main :: IO ()
+main = putStrLn "Test suite not yet implemented"