-
Notifications
You must be signed in to change notification settings - Fork 9
New issue
Have a question about this project? Sign up for a free GitHub account to open an issue and contact its maintainers and the community.
By clicking “Sign up for GitHub”, you agree to our terms of service and privacy statement. We’ll occasionally send you account related emails.
Already on GitHub? Sign in to your account
Store ghc version for each snippet #24
base: master
Are you sure you want to change the base?
Changes from all commits
File filter
Filter by extension
Conversations
Jump to
Diff view
Diff view
There are no files selected for viewing
Original file line number | Diff line number | Diff line change |
---|---|---|
@@ -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" <<EOF | ||
PRAGMA foreign_keys = on; | ||
|
||
UPDATE meta SET version = 6; | ||
|
||
ALTER TABLE pastes ADD COLUMN ghcVersion TEXT; | ||
|
||
VACUUM; | ||
EOF | ||
|
||
echo "Migrated into '$newfname'." |
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -310,6 +310,12 @@ preload_script = {{&preload}}; | |
{{^preload}} | ||
preload_script = null; | ||
{{/preload}} | ||
{{#version}} | ||
preload_ghc_version = {{&version}}; | ||
{{/version}} | ||
{{^preload_ghc_version}} | ||
preload_ghc_version = "default"; | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I don't like the in-band signalling here very much. I think it would be better if the "default" signal was |
||
{{/preload_ghc_version}} | ||
</script> | ||
</head> | ||
<body> | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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\ | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. please add an explicit |
||
\ 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 () | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. Superfluous space after |
||
_ -> 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 | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -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,15 +180,15 @@ 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 | ||
req <- getRequest | ||
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" | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. when isSpam $ do
lift $ httpError 429 "Please slow down a bit, you're rate limited"
exitEarly ()
postdata <- ... |
||
else do postdata <- getRequestBodyEarlyExit maxSaveFileSize "Program too large" | ||
ClientSavePasteReq{csprCode =code, csprVersion = version} <- case J.decodeStrict' postdata of | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. missing space after |
||
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 | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. So this evaluates to |
||
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")) | ||
|
Original file line number | Diff line number | Diff line change |
---|---|---|
|
@@ -79,10 +79,17 @@ const ghcReadableVersion: Record<string, string> = { | |
"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 <script> block in play.mustache | ||
declare var preload_script: string | null; | ||
declare var preload_ghc_version: string | null; | ||
const snippet = preload_script != null ? preload_script : example_snippets[Math.floor(Math.random() * example_snippets.length)]; | ||
if (preload_ghc_version == "default") { | ||
preload_ghc_version = defaultGHCversion | ||
} | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. When switching away from |
||
const ghcversion = preload_ghc_version != null ? preload_ghc_version : defaultGHCversion | ||
|
||
// defined in ace-files/ace.js with a <script src> block in play.mustache | ||
declare var ace: any; | ||
|
@@ -117,8 +124,6 @@ type Runner = "run" | "core" | "asm"; | |
|
||
let lastRunKind: Runner = "run"; | ||
|
||
const defaultGHCversion: string = "9.2.7"; | ||
|
||
|
||
function performXHR( | ||
method: string, | ||
|
@@ -172,7 +177,7 @@ function setWorking(yes: boolean) { | |
} | ||
} | ||
|
||
function getVersions(cb: (response: string) => void) { | ||
function getVersions(cb: (response) => void) { | ||
performXHR("GET", "/versions", "json", cb, function(xhr) { | ||
alert("Error getting available compiler versions (status " + xhr.status + "): " + xhr.responseText); | ||
}); | ||
|
@@ -242,6 +247,8 @@ function doRun(run: Runner) { | |
|
||
function doSave() { | ||
const source: string = editor.getValue(); | ||
let version = (document.getElementById("ghcversionselect") as any).value; | ||
const payload: string = JSON.stringify({code: source, version}); | ||
|
||
performXHR( | ||
"POST", "/save", "text", | ||
|
@@ -257,7 +264,7 @@ function doSave() { | |
xhr => { | ||
alert("Could not save your code!\nServer returned status code " + xhr.status + ": " + xhr.responseText); | ||
}, | ||
"text/plain", source | ||
"application/json", payload | ||
); | ||
} | ||
|
||
|
@@ -332,14 +339,21 @@ window.addEventListener("load", function() { | |
document.getElementById("btn-core").setAttribute("title", runTooltip); | ||
document.getElementById("btn-asm").setAttribute("title", runTooltip); | ||
|
||
getVersions(function(versions) { | ||
getVersions(function(versions: string[]) { | ||
const sel: HTMLElement = document.getElementById("ghcversionselect"); | ||
if (versions.length === 0) { | ||
versions.push(defaultGHCversion) | ||
} | ||
for (let i = 0; i < versions.length; i++) { | ||
const opt: HTMLOptionElement = document.createElement("option"); | ||
opt.value = versions[i]; | ||
const readable = versions[i] in ghcReadableVersion ? ghcReadableVersion[versions[i]] : versions[i]; | ||
opt.textContent = "GHC " + readable; | ||
if (versions[i] == defaultGHCversion) opt.setAttribute("selected", ""); | ||
let readable = versions[i] in ghcReadableVersion ? ghcReadableVersion[versions[i]] : versions[i]; | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. No reason for |
||
let verAnnotation = "" | ||
if (versions[i] === defaultGHCversion) { | ||
verAnnotation = "(Default) " | ||
} | ||
opt.textContent = verAnnotation + "GHC " + readable; | ||
There was a problem hiding this comment. Choose a reason for hiding this commentThe reason will be displayed to describe this comment to others. Learn more. I think I prefer the annotation to come at the end, so |
||
if (versions[i] == ghcversion) opt.setAttribute("selected", ""); | ||
sel.appendChild(opt); | ||
} | ||
}); | ||
|
There was a problem hiding this comment.
Choose a reason for hiding this comment
The reason will be displayed to describe this comment to others. Learn more.
Also add an explicit
NULL
here afterTEXT