diff options
author | James Crayne <jim.crayne@gmail.com> | 2019-09-28 13:43:29 -0400 |
---|---|---|
committer | Joe Crayne <joe@jerkface.net> | 2020-01-01 19:27:53 -0500 |
commit | 11987749fc6e6d3e53ea737d46d5ab13a16faeb8 (patch) | |
tree | 5716463275c2d3e902889db619908ded2a73971c /Presence/IDMangler.hs | |
parent | add2c76bced51fde5e9917e7449ef52be70faf87 (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.hs | 68 |
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 #-} | ||
16 | module IDMangler | ||
17 | ( IDMangler | ||
18 | , newIDMangler | ||
19 | , generateUniqueID | ||
20 | , unmangleId | ||
21 | ) where | ||
22 | |||
23 | import Control.Monad.STM | ||
24 | import Control.Concurrent.STM | ||
25 | import Data.Text (Text) | ||
26 | import qualified Data.Text as Text | ||
27 | import qualified Data.ByteString.Lazy as LazyByteString | ||
28 | import Data.Binary | ||
29 | import qualified Codec.Binary.Base64 as Base64 | ||
30 | import Control.Monad | ||
31 | import Data.Monoid ( (<>) ) | ||
32 | |||
33 | |||
34 | data IDMangler k | ||
35 | = IDMangler { idmCounter :: TVar Int } | ||
36 | |||
37 | newIDMangler :: IO (IDMangler k) | ||
38 | newIDMangler = 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'. | ||
44 | generateUniqueID :: 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 | ||
49 | generateUniqueID 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. | ||
59 | unmangleId :: Binary k => Text -> (Maybe k, Maybe Text) | ||
60 | unmangleId 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 | |||