Skip to content

Commit

Permalink
Merge pull request #2942 from darklang/paul/tests4
Browse files Browse the repository at this point in the history 
Port a lot of DB libraries and machinery
  • Loading branch information
@pbiggar
pbiggar committed Feb 14, 2021
2 parents 3f120b4 + c73bd8a commit b53bcac
Show file tree
Hide file tree
Showing 51 changed files with 4,193 additions and 5,642 deletions.
16 changes: 15 additions & 1 deletion docs/editor-setup.md
View file
Expand Up @@ -10,6 +10,17 @@ folder within container" and it should work.
Use Ionide for F#. It's important to use (at least) version 5, which solves a
few bugs and has the latest version of fantomas (the code formatter).

#### Troubleshooting VScode

If you find that you are not getting language-server feedback (types appearing,
"goto definition" working, errors shown, etc), bring up the terminal within
VSCode and run `dotnet tool restore; dotnet build`. This needs to be done after
adding a new file and in some other cases. It may help to run "Developer:
reload window" as well.

If that doesn't work, look in the "Output" tabs marked "msbuild" or "F#" for
clues.

### Merlin

Merlin is an OCaml language server that provides things like autocompletion,
Expand Down Expand Up @@ -46,7 +57,10 @@ this in an alias or something).

### Formatting

You will also want to support formatting in your client. Dark uses Prettier for JS/HTML/CSS, and OCamlformat for OCaml and Bucklescript. The script `script/format` can be used to format or check formatting, and there is a pre-commit hook you can use to run it automatically.
You will also want to support formatting in your client. Dark uses Prettier for
JS/HTML/CSS, OCamlformat for OCaml and Bucklescript, and Fantomas for F#. The
script `script/format` can be used to format or check formatting, and there is
a pre-commit hook you can use to run it automatically.

For emacs, see [the
readme](https://github.com/ocaml-ppx/ocamlformat#emacs-setup). For vim:
Expand Down
45 changes: 25 additions & 20 deletions fsharp-backend/src/ApiServer/Api.fs
View file
Expand Up @@ -201,7 +201,7 @@ let typToApiString (typ : RT.DType) : string =
| RT.TIncomplete -> "Incomplete"
| RT.TError -> "Error"
| RT.THttpResponse _ -> "Response"
| RT.TDB -> "Datastore"
| RT.TDB _ -> "Datastore"
| RT.TDate -> "Date"
// | TDbList tipe ->
// "[" ^ tipe_to_string tipe ^ "]"
Expand Down Expand Up @@ -246,10 +246,10 @@ let functionsToString (fns : RT.BuiltInFn list) : string =
let adminFunctions : Lazy<string> = lazy (allFunctions |> functionsToString)

let userFunctions : Lazy<string> =
lazy (
allFunctions
|> List.filter (fun fn -> fn.name.module_ <> "DarkInternal")
|> functionsToString)
lazy
(allFunctions
|> List.filter (fun fn -> fn.name.module_ <> "DarkInternal")
|> functionsToString)


let functions (includeAdminFns : bool) : Lazy<string> =
Expand Down Expand Up @@ -285,7 +285,7 @@ module InitialLoad =

let toApiStaticDeploys (d : SA.StaticDeploy) : ApiStaticDeploy =
{ deploy_hash = d.deployHash
url = d.url
url = d.url
last_update = d.lastUpdate
status = d.status }

Expand Down Expand Up @@ -390,7 +390,8 @@ module DB =
}

module F404 =
type T = { f404s : List<TI.F404>}
type T = { f404s : List<TI.F404> }

