git.iko.soy/rowtype-yoga/psfp
on d78b06e help sign in
rowtype-yoga/psfp/server/src/Main.purs
144 lines 4.9 kB history raw
1module Main where
3import Prelude
5import Data.Array (unsafeIndex)
6import Data.Either (Either(..))
7import Data.Int (fromString)
8import Data.Maybe (Maybe(..), fromMaybe)
9import Data.Posix.Signal (Signal(..))
10import Data.String.Utils (lines)
11import Effect (Effect)
12import Effect.Aff (Aff, effectCanceler, launchAff_, makeAff)
13import Effect.Aff.Class (liftAff)
14import Effect.Class (class MonadEffect, liftEffect)
15import Effect.Class.Console (info)
16import Foreign (unsafeToForeign)
17import Middleware.JsonBodyParser (jsonBodyParser)
18import Node.Buffer (Buffer)
19import Node.Buffer as Buffer
20import Node.ChildProcess (ExecResult, defaultExecOptions, exec, kill)
21import Node.Encoding (Encoding(..))
22import Node.Express.App (App, listenHttp, listenHttps, use, useExternal)
23import Node.Express.App as E
24import Node.Express.Handler (HandlerM)
25import Node.Express.Middleware.Static (static)
26import Node.Express.Request (getBody')
27import Node.Express.Response as Response
28import Node.FS.Aff (readTextFile, writeTextFile)
29import Node.HTTP (Server)
30import Node.Process (lookupEnv)
31import Partial.Unsafe (unsafePartial)
32import Shared.Json (readAff)
33import Shared.Models.Body (RunResult)
34import Shared.Models.Body as Body
35import Simple.JSON (read_, write)
37toBody ∷ ∀ r m. MonadEffect m => { stdout ∷ Buffer, stderr ∷ Buffer | r } -> m RunResult
38toBody result = liftEffect $ ado
39 stdout <- Buffer.toString UTF8 result.stdout
40 stderr <- Buffer.toString UTF8 result.stderr
41 let (code ∷ Maybe Int) = asErrorWithCode result >>= _.code
42 in { code, stdout, stderr } ∷ RunResult
44type ErrorWithCode = { code ∷ Maybe Int }
46asErrorWithCode ∷ ∀ a. a -> Maybe ErrorWithCode
47asErrorWithCode = read_ <<< unsafeToForeign
49compileCode ∷ String -> Aff String
50compileCode code = do
51 saveMainFile code
52 { stderr } <- execCommand "spago build -- --json-errors"
53 errorString <- liftEffect $ Buffer.toString UTF8 stderr
54 pure $ unsafePartial (unsafeIndex (lines errorString) 0)
56runCode ∷ Aff ExecResult
57runCode = execCommand "node run.js"
59playground ∷ String
60playground = "../playground"
62saveMainFile ∷ String -> Aff Unit
63saveMainFile code =
64 writeTextFile UTF8 (playground <> "/src/Main.purs") code
66execCommand ∷ String -> Aff ExecResult
67execCommand command =
68 makeAff \callback -> do
69 let options = defaultExecOptions { cwd = Just playground }
70 childProcess <- exec command options (callback <<< Right)
71 pure $ effectCanceler (kill SIGKILL childProcess)
73compileHandler ∷ HandlerM Unit
74compileHandler = do
75 body <- getBody'
76 json <- readAff body # liftAff
77 result <- compileCode (json ∷ Body.CompileRequest).code # liftAff
78 Response.send $ write ({ result } ∷ Body.CompileResult)
80runHandler ∷ HandlerM Unit
81runHandler = do
82 result <- liftAff do
83 result <- runCode
84 toBody result
85 Response.send $ write (result ∷ Body.RunResult)
87main ∷ Effect Unit
88main = launchAff_ do
89 serverSetup makeApp
91makeApp ∷ App
92makeApp = do
93 use $ static "assets"
94 useExternal jsonBodyParser
95 E.post "/compile" compileHandler
96 E.post "/run" runHandler
97 -- useOnError (errorHandler log)
98 -- { method: HTTPure.Post, path: ["_compile"], body } -> do
99 -- result <- compileCode body
100 -- HTTPure.ok' (HTTPure.header "Content-Type" "application/json") result
102 -- { method: HTTPure.Post, path: ["_run"] } -> do
103 -- result <- runCode
104 -- response <- toBody result
105 -- okJson response
107 -- { method: HTTPure.Get, path } | elem path [[], [""], ["/"]] -> do
108 -- content <- readTextFile UTF8 "index.html"
109 -- HTTPure.ok' (HTTPure.header "Content-Type" "text/html") content
111 -- { method: HTTPure.Get, path } -> do
112 -- let filePath = intercalate "/" path
113 -- let mimeType = guessMimeType filePath
114 -- content <- readTextFile UTF8 filePath
115 -- HTTPure.ok' (HTTPure.header "Content-Type" mimeType) content
117 -- _ -> HTTPure.notFound
119data CertificatesToUse
120 = UseLocalCertificates
121 | DoNotUseLocalCertificates
123parseCertificatesToUse ∷ String -> CertificatesToUse
124parseCertificatesToUse = case _ of
125 "LOCAL" -> UseLocalCertificates
126 _ -> DoNotUseLocalCertificates
128serverSetup ∷ App -> Aff Server
129serverSetup app = do
130 maybePortString <- lookupEnv "PORT" # liftEffect
131 let port = maybePortString >>= fromString # fromMaybe 14188
132 useLocalCertificates <- fromMaybe DoNotUseLocalCertificates <<< map parseCertificatesToUse <$> lookupEnv "CERTS" # liftEffect
133 listen <- case useLocalCertificates of
134 UseLocalCertificates -> do
135 httpsOptions <- makeHttpsOptions
136 pure $ listenHttps app (port ∷ Int) httpsOptions
137 DoNotUseLocalCertificates ->
138 pure $ listenHttp app port
139 liftEffect $ listen \_ -> info $ "psfp server started on port " <> show port
140 where
141 makeHttpsOptions = do
142 key <- readTextFile UTF8 "server.key"
143 cert <- readTextFile UTF8 "server.cert"
144 pure { key, cert }