forge/Vervis
1
0
Fork 0
Code Pull requests Activity

More type-safe handling of DB key Hashids

Browse source
This commit is contained in:
fr33domlover 2019-03-29 03:25:32 +00:00
parent 228e954706
commit c2415301bc
9 changed files with 186 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
config/routes
View file

@ -51,7 +51,7 @@
/s SharersR GET
/s/#ShrIdent SharerR GET
/s/#ShrIdent/outbox OutboxR GET POST
/s/#ShrIdent/outbox/#Text OutboxItemR GET
/s/#ShrIdent/outbox/#OutboxItemKeyHashid OutboxItemR GET
/p PeopleR GET
@ -113,7 +113,7 @@
/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/!new WorkflowEnumCtorNewR GET
/s/#ShrIdent/w/#WflIdent/e/#EnmIdent/c/#Text WorkflowEnumCtorR PUT DELETE POST
/s/#ShrIdent/m/#Text MessageR GET
/s/#ShrIdent/m/#LocalMessageKeyHashid MessageR GET
/s/#ShrIdent/p/#PrjIdent/t TicketsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/!tree TicketTreeR GET
@ -131,9 +131,9 @@
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr ClaimRequestsTicketR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/cr/new ClaimRequestNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d TicketDiscussionR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#MessageKeyHashid TicketMessageR POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/!reply TicketTopReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#Text/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/d/#MessageKeyHashid/reply TicketReplyR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps TicketDepsR GET POST
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/!new TicketDepNewR GET
/s/#ShrIdent/p/#PrjIdent/t/#Int/deps/#Int TicketDepR POST DELETE

10
src/Vervis/Application.hs
View file

@ -135,8 +135,7 @@ makeFoundation appSettings = do
let mkFoundation
appConnPool
appCapSignKey
appHashidEncode
appHashidDecode =
appHashidsContext =
App {..}
-- The App {..} syntax is an example of record wild cards. For more
-- information, see:
@ -145,8 +144,7 @@ makeFoundation appSettings = do
mkFoundation
(error "connPool forced in tempFoundation")
(error "capSignKey forced in tempFoundation")
(error "hashidEncode forced in tempFoundation")
(error "hashidDecode forced in tempFoundation")
(error "hashidsContext forced in tempFoundation")
logFunc = loggingFunction tempFoundation
-- Create the database connection pool
@ -160,8 +158,6 @@ makeFoundation appSettings = do
capSignKey <- loadKeyFile loadMode $ appCapabilitySigningKeyFile appSettings
hashidsSalt <- loadKeyFile loadMode $ appHashidsSaltFile appSettings
let hashidsCtx = hashidsContext hashidsSalt
hashidEncode = decodeUtf8 . encodeInt64 hashidsCtx
hashidDecode = decodeInt64 hashidsCtx . encodeUtf8
-- Perform database migration using our application's logging settings.
--runLoggingT (runSqlPool (runMigration migrateAll) pool) logFunc
@ -176,7 +172,7 @@ makeFoundation appSettings = do
Right (_from, _to) -> $logInfo "DB migration success"
-- Return the foundation
return $ mkFoundation pool capSignKey hashidEncode hashidDecode
return $ mkFoundation pool capSignKey hashidsCtx
-- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
-- applying some additional middlewares.

16
src/Vervis/Federation.hs
View file

