1 files changed, 101 insertions, 0 deletions
diff --git a/src/Data/UUID/Typed.hs b/src/Data/UUID/Typed.hs
new file mode 100644
index 0000000..78a5b5f
--- /dev/null
+++ b/src/Data/UUID/Typed.hs
@@ -0,0 +1,101 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DeriveDataTypeable #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
+
+module Data.UUID.Typed where
+
+import Control.Monad.IO.Class
+import GHC.Generics
+import Text.Read
+
+import Control.DeepSeq
+import Data.Aeson as JSON
+import Data.Aeson.Types as JSON
+import Data.Binary
+import qualified Data.ByteString as SB
+import qualified Data.ByteString.Lazy as LB
+import Data.Data
+import Data.Hashable
+import qualified Data.Text as T
+import Data.Text (Text)
+import Foreign.Storable
+import System.Random
+import Web.HttpApiData
+
+import Data.Validity
+import Data.Validity.UUID ()
+
+import qualified Data.UUID as UUID
+import qualified Data.UUID.V4 as UUID
+
+newtype UUID a = UUID
+    { unUUID :: UUID.UUID
+    } deriving ( Eq
+               , Ord
+               , Generic
+               , Data
+               , Storable
+               , Binary
+               , NFData
+               , Hashable
+               , Random
+               )
+
+instance Validity (UUID a)
+
+instance Show (UUID a) where
+    show (UUID u) = show u
+
+instance Read (UUID a) where
+    readPrec = UUID <$> readPrec
+
+uuidBs :: UUID a -> SB.ByteString
+uuidBs (UUID uuid) = UUID.toASCIIBytes uuid
+
+uuidLBs :: UUID a -> LB.ByteString
+uuidLBs = LB.fromStrict . uuidBs
+
+uuidString :: UUID a -> String
+uuidString (UUID uuid) = UUID.toString uuid
+
+uuidText :: UUID a -> Text
+uuidText (UUID uuid) = UUID.toText uuid
+
+nextRandomUUID :: MonadIO m => m (UUID a)
+nextRandomUUID = liftIO $ UUID <$> UUID.nextRandom
+
+parseUUID :: Text -> Maybe (UUID a)
+parseUUID = fmap UUID . UUID.fromText
+
+parseUUIDString :: String -> Maybe (UUID a)
+parseUUIDString = fmap UUID . UUID.fromString
+
+instance FromJSONKey (UUID a) where
+    fromJSONKey = FromJSONKeyTextParser textJSONParseUUID
+
+instance ToJSONKey (UUID a) where
+    toJSONKey = toJSONKeyText (UUID.toText . unUUID)
+
+instance FromJSON (UUID a) where
+    parseJSON = jsonParseUUID
+
+jsonParseUUID :: Value -> Parser (UUID a)
+jsonParseUUID = withText "UUID" textJSONParseUUID
+
+textJSONParseUUID :: Text -> Parser (UUID a)
+textJSONParseUUID t =
+    case UUID.fromText t of
+        Nothing -> fail "Invalid Text when parsing UUID"
+        Just u -> pure $ UUID u
+
+instance ToJSON (UUID a) where
+    toJSON (UUID u) = JSON.String $ UUID.toText u
+
+instance FromHttpApiData (UUID a) where
+    parseUrlPiece t =
+        case UUID.fromText t of
+            Nothing -> fail $ "Invalid UUID in Url Piece: " ++ T.unpack t
+            Just uuid -> pure $ UUID uuid
+
+instance ToHttpApiData (UUID a) where
+    toUrlPiece (UUID uuid) = UUID.toText uuid