summaryrefslogtreecommitdiff
path: root/Presence/IDMangler.hs
diff options
context:
space:
mode:
authorJames Crayne <jim.crayne@gmail.com>2019-09-28 13:43:29 -0400
committerJoe Crayne <joe@jerkface.net>2020-01-01 19:27:53 -0500
commit11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch)
tree5716463275c2d3e902889db619908ded2a73971c /Presence/IDMangler.hs
parentadd2c76bced51fde5e9917e7449ef52be70faf87 (diff)
Factor out some new libraries
word64-map: Data.Word64Map network-addr: Network.Address tox-crypto: Crypto.Tox lifted-concurrent: Control.Concurrent.Lifted.Instrument Control.Concurrent.Async.Lifted.Instrument psq-wrap: Data.Wrapper.PSQInt Data.Wrapper.PSQ minmax-psq: Data.MinMaxPSQ tasks: Control.Concurrent.Tasks kad: Network.Kademlia Network.Kademlia.Bootstrap Network.Kademlia.Routing Network.Kademlia.CommonAPI Network.Kademlia.Persistence Network.Kademlia.Search
Diffstat (limited to 'Presence/IDMangler.hs')
-rw-r--r--Presence/IDMangler.hs68
1 files changed, 0 insertions, 68 deletions
diff --git a/Presence/IDMangler.hs b/Presence/IDMangler.hs
deleted file mode 100644
index 664d4f54..00000000
--- a/Presence/IDMangler.hs
+++ /dev/null
@@ -1,68 +0,0 @@
1---------------------------------------------------------------------------
2-- |
3-- Module : IDMangler
4--
5-- This library is useful for generating id attributes for use in an XMPP
6-- application. It conveniently encodes a key value for looking up context and
7-- an original id attribute in case of forwarded messages.
8--
9-- For example, an id attribute with an embedded 'XMPPServer.ConnectionKey'
10-- for a forwarded message with an original id attribute of \"purplecfa6168a\"
11-- might look something like this:
12--
13-- > AAAAAAAAAAIBksnqOQiYmtmupcLxbXakI9zcmUl4:purplecfa6168a
14--
15{-# LANGUAGE OverloadedStrings #-}
16module IDMangler
17 ( IDMangler
18 , newIDMangler
19 , generateUniqueID
20 , unmangleId
21 ) where
22
23import Control.Monad.STM
24import Control.Concurrent.STM
25import Data.Text (Text)
26import qualified Data.Text as Text
27import qualified Data.ByteString.Lazy as LazyByteString
28import Data.Binary
29import qualified Codec.Binary.Base64 as Base64
30import Control.Monad
31import Data.Monoid ( (<>) )
32
33
34data IDMangler k
35 = IDMangler { idmCounter :: TVar Int }
36
37newIDMangler :: IO (IDMangler k)
38newIDMangler = do
39 nv <- atomically $ newTVar 0
40 return $ IDMangler nv
41
42-- | Use the given state and optional data to generate a unique id attribute
43-- suitable for xml. To recover the optional encoded data, see 'unmangleId'.
44generateUniqueID :: Binary k =>
45 IDMangler k -- ^ the state (a counter) for ensuring uniqueness
46 -> Maybe k -- ^ optional recoverable key for context
47 -> Maybe Text -- ^ optional recoverable auxilary id attribute
48 -> IO Text -- ^ unique id attribute with encoded data
49generateUniqueID mangler mkey mid = do
50 n <- atomically $ do
51 modifyTVar' (idmCounter mangler) (+1)
52 readTVar (idmCounter mangler)
53 let bs = encode (n,mkey)
54 base64 = Base64.encode (LazyByteString.unpack bs)
55 suf = maybe "" (":" <>) mid
56 return $ Text.pack base64 <> suf
57
58-- | Recover data from an encoded id attribute.
59unmangleId :: Binary k => Text -> (Maybe k, Maybe Text)
60unmangleId encoded = (k,mid)
61 where
62 (e,postcolon) = Text.span (/=':') encoded
63 bytes = Base64.decode (Text.unpack e)
64 decoded = fmap (decode . LazyByteString.pack) bytes
65 k = decoded >>= (\(n,k) -> let _ = n :: Int in k)
66 mid = do guard (not . Text.null $ postcolon)
67 return $ Text.drop 1 postcolon
68