More type-safe handling of DB key Hashids

2019-03-29 03:25:32 +00:00 · 2019-03-29 03:25:32 +00:00 · c2415301bc
commit c2415301bc
parent 228e954706
9 changed files with 186 additions and 63 deletions
--- 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
--- 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.
--- 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,11 +133,7 @@ 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)
+        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
@ -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)
--- 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
--- 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
--- 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
--- 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

--- a/src/Yesod/Hashids.hs
+++ b/src/Yesod/Hashids.hs
@ -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
--- 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