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.

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

Open
wants to merge 4 commits into
base: master
Choose a base branch
from
Open
Changes from all commits
Commits
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
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
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";
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>
44 changes: 22 additions & 22 deletions play-haskell-server/src/DB.hs
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\
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\
@@ -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 ()
27 changes: 22 additions & 5 deletions play-haskell-server/src/Pages.hs
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
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
50 changes: 33 additions & 17 deletions play-haskell-server/src/Play.hs
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"
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"))
30 changes: 22 additions & 8 deletions play-haskell-server/static/play-index.ts
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
}
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;
@@ -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];
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);
}
});
3 changes: 2 additions & 1 deletion play-haskell-types/play-haskell-types.cabal
Original file line number Diff line number Diff line change
@@ -23,7 +23,8 @@ library
bytestring >= 0.11 && < 0.12,
cryptonite >= 0.30 && < 0.31,
memory >= 0.17 && < 0.18,
text
text,
time >= 1.9.3 && < 1.11
hs-source-dirs: src
default-language: Haskell2010
ghc-options: -Wall -O2
24 changes: 24 additions & 0 deletions play-haskell-types/src/PlayHaskellTypes.hs
Original file line number Diff line number Diff line change
@@ -3,10 +3,15 @@
{-# LANGUAGE TypeApplications #-}
{-# OPTIONS -Wno-orphans #-}
module PlayHaskellTypes (
Paste(..),
newPaste,
ClientAddr,
KeyType,
-- * Supporting types
Command(..),
Optimisation(..),
Version(..),
defaultGHCVersion,
RunError(..),

-- * Request/response types
@@ -43,8 +48,24 @@ import System.Exit
import PlayHaskellTypes.Sign (PublicKey, SecretKey, Signature)
import qualified PlayHaskellTypes.Sign as Sign
import PlayHaskellTypes.UTF8
import Data.Time.Clock.POSIX (POSIXTime)



type ClientAddr = String

type KeyType = ByteString

data Paste = Paste{
pasteVersion :: Maybe Version, -- ^ Paste Ghc Version
pasteContents :: [(Maybe ByteString, ByteString)], -- ^ Files with optional filenames
pasteKey :: Maybe KeyType, -- ^ Parent paste this was edited from, if any
pasteExpiration :: Maybe POSIXTime -- ^ Expiration date
} deriving (Show, Eq)

newPaste :: Maybe Version -> Maybe ByteString -> ByteString -> Paste
newPaste version fname content = Paste version [(fname, content)] Nothing Nothing

-- | JSON: string; "run", "core", "asm".
data Command = CRun -- ^ Compile and execute a Haskell file
| CCore -- ^ Get simplified core
@@ -61,6 +82,9 @@ data Optimisation = O0 | O1 | O2
newtype Version = Version String
deriving (Show, Eq)

defaultGHCVersion :: Maybe Version
defaultGHCVersion = Nothing

-- | JSON: string; "timeout", "backend".
data RunError = RETimeOut
| REBackend