diff --git a/CHANGELOG.md b/CHANGELOG.md index fdc31e0..eaab4e7 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -2,6 +2,7 @@ ## upcoming - add `Haboli.Euphoria.Command` module +- add `Haboli.Euphoria.Util` module and move `respondingToPing` there - clean up project - fix nick of example bot in readme - remove `Haboli.Euphoria.Examples` module diff --git a/haboli.cabal b/haboli.cabal index e663342..5abf0b3 100644 --- a/haboli.cabal +++ b/haboli.cabal @@ -4,7 +4,7 @@ cabal-version: 1.12 -- -- see: https://github.com/sol/hpack -- --- hash: 93e0477ebf814906c7ad7dcd56922b71fa3189833865db6f5d4442811983b1c7 +-- hash: e4041146c275e14c632860cfd7af7b3ac3fe6bf5493f57168143777df245a1cf name: haboli version: 0.3.1.0 @@ -33,6 +33,7 @@ library Haboli.Euphoria.Api Haboli.Euphoria.Client Haboli.Euphoria.Command + Haboli.Euphoria.Util other-modules: Paths_haboli hs-source-dirs: diff --git a/src/Haboli/Euphoria/Client.hs b/src/Haboli/Euphoria/Client.hs index d6f54ea..22b83c8 100644 --- a/src/Haboli/Euphoria/Client.hs +++ b/src/Haboli/Euphoria/Client.hs @@ -27,7 +27,6 @@ module Haboli.Euphoria.Client -- ** Event handling , Event(..) , nextEvent - , respondingToPing -- ** Exception handling , ClientException(..) , throw @@ -316,21 +315,6 @@ nextEvent = do Left e -> throwRaw e Right e -> pure e --- | Respond to 'EventPing's according to the 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 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/Util.hs b/src/Haboli/Euphoria/Util.hs new file mode 100644 index 0000000..1da51a8 --- /dev/null +++ b/src/Haboli/Euphoria/Util.hs @@ -0,0 +1,97 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Haboli.Euphoria.Util + ( + -- * Events + respondingToPing + , respondingToBounce + , respondingToBounce' + , untilConnected + , untilConnected' + -- * Nick + , nickMention + , nickNormalize + , nickEqual + ) 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 Haboli.Euphoria.Api +import Haboli.Euphoria.Client + +{- Events -} + +-- | Respond to 'EventPing's according to the 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 + +respondingToBounce :: Maybe T.Text -> Client T.Text Event -> Client T.Text Event +respondingToBounce = respondingToBounce' id + +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 + +untilConnected :: Client T.Text Event -> Client T.Text (HelloEvent, SnapshotEvent) +untilConnected = untilConnected' id + +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 -} + +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 ",.!?;&<'\"" + +nickNormalize :: T.Text -> T.Text +nickNormalize name + | T.length name > 1 = T.toCaseFold $ T.filter (not . isSpace) name + | otherwise = T.toCaseFold name + +nickEqual :: T.Text -> T.Text -> Bool +nickEqual = (==) `on` nickNormalize