1 files changed, 68 insertions, 0 deletions

diff --git a/Presence/IDMangler.hs b/Presence/IDMangler.hs
new file mode 100644
index 00000000..664d4f54
--- /dev/null
+++ b/Presence/IDMangler.hs
@@ -0,0 +1,68 @@
+---------------------------------------------------------------------------
+-- |
+-- Module : IDMangler
+--
+-- This library is useful for generating id attributes for use in an XMPP
+-- application.  It conveniently encodes a key value for looking up context and
+-- an original id attribute in case of forwarded messages.
+--
+-- For example, an id attribute with an embedded 'XMPPServer.ConnectionKey'
+-- for a forwarded message with an original id attribute of \"purplecfa6168a\"
+-- might look something like this:
+--
+-- > AAAAAAAAAAIBksnqOQiYmtmupcLxbXakI9zcmUl4:purplecfa6168a
+--
+{-# LANGUAGE OverloadedStrings #-}
+module IDMangler
+    ( IDMangler
+    , newIDMangler
+    , generateUniqueID
+    , unmangleId
+    ) where
+
+import Control.Monad.STM
+import Control.Concurrent.STM
+import Data.Text (Text)
+import qualified Data.Text as Text
+import qualified Data.ByteString.Lazy as LazyByteString
+import Data.Binary
+import qualified Codec.Binary.Base64 as Base64
+import Control.Monad
+import Data.Monoid ( (<>) )
+
+
+data IDMangler k
+ = IDMangler { idmCounter :: TVar Int }
+
+newIDMangler :: IO (IDMangler k)
+newIDMangler = do
+    nv <- atomically $ newTVar 0
+    return $ IDMangler nv
+
+-- | Use the given state and optional data to generate a unique id attribute
+-- suitable for xml.  To recover the optional encoded data, see 'unmangleId'.
+generateUniqueID :: Binary k =>
+    IDMangler k   -- ^ the state (a counter) for ensuring uniqueness
+    -> Maybe k    -- ^ optional recoverable key for context
+    -> Maybe Text -- ^ optional recoverable auxilary id attribute
+    -> IO Text    -- ^ unique id attribute with encoded data
+generateUniqueID mangler mkey mid = do
+    n <- atomically $ do
+        modifyTVar' (idmCounter mangler) (+1)
+        readTVar (idmCounter mangler)
+    let bs = encode (n,mkey)
+        base64 = Base64.encode (LazyByteString.unpack bs)
+        suf = maybe "" (":" <>) mid
+    return $ Text.pack base64 <> suf
+
+-- | Recover data from an encoded id attribute.
+unmangleId :: Binary k => Text -> (Maybe k, Maybe Text)
+unmangleId encoded = (k,mid)
+ where
+    (e,postcolon) = Text.span (/=':') encoded
+    bytes = Base64.decode (Text.unpack e)
+    decoded = fmap (decode . LazyByteString.pack) bytes
+    k = decoded >>= (\(n,k) -> let _ = n :: Int in k)
+    mid = do guard (not . Text.null $ postcolon)
+             return $ Text.drop 1 postcolon
+