blob: 664d4f54d40025ba2204136b2eb78dac59669989 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
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
|
