module Keys.UUID where
import Prelude
import Data.Bits
import Data.Char
import Data.UUID (fromString, toString, toWords, fromWords)
import qualified Data.UUID as U (UUID(..), nil)
import Data.UUID.V4(nextRandom)
import Control.Applicative ((<$>))
import Data.Data
import Data.Hashable
import Control.Monad
import Data.Text (unpack, pack, Text)
import qualified Data.Text as T
import Keys.Random
import Data.SafeCopy
import Data.Serialize
import Web.PathPieces
import Foreign.Storable
import Text.Blaze
import Data.Word
import Data.Aeson
import qualified Data.Aeson as Aeson
newtype UUID = UUID U.UUID
deriving(Ord, Eq, Data, Typeable, Storable)
instance Show UUID where
show = strUUID
instance Read UUID where
readsPrec x y = map (\(a,b) -> (UUID a, b)) $ readsPrec x y
unUUID :: UUID -> U.UUID
unUUID (UUID u) = u
strUUID :: UUID -> String
strUUID (UUID u) = toString u
txtUUID :: UUID -> Text
txtUUID (UUID u) = uuidToText (toWords u)
where
uuidToText :: (Word32, Word32, Word32, Word32) -> Text
uuidToText (w0, w1, w2, w3) = hexw w0 $ hexw' w1 $ hexw' w2 $ hexw w3 T.empty
hexw :: Word32 -> Text -> Text
hexw w s = hexn w 28 `T.cons` hexn w 24 `T.cons` hexn w 20 `T.cons` hexn w 16
`T.cons` hexn w 12 `T.cons` hexn w 8 `T.cons` hexn w 4 `T.cons` hexn w 0 `T.cons` s
hexw' :: Word32 -> Text -> Text
hexw' w s = '-' `T.cons` hexn w 28 `T.cons` hexn w 24 `T.cons` hexn w 20 `T.cons` hexn w 16
`T.cons` '-' `T.cons` hexn w 12 `T.cons` hexn w 8 `T.cons` hexn w 4 `T.cons` hexn w 0 `T.cons` s
hexn :: Word32 -> Int -> Char
hexn w r = intToDigit $ fromIntegral ((w `shiftR` r) .&. 0xf)
nil :: UUID
nil = UUID U.nil
instance Serialize UUID where
put (UUID u) = put $ toWords u
get = (UUID . (\(w1,w2,w3,w4) -> fromWords w1 w2 w3 w4)) `fmap` get
instance HasRandom UUID where
rnd = UUID `fmap` nextRandom
instance ToMarkup UUID where
toMarkup u = toMarkup $ pack $ strUUID u
instance ToJSON UUID where
toJSON u = Aeson.String (txtUUID u)
instance FromJSON UUID where
parseJSON (Aeson.String s) = case fromString (T.unpack s) of
Just u -> return $ UUID u
Nothing -> mzero
parseJSON _ = mzero
instance Hashable UUID where
hashWithSalt i (UUID u) = hashWithSalt i (toWords u)
instance SafeCopy UUID where
putCopy (UUID u) = contain $ safePut $ toWords u
getCopy = contain $ (UUID . (\(a,b,c,d) -> fromWords a b c d) <$> safeGet)
instance PathPiece UUID where
fromPathPiece t = UUID <$> (fromString $ unpack t)
toPathPiece (UUID u) = pack $ toString u