Add more detail to readme

Also add documentation for the existing command modules

.gitignore

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

CHANGELOG.md

@@ -1,18 +1,30 @@
 # Changelog for haboli
 
+## 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
+
 ## 0.3.1.0
-* add `Haboli.Euphoria` module
-* add proper README
-* clean up package structure
-* update documentation
+- add `Haboli.Euphoria` module
+- add proper README
+- clean up package structure
+- update documentation
 
 ## 0.3.0.0
-* fix Client not receiving all kinds of server events
-* rename ConnectionConfig record accessors
+- fix Client not receiving all kinds of server events
+- rename ConnectionConfig record accessors
 
 ## 0.2.0.0
-* add all session and chat room commands
-* modify `send` command so it also returns the old nick
+- add all session and chat room commands
+- modify `send` command so it also returns the old nick
 
 ## 0.1.0.0
-* create project
+- create project

README.md

@@ -21,16 +21,32 @@ supports all session and chat room commands listed in the
 For more information, see the haddock for the `Haboli.Euphoria.Client` and
 `Haboli.Euphoria.Api` modules.
 
-## Example bot
+## Bots
 
-Here is a very basic example bot that replies to `!ping` with `Pong!`:
+The library is built with flexibility and composability in mind. Because of
+this, there is no special `Bot` monad — bots also run inside the `Client` monad.
+However, there are a few convenience modules that make development of bots
+easier.
+
+The convenience modules are built on top of the `Client` monad. None of the
+convenience modules are necessary to create a functioning bot. When creating a
+new bot, you can freely choose which modules to use and which to ignore or
+replace with your own creations.
+
+For an example bot structure using the convenience modules, here is an
+[example bot](src/Haboli/Euphoria/ExampleBot.hs).
+
+## Example client
+
+Here is a very basic example bot that replies to `!ping` with `Pong!`. It does
+not use any of the provided convenience modules.
 
 ```haskell
 pingPongBot :: Client () ()
 pingPongBot = forever $ do
   event <- respondingToPing nextEvent
   case event of
-    EventSnapshot _ -> void $ nick "TreeBot"
+    EventSnapshot _ -> void $ nick "PingPongBot"
     EventSend e ->
       let msg = sendMessage e
       in  when (msgContent msg == "!ping") $
@@ -44,3 +60,11 @@ And here's how to run that bot:
 main :: IO ()
 main = void $ runClient defaultConfig pingPongBot
 ```
+
+## Lenses
+
+Haboli exports lenses for a few data types. The lenses are named like the record
+accessors but suffixed with a `L`. For example, the lens corresponding to
+`svNick` from `SessionView` is named `svNickL`. Lenses are not required to use
+the libary. They are provided for the convenience of those who like using
+lenses.

Setup.hs

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

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 <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,23 +1,31 @@
-name:                haboli
-version:             0.3.1.0
-license:             MIT
-author:              "Garmelon <joscha@plugh.de>"
-copyright:           "2020 Garmelon"
+name: haboli
+version: 0.3.1.0
+license: MIT
+author: Garmelon <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"
+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
   - CHANGELOG.md
+  - LICENSE
+
+extra-doc-files:
+  - README.md
 
 dependencies:
   - base >= 4.7 && < 5
   - aeson
   - containers
+  - megaparsec
+  - microlens
+  - microlens-th
   - network
   - stm
+  - template-haskell
   - text
   - time
   - transformers

src/Haboli/Euphoria.hs

@@ -1,11 +1,19 @@
--- | This module just reexports all euphoria-related modules for convenience.
--- For more detail on how this library works, check the "Haboli.Euphoria.Client"
--- module's documentation.
+-- | 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.Client
-  , module Haboli.Euphoria.Api
+  ( module Haboli.Euphoria.Api
+  , module Haboli.Euphoria.Client
+  , module Haboli.Euphoria.Command
+  , module Haboli.Euphoria.Command.Simple
+  , module Haboli.Euphoria.Listing
+  , module Haboli.Euphoria.Util
   ) where
 
 import           Haboli.Euphoria.Api
 import           Haboli.Euphoria.Client
+import           Haboli.Euphoria.Command
+import           Haboli.Euphoria.Command.Simple
+import           Haboli.Euphoria.Listing
+import           Haboli.Euphoria.Util

src/Haboli/Euphoria/Api.hs

