Eventually-decentralized project hosting and management platform

[[ 🗃 ^WvWbo vervis ]] :: [📥 Inbox] [📤 Outbox] [🐤 Followers] [🤝 Collaborators] [🛠 Changes]

Clone

HTTPS: darcs clone https://vervis.peers.community/repos/WvWbo

SSH: darcs clone USERNAME@vervis.peers.community:WvWbo

Tags

TODO

src / Yesod /

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

{- 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 Yesod.Hashids
    ( YesodHashids (..)
    , KeyHashid
    , keyHashidText

    , encodeKeyHashidPure
    , getEncodeKeyHashid
    , encodeKeyHashid

    , decodeKeyHashidPure
    , decodeKeyHashid
    , decodeKeyHashidF
    , decodeKeyHashidM
    , decodeKeyHashidE
    , decodeKeyHashid404
    )
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 Yesod.Core

import Web.Actor.Persist (KeyHashid, keyHashidText, encodeKeyHashidPure, decodeKeyHashidPure)
import Yesod.MonadSite

import Web.Hashids.Local

class Yesod site => YesodHashids site where
    siteHashidsContext :: site -> HashidsContext

getEncodeKeyHashid
    :: ( MonadSite m
       , YesodHashids (SiteEnv m)
       , ToBackendKey SqlBackend record
       )
    => m (Key record -> KeyHashid record)
getEncodeKeyHashid = do
    ctx <- asksSite siteHashidsContext
    return $ encodeKeyHashidPure ctx

encodeKeyHashid
    :: ( MonadSite m
       , YesodHashids (SiteEnv m)
       , ToBackendKey SqlBackend record
       )
    => Key record
    -> m (KeyHashid record)
encodeKeyHashid k = do
    enc <- getEncodeKeyHashid
    return $ enc k

decodeKeyHashid
    :: ( MonadSite m
       , YesodHashids (SiteEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> m (Maybe (Key record))
decodeKeyHashid khid = do
    ctx <- asksSite siteHashidsContext
    return $ decodeKeyHashidPure ctx khid

decodeKeyHashidF
    :: ( MonadFail m
       , MonadSite m
       , YesodHashids (SiteEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> String
    -> m (Key record)
decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid

decodeKeyHashidM
    :: ( MonadSite m
       , YesodHashids (SiteEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> MaybeT m (Key record)
decodeKeyHashidM = MaybeT . decodeKeyHashid

decodeKeyHashidE
    :: ( MonadSite m
       , YesodHashids (SiteEnv m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> e
    -> ExceptT e m (Key record)
decodeKeyHashidE khid e =
    ExceptT $ maybe (Left e) Right <$> decodeKeyHashid khid

decodeKeyHashid404
    :: ( MonadSite m
       , MonadHandler m
       , HandlerSite m ~ SiteEnv m
       , YesodHashids (HandlerSite m)
       , ToBackendKey SqlBackend record
       )
    => KeyHashid record
    -> m (Key record)
decodeKeyHashid404 khid = maybe notFound return =<< decodeKeyHashid khid
[See repo JSON]