-
Notifications
You must be signed in to change notification settings - Fork 721
/
SerialiseUsing.hs
137 lines (111 loc) · 5.05 KB
/
SerialiseUsing.hs
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
119
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
{-# LANGUAGE ScopedTypeVariables #-}
-- | Raw binary serialisation
--
module Cardano.Api.SerialiseUsing
( UsingRawBytes(..)
, UsingRawBytesHex(..)
, UsingBech32(..)
) where
import Prelude
import qualified Data.Aeson.Types as Aeson
import Data.ByteString (ByteString)
import qualified Data.ByteString.Base16 as Base16
import qualified Data.ByteString.Char8 as BSC
import Data.String (IsString (..))
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Typeable (Typeable, tyConName, typeRep, typeRepTyCon)
import Cardano.Api.Error
import Cardano.Api.HasTypeProxy
import Cardano.Api.SerialiseBech32
import Cardano.Api.SerialiseCBOR
import Cardano.Api.SerialiseJSON
import Cardano.Api.SerialiseRaw
-- | For use with @deriving via@, to provide 'ToCBOR' and 'FromCBOR' instances,
-- based on the 'SerialiseAsRawBytes' instance.
--
-- > deriving (ToCBOR, FromCBOR) via (UsingRawBytes Blah)
--
newtype UsingRawBytes a = UsingRawBytes a
instance (SerialiseAsRawBytes a, Typeable a) => ToCBOR (UsingRawBytes a) where
toCBOR (UsingRawBytes x) = toCBOR (serialiseToRawBytes x)
instance (SerialiseAsRawBytes a, Typeable a) => FromCBOR (UsingRawBytes a) where
fromCBOR = do
bs <- fromCBOR
case deserialiseFromRawBytes ttoken bs of
Just x -> return (UsingRawBytes x)
Nothing -> fail ("cannot deserialise as a " ++ tname)
where
ttoken = proxyToAsType (Proxy :: Proxy a)
tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a)
-- | For use with @deriving via@, to provide instances for any\/all of 'Show',
-- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a hex
-- encoding, based on the 'SerialiseAsRawBytes' instance.
--
-- > deriving (Show, IsString) via (UsingRawBytesHex Blah)
-- > deriving (ToJSON, FromJSON) via (UsingRawBytesHex Blah)
-- > deriving (ToJSONKey, FromJSONKey) via (UsingRawBytesHex Blah)
--
newtype UsingRawBytesHex a = UsingRawBytesHex a
instance SerialiseAsRawBytes a => Show (UsingRawBytesHex a) where
show (UsingRawBytesHex x) = show (serialiseToRawBytesHex x)
instance SerialiseAsRawBytes a => IsString (UsingRawBytesHex a) where
fromString = either error id . deserialiseFromRawBytesBase16 . BSC.pack
instance SerialiseAsRawBytes a => ToJSON (UsingRawBytesHex a) where
toJSON (UsingRawBytesHex x) = toJSON (serialiseToRawBytesHexText x)
instance (SerialiseAsRawBytes a, Typeable a) => FromJSON (UsingRawBytesHex a) where
parseJSON =
Aeson.withText tname $
either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8
where
tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a)
instance SerialiseAsRawBytes a => ToJSONKey (UsingRawBytesHex a) where
toJSONKey =
Aeson.toJSONKeyText $ \(UsingRawBytesHex x) -> serialiseToRawBytesHexText x
instance
(SerialiseAsRawBytes a, Typeable a) => FromJSONKey (UsingRawBytesHex a) where
fromJSONKey =
Aeson.FromJSONKeyTextParser $
either fail pure . deserialiseFromRawBytesBase16 . Text.encodeUtf8
deserialiseFromRawBytesBase16 ::
SerialiseAsRawBytes a => ByteString -> Either String (UsingRawBytesHex a)
deserialiseFromRawBytesBase16 str =
case Base16.decode str of
Right raw -> case deserialiseFromRawBytes ttoken raw of
Just x -> Right (UsingRawBytesHex x)
Nothing -> Left ("cannot deserialise " ++ show str)
Left msg -> Left ("invalid hex " ++ show str ++ ", " ++ msg)
where
ttoken = proxyToAsType (Proxy :: Proxy a)
-- | For use with @deriving via@, to provide instances for any\/all of 'Show',
-- 'IsString', 'ToJSON', 'FromJSON', 'ToJSONKey', FromJSONKey' using a bech32
-- encoding, based on the 'SerialiseAsBech32' instance.
--
-- > deriving (Show, IsString) via (UsingBech32 Blah)
-- > deriving (ToJSON, FromJSON) via (UsingBech32 Blah)
-- > deriving (ToJSONKey, FromJSONKey) via (UsingBech32 Blah)
--
newtype UsingBech32 a = UsingBech32 a
instance SerialiseAsBech32 a => Show (UsingBech32 a) where
show (UsingBech32 x) = show (serialiseToBech32 x)
instance SerialiseAsBech32 a => IsString (UsingBech32 a) where
fromString str =
case deserialiseFromBech32 ttoken (Text.pack str) of
Right x -> UsingBech32 x
Left e -> error ("fromString: " ++ show str ++ ": " ++ displayError e)
where
ttoken :: AsType a
ttoken = proxyToAsType Proxy
instance SerialiseAsBech32 a => ToJSON (UsingBech32 a) where
toJSON (UsingBech32 x) = toJSON (serialiseToBech32 x)
instance (SerialiseAsBech32 a, Typeable a) => FromJSON (UsingBech32 a) where
parseJSON =
Aeson.withText tname $ \str ->
case deserialiseFromBech32 ttoken str of
Right x -> return (UsingBech32 x)
Left e -> fail (show str ++ ": " ++ displayError e)
where
ttoken = proxyToAsType (Proxy :: Proxy a)
tname = (tyConName . typeRepTyCon . typeRep) (Proxy :: Proxy a)
instance SerialiseAsBech32 a => ToJSONKey (UsingBech32 a)
instance (SerialiseAsBech32 a, Typeable a) => FromJSONKey (UsingBech32 a)