@@ -1,4 +1,5 @@
 {-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell   #-}
 
 -- | This module attempts to map the structure of the ephoria API to types.
 
@@ -6,41 +7,101 @@ module Haboli.Euphoria.Api
   ( ToJSONObject(..)
   -- * Basic types
   , AuthOption(..)
-  , Message(..)
-  , PersonalAccountView(..)
-  , SessionView(..)
   , Snowflake
   , UserType(..)
   , UserId(..)
+  , userTypeL
+  , userSnowflakeL
+  , SessionView(..)
+  , svIdL
+  , svNickL
+  , svServerIdL
+  , svServerEraL
+  , svSessionIdL
+  , svIsStaffL
+  , svIsManagerL
+  , svClientAddressL
+  , svRealClientAddressL
+  , Message(..)
+  , msgIdL
+  , msgParentL
+  , msgPreviousEditIdL
+  , msgTimeL
+  , msgSenderL
+  , msgContentL
+  , msgEncryptionKeyIdL
+  , msgEditedL
+  , msgDeletedL
+  , msgTruncatedL
+  , PersonalAccountView(..)
+  , pavIdL
+  , pavNameL
+  , pavEmailL
   -- * Asynchronous events
   -- ** bounce-event
   , BounceEvent(..)
+  , bounceReasonL
+  , bounceAuthOptionL
   -- ** disconnect-event
   , DisconnectEvent(..)
+  , disconnectReasonL
   -- ** hello-event
   , HelloEvent(..)
+  , helloAccountL
+  , helloSessionViewL
+  , helloAccountHasAccessL
+  , helloAccountEmailVerifiedL
+  , helloRoomIsPrivateL
+  , helloVersionL
   -- ** join-event
   , JoinEvent(..)
+  , joinSessionL
   -- ** login-event
   , LoginEvent(..)
+  , loginAccountIdL
   -- ** logout-event
   , LogoutEvent(..)
   -- ** network-event
   , NetworkEvent(..)
+  , networkTypeL
+  , networkServerIdL
+  , networkServerEraL
   -- ** nick-event
   , NickEvent(..)
+  , nickSessionIdL
+  , nickIdL
+  , nickFromL
+  , nickToL
   -- ** edit-message-event
   , EditMessageEvent(..)
+  , editMessageMessageL
+  , editMessageEditIdL
   -- ** part-event
   , PartEvent(..)
+  , partSessionL
   -- ** ping-event
   , PingEvent(..)
+  , pingTimeL
+  , pingNextL
   -- ** pm-initiate-event
   , PmInitiateEvent(..)
+  , pmInitiateFromL
+  , pmInitiateFromNickL
+  , pmInitiateFromRoomL
+  , pmInitiatePmIdL
   -- ** send-event
   , SendEvent(..)
+  , sendMessageL
   -- ** snapshot-event
   , SnapshotEvent(..)
+  , snapshotIdentityL
+  , snapshotSessionIdL
+  , snapshotVersionL
+  , snapshotListingL
+  , snapshotLogL
+  , snapshotNickL
+  , snapshotPmWithNickL
+  , snapshotPmWithUserIdL
   -- * Session commands
   -- ** auth
   , AuthCommand(..)
@@ -77,6 +138,8 @@ import qualified Data.Text             as T
 import           Data.Time
 import           Data.Time.Clock.POSIX
 
+import Haboli.Euphoria.Lens
+
 -- | A class for all types that can be converted into an
 -- 'Data.Aeson.Types.Object'. Similar to 'ToJSON', but more restrictive.
 class ToJSONObject a where
@@ -110,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
--- <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 <http://api.euphoria.io/#snowflake>.
+-- integer. See <https://api.euphoria.io/#snowflake>.
 type Snowflake = T.Text
 
 -- | The type of session a client may have.
@@ -194,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
--- <http://api.euphoria.io/#userid>.
+-- <https://api.euphoria.io/#userid>.
 data UserId = UserId
   { userType      :: UserType
   , userSnowflake :: Snowflake
-  } deriving (Show, Eq)
+  } deriving (Show, Eq, Ord)
+
+makeLensesL ''UserId
 
 instance ToJSON UserId where
   toJSON uid =
@@ -221,15 +219,93 @@ 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"
@@ -237,16 +313,20 @@ instance FromJSON BounceEvent where
 
 {- 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
@@ -256,6 +336,8 @@ data HelloEvent = HelloEvent
   , helloVersion              :: T.Text
   } deriving (Show)
 
+makeLensesL ''HelloEvent
+
 instance FromJSON HelloEvent where
   parseJSON = fromPacket "hello-event" $ \o -> HelloEvent
     <$> o .:? "account"
@@ -267,26 +349,33 @@ 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)
 
