From c2415301bcaaa9f9f57707509b8446be3488b1cf Mon Sep 17 00:00:00 2001 From: fr33domlover Date: Fri, 29 Mar 2019 03:25:32 +0000 Subject: [PATCH] More type-safe handling of DB key Hashids --- config/routes | 8 +- src/Vervis/Application.hs | 10 +-- src/Vervis/Federation.hs | 16 ++-- src/Vervis/Foundation.hs | 25 ++++-- src/Vervis/Handler/Discussion.hs | 6 +- src/Vervis/Handler/Inbox.hs | 3 +- src/Vervis/Handler/Ticket.hs | 53 +++++-------- src/Yesod/Hashids.hs | 127 +++++++++++++++++++++++++++++++ vervis.cabal | 1 + 9 files changed, 186 insertions(+), 63 deletions(-) create mode 100644 src/Yesod/Hashids.hs diff --git a/config/routes b/config/routes index 9e3bfd9..5a627f0 100644 --- a/config/routes +++ b/config/routes @@ -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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 34bf1cc..3e62db5 100644 --- a/src/Vervis/Application.hs +++ b/src/Vervis/Application.hs @@ -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. diff --git a/src/Vervis/Federation.hs b/src/Vervis/Federation.hs index 62dcafd..8273643 100644 --- a/src/Vervis/Federation.hs +++ b/src/Vervis/Federation.hs @@ -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) diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index 6140f4b..f81431b 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -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 diff --git a/src/Vervis/Handler/Discussion.hs b/src/Vervis/Handler/Discussion.hs index 99249e4..9eac968 100644 --- a/src/Vervis/Handler/Discussion.hs +++ b/src/Vervis/Handler/Discussion.hs @@ -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 diff --git a/src/Vervis/Handler/Inbox.hs b/src/Vervis/Handler/Inbox.hs index 12a0e72..fa970cd 100644 --- a/src/Vervis/Handler/Inbox.hs +++ b/src/Vervis/Handler/Inbox.hs @@ -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 diff --git a/src/Vervis/Handler/Ticket.hs b/src/Vervis/Handler/Ticket.hs index 59cc546..ef87c9b 100644 --- a/src/Vervis/Handler/Ticket.hs +++ b/src/Vervis/Handler/Ticket.hs @@ -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 diff --git a/src/Yesod/Hashids.hs b/src/Yesod/Hashids.hs new file mode 100644 index 0000000..982c1e8 --- /dev/null +++ b/src/Yesod/Hashids.hs @@ -0,0 +1,127 @@ +{- This file is part of Vervis. + - + - Written in 2019 by fr33domlover . + - + - ♡ 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 + - . + -} + +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 diff --git a/vervis.cabal b/vervis.cabal index 3cb6a5b..ca8e034 100644 --- a/vervis.cabal +++ b/vervis.cabal @@ -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