diff --git a/.gitignore b/.gitignore index 76467e6..64af04d 100644 --- a/.gitignore +++ b/.gitignore @@ -1,2 +1,3 @@ .stack-work/ -*~ +haboli.cabal +*~ \ No newline at end of file diff --git a/CHANGELOG.md b/CHANGELOG.md index c934c84..77d17d8 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,30 +1,18 @@ # 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 diff --git a/README.md b/README.md index 8758763..b50dd81 100644 --- a/README.md +++ b/README.md @@ -21,32 +21,16 @@ 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. -## Bots +## Example bot -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. +Here is a very basic example bot that replies to `!ping` with `Pong!`: ```haskell pingPongBot :: Client () () pingPongBot = forever $ do event <- respondingToPing nextEvent case event of - EventSnapshot _ -> void $ nick "PingPongBot" + EventSnapshot _ -> void $ nick "TreeBot" EventSend e -> let msg = sendMessage e in when (msgContent msg == "!ping") $ @@ -60,11 +44,3 @@ And here's how to run that bot: main :: IO () main = void $ runClient defaultConfig pingPongBot ``` - -## Lenses - -Haboli exports lenses for a few data types. The lenses are named like the record -accessors but suffixed with a `L`. For example, the lens corresponding to -`svNick` from `SessionView` is named `svNickL`. Lenses are not required to use -the libary. They are provided for the convenience of those who like using -lenses. diff --git a/Setup.hs b/Setup.hs new file mode 100644 index 0000000..9a994af --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/haboli.cabal b/haboli.cabal deleted file mode 100644 index 6fca2d4..0000000 --- a/haboli.cabal +++ /dev/null @@ -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 -homepage: https://github.com/Garmelon/haboli#readme -bug-reports: https://github.com/Garmelon/haboli/issues -author: Garmelon -maintainer: Garmelon -copyright: 2020 Garmelon -license: MIT -license-file: LICENSE -build-type: Simple -extra-source-files: - README.md - CHANGELOG.md - LICENSE -extra-doc-files: - README.md - -source-repository head - type: git - location: https://github.com/Garmelon/haboli - -library - exposed-modules: - Haboli.Euphoria - Haboli.Euphoria.Api - Haboli.Euphoria.Botrulez - Haboli.Euphoria.Client - Haboli.Euphoria.Command - Haboli.Euphoria.Command.Megaparsec - Haboli.Euphoria.Command.Simple - Haboli.Euphoria.ExampleBot - Haboli.Euphoria.Lens - Haboli.Euphoria.Listing - Haboli.Euphoria.Util - other-modules: - Paths_haboli - hs-source-dirs: - src - build-depends: - aeson - , base >=4.7 && <5 - , containers - , megaparsec - , microlens - , microlens-th - , network - , stm - , template-haskell - , text - , time - , transformers - , unordered-containers - , websockets - , wuss - default-language: Haskell2010 diff --git a/package.yaml b/package.yaml index 8f1d9cb..bf0c8d6 100644 --- a/package.yaml +++ b/package.yaml @@ -1,31 +1,23 @@ -name: haboli -version: 0.3.1.0 -license: MIT -author: Garmelon -copyright: 2020 Garmelon +name: haboli +version: 0.3.1.0 +license: MIT +author: "Garmelon " +copyright: "2020 Garmelon" -synopsis: API bindings for https://euphoria.io/ -description: Please see the README on GitHub at -github: Garmelon/haboli +synopsis: API bindings for https://euphoria.io/ +description: Please see the README on GitHub at +github: "Garmelon/haboli" extra-source-files: - README.md - CHANGELOG.md - - LICENSE - -extra-doc-files: - - README.md dependencies: - base >= 4.7 && < 5 - aeson - containers - - megaparsec - - microlens - - microlens-th - network - stm - - template-haskell - text - time - transformers diff --git a/src/Haboli/Euphoria.hs b/src/Haboli/Euphoria.hs index 656bf09..968c565 100644 --- a/src/Haboli/Euphoria.hs +++ b/src/Haboli/Euphoria.hs @@ -1,19 +1,11 @@ --- | This module reexports the most commonly used modules for convenience. For --- more detail on how this library works, check the or the --- "Haboli.Euphoria.Client" module's documentation. +-- | 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. 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 + ( module Haboli.Euphoria.Client + , module Haboli.Euphoria.Api ) where import Haboli.Euphoria.Api import Haboli.Euphoria.Client -import Haboli.Euphoria.Command -import Haboli.Euphoria.Command.Simple -import Haboli.Euphoria.Listing -import Haboli.Euphoria.Util diff --git a/src/Haboli/Euphoria/Api.hs b/src/Haboli/Euphoria/Api.hs index fb528bf..783bb48 100644 --- a/src/Haboli/Euphoria/Api.hs +++ b/src/Haboli/Euphoria/Api.hs @@ -1,5 +1,4 @@ {-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -- | This module attempts to map the structure of the ephoria API to types. @@ -7,101 +6,41 @@ 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,8 +77,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 @@ -173,9 +110,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 +-- . +data Message = Message + { msgId :: Snowflake + , msgParent :: Maybe Snowflake + , msgPreviousEditId :: Maybe Snowflake + , msgTime :: UTCTime + , msgSender :: SessionView + , msgContent :: T.Text + , msgEncryptionKeyId :: Maybe T.Text + , msgEdited :: Maybe UTCTime + , msgDeleted :: Maybe UTCTime + , msgTruncated :: Bool + } deriving (Show) + +instance FromJSON Message where + parseJSON v = parseJSON v >>= \o -> Message + <$> o .: "id" + <*> o .:? "parent" + <*> o .:? "previous_edit_id" + <*> (posixSecondsToUTCTime <$> o .: "time") + <*> o .: "sender" + <*> o .: "content" + <*> o .:? "encryption_key_id" + <*> o .:? "edited" + <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") + <*> o .:? "truncated" .!= False + +data PersonalAccountView = PersonalAccountView + { pavId :: Snowflake + , pavName :: T.Text + , pavEmail :: T.Text + } deriving (Show) + +instance FromJSON PersonalAccountView where + parseJSON v = parseJSON v >>= \o -> PersonalAccountView + <$> o .: "id" + <*> o .: "name" + <*> o .: "email" + +-- | A 'SessionView' describes a session and its identity. See +-- . +data SessionView = SessionView + { svId :: UserId + , svNick :: T.Text + , svServerId :: T.Text + , svServerEra :: T.Text + , svSessionId :: T.Text + , svIsStaff :: Bool + , svIsManager :: Bool + , svClientAddress :: Maybe T.Text + , svRealClientAddress :: Maybe T.Text + } deriving (Show) + +instance FromJSON SessionView where + parseJSON v = parseJSON v >>= \o -> SessionView + <$> o .: "id" + <*> o .: "name" + <*> o .: "server_id" + <*> o .: "server_era" + <*> o .: "session_id" + <*> o .:? "is_staff" .!= False + <*> o .:? "is_manager" .!= False + <*> o .:? "client_address" + <*> o .:? "real_client_address" + -- | A snowflake is a 13-character string, usually used as a unique identifier -- for some type of object. It is the base-36 encoding of an unsigned, 64-bit --- integer. See . +-- integer. See . type Snowflake = T.Text -- | The type of session a client may have. @@ -190,17 +194,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 --- . +-- . data UserId = UserId { userType :: UserType , userSnowflake :: Snowflake - } deriving (Show, Eq, Ord) - -makeLensesL ''UserId + } deriving (Show, Eq) instance ToJSON UserId where toJSON uid = @@ -219,93 +221,15 @@ instance FromJSON UserId where ("bot", snowflake) -> pure $ UserId Bot $ T.drop 1 snowflake _ -> fail "invalid user id label" --- | A 'SessionView' describes a session and its identity. See --- . -data SessionView = SessionView - { svId :: UserId - , svNick :: T.Text - , svServerId :: T.Text - , svServerEra :: T.Text - , svSessionId :: T.Text - , svIsStaff :: Bool - , svIsManager :: Bool - , svClientAddress :: Maybe T.Text - , svRealClientAddress :: Maybe T.Text - } deriving (Show) - -makeLensesL ''SessionView - -instance FromJSON SessionView where - parseJSON v = parseJSON v >>= \o -> SessionView - <$> o .: "id" - <*> o .: "name" - <*> o .: "server_id" - <*> o .: "server_era" - <*> o .: "session_id" - <*> o .:? "is_staff" .!= False - <*> o .:? "is_manager" .!= False - <*> o .:? "client_address" - <*> o .:? "real_client_address" - --- | A 'Message' is a node in a room’s log. It corresponds to a chat message, or --- a post, or any broadcasted event in a room that should appear in the log. See --- . -data Message = Message - { msgId :: Snowflake - , msgParent :: Maybe Snowflake - , msgPreviousEditId :: Maybe Snowflake - , msgTime :: UTCTime - , msgSender :: SessionView - , msgContent :: T.Text - , msgEncryptionKeyId :: Maybe T.Text - , msgEdited :: Maybe UTCTime - , msgDeleted :: Maybe UTCTime - , msgTruncated :: Bool - } deriving (Show) - -makeLensesL ''Message - -instance FromJSON Message where - parseJSON v = parseJSON v >>= \o -> Message - <$> o .: "id" - <*> o .:? "parent" - <*> o .:? "previous_edit_id" - <*> (posixSecondsToUTCTime <$> o .: "time") - <*> o .: "sender" - <*> o .: "content" - <*> o .:? "encryption_key_id" - <*> o .:? "edited" - <*> (fmap posixSecondsToUTCTime <$> o .:? "deleted") - <*> o .:? "truncated" .!= False - --- | A 'PersonalAccountView' contains information about an euphoria account. See --- . -data PersonalAccountView = PersonalAccountView - { pavId :: Snowflake - , pavName :: T.Text - , pavEmail :: T.Text - } deriving (Show) - -makeLensesL ''PersonalAccountView - -instance FromJSON PersonalAccountView where - parseJSON v = parseJSON v >>= \o -> PersonalAccountView - <$> o .: "id" - <*> o .: "name" - <*> o .: "email" - {- Asynchronous events -} {- bounce-event -} --- | See . data BounceEvent = BounceEvent { bounceReason :: Maybe T.Text , bounceAuthOption :: [AuthOption] } deriving (Show) -makeLensesL ''BounceEvent - instance FromJSON BounceEvent where parseJSON = fromPacket "bounce-event" $ \o -> BounceEvent <$> o .:? "reason" @@ -313,20 +237,16 @@ instance FromJSON BounceEvent where {- disconnect-event -} --- | See . newtype DisconnectEvent = DisconnectEvent { disconnectReason :: T.Text } deriving (Show) -makeLensesL ''DisconnectEvent - instance FromJSON DisconnectEvent where parseJSON = fromPacket "disconnect-evnet" $ \o -> DisconnectEvent <$> o .: "reason" {- hello-event -} --- | See . data HelloEvent = HelloEvent { helloAccount :: Maybe PersonalAccountView , helloSessionView :: SessionView @@ -336,8 +256,6 @@ data HelloEvent = HelloEvent , helloVersion :: T.Text } deriving (Show) -makeLensesL ''HelloEvent - instance FromJSON HelloEvent where parseJSON = fromPacket "hello-event" $ \o -> HelloEvent <$> o .:? "account" @@ -349,33 +267,26 @@ instance FromJSON HelloEvent where {- join-event -} --- | See . newtype JoinEvent = JoinEvent { joinSession :: SessionView } deriving (Show) -makeLensesL ''JoinEvent - instance FromJSON JoinEvent where parseJSON = fromPacket "join-event" $ \o -> JoinEvent <$> parseJSON (Object o) {- login-event -} --- | See . newtype LoginEvent = LoginEvent { loginAccountId :: Snowflake } deriving (Show) -makeLensesL ''LoginEvent - instance FromJSON LoginEvent where parseJSON = fromPacket "login-event" $ \o -> LoginEvent <$> o .: "acount_id" {- logout-event -} --- | See . data LogoutEvent = LogoutEvent deriving (Show) @@ -384,15 +295,12 @@ instance FromJSON LogoutEvent where {- network-event -} --- | See . data NetworkEvent = NetworkEvent { networkType :: T.Text -- always "partition" , networkServerId :: T.Text , networkServerEra :: T.Text } deriving (Show) -makeLensesL ''NetworkEvent - instance FromJSON NetworkEvent where parseJSON = fromPacket "network-event" $ \o -> NetworkEvent <$> o .: "type" @@ -401,7 +309,6 @@ instance FromJSON NetworkEvent where {- nick-event -} --- | See . data NickEvent = NickEvent { nickSessionId :: T.Text , nickId :: UserId @@ -409,8 +316,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 +325,11 @@ instance FromJSON NickEvent where {- edit-message-event -} --- | See . data EditMessageEvent = EditMessageEvent { editMessageMessage :: Message , editMessageEditId :: Snowflake } deriving (Show) -makeLensesL ''EditMessageEvent - instance FromJSON EditMessageEvent where parseJSON = fromPacket "EditMessageEvent" $ \o -> EditMessageEvent <$> parseJSON (Object o) @@ -435,27 +337,21 @@ instance FromJSON EditMessageEvent where {- part-event -} --- | See . newtype PartEvent = PartEvent { partSession :: SessionView } deriving (Show) -makeLensesL ''PartEvent - instance FromJSON PartEvent where parseJSON = fromPacket "part-event" $ \o -> PartEvent <$> parseJSON (Object o) {- ping-event -} --- | See . data PingEvent = PingEvent { pingTime :: UTCTime , pingNext :: UTCTime } deriving (Show) -makeLensesL ''PingEvent - instance FromJSON PingEvent where parseJSON = fromPacket "ping-event" $ \o -> PingEvent <$> (posixSecondsToUTCTime <$> o .: "time") @@ -463,7 +359,6 @@ instance FromJSON PingEvent where {- pm-initiate-event -} --- | See . data PmInitiateEvent = PmInitiateEvent { pmInitiateFrom :: UserId , pmInitiateFromNick :: T.Text @@ -471,8 +366,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 +375,16 @@ instance FromJSON PmInitiateEvent where {- send-event -} --- | See . newtype SendEvent = SendEvent { sendMessage :: Message } deriving (Show) -makeLensesL ''SendEvent - instance FromJSON SendEvent where parseJSON = fromPacket "send-event" $ \o -> SendEvent <$> parseJSON (Object o) {- snapshot-event -} --- | See . data SnapshotEvent = SnapshotEvent { snapshotIdentity :: UserId , snapshotSessionId :: T.Text @@ -507,8 +396,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 +411,6 @@ instance FromJSON SnapshotEvent where {- auth -} --- | See . newtype AuthCommand = AuthWithPasscode T.Text deriving (Show) @@ -534,7 +420,6 @@ instance ToJSONObject AuthCommand where , "passcode" .= password ] --- | See . data AuthReply = AuthSuccessful | AuthFailed T.Text deriving (Show) @@ -549,7 +434,6 @@ instance FromJSON AuthReply where {- ping -} --- | See . newtype PingCommand = PingCommand UTCTime deriving (Show) @@ -558,7 +442,6 @@ instance ToJSONObject PingCommand where [ "time" .= utcTimeToPOSIXSeconds time ] --- | See . newtype PingReply = PingReply UTCTime deriving (Show) @@ -575,7 +458,6 @@ instance FromJSON PingReply where {- get-message -} --- | See . newtype GetMessageCommand = GetMessageCommand Snowflake deriving (Show) @@ -584,7 +466,6 @@ instance ToJSONObject GetMessageCommand where [ "id" .= mId ] --- | See . newtype GetMessageReply = GetMessageReply Message deriving (Show) @@ -594,7 +475,6 @@ instance FromJSON GetMessageReply where {- log -} --- | See . data LogCommand = LogCommand Int (Maybe Snowflake) deriving (Show) @@ -607,7 +487,6 @@ instance ToJSONObject LogCommand where , "before" .= before ] --- | See . data LogReply = LogReply [Message] (Maybe Snowflake) deriving (Show) @@ -618,7 +497,6 @@ instance FromJSON LogReply where {- nick -} --- | See . newtype NickCommand = NickCommand T.Text deriving (Show) @@ -627,7 +505,6 @@ instance ToJSONObject NickCommand where [ "name" .= nick ] --- | See . data NickReply = NickReply { nickReplySessionId :: T.Text , nickReplyId :: UserId @@ -644,7 +521,6 @@ instance FromJSON NickReply where {- pm-initiate -} --- | See . newtype PmInitiateCommand = PmInitiateCommand UserId deriving (Show) @@ -653,7 +529,6 @@ instance ToJSONObject PmInitiateCommand where [ "user_id" .= userId ] --- | See . data PmInitiateReply = PmInitiateReply Snowflake T.Text deriving (Show) @@ -664,7 +539,6 @@ instance FromJSON PmInitiateReply where {- send -} --- | See . data SendCommand = SendCommand T.Text (Maybe Snowflake) deriving (Show) @@ -674,7 +548,6 @@ instance ToJSONObject SendCommand where toJSONObject (SendCommand content (Just parent)) = toPacket "send" $ object ["content" .= content, "parent" .= parent] --- | See . newtype SendReply = SendReply Message deriving (Show) @@ -684,14 +557,12 @@ instance FromJSON SendReply where {- who -} --- | See . data WhoCommand = WhoCommand deriving (Show) instance ToJSONObject WhoCommand where toJSONObject WhoCommand = toPacket "who" $ object [] --- | See . newtype WhoReply = WhoReply [SessionView] deriving (Show) diff --git a/src/Haboli/Euphoria/Botrulez.hs b/src/Haboli/Euphoria/Botrulez.hs deleted file mode 100644 index 3f24d0d..0000000 --- a/src/Haboli/Euphoria/Botrulez.hs +++ /dev/null @@ -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) diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index 22b83c8..f535394 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -27,6 +27,7 @@ module Haboli.Euphoria.Client -- ** Event handling , Event(..) , nextEvent + , respondingToPing -- ** Exception handling , ClientException(..) , throw @@ -279,6 +280,7 @@ data Event | EventSnapshot SnapshotEvent deriving (Show) +--TODO: Add all the events instance FromJSON Event where parseJSON v = foldr (<|>) mempty [ EventBounce <$> parseJSON v @@ -315,6 +317,18 @@ nextEvent = do Left e -> throwRaw e Right e -> pure e +-- | Respond to 'EventPing's according to the documentation (see +-- ). This function is meant to be wrapped +-- directly around 'nextEvent': +-- > event <- respondingToPing nextEvent +respondingToPing :: Client e Event -> Client e Event +respondingToPing holdingEvent = do + event <- holdingEvent + case event of + EventPing e -> pingReply (pingTime e) + _ -> pure () + pure event + {- Exception handling -} -- | The type of exceptions in the 'Client' monad. diff --git a/src/Haboli/Euphoria/Command.hs b/src/Haboli/Euphoria/Command.hs deleted file mode 100644 index 1c22893..0000000 --- a/src/Haboli/Euphoria/Command.hs +++ /dev/null @@ -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 diff --git a/src/Haboli/Euphoria/Command/Megaparsec.hs b/src/Haboli/Euphoria/Command/Megaparsec.hs deleted file mode 100644 index 98bf252..0000000 --- a/src/Haboli/Euphoria/Command/Megaparsec.hs +++ /dev/null @@ -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 diff --git a/src/Haboli/Euphoria/Command/Simple.hs b/src/Haboli/Euphoria/Command/Simple.hs deleted file mode 100644 index 49c8e5e..0000000 --- a/src/Haboli/Euphoria/Command/Simple.hs +++ /dev/null @@ -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 @!\@. -pAnyCmd :: (Ord e) => Parsec e T.Text T.Text -pAnyCmd = label "command" $ char '!' *> takeWhileP Nothing (not . isSpace) - --- | @'pCmd' a@ parses commands of the form @!\@ where @cmd@ is equivalent --- to @a@. -pCmd :: (Ord e) => T.Text -> Parsec e T.Text T.Text -pCmd cmd = do - cmd' <- pAnyCmd - guard $ cmd == cmd' - pure cmd' - --- | Parse any nick of the form @\@\@. -pAnyNick :: (Ord e) => Parsec e T.Text T.Text -pAnyNick = label "nick" $ do - void $ char '@' - takeWhile1P Nothing (not . isSpace) - --- | @'pNick' a@ parses nicks of the form @\@\@ where @name@ is --- equivalent (but not necessarily equal) to @a@. -pNick :: (Ord e) => T.Text -> Parsec e T.Text T.Text -pNick name = do - name' <- pAnyNick - guard $ nickEqual name name' - pure name' - --- | Consume the rest of the input. This parser should never fail. -pUntilEof :: (Ord e) => Parsec e T.Text T.Text -pUntilEof = takeWhileP Nothing (const True) - --- | @'pCmdGeneral' cmd@ parses a general command of the form @!\@. -pCmdGeneral :: (Ord e) => T.Text -> Parsec e T.Text T.Text -pCmdGeneral cmd = pCmd cmd *> space *> pUntilEof - --- | @'pCmdSpecific' cmd name@ parses a specific command of the form @!\ \@\@. -pCmdSpecific :: (Ord e) => T.Text -> T.Text -> Parsec e T.Text T.Text -pCmdSpecific cmd name = pCmd cmd *> space1 *> pNick name *> space *> pUntilEof - --- | @'cmdGeneral' cmd f@ is a general command with no arguments in the form of --- @!cmd@. -cmdGeneral :: T.Text -> (Message -> Client e ()) -> Command e -cmdGeneral cmd f = cmdGeneral' cmd $ \msg -> True <$ f msg - --- | A version of 'cmdGeneral' that allows the command function to decide --- whether the command was successful or not. -cmdGeneral' :: T.Text -> (Message -> Client e Bool) -> Command e -cmdGeneral' cmd f = cmdGeneralArgs' cmd $ \msg args -> if T.null args - then f msg - else pure False - --- | @'cmdGeneralArgs' cmd f@ is a general command with arguments in the form of --- @!cmd args@. @f@ is called with the source message and the arguments as --- 'T.Text'. -cmdGeneralArgs :: T.Text -> (Message -> T.Text -> Client e ()) -> Command e -cmdGeneralArgs cmd f = cmdGeneralArgs' cmd $ \msg args -> True <$ f msg args - --- | A version of 'cmdGeneralArgs' that allows the command function to decide --- whether the command was successful or not. -cmdGeneralArgs' :: T.Text -> (Message -> T.Text -> Client e Bool) -> Command e -cmdGeneralArgs' cmd = cmdMega' (pCmdGeneral cmd :: Parsec () T.Text T.Text) - --- | @'cmdSpecific' cmd nick f@ is a specific command with no arguments in the --- form of @!cmd \@nick@. -cmdSpecific :: T.Text -> T.Text -> (Message -> Client e ()) -> Command e -cmdSpecific cmd name f = cmdSpecific' cmd name $ \msg -> True <$ f msg - --- | A version of 'cmdSpecific' that allows the command function to decide --- whether the command was successful or not. -cmdSpecific' :: T.Text -> T.Text -> (Message -> Client e Bool) -> Command e -cmdSpecific' cmd name f = cmdSpecificArgs' cmd name $ \msg args -> if T.null args - then f msg - else pure False - --- | @'cmdSpecificArgs' cmd nick f@ is a specific command with arguments in the --- form of @!cmd \@nick args@. @f@ is called with the source message and the --- arguments as 'T.Text'. -cmdSpecificArgs :: T.Text -> T.Text -> (Message -> T.Text -> Client e ()) -> Command e -cmdSpecificArgs cmd name f = cmdSpecificArgs' cmd name $ \msg args -> True <$ f msg args - --- | A version of 'cmdSpecificArgs' that allows the command function to decide --- whether the command was successful or not. -cmdSpecificArgs' :: T.Text -> T.Text -> (Message -> T.Text -> Client e Bool) -> Command e -cmdSpecificArgs' cmd name = cmdMega' (pCmdSpecific cmd name :: Parsec () T.Text T.Text) diff --git a/src/Haboli/Euphoria/Example.hs b/src/Haboli/Euphoria/Example.hs new file mode 100644 index 0000000..1435fe9 --- /dev/null +++ b/src/Haboli/Euphoria/Example.hs @@ -0,0 +1,74 @@ +{-# 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 () diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs deleted file mode 100644 index 5c25d2e..0000000 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ /dev/null @@ -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 diff --git a/src/Haboli/Euphoria/Lens.hs b/src/Haboli/Euphoria/Lens.hs deleted file mode 100644 index 7116784..0000000 --- a/src/Haboli/Euphoria/Lens.hs +++ /dev/null @@ -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 diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs deleted file mode 100644 index a9e6d7e..0000000 --- a/src/Haboli/Euphoria/Listing.hs +++ /dev/null @@ -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) diff --git a/src/Haboli/Euphoria/Util.hs b/src/Haboli/Euphoria/Util.hs deleted file mode 100644 index f49335f..0000000 --- a/src/Haboli/Euphoria/Util.hs +++ /dev/null @@ -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 --- ). Passes through all events unmodified. --- --- This utility function is meant to be wrapped directly or indirectly around --- 'nextEvent': --- --- > event <- respondingToPing nextEvent -respondingToPing :: Client e Event -> Client e Event -respondingToPing getEvent = do - event <- getEvent - case event of - EventPing e -> pingReply (pingTime e) - _ -> pure () - pure event - --- | Respond to 'EventBounce's according to the euphoria documentation. If no --- password is provided but an 'EventBounce' is encountered, throw a 'T.Text' --- exception. --- --- This utility function is meant to be wrapped directly or indirectly around --- 'nextEvent': --- --- > event <- respondingToBounce (Just passwd) nextEvent -respondingToBounce :: Maybe T.Text -> Client T.Text Event -> Client T.Text Event -respondingToBounce = respondingToBounce' id - --- | A variant of 'respondingToBounce' that allows wrapping the exception into a --- custom type. -respondingToBounce' :: (T.Text -> e) -> Maybe T.Text -> Client e Event -> Client e Event -respondingToBounce' onError mPasswd getEvent = do - event <- getEvent - case event of - EventBounce e - | Passcode `elem` bounceAuthOption e -> case mPasswd of - Nothing -> throw $ onError "Password required but no password given" - Just passwd -> do - response <- auth passwd - case response of - Left msg -> throw $ onError $ "Could not authenticate: " <> msg - Right () -> pure () - _ -> pure () - pure event - --- | Receive events until both an 'EventHello' and 'EventSnapshot' were --- received, then return those. Throw a 'T.Text' exception if an invalid 'Event' --- was encountered. Valid events are 'EventPing', 'EventBounce', 'EventHello' --- and 'EventSnapshot'. -untilConnected :: Client T.Text Event -> Client T.Text (HelloEvent, SnapshotEvent) -untilConnected = untilConnected' id - --- | A variant of 'untilConnected' that allows wrapping the exception into a --- custom type. -untilConnected' :: (T.Text -> e) -> Client e Event -> Client e (HelloEvent, SnapshotEvent) -untilConnected' onError getEvent = evalStateT helper (Nothing, Nothing) - where - helper = do - event <- lift getEvent - case event of - EventPing _ -> pure () - EventBounce _ -> pure () - EventHello e -> modify $ \(_, s) -> (Just e, s) - EventSnapshot e -> modify $ \(h, _) -> (h, Just e) - _ -> lift $ throw $ onError "Received disallowed packet while connecting" - receivedEvents <- get - case receivedEvents of - (Just h, Just s) -> pure (h, s) - _ -> helper - -{- Nick -} - --- | Modify a nick such that — when prepended with an @\@@ — it will (hopefully) --- ping the person with that nick on euphoria. -nickMention :: T.Text -> T.Text -nickMention name - | T.length name > 1 = T.filter isMentionChar name - | otherwise = name - where - isMentionChar c = not $ isSpace c || c `Set.member` terminatingChars - terminatingChars = Set.fromList ",.!?;&<'\"" - --- | Normalize nicks (for nick comparison purposes) by removing all space --- characters and converting the rest into a case-insensitive representation. -nickNormalize :: T.Text -> T.Text -nickNormalize name - | T.length name > 1 = T.toCaseFold $ T.filter (not . isSpace) name - | otherwise = T.toCaseFold name - --- | Check two nicks for equality by comparing their normalized versions. -nickEqual :: T.Text -> T.Text -> Bool -nickEqual = (==) `on` nickNormalize - -{- Time formatting -} - --- | Convert a 'UTCTime' into the format @yyyy-mm-dd HH:MM:SS@. -formatUTCTime :: UTCTime -> T.Text -formatUTCTime t = T.pack $ formatTime defaultTimeLocale "%F %T" t - --- | Convert a 'NominalDiffTime' into the format @[[[\d ]\h --- ]\m ]\s@ where the square brackets denote optional parts. --- Only those parts required to fully display the time span are output. If the --- 'NominalDiffTime' is negative, a @-@ is prefixed. -formatNominalDiffTime :: NominalDiffTime -> T.Text -formatNominalDiffTime t = (sign <>) $ T.intercalate " " $ map T.pack $ if - | days /= 0 -> [fDays, fHours, fMinutes, fSeconds] - | hours /= 0 -> [ fHours, fMinutes, fSeconds] - | minutes /= 0 -> [ fMinutes, fSeconds] - | otherwise -> [ fSeconds] - where - diffSeconds = round $ nominalDiffTimeToSeconds t :: Integer - sign = if diffSeconds < 0 then "-" else "" - totalSeconds = abs diffSeconds - (days, secondsAfterDays) = totalSeconds `quotRem` (60 * 60 * 24) - (hours, secondsAfterHours) = secondsAfterDays `quotRem` (60 * 60) - (minutes, seconds) = secondsAfterHours `quotRem` 60 - fDays = show days ++ "d" - fHours = show hours ++ "h" - fMinutes = show minutes ++ "m" - fSeconds = show seconds ++ "s" diff --git a/stack.yaml b/stack.yaml index c895dad..0961eec 100644 --- a/stack.yaml +++ b/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 diff --git a/stack.yaml.lock b/stack.yaml.lock index 860760a..16e6de6 100644 --- a/stack.yaml.lock +++ b/stack.yaml.lock @@ -6,7 +6,7 @@ packages: [] snapshots: - completed: - size: 491389 - url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/15/7.yaml - sha256: 92ab6303fe20ec928461c82ce0980b4d17c06f4e66205a2967e476474f686c17 - original: lts-15.7 + size: 524155 + url: https://raw.githubusercontent.com/commercialhaskell/stackage-snapshots/master/lts/14/19.yaml + sha256: 9f79f6494473c9b46911364b94c4b5ef19ca8d35ebf62e46697cf651f198ee19 + original: lts-14.19