Skip to content
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.

Sign up for GitHub

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

Jump to bottom

Store ghc version for each snippet #24

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open

Store ghc version for each snippet #24

Show file tree
Hide file tree
Changes from all commits
Commits
Show all changes
4 commits
Select commit Hold shift + click to select a range
012d46a
Store ghc version for each snippet
trevorsibanda Mar 1, 2023
9f6c98d
Accept json body for save
trevorsibanda Mar 2, 2023
13c300a
ghcVersion DB field should be nullable
trevorsibanda Mar 3, 2023
c1f82b9
Apply formatting play-haskell-server/src/DB.hs
trevorsibanda Mar 15, 2023
File filter

Filter by extension

Filter by extension
Conversations
Failed to load comments.
Loading
Jump to
Jump to file
Failed to load files.
Loading
Diff view
Diff view
24 changes: 24 additions & 0 deletions play-haskell-server/migrate_db_5_6.sh
View file
Open in desktop
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;
Copy link
Collaborator

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 after TEXT


VACUUM;
EOF

echo "Migrated into '$newfname'."
6 changes: 6 additions & 0 deletions play-haskell-server/play.mustache
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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";
Copy link
Collaborator

Choose a reason for hiding this comment

The 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 null instead. null here would correspond to NULL in the database.

{{/preload_ghc_version}}
</script>
</head>
<body>
Expand Down
44 changes: 22 additions & 22 deletions play-haskell-server/src/DB.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -2,7 +2,7 @@
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module DB (
Database, ErrCode(..), ClientAddr, KeyType, Contents(..),
Database, ErrCode(..),
withDatabase,
storePaste, getPaste,
removeExpiredPastes,
Expand All @@ -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

Expand All @@ -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)
Expand Down Expand Up @@ -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\
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

please add an explicit NULL after TEXT

\ date INTEGER NULL, \n\
\ expire INTEGER NULL, \n\
\ srcip TEXT NULL, \n\
Expand Down Expand Up @@ -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 ()
Expand All @@ -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) \
Expand All @@ -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 ()
Expand Down
27 changes: 22 additions & 5 deletions play-haskell-server/src/Pages.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -4,6 +4,7 @@ module Pages (
Pages(..), pagesFromDisk
) where

import PlayHaskellTypes
import Data.Bits (shiftR)
import Data.ByteString (ByteString)
import Data.Char (ord, chr)
Expand All @@ -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")
Expand All @@ -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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

Superfluous space after (.
Also, versionToMustache = mixinMaybeNull (\(Version v) -> v) if I'm not mistaken.

_ -> 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
Expand Down
50 changes: 33 additions & 17 deletions play-haskell-server/src/Play.hs
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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
Expand Down Expand Up @@ -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"

Expand All @@ -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"
Copy link
Collaborator

Choose a reason for hiding this comment

The 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
Copy link
Collaborator

Choose a reason for hiding this comment

The 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
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

So this evaluates to fromMaybe Nothing (fmap Just x), which is equivalent to x. I get that you want to abstract defaultGHCVersion out, but since the intuitive semantics of Maybe correspond quite nicely with what is meant here ("Nothing indicates no version specified"), an alternative is to embrace the Maybe, remove defaultGHCVersion (which doesn't really yield a default version, it yields no version which is typically interpreted as meaning some default version), and simplify this to L.find (==version) versions. Which, by the way, is a nice trick.

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"))
Expand Down
30 changes: 22 additions & 8 deletions play-haskell-server/static/play-index.ts
View file
Open in desktop
Original file line number Diff line number Diff line change
Expand Up @@ -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
}
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

When switching away from "default", this whole if-statement can go :)

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;
Expand Down Expand Up @@ -117,8 +124,6 @@ type Runner = "run" | "core" | "asm";

let lastRunKind: Runner = "run";

const defaultGHCversion: string = "9.2.7";


function performXHR(
method: string,
Expand Down Expand Up @@ -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);
});
Expand Down Expand Up @@ -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",
Expand All @@ -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
);
}

Expand Down Expand Up @@ -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];
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

No reason for readable to become non-const, right?

let verAnnotation = ""
if (versions[i] === defaultGHCversion) {
verAnnotation = "(Default) "
}
opt.textContent = verAnnotation + "GHC " + readable;
Copy link
Collaborator

Choose a reason for hiding this comment

The reason will be displayed to describe this comment to others. Learn more.

I think I prefer the annotation to come at the end, so GHC <version> (Default). Then the entries in the list all start in a uniform way (with GHC ).

if (versions[i] == ghcversion) opt.setAttribute("selected", "");
sel.appendChild(opt);
}
});
Expand Down
Loading