special-keys-0.1.0.0: Keys/UUID.hs

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

import Prelude
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.Aeson.Types (FromJSON(..), ToJSON(..), typeMismatch)
-- import qualified Data.Aeson.Types as Aeson (Value(String))
-- import Data.Text.Encoding (encodeUtf8, decodeUtf8)
-- import Control.Monad(mzero)
import Data.Data
import Data.Hashable
import Data.Text (unpack, pack)
import Keys.Random
import Data.SafeCopy
import Data.Serialize
import Web.PathPieces
import Foreign.Storable
import Text.Blaze

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

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

{- these can be useful in postgresql-simple:
instance FromField UUID where
    fromField f bs = 
        case bs of
            Nothing -> returnError UnexpectedNull f ""
            -- Parse the string values in the enum of sql/tableAuth.sql
            Just s -> case fromString . unpack . decodeUtf8 $ s of
                        Just uuid -> pure $ UUID $ uuid
                        Nothing -> returnError ConversionFailed f $ 
                            "UUID must be a 16 bytes long ByteString in network byte order. Input UUID was: " ++ 
                                (unpack (decodeUtf8 s))
instance ToField UUID where
    toField (UUID u) = Escape . encodeUtf8 . pack . toString $ u
    -}

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 :: Text -> Maybe s
    fromPathPiece t = UUID <$> (fromString $ unpack t)
    -- toPathPiece :: s -> Text
    toPathPiece (UUID u) = pack $ toString u