diff --git a/config/settings-default.yaml b/config/settings-default.yaml index 4719090..bac70cc 100644 --- a/config/settings-default.yaml +++ b/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 diff --git a/src/Data/Int/Local.hs b/src/Data/Int/Local.hs new file mode 100644 index 0000000..852c6cc --- /dev/null +++ b/src/Data/Int/Local.hs @@ -0,0 +1,39 @@ +{- 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 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 diff --git a/src/Data/KeyFile.hs b/src/Data/KeyFile.hs new file mode 100644 index 0000000..0a64e04 --- /dev/null +++ b/src/Data/KeyFile.hs @@ -0,0 +1,46 @@ +{- 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 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 diff --git a/src/Vervis/ActorKey.hs b/src/Vervis/ActorKey.hs index 2734e3d..e2bfacd 100644 --- a/src/Vervis/ActorKey.hs +++ b/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 diff --git a/src/Vervis/Application.hs b/src/Vervis/Application.hs index 7654679..4db69a4 100644 --- a/src/Vervis/Application.hs +++ b/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. diff --git a/src/Vervis/Foundation.hs b/src/Vervis/Foundation.hs index a9c464c..05dac52 100644 --- a/src/Vervis/Foundation.hs +++ b/src/Vervis/Foundation.hs @@ -76,15 +76,17 @@ import Vervis.Widget (breadcrumbsW, revisionW) -- starts running, such as database connections. Every handler will have -- access to the data present here. data App = App - { appSettings :: AppSettings - , appStatic :: Static -- ^ Settings for static file serving. - , appConnPool :: ConnectionPool -- ^ Database connection pool. - , appHttpManager :: Manager - , appLogger :: Logger - , appMailQueue :: Maybe (Chan (MailRecipe App)) - , appSvgFont :: PreparedFont Double - , appActorKeys :: TVar (ActorKey, ActorKey, Bool) - , appCapSignKey :: ActorKey + { appSettings :: AppSettings + , appStatic :: Static -- ^ Settings for static file serving. + , appConnPool :: ConnectionPool -- ^ Database connection pool. + , appHttpManager :: Manager + , appLogger :: Logger + , appMailQueue :: Maybe (Chan (MailRecipe 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))) } diff --git a/src/Vervis/KeyFile.hs b/src/Vervis/KeyFile.hs index a3d45e9..6d5998c 100644 --- a/src/Vervis/KeyFile.hs +++ b/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 diff --git a/src/Vervis/Settings.hs b/src/Vervis/Settings.hs index e4df6b5..f819f0b 100644 --- a/src/Vervis/Settings.hs +++ b/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 {..} diff --git a/src/Web/Hashids/Local.hs b/src/Web/Hashids/Local.hs new file mode 100644 index 0000000..9592daa --- /dev/null +++ b/src/Web/Hashids/Local.hs @@ -0,0 +1,61 @@ +{- 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 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 diff --git a/vervis.cabal b/vervis.cabal index f393ef9..1050743 100644 --- a/vervis.cabal +++ b/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