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