UUID.hs

{-# LANGUAGE OverloadedStrings, TemplateHaskell, DeriveDataTypeable, TypeFamilies, GeneralizedNewtypeDeriving #-}
module Data.Indexation.UUID where

import Data.UUID (fromString)
import Data.UUID.V4 (nextRandom)
import qualified Data.UUID as U 
import Data.SafeCopy
import Data.Text (unpack, Text)
import qualified Data.Text as T
import Control.Applicative ((<$>))
import Web.PathPieces
import Data.Aeson
import qualified Data.Aeson as Aeson
import Text.Blaze(ToMarkup(..))
import Data.Bits (shiftR, (.&.), (.|.), shiftL)
import Control.Monad (mzero)
import Data.Char (intToDigit, isHexDigit, digitToInt)
import Data.Word(Word32)
-- Imports for deriving
import Data.Data
import Data.Hashable
import Control.DeepSeq (NFData(..))
import Foreign.Storable
import Data.Serialize
import Data.ByteString.Lazy (ByteString)

newtype UUID = UUID U.UUID
    deriving(Ord, Eq, Data, Typeable, Storable, NFData, Show, Read)

rndUUID :: IO UUID
rndUUID = nextRandom >>= return . UUID

unUUID :: UUID -> U.UUID
unUUID (UUID u) = u

nil :: UUID
nil = UUID U.nil

fromLazyASCIIBytes :: ByteString -> Maybe UUID
fromLazyASCIIBytes bs = UUID `fmap` U.fromLazyASCIIBytes bs

toLazyASCIIBytes :: UUID -> ByteString
toLazyASCIIBytes (UUID u) = U.toLazyASCIIBytes u

toText :: UUID -> Text
toText = txtUUID

fromText :: Text -> Maybe UUID
fromText = uuidTxt

fromWords :: Word32 -> Word32 -> Word32 -> Word32 -> UUID
fromWords w1 w2 w3 w4 = UUID (U.fromWords w1 w2 w3 w4)

toWords :: UUID -> (Word32, Word32, Word32, Word32)
toWords (UUID u) = U.toWords u

txtUUID :: UUID -> Text
txtUUID (UUID u) = uuidToText (U.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)

uuidTxt :: Text -> Maybe UUID
uuidTxt t0 = do 
    (w0, t1) <- hexWord t0
    (w1, t2) <- hexWord t1
    (w2, t3) <- hexWord t2
    (w3, t4) <- hexWord t3
    if T.null t4 
        then Just $ UUID $ U.fromWords w0 w1 w2 w3
        else Nothing
    where hexWord :: Text -> Maybe (Word32, Text)
          hexWord s = Just (0, s) >>= hexByte >>= hexByte
                                  >>= hexByte >>= hexByte

          hexByte :: (Word32, Text) -> Maybe (Word32, Text)
          hexByte (w, txt) = if T.null txt then Nothing else 
            if T.head txt == '-'
                then hexByte (w, T.tail txt)
                else let hi = T.head txt
                         lo = T.head $ T.tail txt
                         ds = T.tail $ T.tail txt
                         bothHex = isHexDigit hi && isHexDigit lo
                         octet = fromIntegral (16 * digitToInt hi + digitToInt lo)
                     in if bothHex then Just ((w `shiftL` 8) .|. octet, ds)
                                   else Nothing

instance Hashable UUID where
    hash (UUID u) = hash u
    hashWithSalt s (UUID u) = hashWithSalt s u

instance SafeCopy UUID where
    putCopy (UUID u) = contain $ safePut $ U.toWords u
    getCopy = contain $ (UUID . (\(a,b,c,d) -> U.fromWords a b c d) <$> safeGet)

instance PathPiece UUID where
    fromPathPiece t = UUID <$> (fromString $ unpack t)
    toPathPiece = txtUUID

instance ToMarkup UUID where
    toMarkup u = toMarkup $ txtUUID 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 Serialize UUID where
    put (UUID u) = put $ U.toWords u
    get = (UUID . (\(w1,w2,w3,w4) -> U.fromWords w1 w2 w3 w4)) `fmap` get