Generate and keep permanent salt for generating hashids for URIs

config/settings-default.yaml

@@ -123,3 +123,6 @@ max-accounts: 3
 
 # Signing key file for signing object capabilities sent to remote users
 capability-signing-key: config/capability_signing_key
+
+# Salt file for encoding and decoding hashids
+hashids-salt-file:      config/hashids_salt

src/Data/Int/Local.hs

@@ -0,0 +1,39 @@
+{- 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 Data.Int.Local
+    ( toInts
+    , fromInts
+    )
+where
+
+import Prelude
+
+import Data.Int (Int64)
+import Data.List.NonEmpty (NonEmpty (..), (<|))
+
+modbase :: Int64
+modbase = 2 ^ 29
+
+toInts :: Int64 -> NonEmpty Int
+toInts n =
+    let (d, m) = n `divMod` modbase
+        m' = fromIntegral m
+    in  if d == 0
+            then m' :| []
+            else m' <| toInts d
+
+fromInts :: NonEmpty Int -> Int64
+fromInts = foldr (\ i n -> fromIntegral i + modbase * n) 0

src/Data/KeyFile.hs

@@ -0,0 +1,46 @@
+{- 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 Data.KeyFile
+    ( KeyFile (..)
+    , loadKeyFile
+    )
+where
+
+import Prelude
+
+import Data.ByteString (ByteString)
+import System.Directory (doesFileExist)
+
+import qualified Data.ByteString as B (readFile, writeFile)
+
+class KeyFile a where
+    generateKey :: IO a
+    parseKey    :: ByteString -> IO a
+    renderKey   :: a -> ByteString
+
+loadKeyFile :: KeyFile a => Bool -> FilePath -> IO a
+loadKeyFile setup path = do
+    e <- doesFileExist path
+    if e
+        then if setup
+                then fail $ "loadKeyFile: Initial setup but file already exists: " ++ path
+                else parseKey =<< B.readFile path
+        else if setup
+                then do
+                    k <- generateKey
+                    B.writeFile path $ renderKey k
+                    return k
+                else fail $ "loadKeyFile: File not found: " ++ path

src/Vervis/ActorKey.hs

@@ -40,7 +40,7 @@ import System.Directory (doesFileExist)
 
 import qualified Data.ByteString as B (writeFile, readFile)
 
-import Vervis.KeyFile
+import Data.KeyFile
 
 -- | Ed25519 signing key, we generate it on the server and use for signing. We
 -- also make its public key available to whoever wishes to verify our

src/Vervis/Application.hs

@@ -59,8 +59,11 @@ import Control.Concurrent.Local (forkCheck)
 
 import Database.Persist.Schema.PostgreSQL (schemaBackend)
 
+import Data.KeyFile (loadKeyFile)
+import Web.Hashids.Local
+
 import Vervis.ActorKey (generateActorKey, actorKeyRotator)
-import Vervis.KeyFile (isInitialSetup, loadKeyFile)
+import Vervis.KeyFile (isInitialSetup)
 
 -- Import all relevant handler modules here.
 -- Don't forget to add new modules to your cabal file!
@@ -125,7 +128,12 @@ makeFoundation appSettings = do
     -- logging function. To get out of this loop, we initially create a
     -- temporary foundation without a real connection pool, get a log function
     -- from there, and then create the real foundation.
-    let mkFoundation appConnPool appCapSignKey = App {..}
+    let mkFoundation
+            appConnPool
+            appCapSignKey
+            appHashidEncode
+            appHashidDecode =
+                App {..}
         -- The App {..} syntax is an example of record wild cards. For more
         -- information, see:
         -- https://ocharles.org.uk/blog/posts/2014-12-04-record-wildcards.html
@@ -133,6 +141,8 @@ makeFoundation appSettings = do
             mkFoundation
                 (error "connPool forced in tempFoundation")
                 (error "capSignKey forced in tempFoundation")
+                (error "hashidEncode forced in tempFoundation")
+                (error "hashidDecode forced in tempFoundation")
         logFunc = loggingFunction tempFoundation
 
     -- Create the database connection pool
@@ -142,6 +152,10 @@ makeFoundation appSettings = do
 
     setup <- isInitialSetup pool schemaBackend
     capSignKey <- loadKeyFile setup $ appCapabilitySigningKeyFile appSettings
+    hashidsSalt <- loadKeyFile setup $ 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
@@ -156,7 +170,7 @@ makeFoundation appSettings = do
                 Right (_from, _to) -> $logInfo "DB migration success"
 
     -- Return the foundation
-    return $ mkFoundation pool capSignKey
+    return $ mkFoundation pool capSignKey hashidEncode hashidDecode
 
 -- | Convert our foundation to a WAI Application by calling @toWaiAppPlain@ and
 -- applying some additional middlewares.

src/Vervis/Foundation.hs

@@ -85,6 +85,8 @@ data App = App
     , appSvgFont      :: PreparedFont Double
     , appActorKeys    :: TVar (ActorKey, ActorKey, Bool)
     , appCapSignKey   :: ActorKey
+    , appHashidEncode :: Int64 -> Text
+    , appHashidDecode :: Text -> Maybe Int64
 
     , appActivities  :: TVar (Vector (UTCTime, Either String (ByteString, BL.ByteString)))
     }

src/Vervis/KeyFile.hs

@@ -33,50 +33,26 @@
 --   * Have a reliable way to determine whether we're in the initial setup
 --     step, and make sure it's not easy to accidentally break this detection
 --
--- This module implements such a mechanism for Vervis. It's really simple:
+-- This module, along with "Data.KeyFile", implements such a mechanism for
+-- Vervis. It's really simple:
 --
 --   * If there are no tables in the DB, it's the initial setup phase
 --   * If initial setup, require that key file doesn't exist, and generate one
 --   * If not initial setup, require that key file exists
 module Vervis.KeyFile
-    ( KeyFile (..)
-    , isInitialSetup
-    , loadKeyFile
+    ( isInitialSetup
     )
 where
 
 import Prelude
 
 import Control.Monad.Trans.Reader (runReaderT)
-import Data.ByteString (ByteString)
 import Database.Persist.Schema (SchemaBackend, hasEntities)
 import Database.Persist.Schema.SQL ()
 import Database.Persist.Sql (SqlBackend, ConnectionPool, runSqlPool)
-import System.Directory (doesFileExist)
-
-import qualified Data.ByteString as B (readFile, writeFile)
-
-class KeyFile a where
-    generateKey :: IO a
-    parseKey    :: ByteString -> IO a
-    renderKey   :: a -> ByteString
 
 -- | Check whether we're in the initial setup step, in which we create keys.
 -- Otherwise, we'll only use existing keys loaded from files.
 isInitialSetup :: ConnectionPool -> SchemaBackend SqlBackend -> IO Bool
 isInitialSetup pool sb =
     flip runSqlPool pool . flip runReaderT sb $ not <$> hasEntities
-
-loadKeyFile :: KeyFile a => Bool -> FilePath -> IO a
-loadKeyFile setup path = do
-    e <- doesFileExist path
-    if e
-        then if setup
-                then fail $ "loadKeyFile: Initial setup but file already exists: " ++ path
-                else parseKey =<< B.readFile path
-        else if setup
-                then do
-                    k <- generateKey
-                    B.writeFile path $ renderKey k
-                    return k
-                else fail $ "loadKeyFile: File not found: " ++ path

src/Vervis/Settings.hs

@@ -105,6 +105,8 @@ data AppSettings = AppSettings
 
       -- Signing key file for signing object capabilities sent to remote users
     , appCapabilitySigningKeyFile :: FilePath
+      -- Salt for encoding and decoding hashids
+    , appHashidsSaltFile          :: FilePath
     }
 
 instance FromJSON AppSettings where
@@ -145,6 +147,7 @@ instance FromJSON AppSettings where
         appMail                   <- o .:? "mail"
 
         appCapabilitySigningKeyFile <- o .: "capability-signing-key"
+        appHashidsSaltFile          <- o .: "hashids-salt-file"
 
         return AppSettings {..}
 

src/Web/Hashids/Local.hs

@@ -0,0 +1,61 @@
+{- 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 Web.Hashids.Local
+    ( hashidsContext
+    , encodeInt64
+    , decodeInt64
+    )
+where
+
+import Prelude
+
+import Control.Monad (replicateM)
+import Data.ByteString (ByteString)
+import Data.Int (Int64)
+import Data.List.NonEmpty (nonEmpty)
+import System.Random (randomIO)
+import Web.Hashids
+
+import qualified Data.ByteString as B (pack, length)
+import qualified Data.List.NonEmpty as NE (toList)
+
+import Data.Int.Local
+import Data.KeyFile
+
+saltLength :: Int
+saltLength = 32
+
+newtype HashidsSalt = HashidsSalt ByteString
+
+instance KeyFile HashidsSalt where
+    generateKey = HashidsSalt <$> generateRandomBytes saltLength
+        where
+        generateRandomBytes :: Int -> IO ByteString
+        generateRandomBytes n = B.pack <$> replicateM n randomIO
+    parseKey b =
+        if B.length b == saltLength
+            then return $ HashidsSalt b
+            else fail "parseKey HashidsSalt: Invalid length"
+    renderKey (HashidsSalt b) = b
+
+hashidsContext :: HashidsSalt -> HashidsContext
+hashidsContext = flip hashidsMinimum 5 . renderKey
+
+encodeInt64 :: HashidsContext -> Int64 -> ByteString
+encodeInt64 c = encodeList c . NE.toList . toInts
+
+decodeInt64 :: HashidsContext -> ByteString -> Maybe Int64
+decodeInt64 c = fmap fromInts . nonEmpty . decode c

vervis.cabal

@@ -60,6 +60,8 @@ library
                        Data.Graph.Inductive.Query.TransRed
                        Data.HashMap.Lazy.Local
                        Data.Hourglass.Local
+                       Data.Int.Local
+                       Data.KeyFile
                        Data.List.Local
                        Data.Maybe.Local
                        Data.Paginate.Local
@@ -84,6 +86,7 @@ library
                        Text.FilePath.Local
                        Text.Jasmine.Local
                        Web.ActivityPub
+                       Web.Hashids.Local
                        Web.PathPieces.Local
                        Yesod.Auth.Unverified
                        Yesod.Auth.Unverified.Creds
@@ -256,6 +259,7 @@ library
                      , filepath
                      , formatting
                      , hashable
+                     , hashids
                        -- for source file highlighting
                      , highlighter2
                      , http-client-signature
@@ -295,6 +299,8 @@ library
                      , persistent-postgresql
                      , persistent-template
                      , process
+                       -- for generating hashids salt
+                     , random
                        -- for Database.Persist.Local
                      , resourcet
                      , safe