Federated forge server
Clone
HTTPS:
git clone https://vervis.peers.community/repos/rjQ3E
SSH:
git clone USERNAME@vervis.peers.community:rjQ3E
Branches
Tags
Local.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 | {- This file is part of Vervis.
-
- Written in 2019, 2020, 2022 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 Database.Persist.Local
( idAndNew
, valAndNew
, getKeyBy
, getValBy
, insertUnique_
, insertBy'
, insertByEntity'
, getE
, getEntityE
, getByJust
, getKeyByJust
, getValByJust
)
where
import Control.Applicative
import Control.Exception
import Control.Monad
import Control.Monad.IO.Class
import Control.Monad.Trans.Class
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Control.Monad.Trans.Reader
import Data.Bifunctor
import Database.Persist
import qualified Data.Text as T
idAndNew :: Either (Entity a) (Key a) -> (Key a, Bool)
idAndNew (Left (Entity iid _)) = (iid, False)
idAndNew (Right iid) = (iid, True)
valAndNew :: Either (Entity a) (Entity a) -> (a, Bool)
valAndNew (Left (Entity _ val)) = (val, False)
valAndNew (Right (Entity _ val)) = (val, True)
getKeyBy
:: ( MonadIO m
, PersistRecordBackend record backend
, PersistUniqueRead backend
)
=> Unique record
-> ReaderT backend m (Maybe (Key record))
getKeyBy u = fmap entityKey <$> getBy u
getValBy
:: ( MonadIO m
, PersistRecordBackend record backend
, PersistUniqueRead backend
)
=> Unique record
-> ReaderT backend m (Maybe record)
getValBy u = fmap entityVal <$> getBy u
insertUnique_
:: ( MonadIO m
, PersistRecordBackend record backend
, PersistUniqueWrite backend
)
=> record
-> ReaderT backend m ()
insertUnique_ = void . insertUnique
insertBy'
:: ( MonadIO m
, PersistUniqueWrite backend
, PersistRecordBackend record backend
)
=> record -> ReaderT backend m (Either (Entity record) (Key record))
insertBy' val = do
let tryGet = Left <$> MaybeT (getByValue val)
tryWrite = Right <$> MaybeT (insertUnique val)
mresult <- runMaybeT $ tryGet <|> tryWrite <|> tryGet
case mresult of
Just result -> return result
Nothing ->
liftIO $ throwIO $ PersistError $
"insertBy': Couldn't insert but also couldn't get the value, \
\perhaps it was concurrently deleted or updated: " <>
T.pack (show $ map toPersistValue $ toPersistFields val)
insertByEntity'
:: ( MonadIO m
, PersistUniqueWrite backend
, PersistRecordBackend record backend
)
=> record -> ReaderT backend m (Either (Entity record) (Entity record))
insertByEntity' val = second (flip Entity val) <$> insertBy' val
getE
:: ( PersistStoreRead backend
, MonadIO m
, PersistRecordBackend record backend
)
=> Key record -> e -> ExceptT e (ReaderT backend m) record
getE key msg = do
mval <- lift $ get key
case mval of
Nothing -> throwE msg
Just val -> return val
getEntityE
:: ( PersistStoreRead backend
, MonadIO m
, PersistRecordBackend record backend
)
=> Key record -> e -> ExceptT e (ReaderT backend m) (Entity record)
getEntityE key msg = Entity key <$> getE key msg
getByJust u = do
me <- getBy u
case me of
Nothing -> error "getByJust"
Just e -> pure e
getKeyByJust u = do
me <- getKeyBy u
case me of
Nothing -> error "getKeyByJust"
Just e -> pure e
getValByJust u = do
me <- getValBy u
case me of
Nothing -> error "getValByJust"
Just e -> pure e
|