module Data.UID (
UID,
newUID,
newUIDString,
fromBase32,
toBase32)
where
import Codec.Binary.Base32 as B32
import Control.Applicative (pure)
import Control.Exception
import Data.Aeson
import qualified Data.ByteString.Lazy as BL
import Data.Char (toLower,toUpper)
import Data.Maybe
import Data.Serialize
import Data.Text (pack,unpack)
import Data.Typeable
import Data.UUID
import Data.UUID.V4
data UID = UID UUID deriving (Eq,Typeable)
instance Serialize UID where
put (UID uuid) = do
put $ toByteString uuid
get = do
bs <- getByteString 16
return $ UID $ fromJust $ fromByteString $ BL.fromStrict bs
toBase32 :: UID -> String
toBase32 (UID uuid) = let encoding = B32.encode $ BL.unpack $ toByteString uuid
except c = c /= '='
in map toLower $ filter except encoding
data InvalidUIDException = InvalidUIDException String deriving (Show,Typeable)
instance Exception InvalidUIDException
fromBase32 :: String -> UID
fromBase32 s = let extended = map toUpper $ s ++ (replicate paddingSize '=')
paddingSize = if (length s) < 32 then (32 (length s)) else 0
decoded = B32.decode $ extended
bs = fromByteString $ BL.pack $
if (isJust decoded)
then fromJust decoded
else (throw $ InvalidUIDException s)
in UID $
if (isJust bs)
then fromJust bs
else throw $ InvalidUIDException s
instance Show UID where
show u = "UID " ++ toBase32 u
instance ToJSON UID where
toJSON u = String $ pack $ toBase32 u
instance FromJSON UID where
parseJSON = withText "Base32" $ pure . fromBase32 . unpack
newUID :: IO UID
newUID = do
uuid <- nextRandom
return $ UID uuid
newUIDString :: IO String
newUIDString = do
uid <- newUID
return $ toBase32 uid