/
Types.hs
807 lines (639 loc) · 25.9 KB
/
Types.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
138
139
140
141
142
143
144
145
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161
162
163
164
165
166
167
168
169
170
171
172
173
174
175
176
177
178
179
180
181
182
183
184
185
186
187
188
189
190
191
192
193
194
195
196
197
198
199
200
201
202
203
204
205
206
207
208
209
210
211
212
213
214
215
216
217
218
219
220
221
222
223
224
225
226
227
228
229
230
231
232
233
234
235
236
237
238
239
240
241
242
243
244
245
246
247
248
249
250
251
252
253
254
255
256
257
258
259
260
261
262
263
264
265
266
267
268
269
270
271
272
273
274
275
276
277
278
279
280
281
282
283
284
285
286
287
288
289
290
291
292
293
294
295
296
297
298
299
300
301
302
303
304
305
306
307
308
309
310
311
312
313
314
315
316
317
318
319
320
321
322
323
324
325
326
327
328
329
330
331
332
333
334
335
336
337
338
339
340
341
342
343
344
345
346
347
348
349
350
351
352
353
354
355
356
357
358
359
360
361
362
363
364
365
366
367
368
369
370
371
372
373
374
375
376
377
378
379
380
381
382
383
384
385
386
387
388
389
390
391
392
393
394
395
396
397
398
399
400
401
402
403
404
405
406
407
408
409
410
411
412
413
414
415
416
417
418
419
420
421
422
423
424
425
426
427
428
429
430
431
432
433
434
435
436
437
438
439
440
441
442
443
444
445
446
447
448
449
450
451
452
453
454
455
456
457
458
459
460
461
462
463
464
465
466
467
468
469
470
471
472
473
474
475
476
477
478
479
480
481
482
483
484
485
486
487
488
489
490
491
492
493
494
495
496
497
498
499
500
501
502
503
504
505
506
507
508
509
510
511
512
513
514
515
516
517
518
519
520
521
522
523
524
525
526
527
528
529
530
531
532
533
534
535
536
537
538
539
540
541
542
543
544
545
546
547
548
549
550
551
552
553
554
555
556
557
558
559
560
561
562
563
564
565
566
567
568
569
570
571
572
573
574
575
576
577
578
579
580
581
582
583
584
585
586
587
588
589
590
591
592
593
594
595
596
597
598
599
600
601
602
603
604
605
606
607
608
609
610
611
612
613
614
615
616
617
618
619
620
621
622
623
624
625
626
627
628
629
630
631
632
633
634
635
636
637
638
639
640
641
642
643
644
645
646
647
648
649
650
651
652
653
654
655
656
657
658
659
660
661
662
663
664
665
666
667
668
669
670
671
672
673
674
675
676
677
678
679
680
681
682
683
684
685
686
687
688
689
690
691
692
693
694
695
696
697
698
699
700
701
702
703
704
705
706
707
708
709
710
711
712
713
714
715
716
717
718
719
720
721
722
723
724
725
726
727
728
729
730
731
732
733
734
735
736
737
738
739
740
741
742
743
744
745
746
747
748
749
750
751
752
753
754
755
756
757
758
759
760
761
762
763
764
765
766
767
768
769
770
771
772
773
774
775
776
777
778
779
780
781
782
783
784
785
786
787
788
789
790
791
792
793
794
795
796
797
798
799
800
801
802
803
804
805
806
807
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE ViewPatterns #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
-- |
-- Copyright: © 2018-2023 IOHK
-- License: Apache-2.0
--
-- This module contains instances and types necessary for storing wallets in a
-- SQL database with Persistent.
--
-- It's in a separate module due to the GHC stage restriction.
--
-- The ToJSON/FromJSON and Read instance orphans exist due to class constraints
-- on Persistent functions.
module Cardano.Wallet.DB.Sqlite.Types where
import Prelude
import Cardano.Address.Script
( Cosigner, Script, ScriptHash (..) )
import Cardano.Api
( TxMetadataJsonSchema (..)
, displayError
, metadataFromJson
, metadataToJson
)
import Cardano.Pool.Types
( PoolId )
import Cardano.Slotting.Slot
( SlotNo (..) )
import Cardano.Wallet.Address.Derivation
( Role (..) )
import Cardano.Wallet.Address.Discovery.Sequential
( AddressPoolGap (..)
, DerivationPrefix
, getAddressPoolGap
, mkAddressPoolGap
)
import Cardano.Wallet.Address.Discovery.Shared
( CredentialType )
import Cardano.Wallet.DB.Store.UTxOHistory.Model
( Pruned (..), Spent (..) )
import Cardano.Wallet.Primitive.Passphrase.Types
( Passphrase (..), PassphraseScheme (..) )
import Cardano.Wallet.Primitive.Types
( EpochNo (..)
, FeePolicy
, PoolMetadataSource (..)
, Slot
, WalletId (..)
, WithOrigin (..)
, isValidEpochNo
, unsafeEpochNo
, unsafeToPMS
)
import Cardano.Wallet.Primitive.Types.Address
( Address (..), AddressState (..) )
import Cardano.Wallet.Primitive.Types.Coin
( Coin (..) )
import Cardano.Wallet.Primitive.Types.Hash
( Hash (..) )
import Cardano.Wallet.Primitive.Types.RewardAccount
( RewardAccount (..) )
import Cardano.Wallet.Primitive.Types.TokenPolicy
( TokenName, TokenPolicyId )
import Cardano.Wallet.Primitive.Types.TokenQuantity
( TokenQuantity (..) )
import Cardano.Wallet.Primitive.Types.Tx.SealedTx
( SealedTx (..), persistSealedTx, unPersistSealedTx )
import Cardano.Wallet.Primitive.Types.Tx.Tx
( TxMetadata, TxScriptValidity (..) )
import Cardano.Wallet.Primitive.Types.Tx.TxMeta
( Direction (..), TxStatus (..) )
import Control.Arrow
( left )
import Control.Monad
( (<=<), (>=>) )
import Data.Aeson
( FromJSON (..), ToJSON (..), Value (..) )
import Data.Aeson.Extra
( aesonFromText )
import Data.Bifunctor
( bimap, first )
import Data.ByteArray.Encoding
( Base (..), convertFromBase, convertToBase )
import Data.ByteString
( ByteString )
import Data.Maybe
( fromMaybe, mapMaybe )
import Data.Proxy
( Proxy (..) )
import Data.Quantity
( Percentage, Quantity (..) )
import Data.Text
( Text )
import Data.Text.Class.Extended
( FromText (..)
, TextDecodingError (TextDecodingError)
, ToText (..)
, fromText'
, fromTextMaybe
)
import Data.Text.Encoding
( decodeUtf8, encodeUtf8 )
import Data.Time.Clock.POSIX
( POSIXTime, posixSecondsToUTCTime, utcTimeToPOSIXSeconds )
import Data.Time.Format
( defaultTimeLocale, formatTime, parseTimeM )
import Data.Word
( Word32, Word64 )
import Data.Word.Odd
( Word31 )
import Database.Persist.PersistValue.Extended
( fromPersistValueFromText )
import Database.Persist.Sqlite
( PersistField (..), PersistFieldSql (..), PersistValue (..) )
import Database.Persist.TH
( MkPersistSettings (..), sqlSettings )
import GHC.Generics
( Generic )
import GHC.Int
( Int64 )
import Network.URI
( parseAbsoluteURI )
import System.Random.Internal
( StdGen (..) )
import System.Random.SplitMix
( seedSMGen, unseedSMGen )
import Text.Read
( readMaybe )
import Web.HttpApiData
( FromHttpApiData (..), ToHttpApiData (..) )
import Web.PathPieces
( PathPiece (..) )
import qualified Cardano.Wallet.Primitive.Types.Coin as Coin
import qualified Data.Aeson as Aeson
import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as BL
import qualified Data.Text as T
import qualified Data.Text.Encoding as T
----------------------------------------------------------------------------
-- | Settings for generating the Persistent types.
sqlSettings' :: MkPersistSettings
sqlSettings' = sqlSettings { mpsPrefixFields = False }
----------------------------------------------------------------------------
-- Direction
instance PersistField Direction where
toPersistValue = toPersistValue . directionToBool
fromPersistValue pv = do
let err = "not a valid value: " <> T.pack (show pv)
bimap (const err) directionFromBool (fromPersistValue pv)
instance PersistFieldSql Direction where
sqlType _ = sqlType (Proxy @Bool)
directionToBool :: Direction -> Bool
directionToBool Incoming = True
directionToBool Outgoing = False
directionFromBool :: Bool -> Direction
directionFromBool True = Incoming
directionFromBool False = Outgoing
----------------------------------------------------------------------------
-- Fee Policy
instance PersistField FeePolicy where
toPersistValue = toPersistValue . toText
fromPersistValue pv = fromPersistValue pv >>= left (const err) . fromText
where err = "not a valid value: " <> T.pack (show pv)
instance PersistFieldSql FeePolicy where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- Percentage
instance PersistField Percentage where
toPersistValue = toPersistValue . toText
fromPersistValue pv = fromPersistValue pv >>= left (const err) . fromText
where err = "not a valid percentage: " <> T.pack (show pv)
instance PersistFieldSql Percentage where
sqlType _ = sqlType (Proxy @Rational)
----------------------------------------------------------------------------
-- WalletId
instance PersistField WalletId where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql WalletId where
sqlType _ = sqlType (Proxy @Text)
instance Read WalletId where
readsPrec _ = error "readsPrec stub needed for persistent"
instance ToHttpApiData WalletId where
toUrlPiece = toText
instance FromHttpApiData WalletId where
parseUrlPiece = fromText'
instance ToJSON WalletId where
toJSON = String . toText
instance FromJSON WalletId where
parseJSON = aesonFromText "WalletId"
instance PathPiece WalletId where
fromPathPiece = fromTextMaybe
toPathPiece = toText
----------------------------------------------------------------------------
-- TxId
-- | Wraps 'Hash "Tx"' because the persistent entity syntax doesn't seem to
-- support parameterized types.
newtype TxId = TxId { getTxId :: Hash "Tx" } deriving (Show, Eq, Ord, Generic)
instance PersistField TxId where
toPersistValue = toPersistValue . toText . getTxId
fromPersistValue = fmap TxId <$> fromPersistValueFromText
instance PersistFieldSql TxId where
sqlType _ = sqlType (Proxy @Text)
instance Read TxId where
readsPrec _ = error "readsPrec stub needed for persistent"
instance ToJSON TxId where
toJSON = String . toText . getTxId
instance FromJSON TxId where
parseJSON = fmap TxId . aesonFromText "TxId"
instance ToHttpApiData TxId where
toUrlPiece = toText . getTxId
instance FromHttpApiData TxId where
parseUrlPiece = fmap TxId . fromText'
instance PathPiece TxId where
toPathPiece = toText . getTxId
fromPathPiece = fmap TxId . fromTextMaybe
--------------------------------------------------------------------------------
-- Tokens
--------------------------------------------------------------------------------
instance PersistField TokenName where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql TokenName where
sqlType _ = sqlType (Proxy @Text)
instance PersistField TokenPolicyId where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql TokenPolicyId where
sqlType _ = sqlType (Proxy @Text)
instance PersistField TokenQuantity where
-- SQLite has no big integer type, so we use a textual representation
-- instead.
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql TokenQuantity where
-- SQLite has no big integer type, so we use a textual representation
-- instead.
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- BlockId
-- Wraps Hash "BlockHeader" because the persistent dsl doesn't like it raw.
newtype BlockId = BlockId { getBlockId :: Hash "BlockHeader" }
deriving (Show, Eq, Ord, Generic)
-- | Magic value that denotes the hash of the parent of the genesis block
-- (which does not exist). This value is used for serializing
-- the Nothing case of the #parentHeaderHash field.
hashOfNoParent :: Hash "BlockHeader"
hashOfNoParent = Hash . BS.pack $ replicate 32 0
fromMaybeHash :: Maybe (Hash "BlockHeader") -> BlockId
fromMaybeHash = BlockId . fromMaybe hashOfNoParent
toMaybeHash :: BlockId -> Maybe (Hash "BlockHeader")
toMaybeHash (BlockId h) = if h == hashOfNoParent then Nothing else Just h
instance PersistField BlockId where
toPersistValue = toPersistValue . toText . getBlockId
fromPersistValue = fmap BlockId <$> fromPersistValueFromText
instance PersistFieldSql BlockId where
sqlType _ = sqlType (Proxy @Text)
instance Read BlockId where
readsPrec _ = error "readsPrec stub needed for persistent"
instance ToJSON BlockId where
toJSON = String . toText . getBlockId
instance FromJSON BlockId where
parseJSON = fmap BlockId . aesonFromText "BlockId"
instance ToHttpApiData BlockId where
toUrlPiece = toText . getBlockId
instance FromHttpApiData BlockId where
parseUrlPiece = fmap BlockId . fromText'
instance PathPiece BlockId where
toPathPiece = toText . getBlockId
fromPathPiece = fmap BlockId . fromTextMaybe
----------------------------------------------------------------------------
-- SlotId
instance PersistFieldSql SlotNo where
sqlType _ = sqlType (Proxy @Word64)
instance Read SlotNo where
readsPrec _ = error "readsPrec stub needed for persistent"
persistSlotNo :: SlotNo -> PersistValue
persistSlotNo = toPersistValue . unSlotNo
unPersistSlotNo :: PersistValue -> Either Text SlotNo
unPersistSlotNo = fmap SlotNo . fromPersistValue
instance PersistField SlotNo where
toPersistValue = persistSlotNo
fromPersistValue = unPersistSlotNo
instance ToHttpApiData SlotNo where
toUrlPiece = error "toUrlPiece stub needed for persistent"
instance FromHttpApiData SlotNo where
parseUrlPiece = error "parseUrlPiece stub needed for persistent"
instance PathPiece SlotNo where
toPathPiece = error "toPathPiece stub needed for persistent"
fromPathPiece = error "fromPathPiece stub needed for persistent"
----------------------------------------------------------------------------
-- EpochNo
instance PersistFieldSql EpochNo where
sqlType _ = sqlType (Proxy @Word32)
mkEpochNo :: Word32 -> Either Text EpochNo
mkEpochNo n
| isValidEpochNo c = Right c
| otherwise = Left . T.pack $ "not a valid epoch number: " <> show n
where c = unsafeEpochNo n
persistEpochNo :: EpochNo -> PersistValue
persistEpochNo = toPersistValue . fromIntegral @Word31 @Word32 . unEpochNo
instance PersistField EpochNo where
toPersistValue = persistEpochNo
fromPersistValue = fromPersistValue >=> mkEpochNo
instance ToHttpApiData EpochNo where
toUrlPiece = error "toUrlPiece stub needed for persistent"
instance FromHttpApiData EpochNo where
parseUrlPiece = error "parseUrlPiece stub needed for persistent"
instance PathPiece EpochNo where
toPathPiece = error "toPathPiece stub needed for persistent"
fromPathPiece = error "fromPathPiece stub needed for persistent"
----------------------------------------------------------------------------
-- TxStatus
instance PersistField TxStatus where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql TxStatus where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- TxMetadata
instance PersistField TxMetadata where
toPersistValue =
toPersistValue .
decodeUtf8 .
BL.toStrict .
Aeson.encode .
metadataToJson TxMetadataJsonDetailedSchema
fromPersistValue =
(left (T.pack . displayError) . metadataFromJsonWithFallback) <=<
(left T.pack . Aeson.eitherDecode . BL.fromStrict . encodeUtf8) <=<
fromPersistValue
where
-- FIXME
-- Because of time constraints, we have had two consecutives releases
-- of cardano-wallet which ended up using different conversions method
-- for metadata to/from JSON.
-- As a result, some users' databases contain metadata using the direct
-- JSON conversion while we now expect the detailed schema variant.
--
-- We do therefore fallback when deserializing data do the direct
-- conversion (which will then be serialized back using the detailed
-- schema). We can remove that fallback after some time has passed since
-- release v2020-09-22.
metadataFromJsonWithFallback json =
case metadataFromJson TxMetadataJsonDetailedSchema json of
Right meta -> Right meta
Left e -> case metadataFromJson TxMetadataJsonNoSchema json of
Right meta -> Right meta
Left{} -> Left e
instance PersistFieldSql TxMetadata where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- SealedTx - store the serialised tx as a binary blob
instance PersistField SealedTx where
toPersistValue = toPersistValue . persistSealedTx
fromPersistValue = fromPersistValue >=> unPersistSealedTx
instance PersistFieldSql SealedTx where
sqlType _ = sqlType (Proxy @ByteString)
----------------------------------------------------------------------------
-- Coin
instance PersistField Coin where
toPersistValue = toPersistValue . Coin.unsafeToWord64
fromPersistValue = fmap Coin.fromWord64 . fromPersistValue
instance PersistFieldSql Coin where
sqlType _ = sqlType (Proxy @Word64)
----------------------------------------------------------------------------
-- Address
instance PersistField Address where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql Address where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- ScriptHash
instance ToText ScriptHash where
toText (ScriptHash sh) =
T.decodeUtf8 $ convertToBase Base16 sh
instance FromText ScriptHash where
fromText = bimap textDecodingError ScriptHash
. convertFromBase Base16
. T.encodeUtf8
where
textDecodingError = TextDecodingError . show
instance PersistField ScriptHash where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql ScriptHash where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- Script Cosigner
instance PersistField (Script Cosigner) where
toPersistValue =
toPersistValue .
decodeUtf8 .
BL.toStrict .
Aeson.encode .
toJSON
fromPersistValue =
(left T.pack . Aeson.eitherDecode . BL.fromStrict . encodeUtf8) <=<
fromPersistValue
instance PersistFieldSql (Script Cosigner) where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- CredentialType
instance PersistField CredentialType where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql CredentialType where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
----------------------------------------------------------------------------
-- AddressPoolGap
instance PersistField AddressPoolGap where
toPersistValue = toPersistValue . getAddressPoolGap
fromPersistValue pv = fromPersistValue >=> mkAddressPoolGap' $ pv
where
mkAddressPoolGap' :: Word32 -> Either Text AddressPoolGap
mkAddressPoolGap' = first msg . mkAddressPoolGap . fromIntegral
msg e = T.pack $ "not a valid value: " <> show pv <> ": " <> show e
instance PersistFieldSql AddressPoolGap where
sqlType _ = sqlType (Proxy @Word32)
----------------------------------------------------------------------------
-- Role
instance PersistField Role where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql Role where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- StdGen
instance PersistFieldSql StdGen where
sqlType _ = sqlType (Proxy @Text)
instance PersistField StdGen where
toPersistValue = toPersistValue . stdGenToString
fromPersistValue = fromPersistValue >=> stdGenFromString
-- | In @random < 1.2@ there used to be an @instance Read StdGen@, but no
-- longer.
--
-- The format used to look like this:
-- @
-- 5889121503043413025 17512980752375952679
-- @
stdGenFromString :: String -> Either Text StdGen
stdGenFromString s = case mapMaybe readMaybe (words s) of
[i, j] -> Right $ StdGen $ seedSMGen i j
_ -> Left "StdGen should be formatted as two space-separated integers"
-- | Equivalent to the old @random < 1.2@ 'StdGen' 'Show' instance.
stdGenToString :: StdGen -> String
stdGenToString (StdGen (unseedSMGen -> (i, j))) = unwords $ map show [i, j]
----------------------------------------------------------------------------
-- PoolId
instance PersistField PoolId where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql PoolId where
sqlType _ = sqlType (Proxy @Text)
instance Read PoolId where
readsPrec _ = error "readsPrec stub needed for persistent"
instance PathPiece PoolId where
fromPathPiece = fromTextMaybe
toPathPiece = toText
instance ToJSON PoolId where
toJSON = String . toText
instance FromJSON PoolId where
parseJSON = aesonFromText "PoolId"
instance ToHttpApiData PoolId where
toUrlPiece = error "toUrlPiece stub needed for persistent"
instance FromHttpApiData PoolId where
parseUrlPiece = error "parseUrlPiece stub needed for persistent"
----------------------------------------------------------------------------
-- HDPassphrase
newtype HDPassphrase = HDPassphrase (Passphrase "addr-derivation-payload")
deriving (Generic, Show)
instance PersistField HDPassphrase where
toPersistValue (HDPassphrase (Passphrase pwd)) =
toPersistValue (convertToBase @_ @ByteString Base16 pwd)
fromPersistValue = fromPersistValue >=>
fmap (HDPassphrase . Passphrase)
. left T.pack
. convertFromBase @ByteString Base16
instance PersistFieldSql HDPassphrase where
sqlType _ = sqlType (Proxy @ByteString)
instance Read HDPassphrase where
readsPrec _ = error "readsPrec stub needed for persistent"
----------------------------------------------------------------------------
-- PassphraseScheme
instance PersistField PassphraseScheme where
toPersistValue = toPersistValue . show
fromPersistValue = fromPersistValue >=> pure . read
instance PersistFieldSql PassphraseScheme where
sqlType _ = sqlType (Proxy @String)
----------------------------------------------------------------------------
-- RewardAccount
instance PersistField RewardAccount where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql RewardAccount where
sqlType _ = sqlType (Proxy @Text)
instance ToHttpApiData RewardAccount where
toUrlPiece = toText
instance FromHttpApiData RewardAccount where
parseUrlPiece = fromText'
instance PathPiece RewardAccount where
fromPathPiece = fromTextMaybe
toPathPiece = toText
----------------------------------------------------------------------------
-- AddressState
instance PersistField AddressState where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql AddressState where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- PoolMetadataSource
instance PersistField PoolMetadataSource where
toPersistValue = toPersistValue . toText
-- be more permissive than fromText here
fromPersistValue = fromPersistValue
>=> \case
"none" -> Right FetchNone
"direct" -> Right FetchDirect
uri -> fmap unsafeToPMS
. maybe (Left "Not an absolute URI") Right
. parseAbsoluteURI
$ uri
instance PersistFieldSql PoolMetadataSource where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- DerivationPrefix
instance PersistField DerivationPrefix where
toPersistValue = toPersistValue . toText
fromPersistValue = fromPersistValueFromText
instance PersistFieldSql DerivationPrefix where
sqlType _ = sqlType (Proxy @Text)
----------------------------------------------------------------------------
-- ScriptValidation
instance PersistField TxScriptValidity where
toPersistValue = \case
TxScriptValid -> PersistBool True
TxScriptInvalid -> PersistBool False
fromPersistValue = \case
PersistBool True -> Right TxScriptValid
PersistBool False -> Right TxScriptInvalid
x -> Left $ T.unwords
[ "Failed to parse Haskell type `TxScriptValidity`;"
, "expected null or boolean"
, "from database, but received:"
, T.pack (show x)
]
instance PersistFieldSql TxScriptValidity where
sqlType _ = sqlType (Proxy @(Maybe Bool))
----------------------------------------------------------------------------
-- Other
instance PersistField POSIXTime where
toPersistValue = PersistText
. T.pack
. formatTime defaultTimeLocale iso8601DateFormatHMS
. posixSecondsToUTCTime
fromPersistValue (PersistText time) =
utcTimeToPOSIXSeconds <$>
getEitherText (parseTimeM True defaultTimeLocale
iso8601DateFormatHMS (T.unpack time))
fromPersistValue _ = Left
"Could not parse POSIX time value"
instance PersistFieldSql POSIXTime where
sqlType _ = sqlType (Proxy @Text)
-- | Newtype to get a MonadFail instance for @Either Text@.
--
-- We need it to use @parseTimeM@.
newtype EitherText a = EitherText { getEitherText :: Either Text a }
deriving (Functor, Applicative, Monad) via (Either Text)
instance MonadFail EitherText where
fail = EitherText . Left . T.pack
data TxSubmissionStatusEnum = InSubmissionE | InLedgerE | ExpiredE
deriving (Eq, Show, Enum, Generic)
instance PersistField TxSubmissionStatusEnum where
toPersistValue = toPersistValue . fromEnum
fromPersistValue = fmap toEnum . fromPersistValue
instance PersistFieldSql TxSubmissionStatusEnum where
sqlType _ = sqlType (Proxy @Int)
type BlockHeight = Quantity "block" Word32
instance PersistField BlockHeight where
toPersistValue = toPersistValue . getQuantity
fromPersistValue = fmap Quantity . fromPersistValue
instance PersistFieldSql BlockHeight where
sqlType _ = sqlType (Proxy @Word32)
iso8601DateFormatHMS :: String
-- Equivalent to `iso8601DateFormatHMS (Just "%H:%M:%S")`
-- The function `iso8601DateFormatHMS` has been deprecated from the `time` library.
iso8601DateFormatHMS = "%Y-%m-%dT%H:%M:%S"
data DelegationStatusEnum = InactiveE | RegisteredE | ActiveE
deriving (Eq, Show, Enum, Generic)
instance PersistField DelegationStatusEnum where
toPersistValue = toPersistValue . \case
InactiveE -> "inactive" :: Text
RegisteredE -> "registered"
ActiveE -> "active"
fromPersistValue = fromPersistValue >=> readDelegationStatus
readDelegationStatus :: Text -> Either Text DelegationStatusEnum
readDelegationStatus "inactive" = Right InactiveE
readDelegationStatus "registered" = Right RegisteredE
readDelegationStatus "active" = Right ActiveE
readDelegationStatus other = Left $ "Invalid delegation status: " <> other
instance PersistFieldSql DelegationStatusEnum where
sqlType _ = sqlType (Proxy @Text)
instance PersistField Slot where
toPersistValue Origin = toPersistValue ((-1) :: Int64)
toPersistValue (At s) = toPersistValue (fromIntegral $ unSlotNo s :: Int64)
fromPersistValue v = case fromPersistValue v of
Right (PersistInt64 x)
| x < (-1) -> Left "Slot must be positive or -1"
| x == (-1) -> Right Origin
| otherwise -> Right . At . SlotNo . fromIntegral $ x
_ -> Left "Slot must be an Int64"
instance PersistFieldSql Slot where
sqlType _ = sqlType (Proxy @Int64)
instance PersistField Pruned where
toPersistValue NotPruned = toPersistValue @(Maybe Word64) Nothing
toPersistValue (PrunedUpTo h) = toPersistValue (Just h)
fromPersistValue v = case fromPersistValue @(Maybe Word64) v of
Right Nothing -> Right NotPruned
Right (Just x) -> Right $ PrunedUpTo $ fromIntegral x
_ -> Left "Pruned must be an Int64 or Null"
instance PersistFieldSql Pruned where
sqlType _ = sqlType (Proxy @(Maybe Word64))
instance PersistField Spent where
toPersistValue Unspent = toPersistValue @(Maybe Word64) Nothing
toPersistValue (Spent h) = toPersistValue (Just h)
fromPersistValue v = case fromPersistValue @(Maybe Word64) v of
Right Nothing -> Right Unspent
Right (Just x) -> Right $ Spent $ fromIntegral x
_ -> Left "Spent must be an Int64 or Null"
instance PersistFieldSql Spent where
sqlType _ = sqlType (Proxy @(Maybe Word64))