@ -53,6 +53,7 @@ import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Data.Either.Local
import Database.Persist.Local
@ -132,12 +133,8 @@ parseComment luParent = do
Nothing -> throwE "Not a local route"
Just r -> return r
case route of
MessageR shr hid -> do
decodeHid <- getsYesod appHashidDecode
case toSqlKey <$> decodeHid hid of
Nothing -> throwE "Non-existent local message hashid"
Just k -> return (shr, k)
_ -> throwE "Not a local message route"
MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
_ -> throwE "Not a local message route"
getLocalParentMessageId :: DiscussionId -> ShrIdent -> LocalMessageId -> ExceptT Text AppDB MessageId
getLocalParentMessageId did shr lmid = do
@ -582,14 +579,14 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
_ -> Nothing
}
route2local <- getEncodeRouteLocal
encodeHid <- getsYesod appHashidEncode
lmhid <- encodeKeyHashid lmid
let activity luAct = Doc host Activity
{ activityId = luAct
, activityActor = luAttrib
, activityAudience = aud
, activitySpecific = CreateActivity Create
{ createObject = Note
{ noteId = Just $ route2local $ MessageR shrUser $ encodeHid $ fromSqlKey lmid
{ noteId = Just $ route2local $ MessageR shrUser lmhid
, noteAttrib = luAttrib
, noteAudience = aud
, noteReplyTo = Just $ fromMaybe uContext muParent
@ -604,7 +601,8 @@ handleOutboxNote host (Note mluNote luAttrib aud muParent muContext mpublished c
, outboxItemActivity = PersistJSON $ activity $ LocalURI "" ""
, outboxItemPublished = now
}
let luAct = route2local $ OutboxItemR shrUser $ encodeHid $ fromSqlKey obid
obhid <- encodeKeyHashid obid
let luAct = route2local $ OutboxItemR shrUser obhid
doc = activity luAct
update obid [OutboxItemActivity =. PersistJSON doc]
return (lmid, doc)

25
src/Vervis/Foundation.hs
View file

@ -24,7 +24,6 @@ import Control.Monad.STM (atomically)
import Control.Monad.Trans.Except
import Control.Monad.Trans.Maybe
import Crypto.Error (CryptoFailable (..))
import Crypto.PubKey.Ed25519 (PublicKey, publicKey, signature, verify)
import Data.Char
import Data.Either (isRight)
import Data.HashMap.Strict (HashMap)
@ -42,6 +41,7 @@ import Text.Shakespeare.Text (textFile)
import Text.Hamlet (hamletFile)
--import Text.Jasmine (minifym)
import UnliftIO.MVar (withMVar)
import Web.Hashids
import Yesod.Auth.Account
import Yesod.Auth.Account.Message (AccountMsg (MsgUsernameExists))
import Yesod.Auth.Message (AuthMessage (IdentifierNotFound))
@ -67,7 +67,8 @@ import qualified Network.HTTP.Signature as S (Algorithm (..))
import Crypto.PublicVerifKey
import Network.FedURI
import Web.ActivityAccess
import Web.ActivityPub hiding (PublicKey)
import Web.ActivityPub
import Yesod.Hashids
import Text.Email.Local
import Text.Jasmine.Local (discardm)
@ -102,12 +103,17 @@ data App = App
, appActorKeys :: TVar (ActorKey, ActorKey, Bool)
, appInstanceMutex :: InstanceMutex
, appCapSignKey :: AccessTokenSecretKey
, appHashidEncode :: Int64 -> Text
, appHashidDecode :: Text -> Maybe Int64
, appHashidsContext :: HashidsContext
, appActivities :: TVar (Vector (UTCTime, ActivityReport))
}
-- Aliases for the routes file, because it doesn't like spaces in path piece
-- type names.
type OutboxItemKeyHashid = KeyHashid OutboxItem
type MessageKeyHashid = KeyHashid Message
type LocalMessageKeyHashid = KeyHashid LocalMessage
-- This is where we define all of the routes in our application. For a full
-- explanation of the syntax, please see:
-- http://www.yesodweb.com/book/routing-and-handlers
@ -611,6 +617,9 @@ unsafeHandler = Unsafe.fakeHandlerGetLogger appLogger
-- https://github.com/yesodweb/yesod/wiki/Serve-static-files-from-a-separate-domain
-- https://github.com/yesodweb/yesod/wiki/i18n-messages-in-the-scaffolding
instance YesodHashids App where
siteHashidsContext = appHashidsContext
instance YesodRemoteActorStore App where
siteInstanceMutex = appInstanceMutex
siteInstanceRoomMode = appMaxInstanceKeys . appSettings
@ -768,7 +777,9 @@ instance YesodBreadcrumbs App where
PublishR -> ("Publish", Just HomeR)
InboxR -> ("Inbox", Just HomeR)
OutboxR shr -> ("Outbox", Just $ SharerR shr)
OutboxItemR shr hid -> ("#" <> hid, Just $ OutboxR shr)
OutboxItemR shr hid -> ( "#" <> keyHashidText hid
, Just $ OutboxR shr
)
ActorKey1R -> ("Actor Key 1", Nothing)
ActorKey2R -> ("Actor Key 2", Nothing)
@ -894,7 +905,9 @@ instance YesodBreadcrumbs App where
WorkflowEnumCtorsR shr wfl enm
)
MessageR shr lmhid -> ("#" <> lmhid, Just $ SharerR shr)
MessageR shr lmhid -> ( "#" <> keyHashidText lmhid
, Just $ SharerR shr
)
TicketsR shar proj -> ( "Tickets"
, Just $ ProjectR shar proj

6
src/Vervis/Handler/Discussion.hs
View file

@ -43,6 +43,7 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
import Network.FedURI
import Web.ActivityPub
import Yesod.FedURI
import Yesod.Hashids
import Database.Persist.Local
import Yesod.Persist.Local
@ -105,7 +106,6 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
unless (localMessageAuthor lm == pid) notFound
m <- getJust $ localMessageRest lm
route2fed <- getEncodeRouteFed
encodeHid <- getsYesod appHashidEncode
(uRecip, uContext) <- do
let did = messageRoot m
mt <- getValBy $ UniqueTicketDiscussion did
@ -153,7 +153,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
(Just (Entity lmidParent lmParent), Nothing) -> do
p <- getJust $ localMessageAuthor lmParent
s <- getJust $ personIdent p
let lmhidParent = encodeHid $ fromSqlKey lmidParent
lmhidParent <- encodeKeyHashid lmidParent
return $ route2fed $ MessageR (sharerIdent s) lmhidParent
(Nothing, Just rmParent) -> do
rs <- getJust $ remoteMessageAuthor rmParent
@ -162,7 +162,7 @@ getDiscussionMessage shr lmid = selectRep $ provideAP $ runDB $ do
host <- getsYesod $ appInstanceHost . appSettings
route2local <- getEncodeRouteLocal
let lmhid = encodeHid $ fromSqlKey lmid
lmhid <- encodeKeyHashid lmid
return $ Doc host Note
{ noteId = Just $ route2local $ MessageR shr lmhid
, noteAttrib = route2local $ SharerR shr

3
src/Vervis/Handler/Inbox.hs
View file

@ -87,6 +87,7 @@ import Network.FedURI
import Web.ActivityPub
import Yesod.Auth.Unverified
import Yesod.FedURI
import Yesod.Hashids
import Vervis.ActorKey
import Vervis.Federation
@ -240,7 +241,7 @@ getPublishR = do
getOutboxR :: ShrIdent -> Handler TypedContent
getOutboxR = error "Not implemented yet"
getOutboxItemR :: ShrIdent -> Text -> Handler TypedContent
getOutboxItemR :: ShrIdent -> KeyHashid OutboxItem -> Handler TypedContent
getOutboxItemR = error "Not implemented yet"
postOutboxR :: ShrIdent -> Handler Html

53
src/Vervis/Handler/Ticket.hs
View file

@ -80,8 +80,11 @@ import Yesod.Persist.Core (runDB, get404, getBy404)
import qualified Data.Text as T (filter, intercalate, pack)
import qualified Database.Esqueleto as E ((==.))
import Data.Maybe.Local (partitionMaybePairs)
import Database.Persist.Sql.Graph.TransitiveReduction (trrFix)
import Yesod.Hashids
import Data.Maybe.Local (partitionMaybePairs)
import Vervis.Form.Ticket
import Vervis.Foundation
import Vervis.Handler.Discussion
@ -238,13 +241,13 @@ getTicketR shar proj num = do
, author, massignee, closer, ticket, tparams, eparams
, deps, rdeps
)
encodeHid <- getsYesod appHashidEncode
encodeHid <- getEncodeKeyHashid
let desc = renderSourceT Markdown $ T.filter (/= '\r') $ ticketDesc ticket
discuss =
discussionW
(return $ ticketDiscuss ticket)
(TicketTopReplyR shar proj num)
(TicketReplyR shar proj num . encodeHid . fromSqlKey)
(TicketReplyR shar proj num . encodeHid)
cRelevant <- newIdent
cIrrelevant <- newIdent
let relevant filt =
@ -630,9 +633,9 @@ selectDiscussionId shar proj tnum = do
getTicketDiscussionR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketDiscussionR shar proj num = do
encodeHid <- getsYesod appHashidEncode
encodeHid <- getEncodeKeyHashid
getDiscussion
(TicketReplyR shar proj num . encodeHid . fromSqlKey)
(TicketReplyR shar proj num . encodeHid)
(TicketTopReplyR shar proj num)
(selectDiscussionId shar proj num)
@ -643,30 +646,18 @@ postTicketDiscussionR shar proj num =
(const $ TicketR shar proj num)
(selectDiscussionId shar proj num)
getMessageR :: ShrIdent -> Text -> Handler TypedContent
getMessageR :: ShrIdent -> KeyHashid LocalMessage -> Handler TypedContent
getMessageR shr hid = do
decodeHid <- getsYesod appHashidDecode
--encodeHid <- getsYesod appHashidEncode
lmid <-
case toSqlKey <$> decodeHid hid of
Nothing -> notFound
Just k -> return k
lmid <- decodeKeyHashid404 hid
getDiscussionMessage shr lmid
--(TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
--(selectDiscussionId shar proj tnum)
--lmid
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html
postTicketMessageR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
postTicketMessageR shar proj tnum hid = do
decodeHid <- getsYesod appHashidDecode
encodeHid <- getsYesod appHashidEncode
mid <-
case toSqlKey <$> decodeHid hid of
Nothing -> notFound
Just k -> return k
encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 hid
postReply
(TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
(TicketMessageR shar proj tnum . encodeHid . fromSqlKey)
(TicketReplyR shar proj tnum . encodeHid)
(TicketMessageR shar proj tnum . encodeHid)
(const $ TicketR shar proj tnum)
(selectDiscussionId shar proj tnum)
mid
@ -675,17 +666,13 @@ getTicketTopReplyR :: ShrIdent -> PrjIdent -> Int -> Handler Html
getTicketTopReplyR shar proj num =
getTopReply $ TicketDiscussionR shar proj num
getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> Text -> Handler Html
getTicketReplyR :: ShrIdent -> PrjIdent -> Int -> KeyHashid Message -> Handler Html
getTicketReplyR shar proj tnum hid = do
decodeHid <- getsYesod appHashidDecode
encodeHid <- getsYesod appHashidEncode
mid <-
case toSqlKey <$> decodeHid hid of
Nothing -> notFound
Just k -> return k
encodeHid <- getEncodeKeyHashid
mid <- decodeKeyHashid404 hid
getReply
(TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
(TicketMessageR shar proj tnum . encodeHid . fromSqlKey)
(TicketReplyR shar proj tnum . encodeHid)
(TicketMessageR shar proj tnum . encodeHid)
(selectDiscussionId shar proj tnum)
mid

127
src/Yesod/Hashids.hs Normal file
View file

@ -0,0 +1,127 @@
{- This file is part of Vervis.
-
- Written in 2019 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
, getEncodeKeyHashid
, encodeKeyHashid
, 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 Yesod.Core.Handler
import Web.Hashids.Local
class Yesod site => YesodHashids site where
siteHashidsContext :: site -> HashidsContext
newtype KeyHashid record = KeyHashid
{ keyHashidText :: Text
}
deriving (Eq, Read, Show)
instance PersistEntity record => PathPiece (KeyHashid record) where
fromPathPiece t = KeyHashid <$> fromPathPiece t
toPathPiece (KeyHashid t) = toPathPiece t
getEncodeKeyHashid
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> m (Key record -> KeyHashid record)
getEncodeKeyHashid = do
ctx <- getsYesod siteHashidsContext
return $ KeyHashid . decodeUtf8 . encodeInt64 ctx . fromSqlKey
encodeKeyHashid
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> Key record
-> m (KeyHashid record)
encodeKeyHashid k = do
enc <- getEncodeKeyHashid
return $ enc k
decodeKeyHashid
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> KeyHashid record
-> m (Maybe (Key record))
decodeKeyHashid (KeyHashid t) = do
ctx <- getsYesod siteHashidsContext
return $ fmap toSqlKey $ decodeInt64 ctx $ encodeUtf8 t
decodeKeyHashidF
:: ( MonadFail m
, MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> KeyHashid record
-> String
-> m (Key record)
decodeKeyHashidF khid e = maybe (fail e) return =<< decodeKeyHashid khid
decodeKeyHashidM
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> KeyHashid record
-> MaybeT m (Key record)
decodeKeyHashidM = MaybeT . decodeKeyHashid
decodeKeyHashidE
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> KeyHashid record
-> e
-> ExceptT e m (Key record)
decodeKeyHashidE khid e =
ExceptT $ maybe (Left e) Right <$> decodeKeyHashid khid
decodeKeyHashid404
:: ( MonadHandler m
, YesodHashids (HandlerSite m)
, ToBackendKey SqlBackend record
)
=> KeyHashid record
-> m (Key record)
decodeKeyHashid404 khid = maybe notFound return =<< decodeKeyHashid khid

1
vervis.cabal
View file

@ -97,6 +97,7 @@ library
Yesod.Auth.Unverified.Creds
Yesod.Auth.Unverified.Internal
Yesod.FedURI
Yesod.Hashids
Yesod.Paginate.Local
Yesod.Persist.Local
Yesod.SessionEntity