Add a few utility functions

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

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:

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