let get404s (ctx : HttpContext) : Task<T> =
task {
let canvasInfo = Middleware.loadCanvasInfo ctx
Expand All @@ -411,50 +412,54 @@ module Traces =
let! args = ctx.BindModelAsync<Params>()

let! (c : LibBackend.Canvas.T) =
Canvas.loadTLIDsFromCache [ args.tlid ] canvasInfo.name canvasInfo.id canvasInfo.owner
Canvas.loadTLIDsFromCache
[ args.tlid ]
canvasInfo.name
canvasInfo.id
canvasInfo.owner
|> Task.map Result.unwrapUnsafe

// TODO: we dont need the handlers or functions at all here, just for the sample
// values which we can do on the client instead
let handler =
c.handlers
|> Map.get args.tlid
let handler = c.handlers |> Map.get args.tlid

match handler with
| Some h -> return! LibBackend.Analysis.handlerTrace c.id args.trace_id h
| None ->
let userFn =
c.userFunctions
|> Map.get args.tlid
|> Option.unwrapUnsafe
let userFn = c.userFunctions |> Map.get args.tlid |> Option.unwrapUnsafe
return! LibBackend.Analysis.userfnTrace c.id args.trace_id userFn

}

let fetchAllTraces (ctx : HttpContext) : Task<AllTraces> =
task {
let canvasInfo = Middleware.loadCanvasInfo ctx

let! (c : LibBackend.Canvas.T) =
// CLEANUP we only need the HTTP handler paths here, so we can remove the loadAll
Canvas.loadAll canvasInfo.name canvasInfo.id canvasInfo.owner
|> Task.map Result.unwrapUnsafe

let! hTraces =
c.handlers
|> Map.values
|> List.map (fun h ->
LibBackend.Analysis.traceIDsForHandler c h
|> Task.map (List.map (fun traceid -> (h.tlid, traceid))))
|> List.map
(fun h ->
LibBackend.Analysis.traceIDsForHandler c h
|> Task.map (List.map (fun traceid -> (h.tlid, traceid))))
|> Task.flatten
|> Task.map List.concat
in

let! ufTraces =
c.userFunctions
|> Map.values
|> List.map (fun uf ->
|> List.map
(fun uf ->
LibBackend.Analysis.traceIDsForUserFn c.id uf.tlid
|> Task.map (List.map (fun traceID -> (uf.tlid, traceID))))
|> Task.flatten
|> Task.map List.concat

return { traces = hTraces @ ufTraces }
}

Expand Down
7 changes: 4 additions & 3 deletions fsharp-backend/src/ApiServer/Middleware.fs
View file
Expand Up @@ -113,8 +113,7 @@ let save' (id : dataID) (value : 'a) (ctx : HttpContext) : HttpContext =
ctx.Items.[id.ToString()] <- value
ctx

let load'<'a> (id : dataID) (ctx : HttpContext) : 'a =
ctx.Items.[$"{id}".ToString()] :?> 'a
let load'<'a> (id : dataID) (ctx : HttpContext) : 'a = ctx.Items.[$"{id}"] :?> 'a

type CanvasInfo = { name : CanvasName.T; id : CanvasID; owner : UserID }

Expand All @@ -133,7 +132,9 @@ let loadPermission (ctx : HttpContext) : Option<Auth.Permission> =
let saveSessionData (s : Session.T) (ctx : HttpContext) = save' SessionData s ctx
let saveUserInfo (u : Account.UserInfo) (ctx : HttpContext) = save' UserInfo u ctx
let saveCanvasInfo (c : CanvasInfo) (ctx : HttpContext) = save' CanvasInfo c ctx
let savePermission (p : Option<Auth.Permission>) (ctx : HttpContext) = save' Permission p ctx

let savePermission (p : Option<Auth.Permission>) (ctx : HttpContext) =
save' Permission p ctx



Expand Down
182 changes: 90 additions & 92 deletions fsharp-backend/src/BwdServer/BwdServer.fs
View file
Expand Up @@ -25,6 +25,7 @@ open FSharpx

module PT = LibBackend.ProgramSerialization.ProgramTypes
module RT = LibExecution.RuntimeTypes
module Exe = LibExecution.Execution

// This boilerplate is copied from Giraffe. I elected not to use Giraffe
// because we don't need any of its feature, but the types it uses are very
Expand Down Expand Up @@ -103,6 +104,11 @@ let canvasNameFromHost (host : string) : Task<Option<CanvasName.T>> =
| _ -> return! LibBackend.Canvas.canvasNameFromCustomDomain host
}

