1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
|
{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
module Data.UUID.Typed
( UUID (..),
uuidText,
uuidString,
uuidASCIIBytes,
uuidLazyASCIIBytes,
nextRandomUUID,
parseUUIDText,
parseUUIDString,
parseUUIDAsciiBytes,
parseUUIDLazyAsciiBytes,
)
where
import Control.DeepSeq
import Control.Monad.IO.Class
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 qualified Data.UUID as UUID
import qualified Data.UUID.V4 as UUID
import Data.Validity
import Data.Validity.UUID ()
import Foreign.Storable
import GHC.Generics
import System.Random
import Text.Read
import Web.HttpApiData
import YamlParse.Applicative (YamlKeySchema (..), YamlSchema (..), extraParser, viaYamlSchema)
newtype UUID a
= UUID
{ unUUID :: UUID.UUID
}
deriving (Eq, Ord, Generic, Data, Storable, Binary, NFData, Hashable, Random, Show, Read, Validity)
-- | See 'UUID.toText'
uuidText :: UUID a -> Text
uuidText (UUID uuid) = UUID.toText uuid
-- | See 'UUID.toString'
uuidString :: UUID a -> String
uuidString (UUID uuid) = UUID.toString uuid
-- | See 'UUID.toASCIIBytes'
uuidASCIIBytes :: UUID a -> SB.ByteString
uuidASCIIBytes (UUID uuid) = UUID.toASCIIBytes uuid
-- | See 'UUID.toLazyASCIIBytes'
uuidLazyASCIIBytes :: UUID a -> LB.ByteString
uuidLazyASCIIBytes (UUID uuid) = UUID.toLazyASCIIBytes uuid
-- | See 'UUID.nextRandom'
nextRandomUUID :: MonadIO m => m (UUID a)
nextRandomUUID = liftIO $ UUID <$> UUID.nextRandom
-- | See 'UUID.fromText'
parseUUIDText :: Text -> Maybe (UUID a)
parseUUIDText = fmap UUID . UUID.fromText
-- | See 'UUID.fromString'
parseUUIDString :: String -> Maybe (UUID a)
parseUUIDString = fmap UUID . UUID.fromString
-- | See 'UUID.parseUUIDAsciiBytes'
parseUUIDAsciiBytes :: SB.ByteString -> Maybe (UUID a)
parseUUIDAsciiBytes = fmap UUID . UUID.fromASCIIBytes
-- | See 'UUID.parseUUIDLazyAsciiBytes'
parseUUIDLazyAsciiBytes :: LB.ByteString -> Maybe (UUID a)
parseUUIDLazyAsciiBytes = fmap UUID . UUID.fromLazyASCIIBytes
instance FromJSONKey (UUID a) where
fromJSONKey = FromJSONKeyTextParser textJSONParseUUID
instance ToJSONKey (UUID a) where
toJSONKey = toJSONKeyText (UUID.toText . unUUID)
instance FromJSON (UUID a) where
parseJSON = viaYamlSchema
instance YamlSchema (UUID a) where
yamlSchema = extraParser textJSONParseUUID yamlSchema
instance YamlKeySchema (UUID a) where
yamlKeySchema = extraParser textJSONParseUUID yamlKeySchema
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 -> Left $ "Invalid UUID in Url Piece: " <> t
Just uuid -> pure $ UUID uuid
instance ToHttpApiData (UUID a) where
toUrlPiece (UUID uuid) = UUID.toText uuid
|