@@ -295,12 +384,15 @@ 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"
@@ -309,6 +401,7 @@ instance FromJSON NetworkEvent where
 
 {- nick-event -}
 
+-- | See <https://api.euphoria.io/#nick-event>.
 data NickEvent = NickEvent
   { nickSessionId :: T.Text
   , nickId        :: UserId
@@ -316,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"
@@ -325,11 +420,14 @@ 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)
@@ -337,21 +435,27 @@ 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")
@@ -359,6 +463,7 @@ instance FromJSON PingEvent where
 
 {- pm-initiate-event -}
 
+-- | See <https://api.euphoria.io/#pm-initiate-event>.
 data PmInitiateEvent = PmInitiateEvent
   { pmInitiateFrom     :: UserId
   , pmInitiateFromNick :: T.Text
@@ -366,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"
@@ -375,16 +482,20 @@ 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
@@ -396,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"
@@ -411,6 +524,7 @@ instance FromJSON SnapshotEvent where
 
 {- auth -}
 
+-- | See <https://api.euphoria.io/#auth>.
 newtype AuthCommand = AuthWithPasscode T.Text
   deriving (Show)
 
@@ -420,6 +534,7 @@ instance ToJSONObject AuthCommand where
     , "passcode" .= password
     ]
 
+-- | See <https://api.euphoria.io/#auth>.
 data AuthReply = AuthSuccessful | AuthFailed T.Text
   deriving (Show)
 
@@ -434,6 +549,7 @@ instance FromJSON AuthReply where
 
 {- ping -}
 
+-- | See <https://api.euphoria.io/#ping>.
 newtype PingCommand = PingCommand UTCTime
   deriving (Show)
 
@@ -442,6 +558,7 @@ instance ToJSONObject PingCommand where
     [ "time" .= utcTimeToPOSIXSeconds time
     ]
 
+-- | See <https://api.euphoria.io/#ping>.
 newtype PingReply = PingReply UTCTime
   deriving (Show)
 
@@ -458,6 +575,7 @@ instance FromJSON PingReply where
 
 {- get-message -}
 
+-- | See <https://api.euphoria.io/#get-message>.
 newtype GetMessageCommand = GetMessageCommand Snowflake
   deriving (Show)
 
@@ -466,6 +584,7 @@ instance ToJSONObject GetMessageCommand where
     [ "id" .= mId
     ]
 
+-- | See <https://api.euphoria.io/#get-message>.
 newtype GetMessageReply = GetMessageReply Message
   deriving (Show)
 
@@ -475,6 +594,7 @@ instance FromJSON GetMessageReply where
 
 {- log -}
 
+-- | See <https://api.euphoria.io/#log>.
 data LogCommand = LogCommand Int (Maybe Snowflake)
   deriving (Show)
 
@@ -487,6 +607,7 @@ instance ToJSONObject LogCommand where
     , "before" .= before
     ]
 
+-- | See <https://api.euphoria.io/#log>.
 data LogReply = LogReply [Message] (Maybe Snowflake)
   deriving (Show)
 
@@ -497,6 +618,7 @@ instance FromJSON LogReply where
 
 {- nick -}
 
+-- | See <https://api.euphoria.io/#nick>.
 newtype NickCommand = NickCommand T.Text
   deriving (Show)
 
@@ -505,6 +627,7 @@ instance ToJSONObject NickCommand where
     [ "name" .= nick
     ]
 
