More type-safe handling of DB key Hashids

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

src/Vervis/Application.hs

@@ -135,8 +135,7 @@ makeFoundation appSettings = do
     let mkFoundation
             appConnPool
             appCapSignKey
-            appHashidEncode
+            appHashidsContext =
-            appHashidDecode =
                 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 "hashidsContext forced in tempFoundation")
-                (error "hashidDecode 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.

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
+        MessageR shr hid -> (shr,) <$> decodeKeyHashidE hid "Non-existent local message hashid"
-            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"
 
 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)

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
+    , appHashidsContext :: HashidsContext
-    , appHashidDecode :: Text -> Maybe Int64
 
     , 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

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

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

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
+    lmid <- decodeKeyHashid404 hid
-    --encodeHid <- getsYesod appHashidEncode
-    lmid <-
-        case toSqlKey <$> decodeHid hid of
-            Nothing -> notFound
-            Just k  -> return k
     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 <- getEncodeKeyHashid
-    encodeHid <- getsYesod appHashidEncode
+    mid <- decodeKeyHashid404 hid
-    mid <-
-        case toSqlKey <$> decodeHid hid of
-            Nothing -> notFound
-            Just k  -> return k
     postReply
-        (TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
+        (TicketReplyR shar proj tnum . encodeHid)
-        (TicketMessageR shar proj tnum . encodeHid . fromSqlKey)
+        (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 <- getEncodeKeyHashid
-    encodeHid <- getsYesod appHashidEncode
+    mid <- decodeKeyHashid404 hid
-    mid <-
-        case toSqlKey <$> decodeHid hid of
-            Nothing -> notFound
-            Just k  -> return k
     getReply
-        (TicketReplyR shar proj tnum . encodeHid . fromSqlKey)
+        (TicketReplyR shar proj tnum . encodeHid)
-        (TicketMessageR shar proj tnum . encodeHid . fromSqlKey)
+        (TicketMessageR shar proj tnum . encodeHid)
         (selectDiscussionId shar proj tnum)
         mid
 

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

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