let fns =
lazy
(LibExecution.StdLib.StdLib.fns @ LibBackend.StdLib.StdLib.fns
|> Map.fromListBy (fun fn -> fn.name))

let runDarkHandler : HttpHandler =
fun (next : HttpFunc) (ctx : HttpContext) ->
task {
Expand All @@ -125,96 +131,87 @@ let runDarkHandler : HttpHandler =

let requestPath = ctx.Request.Path.Value

let exprs : Task<List<PT.Toplevel>> =
task {
let executionID = gid ()
let loggerFactory = ctx.RequestServices.GetService<ILoggerFactory>()
let logger = loggerFactory.CreateLogger("logger")
let log msg (v : 'a) = logger.LogError("{msg}: {v}", msg, v)

match! canvasNameFromHost ctx.Request.Host.Host with
| Some canvasName ->
let ownerName = LibBackend.Account.ownerNameFromCanvasName canvasName
let ownerUsername = UserName.create (ownerName.ToString())
let! ownerID = LibBackend.Account.userIDForUserName ownerUsername

let! canvasID =
LibBackend.Canvas.canvasIDForCanvasName ownerID canvasName

let method = ctx.Request.Method

let! canvas =
LibBackend.Canvas.loadHttpHandlersFromCache
canvasName
canvasID
ownerID
requestPath
method

return
canvas
|> Result.unwrapUnsafe
|> LibBackend.Canvas.toplevels
|> Map.values
| None ->
log "no canvas found" []
return []
}

match! exprs with
| [ PT.TLHandler { spec = PT.Handler.HTTP (route = route)
ast = expr
tlid = tlid } ] ->
let ms = new IO.MemoryStream()
do! ctx.Request.Body.CopyToAsync(ms)
let url = ctx.Request.GetEncodedUrl()
let body = ms.ToArray()
let expr = expr.toRuntimeType ()
let fns = LibExecution.StdLib.StdLib.fns @ LibBackend.StdLib.StdLib.fns
let vars = LibBackend.Routing.routeInputVars route requestPath

match vars with
| None ->
return!
msg
500
$"The request ({requestPath}) does not match the route ({route})"
| Some vars ->
let symtable = Map.ofList vars

let! result =
LibExecution.Execution.runHttp tlid url symtable body fns expr

printfn $"result of runHttp is {result}"

match result with
| RT.DHttpResponse (RT.Redirect url, _) ->
ctx.Response.Redirect(url, false)
return! next ctx
| RT.DHttpResponse (RT.Response (status, headers), RT.DBytes body) ->
ctx.Response.StatusCode <- status
List.iter (fun (k, v) -> addHeader ctx k v) headers
do! ctx.Response.Body.WriteAsync(body, 0, body.Length)
return! next ctx
// TODO: maybe not the right thing, but this is what the OCaml does
// FSTODO: move this to LibExecution so it can be available in the client
| RT.DFakeVal (RT.DErrorRail (RT.DResult (Error _)))
| RT.DFakeVal (RT.DErrorRail (RT.DOption None)) ->
ctx.Response.StatusCode <- 404
addHeader ctx "server" "darklang"
return Some ctx
| RT.DFakeVal (RT.DIncomplete _) ->
let loggerFactory = ctx.RequestServices.GetService<ILoggerFactory>()
let logger = loggerFactory.CreateLogger("logger")
let log msg (v : 'a) = logger.LogError("{msg}: {v}", msg, v)

match! canvasNameFromHost ctx.Request.Host.Host with
| Some canvasName ->

let ownerName = LibBackend.Account.ownerNameFromCanvasName canvasName
let ownerUsername = UserName.create (ownerName.ToString())
let! ownerID = LibBackend.Account.userIDForUserName ownerUsername
let! canvasID = LibBackend.Canvas.canvasIDForCanvasName ownerID canvasName
let method = ctx.Request.Method

let! c =
LibBackend.Canvas.loadHttpHandlersFromCache
canvasName
canvasID
ownerID
requestPath
method
|> Task.map Result.unwrapUnsafe

match Map.values c.handlers with
| [ { spec = PT.Handler.HTTP (route = route); ast = expr; tlid = tlid } ] ->
let ms = new IO.MemoryStream()
do! ctx.Request.Body.CopyToAsync(ms)
let body = ms.ToArray()
let url = ctx.Request.GetEncodedUrl()
let expr = expr.toRuntimeType ()
let vars = LibBackend.Routing.routeInputVars route requestPath

match vars with
| Some vars ->
let symtable = Map.ofList vars

let state =
Exe.createState
ownerID
canvasID
tlid
(fns.Force())
(c.dbs |> Map.map (fun pt -> pt.toRuntimeType ()) |> Map.values)
(c.userFunctions
|> Map.map (fun pt -> pt.toRuntimeType ())
|> Map.values)
(c.userTypes
|> Map.map (fun pt -> pt.toRuntimeType ())
|> Map.values)
(c.secrets
|> Map.map (fun pt -> pt.toRuntimeType ())
|> Map.values)

let! result = Exe.runHttp state url body symtable expr

match result with
| RT.DHttpResponse (RT.Redirect url, _) ->
ctx.Response.Redirect(url, false)
return! next ctx
| RT.DHttpResponse (RT.Response (status, headers), RT.DBytes body) ->
ctx.Response.StatusCode <- status
List.iter (fun (k, v) -> addHeader ctx k v) headers
do! ctx.Response.Body.WriteAsync(body, 0, body.Length)
return! next ctx
| RT.DFakeVal (RT.DIncomplete _) ->
return!
msg
500
"Error calling server code: Handler returned an \
incomplete result. Please inform the owner of this \
site that their code is broken."
| other ->
printfn $"Not a HTTP response: {other}"
return! msg 500 "body is not a HttpResponse"
| None -> // vars didnt parse
return!
msg
500
"Error calling server code: Handler returned an \
incomplete result. Please inform the owner of this \
site that their code is broken."
| other ->
printfn $"Not a HTTP response: {other}"
return! msg 500 "body is not a HttpResponse"
| [] -> return! msg 404 "No handler was found for this URL"
| _ -> return! msg 500 "More than one handler found for this URL"
$"The request ({requestPath}) does not match the route ({route})"
| [] -> return! msg 404 "No handler was found for this URL"
| _ -> return! msg 500 "More than one handler found for this URL"
| None -> return! msg 404 "No handler was found for this URL"
}

let webApp : HttpHandler =
Expand All @@ -229,8 +226,9 @@ let webApp : HttpHandler =
let configureApp (app : IApplicationBuilder) =
app.UseDeveloperExceptionPage().UseMiddleware<BwdMiddleware>(webApp) |> ignore

let configureLogging (builder : ILoggingBuilder) =
let filter (l : LogLevel) : bool = true
let configureLogging (shouldLog : bool) (builder : ILoggingBuilder) =
// We want to disable this by default for tests because it clogs the output
let filter (l : LogLevel) : bool = shouldLog

// Configure the logging factory
builder
Expand All @@ -242,12 +240,12 @@ let configureLogging (builder : ILoggingBuilder) =

let configureServices (services : IServiceCollection) = ()

let webserver (port : int) =
let webserver (shouldLog : bool) (port : int) =
WebHost.CreateDefaultBuilder()
|> fun wh -> wh.UseKestrel(fun kestrel -> kestrel.AddServerHeader <- false)
|> fun wh -> wh.ConfigureServices(configureServices)
|> fun wh -> wh.Configure(configureApp)
|> fun wh -> wh.ConfigureLogging(configureLogging)
|> fun wh -> wh.ConfigureLogging(configureLogging shouldLog)
|> fun wh -> wh.UseUrls($"http://*:{port}")
|> fun wh -> wh.Build()

Expand All @@ -256,5 +254,5 @@ let webserver (port : int) =
let main _ =
printfn "Starting BwdServer"
LibBackend.Init.init ()
(webserver 9001).Run()
(webserver true 9001).Run()
0

0 comments on commit b53bcac

Please sign in to comment.