+-- | See <https://api.euphoria.io/#nick>.
 data NickReply = NickReply
   { nickReplySessionId :: T.Text
   , nickReplyId        :: UserId
@@ -521,6 +644,7 @@ instance FromJSON NickReply where
 
 {- pm-initiate -}
 
+-- | See <https://api.euphoria.io/#pm-initiate>.
 newtype PmInitiateCommand = PmInitiateCommand UserId
   deriving (Show)
 
@@ -529,6 +653,7 @@ instance ToJSONObject PmInitiateCommand where
     [ "user_id" .= userId
     ]
 
+-- | See <https://api.euphoria.io/#pm-initiate>.
 data PmInitiateReply = PmInitiateReply Snowflake T.Text
   deriving (Show)
 
@@ -539,6 +664,7 @@ instance FromJSON PmInitiateReply where
 
 {- send -}
 
+-- | See <https://api.euphoria.io/#send>.
 data SendCommand = SendCommand T.Text (Maybe Snowflake)
   deriving (Show)
 
@@ -548,6 +674,7 @@ 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)
 
@@ -557,12 +684,14 @@ 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

@@ -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)

src/Haboli/Euphoria/Client.hs

@@ -27,7 +27,6 @@ module Haboli.Euphoria.Client
   -- ** Event handling
   , Event(..)
   , nextEvent
-  , respondingToPing
   -- ** Exception handling
   , ClientException(..)
   , throw
@@ -280,7 +279,6 @@ data Event
   | EventSnapshot SnapshotEvent
   deriving (Show)
 
---TODO: Add all the events
 instance FromJSON Event where
   parseJSON v = foldr (<|>) mempty
     [ EventBounce <$> parseJSON v
@@ -317,18 +315,6 @@ 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

@@ -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

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

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 @!\<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

@@ -1,74 +0,0 @@
-{-# LANGUAGE OverloadedStrings #-}
-
--- | This module contains a few basic example bots.
-module Haboli.Euphoria.Example where
-
-import           Control.Concurrent
-import           Control.Monad
-import           Control.Monad.IO.Class
-import           Data.Foldable
-import           Haboli.Euphoria
-
-printAllEventsBot :: Client () ()
-printAllEventsBot = forever $ do
-  liftIO $ putStrLn "\nWaiting for the next event...\n"
-  liftIO . print =<< respondingToPing nextEvent
-
-setNickAndThenWaitBot :: Client () ()
-setNickAndThenWaitBot = forever $ do
-  event <- respondingToPing nextEvent
-  case event of
-    EventSnapshot _ -> void $ nick "HaboliTestBot"
-    _               -> pure ()
-
-throwCustomExceptionBot :: Client String ()
-throwCustomExceptionBot = throw "Hello world"
-
-immediatelyDisconnectBot :: Client () ()
-immediatelyDisconnectBot = pure ()
-
-sendMessagesUntilThrottledBot :: Client () ()
-sendMessagesUntilThrottledBot = forever $ do
-  event <- respondingToPing nextEvent
-  case event of
-    EventSnapshot _ -> do
-      void $ nick "SpamBot"
-      msg <- send "start thread"
-      void $ fork $ handle (\_ -> reply msg "got throttled") $
-        forever $ reply msg "continue thread"
-    _ -> pure ()
-
-sendMessagesThreadedBot :: Client () ()
-sendMessagesThreadedBot = forever $ do
-  event <- respondingToPing nextEvent
-  case event of
-    EventSnapshot _ -> void $ nick "TreeBot"
-    EventSend e ->
-      let msg = sendMessage e
-      in  when (msgContent msg == "!tree") $
-            void $ fork $ buildTree msg
-    _ -> pure ()
-  where
-    buildTree msg = do
-      t1 <- fork $ reply msg "subtree 1"
-      t2 <- fork $ reply msg "subtree 2"
-      subtree1 <- wait t1
-      subtree2 <- wait t2
-      t3 <- fork $ reply subtree1 "subtree 1.1"
-      t4 <- fork $ reply subtree1 "subtree 1.2"
-      t5 <- fork $ reply subtree2 "subtree 2.1"
-      t6 <- fork $ reply subtree2 "subtree 2.2"
-      for_ [t3, t4, t5, t6] wait
-      reply msg "tree done"
-
-cloneItselfBot :: Client () ()
-cloneItselfBot = forever $ do
-  event <- respondingToPing nextEvent
-  case event of
-    EventSnapshot _ -> void $ nick "CloneBot"
-    EventSend e
-      | msgContent (sendMessage e) == "!clone" -> do
-        config <- getConnectionConfig
-        void $ liftIO $ forkIO $ void $ runClient config cloneItselfBot
-      | otherwise -> pure ()
-    _ -> pure ()

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

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

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)

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
+-- <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,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

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