Federated forge server

[[ 🗃 ^rjQ3E vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Commits]

Clone

HTTPS: git clone https://vervis.peers.community/repos/rjQ3E

SSH: git clone USERNAME@vervis.peers.community:rjQ3E

Branches

Tags

main :: src / Web / Actor /

Persist.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

{- This file is part of Vervis.
 -
 - Written in 2019, 2020, 2022, 2023 by fr33domlover <fr33domlover@riseup.net>.
 -
 - ♡ Copying is an act of love. Please copy, reuse and share.
 -
 - The author(s) have dedicated all copyright and related and neighboring
 - rights to this software to the public domain worldwide. This software is
 - distributed without any warranty.
 -
 - You should have received a copy of the CC0 Public Domain Dedication along
 - with this software. If not, see
 - <http://creativecommons.org/publicdomain/zero/1.0/>.
 -}

module Web.Actor.Persist
    ( StageHashids (..)
    , KeyHashid ()
    , keyHashidText

    , encodeKeyHashidPure
    --, getEncodeKeyHashid
    , encodeKeyHashid

    , decodeKeyHashidPure
    --, decodeKeyHashid
    --, decodeKeyHashidF
    --, decodeKeyHashidM
    , decodeKeyHashidE
    )
where

import Prelude hiding (fail)

import Control.Monad.Fail
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Data.Text (Text)
import Data.Text.Encoding
import Database.Persist.Class
import Database.Persist.Sql
import Web.Hashids
import Web.PathPieces

import Control.Concurrent.Actor
import Web.Actor
--import Yesod.MonadActor

import Web.Hashids.Local

class StageWeb s => StageHashids s where
    stageHashidsContext :: s -> HashidsContext

newtype KeyHashid record = KeyHashid
    { keyHashidText :: Text
    }
    deriving (Eq, Ord, Read, Show)

instance PersistEntity record => PathPiece (KeyHashid record) where
    fromPathPiece t = KeyHashid <$> fromPathPiece t
    toPathPiece (KeyHashid t) = toPathPiece t

encodeKeyHashidPure
    :: ToBackendKey SqlBackend record
    => HashidsContext -> Key record -> KeyHashid record
encodeKeyHashidPure ctx = KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey

getEncodeKeyHashid
    :: ( MonadActor m
       , StageHashids (ActorEnv m)
       , ToBackendKey SqlBackend record
       )
    => m (Key record -> KeyHashid record)
getEncodeKeyHashid = do
    ctx <- asksEnv stageHashidsContext
    return $ encodeKeyHashidPure ctx

encodeKeyHashid
    :: ( MonadActor m
       , StageHashids (ActorEnv m)
       , ToBackendKey SqlBackend record
       )
    => Key record
    -> m (KeyHashid record)
encodeKeyHashid k = do
    enc <- getEncodeKeyHashid
    return $ enc k

decodeKeyHashidPure
    :: ToBackendKey SqlBackend record
    => HashidsContext
    -> KeyHashid record
    -> Maybe (Key record)
decodeKeyHashidPure ctx (KeyHashid t) =
    fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t

decodeKeyHashid
    :: ( MonadActor m
       , StageHashids (ActorEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> m (Maybe (Key record))
decodeKeyHashid khid = do
    ctx <- asksEnv stageHashidsContext
    return $ decodeKeyHashidPure ctx khid

decodeKeyHashidF
    :: ( MonadFail m
       , MonadActor m
       , StageHashids (ActorEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> String
    -> m (Key record)
decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid

decodeKeyHashidM
    :: ( MonadActor m
       , StageHashids (ActorEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> MaybeT m (Key record)
decodeKeyHashidM = MaybeT . decodeKeyHashid

decodeKeyHashidE
    :: ( MonadActor m
       , StageHashids (ActorEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> e
    -> ExceptT e m (Key record)
decodeKeyHashidE khid e =
    ExceptT $ maybe (Left e) Right <$> decodeKeyHashid khid
[See repo JSON]