diff --git a/fsharp-backend/src/BackendOnlyStdLib/LibStaticAssets.fs b/fsharp-backend/src/BackendOnlyStdLib/LibStaticAssets.fs index f671e24de8..75b2bfb637 100644 --- a/fsharp-backend/src/BackendOnlyStdLib/LibStaticAssets.fs +++ b/fsharp-backend/src/BackendOnlyStdLib/LibStaticAssets.fs @@ -1,490 +1,406 @@ /// StdLib functions to manage and retrieve static assets of Dark users module BackendOnlyStdLib.LibStaticAssets +open System.Threading.Tasks +open FSharp.Control.Tasks + open LibExecution.RuntimeTypes open Prelude +module SA = LibBackend.StaticAssets module Errors = LibExecution.Errors let fn = FQFnName.stdlibFnName let err (str : string) = Ply(Dval.errStr str) -let incorrectArgs = LibExecution.Errors.incorrectArgs - -let varA = TVariable "a" -let varB = TVariable "b" - -let fns : List = [] -// [ { name = fn "StaticAssets" "baseUrlFor" 0 -// -// ; parameters = [Param.make "deploy_hash" TStr ""] -// ; returnType = TStr -// ; description = "Return the baseUrl for the specified deploy hash" -// ; fn = -// (function -// | state, [DStr deploy_hash] -> -// url state.canvas_id (Unicode_string.to_string deploy_hash) `Short -// |> DStr -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "baseUrlForLatest" 0 -// ; parameters = [] -// ; returnType = TStr -// ; description = "Return the baseUrl for the latest deploy" -// ; fn = -// (function -// | state, [] -> -// url state.canvas_id (latest_deploy_hash state.canvas_id) `Short -// |> DStr -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "urlFor" 0 -// ; parameters = [Param.make "deploy_hash" TStr ""; Param.make "file" TStr ""] -// ; returnType = TStr -// ; description = "Return a url for the specified file and deploy hash" -// ; fn = -// (function -// | state, [DStr deploy_hash; DStr file] -> -// url_for -// state.canvas_id -// (Unicode_string.to_string deploy_hash) -// `Short -// (Unicode_string.to_string file) -// |> DStr -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "urlForLatest" 0 -// ; parameters = [Param.make "file" TStr ""] -// ; returnType = TStr -// ; description = "Return a url for the specified file and latest deploy" -// ; fn = -// (function -// | state, [DStr file] -> -// url_for -// state.canvas_id -// (latest_deploy_hash state.canvas_id) -// `Short -// (Unicode_string.to_string file) -// |> DStr -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "fetch" 0 -// ; parameters = [Param.make "deploy_hash" TStr ""; Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the specified file from the deploy_hash - only works on UTF8-safe files for now" -// ; fn = -// (function -// | state, [DStr deploy_hash; DStr file] -> -// let url = -// url_for -// state.canvas_id -// (Unicode_string.to_string deploy_hash) -// `Short -// (Unicode_string.to_string file) -// in -// let response = -// Legacy.HttpclientV0.call url Httpclient.GET [] "" -// |> Dval.dstr_of_string -// in -// ( match response with -// | Some dv -> -// DResult (Ok dv) -// | None -> -// DResult -// (ResError -// (DStr "Response was not -// UTF-8 safe")) -// ) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = ReplacedBy(fn "" "" 0) } -// ; { name = fn "StaticAssets" "fetch" 1 -// ; parameters = [Param.make "deploy_hash" TStr ""; Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the specified file from the deploy_hash - only works on UTF8-safe files for now" -// ; fn = -// (function -// | state, [DStr deploy_hash; DStr file] -> -// let url = -// url_for -// state.canvas_id -// (Unicode_string.to_string deploy_hash) -// `Short -// (Unicode_string.to_string file) -// in -// let response = -// Legacy.HttpclientV0.call url Httpclient.GET [] "" -// |> Dval.dstr_of_string -// in -// ( match response with -// | Some dv -> -// Dval.to_res_ok dv -// | None -> -// Dval.to_res_err -// (DStr "Response was not UTF-8 safe") ) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "fetchBytes" 0 -// ; parameters = [Param.make "deploy_hash" TStr ""; Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the bytes of the specified file from the deploy_hash" -// ; fn = -// (function -// | state, [DStr deploy_hash; DStr file] -> -// let url = -// url_for -// state.canvas_id -// (Unicode_string.to_string deploy_hash) -// `Short -// (Unicode_string.to_string file) -// in -// let response = -// Legacy.HttpclientV1.call -// ~raw_bytes:true -// url -// Httpclient.GET -// [] -// "" -// in -// DResult (Ok (DBytes (response |> RawBytes.of_string))) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "fetchLatest" 0 -// ; parameters = [Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the specified file from the latest deploy - only works on UTF8-safe files for now" -// ; fn = -// (function -// | state, [DStr file] -> -// let url = -// url_for -// state.canvas_id -// (latest_deploy_hash state.canvas_id) -// `Short -// (Unicode_string.to_string file) -// in -// let response = -// Legacy.HttpclientV0.call url Httpclient.GET [] "" -// |> Dval.dstr_of_string -// in -// ( match response with -// | Some dv -> -// DResult (Ok dv) -// | None -> -// DResult -// (ResError -// (DStr "Response was not -// UTF-8 safe")) -// ) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = ReplacedBy(fn "" "" 0) } -// ; { name = fn "StaticAssets" "fetchLatest" 1 -// ; parameters = [Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the specified file from the latest deploy - only works on UTF8-safe files for now" -// ; fn = -// (function -// | state, [DStr file] -> -// let url = -// url_for -// state.canvas_id -// (latest_deploy_hash state.canvas_id) -// `Short -// (Unicode_string.to_string file) -// in -// let response = -// Legacy.HttpclientV0.call url Httpclient.GET [] "" -// |> Dval.dstr_of_string -// in -// ( match response with -// | Some dv -> -// Dval.to_res_ok dv -// | None -> -// Dval.to_res_err -// (DStr "Response was not -// UTF-8 safe") ) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "fetchLatestBytes" 0 -// ; parameters = [Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the bytes of the specified file from the latest deploy" -// ; fn = -// (function -// | state, [DStr file] -> -// let url = -// url_for -// state.canvas_id -// (latest_deploy_hash state.canvas_id) -// `Short -// (Unicode_string.to_string file) -// in -// let response = -// Legacy.HttpclientV1.call -// ~raw_bytes:true -// url -// Httpclient.GET -// [] -// "" -// in -// DResult (Ok (DBytes (response |> RawBytes.of_string))) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "serve" 0 -// ; parameters = [Param.make "deploy_hash" TStr ""; Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the specified file from the latest deploy - only works on UTF8-safe files for now" -// ; fn = -// (function -// | state, [DStr deploy_hash; DStr file] -> -// let url = -// url_for -// state.canvas_id -// (Unicode_string.to_string deploy_hash) -// `Short -// (Unicode_string.to_string file) -// in -// let body, code, headers, _erroreturnType = -// Legacy.HttpclientV2.http_call_with_code -// url -// [] -// Httpclient.GET -// [] -// "" -// in -// let headers = -// headers -// |> List.map (fun (k, v) -> (k, String.trim v)) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Content-Length")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Transfer-Encoding")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Cache-Control")) -// |> List.filter (fun (k, v) -> not (String.trim k = "")) -// |> List.filter (fun (k, v) -> not (String.trim v = "")) -// in -// let body = Dval.dstr_of_string body in -// ( match body with -// | Some dv -> -// DResult (Ok (DResp (Response (code, headers), dv))) -// | None -> -// DResult -// (ResError -// (DStr "Response was not UTF-8 safe")) -// ) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = ReplacedBy(fn "" "" 0) } -// ; { name = fn "StaticAssets" "serve" 1 -// ; parameters = [Param.make "deploy_hash" TStr ""; Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = "Return the specified file from the latest deploy" -// ; fn = -// (function -// | state, [DStr deploy_hash; DStr file] -> -// let url = -// url_for -// state.canvas_id -// (Unicode_string.to_string deploy_hash) -// `Short -// (Unicode_string.to_string file) -// in -// let body, code, headers, _erroreturnType = -// Legacy.HttpclientV2.http_call_with_code -// ~raw_bytes:true -// url -// [] -// Httpclient.GET -// [] -// "" -// in -// let headers = -// headers -// |> List.map (fun (k, v) -> (k, String.trim v)) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Content-Length")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Transfer-Encoding")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Cache-Control")) -// |> List.filter (fun (k, v) -> not (String.trim k = "")) -// |> List.filter (fun (k, v) -> not (String.trim v = "")) -// in -// DResult -// (Ok -// (DResp -// ( Response (code, headers) -// , DBytes (body |> RawBytes.of_string) ))) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } -// ; { name = fn "StaticAssets" "serveLatest" 0 -// ; parameters = [Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = -// "Return the specified file from the latest deploy - only works on UTF8-safe files for now" -// ; fn = -// (function -// | state, [DStr file] -> -// let url = -// url_for -// state.canvas_id -// (latest_deploy_hash state.canvas_id) -// `Short -// (Unicode_string.to_string file) -// in -// let body, code, headers, _erroreturnType = -// Legacy.HttpclientV2.http_call_with_code -// ~raw_bytes:true -// url -// [] -// Httpclient.GET -// [] -// "" -// in -// let headers = -// headers -// |> List.map (fun (k, v) -> (k, String.trim v)) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Content-Length")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Transfer-Encoding")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Cache-Control")) -// |> List.filter (fun (k, v) -> not (String.trim k = "")) -// |> List.filter (fun (k, v) -> not (String.trim v = "")) -// in -// DResult -// (Ok -// (DResp -// ( Response (code, headers) -// , DBytes (body |> RawBytes.of_string) ))) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = ReplacedBy(fn "" "" 0) } -// ; { name = fn "StaticAssets" "serveLatest" 1 -// ; parameters = [Param.make "file" TStr ""] -// ; returnType = TResult -// ; description = "Return the specified file from the latest deploy" -// ; fn = -// (function -// | state, [DStr file] -> -// let url = -// url_for -// state.canvas_id -// (latest_deploy_hash state.canvas_id) -// `Short -// (Unicode_string.to_string file) -// in -// let body, code, headers, _erroreturnType = -// Legacy.HttpclientV2.http_call_with_code -// ~raw_bytes:true -// url -// [] -// Httpclient.GET -// [] -// "" -// in -// let headers = -// headers -// |> List.map (fun (k, v) -> (k, String.trim v)) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Content-Length")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Transfer-Encoding")) -// |> List.filter (fun (k, v) -> -// not -// (Core_kernel.String.is_substring -// k -// "Cache-Control")) -// |> List.filter (fun (k, v) -> not (String.trim k = "")) -// |> List.filter (fun (k, v) -> not (String.trim v = "")) -// in -// DResult -// (Ok -// (DResp -// ( Response (code, headers) -// , DBytes (body |> RawBytes.of_string) ))) -// | _ -> -// Libexecution.Lib.incorrectArgs ()) -// ; sqlSpec = NotYetImplementedTODO -// ; previewable = Impure -// ; deprecated = NotDeprecated } ] -// +let incorrectArgs = Errors.incorrectArgs + +open System.IO +open System.IO.Compression +open System.Net.Http + +let httpClient = + let socketHandler : HttpMessageHandler = + let handler = new SocketsHttpHandler() + + // Cookies shouldn't be necessary + handler.UseCookies <- false + handler + + let client = new HttpClient(socketHandler, disposeHandler = false) + client.Timeout <- System.TimeSpan.FromSeconds 30.0 + // Can't find what this was in OCaml/Curl, but 100MB seems a reasonable default + client.MaxResponseContentBufferSize <- 1024L * 1024L * 100L + client + + + + +/// Replaces legacy HttpClientv0. Returns bytes, and throws on non-200s or if +/// anything goes wrong. +let getV0 (url : string) : Task = + task { + try + use req = new HttpRequestMessage(HttpMethod.Get, url) + let! response = httpClient.SendAsync req + let code = int response.StatusCode + let! body = response.Content.ReadAsByteArrayAsync() + if code < 200 || code >= 300 then + return + Exception.raiseLibrary + $"Bad HTTP response ({code}) in call to {url}" + [ "url", url; "code", code; "body", UTF8.ofBytesWithReplacement body ] + else + return body + with + | e -> + return + Exception.raiseLibrary + $"Internal HTTP-stack exception: {e.Message}" + [ "url", url ] + } + +/// Replaces legacy HttpClientv1. Returns bytes, headers, and status code, and throws +/// on non-200s or if anything goes wrong. +let getV1 (url : string) : Task * int> = + task { + try + use req = new HttpRequestMessage(HttpMethod.Get, url) + let! response = httpClient.SendAsync req + let code = int response.StatusCode + let headers = response.Headers |> HttpHeaders.fromAspNetHeaders + let! body = response.Content.ReadAsByteArrayAsync() + if code < 200 || code >= 300 then + return + Exception.raiseLibrary + $"Bad HTTP response ({code}) in call to {url}" + [ "url", url; "code", code; "body", UTF8.ofBytesWithReplacement body ] + else + return body, headers, code + with + | e -> + return + Exception.raiseLibrary + $"Internal HTTP-stack exception: {e.Message}" + [ "url", url ] + } + +/// Replaces legacy HttpClientv2. Returns bytes, headers, and status code, and throws +/// if the request has issues. Does not raise on non-200 status code. +let getV2 (url : string) : Task * int> = + task { + try + use req = new HttpRequestMessage(HttpMethod.Get, url) + let! response = httpClient.SendAsync req + let code = int response.StatusCode + let headers = response.Headers |> HttpHeaders.fromAspNetHeaders + let! body = response.Content.ReadAsByteArrayAsync() + return body, headers, code + with + | e -> + return + Exception.raiseLibrary + $"Internal HTTP-stack exception: {e.Message}" + [ "url", url ] + } + + +let fns : List = + [ { name = fn "StaticAssets" "baseUrlFor" 0 + parameters = [ Param.make "deploy_hash" TStr "" ] + returnType = TStr + description = "Return the baseUrl for the specified deploy hash" + fn = + (function + | state, [ DStr deployHash ] -> + SA.url state.program.canvasName deployHash SA.Short |> DStr |> Ply + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "baseUrlForLatest" 0 + parameters = [] + returnType = TStr + description = "Return the baseUrl for the latest deploy" + fn = + (function + | state, [] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.url state.program.canvasName deployHash SA.Short + return DStr url + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "urlFor" 0 + parameters = [ Param.make "deploy_hash" TStr ""; Param.make "file" TStr "" ] + returnType = TStr + description = "Return a url for the specified file and deploy hash" + fn = + (function + | state, [ DStr deployHash; DStr file ] -> + SA.urlFor state.program.canvasName deployHash SA.Short file |> DStr |> Ply + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "urlForLatest" 0 + parameters = [ Param.make "file" TStr "" ] + returnType = TStr + description = "Return a url for the specified file and latest deploy" + fn = + (function + | state, [ DStr file ] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + return DStr url + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "fetch" 0 + parameters = [ Param.make "deploy_hash" TStr ""; Param.make "file" TStr "" ] + returnType = TResult(TStr, TStr) + description = + "Return the specified file from the deploy_hash - only works on UTF8-safe files for now" + fn = + (function + | state, [ DStr deployHash; DStr file ] -> + uply { + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + + let! response = getV0 url + match UTF8.ofBytesOpt response with + | Some dv -> return DResult(Ok(DStr dv)) + | None -> return DResult(Error(DStr "Response was not UTF-8 safe")) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = ReplacedBy(fn "StaticAssets" "fetch" 1) } + + + { name = fn "StaticAssets" "fetch" 1 + parameters = [ Param.make "deploy_hash" TStr ""; Param.make "file" TStr "" ] + returnType = TResult(TStr, TStr) + description = + "Return the specified file from the deploy_hash - only works on UTF8-safe files for now" + fn = + (function + | state, [ DStr deployHash; DStr file ] -> + uply { + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! response = getV0 url + match UTF8.ofBytesOpt response with + | Some dv -> return DResult(Ok(DStr dv)) + | None -> return (DResult(Error(DStr "Response was not UTF-8 safe"))) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "fetchBytes" 0 + parameters = [ Param.make "deploy_hash" TStr ""; Param.make "file" TStr "" ] + returnType = TResult(TBytes, TStr) + description = "Return the bytes of the specified file from the deploy_hash" + fn = + (function + | state, [ DStr deployHash; DStr file ] -> + uply { + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! response, _, _ = getV1 url + return DResult(Ok(DBytes response)) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "fetchLatest" 0 + parameters = [ Param.make "file" TStr "" ] + returnType = TResult(TStr, TStr) + description = + "Return the specified file from the latest deploy - only works on UTF8-safe files for now" + fn = + (function + | state, [ DStr file ] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! response = getV0 url + match UTF8.ofBytesOpt response with + | Some str -> return DResult(Ok(DStr str)) + | None -> return DResult(Error(DStr "Response was not UTF-8 safe")) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = ReplacedBy(fn "StaticAssets" "fetchLatest" 1) } + + + { name = fn "StaticAssets" "fetchLatest" 1 + parameters = [ Param.make "file" TStr "" ] + returnType = TResult(TStr, TStr) + description = + "Return the specified file from the latest deploy - only works on UTF8-safe files for now" + fn = + (function + | state, [ DStr file ] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! response = getV0 url + match UTF8.ofBytesOpt response with + | Some str -> return Dval.resultOk (DStr str) + | None -> return Dval.resultError (DStr "Response was not UTF-8 safe") + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "fetchLatestBytes" 0 + parameters = [ Param.make "file" TStr "" ] + returnType = TResult(TBytes, TStr) + description = "Return the bytes of the specified file from the latest deploy" + fn = + (function + | state, [ DStr file ] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! response, _, _ = getV1 url + return DResult(Ok(DBytes(response))) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "serve" 0 + parameters = [ Param.make "deploy_hash" TStr ""; Param.make "file" TStr "" ] + returnType = TResult(THttpResponse TStr, TStr) + description = + "Return the specified file from the latest deploy - only works on UTF8-safe files for now" + fn = + (function + | state, [ DStr deployHash; DStr file ] -> + uply { + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! (body, headers, code) = getV2 url + let headers = + headers + |> List.map (fun (k, v) -> (k, v.Trim())) + |> List.filter (fun (k, v) -> not (k.Contains("Content-Length"))) + |> List.filter (fun (k, v) -> not (k.Contains("Transfer-Encoding"))) + |> List.filter (fun (k, v) -> not (k.Contains("Cache-Control"))) + |> List.filter (fun (k, v) -> not (k.Trim() = "")) + |> List.filter (fun (k, v) -> not (v.Trim() = "")) + match UTF8.ofBytesOpt body with + | Some str -> + return DResult(Ok(DHttpResponse(Response(code, headers, DStr str)))) + | None -> return DResult(Error(DStr "Response was not UTF-8 safe")) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = ReplacedBy(fn "StaticAssets" "serve" 1) } + + + { name = fn "StaticAssets" "serve" 1 + parameters = [ Param.make "deploy_hash" TStr ""; Param.make "file" TStr "" ] + returnType = TResult(THttpResponse TBytes, TStr) + description = "Return the specified file from the latest deploy" + fn = + (function + | state, [ DStr deployHash; DStr file ] -> + uply { + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! (body, headers, code) = getV2 url + let headers = + headers + |> List.map (fun (k, v) -> (k, v.Trim())) + |> List.filter (fun (k, v) -> not (k.Contains "Content-Length")) + |> List.filter (fun (k, v) -> not (k.Contains "Transfer-Encoding")) + |> List.filter (fun (k, v) -> not (k.Contains "Cache-Control")) + |> List.filter (fun (k, v) -> not (k.Trim() = "")) + |> List.filter (fun (k, v) -> not (v.Trim() = "")) + return DResult(Ok(DHttpResponse(Response(code, headers, DBytes(body))))) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } + + + { name = fn "StaticAssets" "serveLatest" 0 + parameters = [ Param.make "file" TStr "" ] + returnType = TResult(TStr, TStr) + description = + "Return the specified file from the latest deploy - only works on UTF8-safe files for now" + fn = + (function + | state, [ DStr file ] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! body, headers, code = getV2 url + let headers = + headers + |> List.map (fun (k, v) -> (k, v.Trim())) + |> List.filter (fun (k, v) -> not (k.Contains "Content-Length")) + |> List.filter (fun (k, v) -> not (k.Contains "Transfer-Encoding")) + |> List.filter (fun (k, v) -> not (k.Contains "Cache-Control")) + |> List.filter (fun (k, v) -> not (k.Trim() = "")) + |> List.filter (fun (k, v) -> not (v.Trim() = "")) + return DResult(Ok(DHttpResponse(Response(code, headers, DBytes body)))) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = ReplacedBy(fn "StaticAssets" "serveLatest" 1) } + + + { name = fn "StaticAssets" "serveLatest" 1 + parameters = [ Param.make "file" TStr "" ] + returnType = TResult(THttpResponse(TBytes), TStr) + description = "Return the specified file from the latest deploy" + fn = + (function + | state, [ DStr file ] -> + uply { + let! deployHash = SA.latestDeployHash state.program.canvasID + let url = SA.urlFor state.program.canvasName deployHash SA.Short file + let! body, headers, code = getV2 url + let headers = + headers + |> List.map (fun (k, v) -> (k, v.Trim())) + |> List.filter (fun (k, v) -> not (k.Contains "Content-Length")) + |> List.filter (fun (k, v) -> not (k.Contains "Transfer-Encoding")) + |> List.filter (fun (k, v) -> not (k.Contains "Cache-Control")) + |> List.filter (fun (k, v) -> not (k.Trim() = "")) + |> List.filter (fun (k, v) -> not (v.Trim() = "")) + return DResult(Ok(DHttpResponse(Response(code, headers, DBytes(body))))) + } + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } ] diff --git a/fsharp-backend/src/BackendOnlyStdLib/LibTwilio.fs b/fsharp-backend/src/BackendOnlyStdLib/LibTwilio.fs index 19def901f3..ce32696b4c 100644 --- a/fsharp-backend/src/BackendOnlyStdLib/LibTwilio.fs +++ b/fsharp-backend/src/BackendOnlyStdLib/LibTwilio.fs @@ -6,134 +6,110 @@ open Prelude module Errors = LibExecution.Errors -let fn = FQFnName.stdlibFnName +module Canvas = LibBackend.Canvas -let err (str : string) = Ply(Dval.errStr str) +let fn = FQFnName.stdlibFnName -let incorrectArgs = LibExecution.Errors.incorrectArgs +let incorrectArgs = Errors.incorrectArgs let varA = TVariable "a" -let varB = TVariable "b" -let fns : List = [] -// [ { name = fn "Twilio" "sendText" 0 -// -// ; parameters = -// [ Param.make "accountSID" TStr -// ; Param.make "authToken" TStr -// ; Param.make "fromNumber" TStr -// ; Param.make "toNumber" TStr -// ; Param.make "body" TStr ] -// ; returnType = TObj -// ; description = -// "Send text with `body` to phone number `toNumber` from number `fromNumber`, authenticated via `accountSID` and `authToken`" -// ; fn = -// (function -// | ( s -// , [ DStr accountSID -// ; DStr authToken -// ; DStr fromNumber -// ; DStr toNumber -// ; DStr body ] ) -> -// let basic_auth_string = -// Libhttpclient.encode_basic_auth_broken accountSID authToken -// in -// let encoding = "application/x-www-form-urlencoded" in -// let headers = -// [ ("Authorization", DStr basic_auth_string) -// ; ("Content-Type", Libexecution.DStr encoding) -// ] -// |> DvalMap.from_list -// |> DObj -// in -// let host_url = Canvas.url_for s.canvas_id in -// let body = -// [ ("From", DStr fromNumber) -// ; ("To", DStr toNumber) -// ; ("Body", DStr body) -// ; ("ValidityPeriod", Libexecution.DStr "900") -// ; ( "StatusCallback" -// , Libexecution.DStr -// (host_url ^ "/twilioCallback") ) ] -// |> DvalMap.fromList -// |> DObj -// in -// let twilio_uri = -// "https://api.twilio.com/2010-04-01/Accounts/" -// ^ Libexecution.Unicode_string.to_string accountSID -// ^ "/Messages.json" -// in -// Legacy.LibhttpclientV2.send_request -// twilio_uri -// Httpclient.POST -// Libexecution.Dval.to_pretty_machine_json_v1 -// body -// (DObj DvalMap.empty) -// headers -// | _ -> -// incorrectArgs ()) -// ; sqlSpec = NotQueryable -// ; previewable = Impure -// ; deprecated = -// true -// (* Deprecated due to using Libhttpclient.encode_basic_auth_broken *) } -// -// ; { name = fn "Twilio" "sendText" 1 -// ; parameters = -// [ Param.make "accountSID" TStr -// ; Param.make "authToken" TStr -// ; Param.make "fromNumber" TStr -// ; Param.make "toNumber" TStr -// ; Param.make "body" TStr ] -// ; returnType = TObj -// ; description = -// "Send text with `body` to phone number `toNumber` from number `fromNumber`, authenticated via `accountSID` and `authToken`" -// ; fn = -// (function -// | ( s -// , [ DStr accountSID -// ; DStr authToken -// ; DStr fromNumber -// ; DStr toNumber -// ; DStr body ] ) -> -// let basic_auth_string = -// Libhttpclient.encode_basic_auth accountSID authToken -// in -// let encoding = "application/x-www-form-urlencoded" in -// let headers = -// [ ("Authorization", DStr basic_auth_string) -// ; ("Content-Type", Libexecution.DStr encoding) -// ] -// |> DvalMap.from_list -// |> DObj -// in -// let host_url = Canvas.url_for s.canvas_id in -// let body = -// [ ("From", DStr fromNumber) -// ; ("To", DStr toNumber) -// ; ("Body", DStr body) -// ; ("ValidityPeriod", Libexecution.DStr "900") -// ; ( "StatusCallback" -// , Libexecution.DStr -// (host_url ^ "/twilioCallback") ) ] -// |> DvalMap.fromList -// |> DObj -// in -// let twilio_uri = -// "https://api.twilio.com/2010-04-01/Accounts/" -// ^ Libexecution.Unicode_string.to_string accountSID -// ^ "/Messages.json" -// in -// Legacy.LibhttpclientV2.send_request -// twilio_uri -// Httpclient.POST -// Libexecution.Dval.to_pretty_machine_json_v1 -// body -// (DObj DvalMap.empty) -// headers -// | _ -> -// incorrectArgs ()) -// ; sqlSpec = NotQueryable -// ; previewable = Impure -// ; deprecated = NotDeprecated } ] -// +let fns : List = + [ { name = fn "Twilio" "sendText" 0 + + parameters = + [ Param.make "accountSID" TStr "" + Param.make "authToken" TStr "" + Param.make "fromNumber" TStr "" + Param.make "toNumber" TStr "" + Param.make "body" TStr "" ] + returnType = TDict(varA) + description = + "Send text with `body` to phone number `toNumber` from number `fromNumber`, authenticated via `accountSID` and `authToken`" + fn = + (function + | (s, + [ DStr accountSID + DStr authToken + DStr fromNumber + DStr toNumber + DStr body ]) -> + let basicAuthString = + LibHttpClientAuth.encodeBasicAuthBroken accountSID authToken + let encoding = "application/x-www-form-urlencoded" in + let headers = + [ ("Authorization", DStr basicAuthString) + ("Content-Type", DStr encoding) ] + |> Map + |> DObj + let hostUrl = Canvas.urlFor s.program.canvasName in + let body = + [ ("From", DStr fromNumber) + ("To", DStr toNumber) + ("Body", DStr body) + ("ValidityPeriod", DStr "900") + ("StatusCallback", DStr(hostUrl + "/twilioCallback")) ] + |> Map + |> DObj + let twilioUri = + $"https://api.twilio.com/2010-04-01/Accounts/{accountSID}/Messages.json" + LegacyHttpClient0.sendRequest + twilioUri + System.Net.Http.HttpMethod.Post + LibExecution.DvalReprExternal.toPrettyMachineJsonStringV1 + (Some body) + (DObj Map.empty) + headers + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + // Deprecated due to using encodeBasicAuthBroken + deprecated = DeprecatedBecause "bad unicode support" } + { name = fn "Twilio" "sendText" 1 + parameters = + [ Param.make "accountSID" TStr "" + Param.make "authToken" TStr "" + Param.make "fromNumber" TStr "" + Param.make "toNumber" TStr "" + Param.make "body" TStr "" ] + returnType = varA + description = + "Send text with `body` to phone number `toNumber` from number `fromNumber`, authenticated via `accountSID` and `authToken`" + fn = + (function + | (s, + [ DStr accountSID + DStr authToken + DStr fromNumber + DStr toNumber + DStr body ]) -> + let basicAuthString = + LibHttpClientAuth.encodeBasicAuth accountSID authToken + let encoding = "application/x-www-form-urlencoded" in + let headers = + [ ("Authorization", DStr basicAuthString) + ("Content-Type", DStr encoding) ] + |> Map + |> DObj + let hostUrl = Canvas.urlFor s.program.canvasName in + let body = + [ ("From", DStr fromNumber) + ("To", DStr toNumber) + ("Body", DStr body) + ("ValidityPeriod", DStr "900") + ("StatusCallback", DStr(hostUrl + "/twilioCallback")) ] + |> Map + |> DObj + let twilioUri = + $"https://api.twilio.com/2010-04-01/Accounts/{accountSID}/Messages.json" + LegacyHttpClient0.sendRequest + twilioUri + System.Net.Http.HttpMethod.Post + LibExecution.DvalReprExternal.toPrettyMachineJsonStringV1 + (Some body) + (DObj Map.empty) + headers + | _ -> incorrectArgs ()) + sqlSpec = NotQueryable + previewable = Impure + deprecated = NotDeprecated } ] diff --git a/fsharp-backend/src/LibBackend/Canvas.fs b/fsharp-backend/src/LibBackend/Canvas.fs index 595385b5b8..9f95ef9a32 100644 --- a/fsharp-backend/src/LibBackend/Canvas.fs +++ b/fsharp-backend/src/LibBackend/Canvas.fs @@ -334,9 +334,8 @@ let updateCorsSetting |> Sql.executeStatementAsync -// let url_for (id : Uuidm.t) : string = -// let canvas_name = name_for_id id in -// "http://" ^ canvas_name ^ "." ^ Config.public_domain +let urlFor (canvasName : CanvasName.T) : string = + $"https://{canvasName}.{Config.publicDomain}" // ------------------------- diff --git a/fsharp-backend/src/LibBackend/StaticAssets.fs b/fsharp-backend/src/LibBackend/StaticAssets.fs index 2407384252..140a13d3a8 100644 --- a/fsharp-backend/src/LibBackend/StaticAssets.fs +++ b/fsharp-backend/src/LibBackend/StaticAssets.fs @@ -13,10 +13,6 @@ open Prelude open Prelude.Tablecloth open Tablecloth -// let pp_gcloud_err (err : Gcloud.Auth.error) : string = -// Gcloud.Auth.pp_error Format.str_formatter err ; -// Format.flush_str_formatter () - type DeployStatus = | Deploying | Deployed @@ -56,7 +52,7 @@ type StaticDeploy = // Lwt_result.fail (`GcloudAuthError (pp_gcloud_err x)) -let appHash (canvasName : CanvasName.T) (canvasID : CanvasID) : string = +let appHash (canvasName : CanvasName.T) : string = // enough of a hash to make this not easily discoverable $"{canvasName}SOME SALT HERE{LibService.Config.envDisplayName}" |> sha1digest @@ -69,41 +65,40 @@ type UrlType = | Short | Long -let url - (canvasName : CanvasName.T) - (canvasID : CanvasID) - (deployHash : string) - (t : UrlType) - : string = +let url (canvasName : CanvasName.T) (deployHash : string) (t : UrlType) : string = let domain = match t with | Short -> ".darksa.com" | Long -> ".darkstaticassets.com" - let apphash = appHash canvasName canvasID + let apphash = appHash canvasName + + $"https://{canvasName}{domain}/{apphash}/{deployHash}" + +// TODO [polish] could instrument this to error on bad deploy hash, maybe also +// unknown file +let urlFor + (canvasName : CanvasName.T) + (deployHash : string) + (variant : UrlType) + (file : string) + : string = + url canvasName deployHash variant + "/" + file + + +let latestDeployHash (canvasID : CanvasID) : Task = + let branch = "main" in + + Sql.query + "SELECT deploy_hash FROM static_asset_deploys + WHERE canvas_id=@canvasID AND branch=@branch AND live_at IS NOT NULL + ORDER BY created_at desc + LIMIT 1" + |> Sql.parameters [ "canvasID", Sql.uuid canvasID; "branch", Sql.string branch ] + |> Sql.executeRowAsync (fun read -> read.string "deploy_hash") + - $"https://{canvasName}{domain}/{apphash}/deployHash" -// (* TODO [polish] could instrument this to error on bad deploy hash, maybe also -// * unknown file *) -// let url_for (canvas_id : Uuidm.t) (deploy_hash : string) variant (file : string) -// : string = -// url canvas_id deploy_hash variant ^ "/" ^ file -// -// -// let latest_deploy_hash (canvas_id : Uuidm.t) : string = -// let branch = "main" in -// Db.fetch_one -// ~name:"select latest deploy hash" -// ~subject:(Uuidm.to_string canvas_id) -// "SELECT deploy_hash FROM static_asset_deploys -// WHERE canvas_id=$1 AND branch=$2 AND live_at IS NOT NULL -// ORDER BY created_at desc -// LIMIT 1" -// ~params:[Uuid canvas_id; String branch] -// |> List.hd_exn -// -// // let upload_to_bucket // (filename : string) // (body : string) @@ -258,15 +253,18 @@ let url // ; url = url canvas_id deploy_hash `Short // ; last_update // ; status = Deployed } -// + let allDeploysInCanvas (canvasName : CanvasName.T) (canvasID : CanvasID) : Task> = Sql.query - "SELECT deploy_hash, created_at, live_at FROM static_asset_deploys - WHERE canvas_id=@canvasID ORDER BY created_at DESC LIMIT 25" + "SELECT deploy_hash, created_at, live_at + FROM static_asset_deploys + WHERE canvas_id=@canvasID + ORDER BY created_at + DESC LIMIT 25" |> Sql.parameters [ "canvasID", Sql.uuid canvasID ] |> Sql.executeAsync (fun read -> let deployHash = read.string "deploy_hash" @@ -277,6 +275,6 @@ let allDeploysInCanvas | None -> Deploying, read.instant "created_at" { deployHash = deployHash - url = url canvasName canvasID deployHash Short + url = url canvasName deployHash Short status = status lastUpdate = lastUpdate })