From 822bb9efadae6949e89f49bd5a0ab7c0de514e8e Mon Sep 17 00:00:00 2001 From: Joscha Date: Thu, 9 Apr 2020 10:40:24 +0000 Subject: [PATCH] Add lenses to listing and use them in the example bot --- src/Haboli/Euphoria/ExampleBot.hs | 37 +++++++++------- src/Haboli/Euphoria/Listing.hs | 74 ++++++++++++++++++++----------- 2 files changed, 70 insertions(+), 41 deletions(-) diff --git a/src/Haboli/Euphoria/ExampleBot.hs b/src/Haboli/Euphoria/ExampleBot.hs index 9012eab..f4059d8 100644 --- a/src/Haboli/Euphoria/ExampleBot.hs +++ b/src/Haboli/Euphoria/ExampleBot.hs @@ -1,7 +1,13 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} -- | This module contains an example implementation of a small bot. It is a good -- starting point if you want to create your own bot. +-- +-- The example bot uses lenses for its state because they vastly reduce the +-- amount of code required to update the 'Listing' inside the state. It is +-- entirely possible to use haboli without lenses though, should you want to do +-- that. module Haboli.Euphoria.ExampleBot ( exampleBot @@ -14,15 +20,19 @@ import Data.List import qualified Data.Map.Strict as Map import qualified Data.Text as T import Data.Time +import Lens.Micro +import Lens.Micro.TH import Haboli.Euphoria import Haboli.Euphoria.Botrulez data BotState = BotState - { botStartTime :: UTCTime - , botListing :: Listing + { _botStartTime :: UTCTime + , _botListing :: Listing } deriving (Show) +makeLenses ''BotState + -- | A small example bot. Takes a room password as its first argument. You can -- run this bot in [&test](https://euphoria.io/room/test) like this: -- @@ -33,27 +43,27 @@ exampleBot mPasswd = do initialEvents <- untilConnected $ respondingToBounce mPasswd $ respondingToPing nextEvent - listing <- preferNick "ExampleBot" $ newListing initialEvents - stateVar <- liftIO $ newMVar $ BotState startTime listing + let initialState = BotState startTime $ newListing initialEvents + stateVar <- liftIO $ newMVar initialState + preferNickVia botListing stateVar "ExampleBot" botMain stateVar botMain :: MVar BotState -> Client T.Text () botMain stateVar = forever $ do event <- respondingToCommands (getCommands stateVar) $ respondingToPing nextEvent - -- Update the listing - liftIO $ modifyMVar_ stateVar $ \state -> - pure state{botListing = updateFromEvent event $ botListing state} + updateFromEventVia botListing stateVar event getCommands :: MVar BotState -> Client e [Command T.Text] getCommands stateVar = do state <- liftIO $ readMVar stateVar - let name = svNick $ self $ botListing state + let name = state ^. botListing . lsSelfL . svNickL pure [ botrulezPingGeneral , botrulezPingSpecific name - , botrulezHelpSpecific name "I am an example bot for https://github.com/Garmelon/haboli/." - , botrulezUptimeSpecific name $ botStartTime state + , botrulezHelpSpecific name + "I am an example bot for https://github.com/Garmelon/haboli/." + , botrulezUptimeSpecific name $ state ^. botStartTime , botrulezKillSpecific name , cmdSpecific "hug" name $ \msg -> void $ reply msg "/me hugs back" , cmdHello @@ -68,15 +78,12 @@ cmdHello = cmdGeneral "hello" $ \msg -> do cmdNick :: MVar BotState -> T.Text -> Command e cmdNick stateVar name = cmdSpecificArgs "nick" name $ \msg args -> do - -- Update the listing while updating the nick - state <- liftIO $ takeMVar stateVar - listing' <- preferNick args $ botListing state - liftIO $ putMVar stateVar state{botListing = listing'} + preferNickVia botListing stateVar args void $ reply msg "Is this better?" cmdWho :: MVar BotState -> Command e cmdWho stateVar = cmdGeneral "who" $ \msg -> do state <- liftIO $ readMVar stateVar - let people = others $ botListing state + let people = state ^. botListing . lsOthersL nicks = sort $ map svNick $ Map.elems people void $ reply msg $ T.intercalate "\n" nicks diff --git a/src/Haboli/Euphoria/Listing.hs b/src/Haboli/Euphoria/Listing.hs index 4f65218..a9e6d7e 100644 --- a/src/Haboli/Euphoria/Listing.hs +++ b/src/Haboli/Euphoria/Listing.hs @@ -1,34 +1,49 @@ {-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE TemplateHaskell #-} -- | A 'Listing' helps keep track of a bot's own 'SessionView' as well as all -- other clients connected to a room. It must be kept up-to-date manually. module Haboli.Euphoria.Listing - ( Listing + ( Listing(..) + , lsSelfL + , lsOthersL , newListing - , self - , others , updateOwnNick , preferNick + , preferNickVia , updateFromList + , updateFromListVia , updateFromEvent + , updateFromEventVia ) where +import Control.Concurrent +import Control.Monad.IO.Class import qualified Data.Map.Strict as Map import Data.Maybe import qualified Data.Text as T +import Lens.Micro import Haboli.Euphoria.Api import Haboli.Euphoria.Client +import Haboli.Euphoria.Lens --- | A listing contains a bot's own 'SessionView' (accessible via 'self') and a +-- | A listing contains a bot's own 'SessionView' (accessible via 'lsSelf') and a -- map of all other clients currently connected to the room (accessible via --- 'others'). The latter never includes the bot itself. +-- 'lsOthers'). The latter never includes the bot itself. data Listing = Listing { lsSelf :: SessionView + -- ^ The 'SessionView' describing the bot itself. , lsOthers :: Map.Map UserId SessionView + -- ^ The 'SessionView's describing the other clients connected to the current + -- room. Does not include the bot's own 'SessionView' (use 'lsSelf' to access + -- that). } deriving (Show) +makeLensesL ''Listing + othersFromList :: [SessionView] -> Map.Map UserId SessionView othersFromList sessions = Map.fromList [(svId sv, sv) | sv <- sessions] @@ -39,29 +54,28 @@ newListing (h, s) = Listing , lsOthers = othersFromList $ snapshotListing s } --- | The 'SessionView' describing the bot itself. -self :: Listing -> SessionView -self = lsSelf - --- | The 'SessionView's describing the other clients connected to the current --- room. Does not include the bot's own 'SessionView' (use 'self' to access --- that). -others :: Listing -> Map.Map UserId SessionView -others = lsOthers - -- | Set the bot's own nick to a new nick. updateOwnNick :: T.Text -> Listing -> Listing -updateOwnNick name listing = listing{lsSelf = (lsSelf listing){svNick = name}} +updateOwnNick name = lsSelfL . svNickL .~ name -- | Set the bot's nick and update the 'Listing' with the server's reply in one -- go. preferNick :: T.Text -> Listing -> Client e Listing preferNick name listing - | name == svNick (self listing) = pure listing + | name == listing ^. lsSelfL . svNickL = pure listing | otherwise = do (_, newNick) <- nick name pure $ updateOwnNick newNick listing +-- | Like 'preferNick', but updates a 'Listing' inside a data type inside an +-- 'MVar'. +preferNickVia :: Lens' a Listing -> MVar a -> T.Text -> Client e () +preferNickVia field mvar name = do + a <- liftIO $ takeMVar mvar + listing' <- preferNick name $ a ^. field + let a' = a & field .~ listing' + liftIO $ putMVar mvar a' + -- | Update a 'Listing' from a list of sessions currently connected to the room. -- Afterwards, the 'Listing' will contain only those sessions present in the -- list. @@ -73,22 +87,30 @@ updateFromList sessions listing = newOthers = Map.filterWithKey (\k _ -> k /= ownId) others' in Listing newSelf newOthers -onJoin :: SessionView -> Listing -> Listing -onJoin sv listing = listing{lsOthers = Map.insert (svId sv) sv $ lsOthers listing} - -onPart :: SessionView -> Listing -> Listing -onPart sv listing = listing{lsOthers = Map.delete (svId sv) $ lsOthers listing} +-- | Like 'updateFromList', but updates a 'Listing' inside a data type inside an +-- 'MVar'. +updateFromListVia :: Lens' a Listing -> MVar a -> [SessionView] -> Client e () +updateFromListVia field mvar list = + liftIO $ modifyMVar_ mvar $ pure . (field %~ updateFromList list) -- | Update a 'Listing' based on an 'Event'. Follows the euphoria documentation -- for 'JoinEvent', 'PartEvent' and 'NetworkEvent'. updateFromEvent :: Event -> Listing -> Listing -updateFromEvent (EventJoin e) listing = onJoin (joinSession e) listing -updateFromEvent (EventPart e) listing = onPart (partSession e) listing +updateFromEvent (EventJoin e) listing = + let sv = joinSession e + in listing & lsOthersL %~ Map.insert (svId sv) sv +updateFromEvent (EventPart e) listing = + let sv = partSession e + in listing & lsOthersL %~ Map.delete (svId sv) updateFromEvent (EventNetwork e) listing | networkType e == "partition" = let sId = networkServerId e sEra = networkServerEra e isAffected sv = svServerId sv == sId && svServerEra sv == sEra - others' = Map.filter (not . isAffected) $ lsOthers listing - in listing{lsOthers = others'} + in listing & lsOthersL %~ Map.filter (not . isAffected) updateFromEvent _ listing = listing +-- | Like 'updateFromEvent', but updates a 'Listing' inside a data type inside +-- an 'MVar'. +updateFromEventVia :: Lens' a Listing -> MVar a -> Event -> Client e () +updateFromEventVia field mvar event = + liftIO $ modifyMVar_ mvar $ pure . (field %~ updateFromEvent event)