diff --git a/play-haskell-server/migrate_db_5_6.sh b/play-haskell-server/migrate_db_5_6.sh new file mode 100755 index 0000000..bf130f8 --- /dev/null +++ b/play-haskell-server/migrate_db_5_6.sh @@ -0,0 +1,24 @@ +#!/usr/bin/env bash +set -euo pipefail + +newfname='pastes.migrate_5_6.db' +[[ -f $newfname ]] && { echo >&2 "Destination '$newfname' already exists!"; exit 1; } + +echo "Copying database to '$newfname'..." +sqlite3 pastes.db "VACUUM INTO \"$newfname\"" + +oldversion=$(sqlite3 "$newfname" 'SELECT version FROM meta') +[[ $oldversion -ne 5 ]] && { echo >&2 "Database is not currently at version 5!"; exit 1; } + +echo "Migrating '$newfname'..." +sqlite3 "$newfname" < diff --git a/play-haskell-server/src/DB.hs b/play-haskell-server/src/DB.hs index c35ca2c..547e6c8 100644 --- a/play-haskell-server/src/DB.hs +++ b/play-haskell-server/src/DB.hs @@ -2,7 +2,7 @@ {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE TypeApplications #-} module DB ( - Database, ErrCode(..), ClientAddr, KeyType, Contents(..), + Database, ErrCode(..), withDatabase, storePaste, getPaste, removeExpiredPastes, @@ -15,10 +15,15 @@ import qualified Data.Text as T import Data.Time.Clock (secondsToNominalDiffTime) import Data.Time.Clock.POSIX (POSIXTime, getPOSIXTime) import Database.SQLite.Simple +import Database.SQLite.Simple.ToField import System.Exit (die) import System.IO (hPutStrLn, stderr) +import PlayHaskellTypes (Version(..), Paste(..), KeyType, ClientAddr) +instance ToField Version where + toField (Version v) = toField v + maxDbFileSize :: Int maxDbFileSize = 1024 * 1024 * 1024 -- 1 GiB @@ -28,13 +33,6 @@ dbFileName dbdir = dbdir ++ "/pastes.db" newtype Database = Database Connection -type ClientAddr = String -type KeyType = ByteString -data Contents = - Contents [(Maybe ByteString, ByteString)] -- ^ Files with optional filenames - (Maybe KeyType) -- ^ Parent paste this was edited from, if any - (Maybe POSIXTime) -- ^ Expiration date - data ErrCode = ErrExists -- ^ Key already exists in database | ErrFull -- ^ Database disk quota has been reached deriving (Show) @@ -71,6 +69,7 @@ schemaVersion :: Int ,"CREATE TABLE pastes (\n\ \ id INTEGER PRIMARY KEY NOT NULL, \n\ \ key BLOB NOT NULL, \n\ + \ ghcVersion TEXT, \n\ \ date INTEGER NULL, \n\ \ expire INTEGER NULL, \n\ \ srcip TEXT NULL, \n\ @@ -104,8 +103,8 @@ applySchema (Database conn) = do mapM_ (execute_ conn) schema execute conn "INSERT INTO meta (version) VALUES (?)" (Only schemaVersion) -storePaste :: Database -> ClientAddr -> KeyType -> Contents -> IO (Maybe ErrCode) -storePaste (Database conn) clientaddr key (Contents files mparent mexpire) = do +storePaste :: Database -> ClientAddr -> KeyType -> Paste -> IO (Maybe ErrCode) +storePaste (Database conn) clientaddr key (Paste ghcVersion files mparent mexpire) = do now <- truncate <$> getPOSIXTime :: IO Int let mexpire' = truncate <$> mexpire :: Maybe Int let predicate (SQLError { sqlError = ErrorError }) = Just () @@ -118,13 +117,13 @@ storePaste (Database conn) clientaddr key (Contents files mparent mexpire) = do then do case mparent of Just parent -> - execute conn "INSERT INTO pastes (key, date, expire, srcip, parent) \ - \VALUES (?, ?, ?, ?, (SELECT id FROM pastes WHERE key = ?))" - (key, now, mexpire', clientaddr, parent) + execute conn "INSERT INTO pastes (key, ghcVersion, date, expire, srcip, parent) \ + \VALUES (?, ?, ?, ?, ?, (SELECT id FROM pastes WHERE key = ?))" + (key, ghcVersion, now, mexpire', clientaddr, parent) Nothing -> - execute conn "INSERT INTO pastes (key, date, expire, srcip) \ - \VALUES (?, ?, ?, ?)" - (key, now, mexpire', clientaddr) + execute conn "INSERT INTO pastes (key, ghcVersion, date, expire, srcip) \ + \VALUES (?, ?, ?, ?, ?)" + (key, ghcVersion, now, mexpire', clientaddr) pasteid <- lastInsertRowId conn forM_ (zip files [1::Int ..]) $ \((mfname, contents), idx) -> execute conn "INSERT INTO files (paste, fname, value, fileorder) \ @@ -133,19 +132,20 @@ storePaste (Database conn) clientaddr key (Contents files mparent mexpire) = do return Nothing else return (Just ErrExists) -getPaste :: Database -> KeyType -> IO (Maybe (Maybe POSIXTime, Contents)) +getPaste :: Database -> KeyType -> IO (Maybe (Maybe POSIXTime, Paste)) getPaste (Database conn) key = do - res <- query @_ @(Maybe Int, Maybe Int, Maybe ByteString, ByteString, Maybe ByteString) - conn "SELECT P.date, P.expire, F.fname, F.value, (SELECT key FROM pastes WHERE id = P.parent) \ + res <- query @_ @(Maybe Int, Maybe String, Maybe Int, Maybe ByteString, ByteString, Maybe ByteString) + conn "SELECT P.date, P.ghcVersion, P.expire, F.fname, F.value, (SELECT key FROM pastes WHERE id = P.parent) \ \FROM pastes AS P, files as F \ \WHERE P.id = F.paste AND P.key = ? ORDER BY F.fileorder" (Only key) case res of - (date, expire, _, _, mparent) : _ -> + (date, version, expire, _, _, mparent) : _ -> let date' = secondsToNominalDiffTime . fromIntegral <$> date expire' = secondsToNominalDiffTime . fromIntegral <$> expire - files = [(mfname, contents) | (_, _, mfname, contents, _) <- res] - in return (Just (date', Contents files mparent expire')) + files = [(mfname, contents) | (_, _, _, mfname, contents, _) <- res] + ghcVersion = Version <$> version + in return (Just (date', Paste ghcVersion files mparent expire')) [] -> return Nothing removeExpiredPastes :: Database -> IO () diff --git a/play-haskell-server/src/Pages.hs b/play-haskell-server/src/Pages.hs index 5aeeb9c..04e9057 100644 --- a/play-haskell-server/src/Pages.hs +++ b/play-haskell-server/src/Pages.hs @@ -4,6 +4,7 @@ module Pages ( Pages(..), pagesFromDisk ) where +import PlayHaskellTypes import Data.Bits (shiftR) import Data.ByteString (ByteString) import Data.Char (ord, chr) @@ -17,7 +18,7 @@ import Text.Mustache (toMustache) import qualified Text.Mustache.Types as Mustache (Value) -data Pages = Pages { pPlay :: Maybe ByteString -> ByteString } +data Pages = Pages { pPlay :: Maybe Paste -> ByteString } pagesFromDisk :: IO Pages pagesFromDisk = Pages <$> (renderPlayPage <$> loadTemplate "play.mustache") @@ -29,10 +30,26 @@ loadTemplate fp = do Right templ -> return templ Left err -> die (show err) -renderPlayPage :: Mustache.Template -> Maybe ByteString -> ByteString -renderPlayPage templ mcontents = Enc.encodeUtf8 $ - Mustache.substituteValue templ $ Mustache.object - [(Text.pack "preload", mixinMaybeNull (jsStringEncode . decodeUtf8) mcontents)] +renderPlayPage :: Mustache.Template -> Maybe Paste -> ByteString +renderPlayPage templ = \case + Just paste -> Enc.encodeUtf8 $ Mustache.substituteValue templ $ pasteToMustacheObject paste + Nothing -> Enc.encodeUtf8 $ Mustache.substituteValue templ $ Mustache.object [(Text.pack "preload", toMustache False)] + +versionToMustache :: Maybe Version -> Mustache.Value +versionToMustache = \case + Just ( Version v) -> toMustache v + _ -> toMustache False + +pasteToMustacheObject :: Paste -> Mustache.Value +pasteToMustacheObject (Paste mversion contents _ _) = Mustache.object l + where + l = [(Text.pack "preload", mixinMaybeNull (jsStringEncode . decodeUtf8) msource), + (Text.pack "version", versionToMustache mversion)] + msource = case contents of + ((_, source) : _) -> Just source + _ -> Nothing + + mixinMaybeNull :: Mustache.ToMustache b => (a -> b) -> Maybe a -> Mustache.Value mixinMaybeNull _ Nothing = toMustache False diff --git a/play-haskell-server/src/Play.hs b/play-haskell-server/src/Play.hs index b8c1c01..9dc6baa 100644 --- a/play-haskell-server/src/Play.hs +++ b/play-haskell-server/src/Play.hs @@ -15,22 +15,21 @@ import qualified Data.Aeson.Types as J import Data.ByteString (ByteString) import qualified Data.ByteString as BS import qualified Data.ByteString.Char8 as Char8 -import qualified Data.ByteString.Lazy as BSL import qualified Data.ByteString.Short as BSS import Data.Char (chr) +import qualified Data.List as L import Data.Maybe (fromMaybe) import qualified Data.Map.Strict as Map import Data.String (fromString) import Data.Text (Text) +import qualified Data.Text as T import Data.Time (secondsToDiffTime) -import Data.Word (Word64) import GHC.Generics (Generic) import Snap.Core hiding (path, method, pass) import System.Directory (listDirectory) import System.FilePath (takeExtension, takeFileName, ()) import System.Random (StdGen, genByteString, newStdGen) -import DB (KeyType, Contents(..), ClientAddr) import qualified DB import Pages import ServerModule @@ -61,6 +60,17 @@ instance J.FromJSON ClientJobReq where <*> (fromMaybe O1 <$> (v J..:? fromString "opt")) parseJSON val = J.prependFailure "parsing ClientJobReq failed, " (J.typeMismatch "Object" val) +data ClientSavePasteReq = ClientSavePasteReq + { + csprCode :: Text, + csprVersion :: Version + } deriving (Show) + +instance J.FromJSON ClientSavePasteReq where + parseJSON (J.Object v) = + ClientSavePasteReq <$> v J..: fromString "code" <*> v J..: fromString "version" + parseJSON val = J.prependFailure "parsing ClientSavePasteReq failed, " (J.typeMismatch "Object" val) + data ClientSubmitReq = ClientSubmitReq { csrCode :: Text , csrVersion :: Version @@ -101,7 +111,7 @@ genKey' var = atomically $ do return key -- returns the generated key, or an error string -genStorePaste :: GlobalContext -> TVar StdGen -> ClientAddr -> Contents -> IO (Either String KeyType) +genStorePaste :: GlobalContext -> TVar StdGen -> ClientAddr -> Paste -> IO (Either String KeyType) genStorePaste gctx stvar srcip contents = let loop iter = do key <- genKey' stvar @@ -170,7 +180,7 @@ handleRequest gctx ctx = \case req <- getRequest renderer <- liftIO $ getPageFromGCtx pPlay gctx case Map.lookup "code" (rqQueryParams req) of - Just (source : _) -> writeHTML (renderer (Just source)) + Just (source : _) -> writeHTML (renderer (Just $ newPaste defaultGHCVersion Nothing source)) _ -> writeHTML (renderer Nothing) PostedIndex -> do @@ -178,7 +188,7 @@ handleRequest gctx ctx = \case case Map.lookup "code" (rqPostParams req) of Just [source] -> do renderer <- liftIO $ getPageFromGCtx pPlay gctx - writeHTML (renderer (Just source)) + writeHTML (renderer (Just $ newPaste defaultGHCVersion Nothing source)) _ -> httpError 400 "Invalid request" @@ -188,32 +198,38 @@ handleRequest gctx ctx = \case renderer <- liftIO $ getPageFromGCtx pPlay gctx writeHTML (renderer (Just contents)) case res of - Just (_, Contents [] _ _) -> do + Just (_, Paste _ [] _ _) -> do modifyResponse (setContentType (Char8.pack "text/plain")) writeBS (Char8.pack "Save key not found (empty file list?)") - Just (_, Contents ((_, source) : _) _ _) -> - buildPage source + Just (_, contents) -> + buildPage contents Nothing -> do modifyResponse (setContentType (Char8.pack "text/plain")) writeBS (Char8.pack "Save key not found") - Save -> do - req <- getRequest + Save -> execExitEarlyT $ do + req <- lift getRequest isSpam <- liftIO $ recordCheckSpam PlaySave (gcSpam gctx) (rqClientAddr req) if isSpam - then httpError 429 "Please slow down a bit, you're rate limited" - else do body <- readRequestBody (fromIntegral @Int @Word64 maxSaveFileSize) - let body' = BSL.toStrict body - let contents = Contents [(Nothing, body')] Nothing Nothing + then lift $ httpError 429 "Please slow down a bit, you're rate limited" + else do postdata <- getRequestBodyEarlyExit maxSaveFileSize "Program too large" + ClientSavePasteReq{csprCode =code, csprVersion = version} <- case J.decodeStrict' postdata of + Just request -> return request + _ -> do lift (httpError 400 "Invalid JSON") + exitEarly () + versions <- liftIO (WP.getAvailableVersions (ctxPool ctx)) + let version' = fromMaybe defaultGHCVersion $ Just <$> L.find (==version) versions + code' = Char8.pack $ T.unpack code + contents = Paste version' [(Nothing, code')] Nothing Nothing srcip = Char8.unpack (rqClientAddr req) mkey <- liftIO $ genStorePaste gctx (ctxRNG ctx) srcip contents case mkey of - Right key -> do + Right key -> lift $ do modifyResponse (setContentType (Char8.pack "text/plain")) writeBS key - Left err -> httpError 500 err + Left err -> lift $ httpError 500 err Versions -> do modifyResponse (setContentType (Char8.pack "text/plain")) diff --git a/play-haskell-server/static/play-index.ts b/play-haskell-server/static/play-index.ts index d42d9df..ae0ebcf 100644 --- a/play-haskell-server/static/play-index.ts +++ b/play-haskell-server/static/play-index.ts @@ -79,10 +79,17 @@ const ghcReadableVersion: Record = { "9.6.0.20230128": "9.6.1-alpha2", "9.6.0.20230210": "9.6.1-alpha3", }; +const defaultGHCversion: string = "9.2.7"; + // defined in a