WIP System.IO

guida-lang · Nov 23, 2024 · ebca0be · ebca0be
1 parent 225d983
commit ebca0be
Show file tree

Hide file tree

Showing 4 changed files with 87 additions and 29 deletions.
diff --git a/bin/index.js b/bin/index.js
@@ -464,6 +464,7 @@ const app = Elm.Terminal.Main.init({
     args: process.argv.slice(2),
     currentDirectory: process.cwd(),
     envVars: Object.keys(process.env).reduce((acc, key) => { acc.push([key, process.env[key]]); return acc }, []),
+    homedir: os.homedir(),
     progName: "guida"
   }
 });
@@ -481,14 +482,50 @@ app.ports.sendWriteString.subscribe(function (...args) {
 });
 
 app.ports.sendRead.subscribe(function ({ index, fd }) {
+  console.log("sendRead", index, fd);
+
   fs.readFile(fd, (err, data) => {
     if (err) throw err;
     app.ports.recvRead.send({ index, value: data.toString() });
   });
 });
 
-app.ports.sendHttpFetch.subscribe(function (...args) {
-  console.log("sendHttpFetch", args);
+app.ports.sendHttpFetch.subscribe(function ({ index, method, urlStr, headers }) {
+  const url = new URL(urlStr);
+  const client = url.protocol == "https:" ? https : http;
+
+  const req = client.request(url, { method, headers }, (res) => {
+    let chunks = [];
+
+    res.on("data", (chunk) => {
+      chunks.push(chunk);
+    });
+
+    res.on("end", () => {
+      const buffer = Buffer.concat(chunks);
+      const encoding = res.headers["content-encoding"];
+
+      if (encoding == "gzip") {
+        zlib.gunzip(buffer, (err, decoded) => {
+          if (err) throw err;
+          app.ports.recvHttpFetch.send({ index, value: decoded && decoded.toString() });
+        });
+      } else if (encoding == "deflate") {
+        zlib.inflate(buffer, (err, decoded) => {
+          if (err) throw err;
+          app.ports.recvHttpFetch.send({ index, value: decoded && decoded.toString() });
+        });
+      } else {
+        app.ports.recvHttpFetch.send({ index, value: buffer.toString() });
+      }
+    });
+  });
+
+  req.on("error", (err) => {
+    throw err;
+  });
+
+  req.end();
 });
 
 app.ports.sendGetArchive.subscribe(function (...args) {
@@ -528,6 +565,8 @@ app.ports.sendExitWith.subscribe(function (...args) {
 });
 
 app.ports.sendNewEmptyMVar.subscribe(function (index) {
+  console.log("sendNewEmptyMVar", index);
+
     nextCounter += 1;
     mVars[nextCounter] = { subscribers: [], value: undefined };
   app.ports.recvNewEmptyMVar.send({ index, value: nextCounter });
@@ -549,7 +588,7 @@ app.ports.sendPutMVar.subscribe(function ({ index, id, value }) {
 
       mVars[id].subscribers = mVars[id].subscribers.filter((subscriber) => {
         if (subscriber.action === "read") {
-        // FIXME app.ports.???.send({ index: subscriber.index, value });
+        app.ports.recvReadMVar.send({ index: subscriber.index, value });
         }
 
         return subscriber.action !== "read";
@@ -558,6 +597,7 @@ app.ports.sendPutMVar.subscribe(function ({ index, id, value }) {
       const subscriber = mVars[id].subscribers.shift();
 
       if (subscriber) {
+      console.log("sendPutMVar!subscriber", subscriber);
       // FIXME app.ports.???.send({ index: subscriber.index, value });
 
         if (subscriber.action === "take") {
@@ -572,16 +612,22 @@ app.ports.sendPutMVar.subscribe(function ({ index, id, value }) {
 });
 
 app.ports.sendDirDoesFileExist.subscribe(function ({ index, filename }) {
+  console.log("sendDirDoesFileExist", index, filename);
+
   app.ports.recvDirDoesFileExist.send({ index, value: fs.existsSync(filename) });
 });
 
 app.ports.sendDirCreateDirectoryIfMissing.subscribe(function ({ index, createParents, filename }) {
+  console.log("sendDirCreateDirectoryIfMissing", index, createParents, filename);
+
   fs.mkdir(filename, { recursive: createParents }, (err) => {
     app.ports.recvDirCreateDirectoryIfMissing.send(index);
   });
 });
 
 app.ports.sendLockFile.subscribe(function ({ index, path }) {
+  console.log("sendLockFile", index, path);
+
   if (lockedFiles[path]) {
     lockedFiles[path].subscribers.push(index);
   } else {
@@ -591,21 +637,29 @@ app.ports.sendLockFile.subscribe(function ({ index, path }) {
 });
 
 app.ports.sendDirGetModificationTime.subscribe(function ({ index, filename }) {
+  console.log("sendDirGetModificationTime", index, filename);
+
   fs.stat(filename, (err, stats) => {
     if (err) throw err;
     app.ports.recvDirGetModificationTime.send({ index, value: parseInt(stats.mtimeMs, 10) });
   });
 });
 
 app.ports.sendDirDoesDirectoryExist.subscribe(function ({ index, path }) {
+  console.log("sendDirDoesDirectoryExist", index, path);
+
   app.ports.recvDirDoesDirectoryExist.send({ index, value: fs.existsSync(path) });
 });
 
 app.ports.sendDirCanonicalizePath.subscribe(function ({ index, path }) {
+  console.log("sendDirCanonicalizePath", index, path);
+
   app.ports.recvDirCanonicalizePath.send({ index, value: resolve(path) });
 });
 
 app.ports.sendReadMVar.subscribe(function ({ index, id }) {
+  console.log("sendReadMVar", mVars, index, id, typeof mVars[id].value);
+
   if (typeof mVars[id].value === "undefined") {
     mVars[id].subscribers.push({ index, action: "read" });
   } else {

diff --git a/src/Compiler/Json/Encode.elm b/src/Compiler/Json/Encode.elm
@@ -222,7 +222,6 @@ writeUgly path value =
 -}
 fileWriteBuilder : String -> String -> IO ()
 fileWriteBuilder path value =
-    -- IO.make (Decode.succeed ()) (IO.WriteString path value)
     IO (\s -> ( s, IO.WriteString IO.pure path value ))
 
 

diff --git a/src/System/IO.elm b/src/System/IO.elm
@@ -79,6 +79,7 @@ type alias Flags =
     { args : List String
     , currentDirectory : String
     , envVars : List ( String, String )
+    , homedir : FilePath
     , progName : String
     }
 
@@ -97,6 +98,7 @@ run app =
                         { args = flags.args
                         , currentDirectory = flags.currentDirectory
                         , envVars = Dict.fromList compare flags.envVars
+                        , homedir = flags.homedir
                         , progName = flags.progName
                         , ioRefs = Array.empty
                         }
@@ -204,12 +206,20 @@ type Msg
 
 update : Msg -> Model -> ( Model, Cmd Msg )
 update msg model =
-    case Debug.log "update" msg of
+    case msg of
         PureMsg index (IO fn) ->
-            case Debug.log "update2" (fn model.realWorld) of
+            case fn model.realWorld of
                 ( newRealWorld, Pure () ) ->
                     ( { model | realWorld = newRealWorld }, Cmd.none )
 
+                ( newRealWorld, ForkIO next forkIO ) ->
+                    let
+                        ( updatedModel, updatedCmd ) =
+                            update (PureMsg (index + 1) forkIO) { model | realWorld = newRealWorld }
+                    in
+                    update (PureMsg index (next ())) updatedModel
+                        |> Tuple.mapSecond (\cmd -> Cmd.batch [ updatedCmd, cmd ])
+
                 ( newRealWorld, GetLine next ) ->
                     ( { model | realWorld = newRealWorld, next = Dict.insert compare index (GetLineNext next) model.next }, sendGetLine () )
 
@@ -222,17 +232,17 @@ update msg model =
                 ( newRealWorld, Read next fd ) ->
                     ( { model | realWorld = newRealWorld, next = Dict.insert compare index (ReadNext next) model.next }, sendRead { index = index, fd = fd } )
 
-                ( newRealWorld, HttpFetch next method url headers ) ->
-                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HttpFetchNext next) model.next }, sendHttpFetch { method = method, url = url, headers = headers } )
+                ( newRealWorld, HttpFetch next method urlStr headers ) ->
+                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HttpFetchNext next) model.next }, sendHttpFetch { index = index, method = method, urlStr = urlStr, headers = headers } )
 
                 ( newRealWorld, GetArchive next method url ) ->
-                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (GetArchiveNext next) model.next }, sendGetArchive { method = method, url = url } )
+                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (GetArchiveNext next) model.next }, sendGetArchive { index = index, method = method, url = url } )
 
                 ( newRealWorld, HttpUpload next url headers parts ) ->
-                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HttpUploadNext next) model.next }, sendHttpUpload { url = url, headers = headers, parts = parts } )
+                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HttpUploadNext next) model.next }, sendHttpUpload { index = index, url = url, headers = headers, parts = parts } )
 
                 ( newRealWorld, HFlush next (Handle fd) ) ->
-                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HFlushNext next) model.next }, sendHFlush fd )
+                    ( { model | realWorld = newRealWorld, next = Dict.insert compare index (HFlushNext next) model.next }, sendHFlush { index = index, fd = fd } )
 
                 ( newRealWorld, WithFile next path mode ) ->
                     ( { model | realWorld = newRealWorld, next = Dict.insert compare index (WithFileNext next) model.next }
@@ -543,25 +553,25 @@ port sendRead : { index : Int, fd : String } -> Cmd msg
 port recvRead : ({ index : Int, value : String } -> msg) -> Sub msg
 
 
-port sendHttpFetch : { method : String, url : String, headers : List ( String, String ) } -> Cmd msg
+port sendHttpFetch : { index : Int, method : String, urlStr : String, headers : List ( String, String ) } -> Cmd msg
 
 
 port recvHttpFetch : ({ index : Int, value : String } -> msg) -> Sub msg
 
 
-port sendGetArchive : { method : String, url : String } -> Cmd msg
+port sendGetArchive : { index : Int, method : String, url : String } -> Cmd msg
 
 
 port recvGetArchive : ({ index : Int, value : ( String, Zip.Archive ) } -> msg) -> Sub msg
 
 
-port sendHttpUpload : { url : String, headers : List ( String, String ), parts : List Encode.Value } -> Cmd msg
+port sendHttpUpload : { index : Int, url : String, headers : List ( String, String ), parts : List Encode.Value } -> Cmd msg
 
 
 port recvHttpUpload : (Int -> msg) -> Sub msg
 
 
-port sendHFlush : Int -> Cmd msg
+port sendHFlush : { index : Int, fd : Int } -> Cmd msg
 
 
 port recvHFlush : (Int -> msg) -> Sub msg
@@ -688,6 +698,7 @@ type IO a
 
 type ION a
     = Pure a
+    | ForkIO (() -> IO a) (IO ())
     | HPutStr (() -> IO a) Handle String
     | GetLine (String -> IO a)
     | WriteString (() -> IO a) FilePath String
@@ -721,6 +732,7 @@ type alias RealWorld =
     { args : List String
     , currentDirectory : String
     , envVars : Dict String String
+    , homedir : FilePath
     , progName : String
     , ioRefs : Array Encode.Value
     }
@@ -749,6 +761,9 @@ bind f (IO ma) =
                 ( s1, Pure a ) ->
                     unIO (f a) s1
 
+                ( s1, ForkIO next forkIO ) ->
+                    ( s1, ForkIO (\() -> bind f (next ())) forkIO )
+
                 ( s1, GetLine next ) ->
                     ( s1, GetLine (\input -> bind f (next input)) )
 
@@ -761,8 +776,8 @@ bind f (IO ma) =
                 ( s1, Read next fd ) ->
                     ( s1, Read (\input -> bind f (next input)) fd )
 
-                ( s1, HttpFetch next method url headers ) ->
-                    ( s1, HttpFetch (\body -> bind f (next body)) method url headers )
+                ( s1, HttpFetch next method urlStr headers ) ->
+                    ( s1, HttpFetch (\body -> bind f (next body)) method urlStr headers )
 
                 ( s1, GetArchive next method url ) ->
                     ( s1, GetArchive (\body -> bind f (next body)) method url )

diff --git a/src/Utils/Main.elm b/src/Utils/Main.elm
@@ -860,8 +860,7 @@ dirGetCurrentDirectory =
 
 dirGetAppUserDataDirectory : FilePath -> IO FilePath
 dirGetAppUserDataDirectory filename =
-    -- IO.make Decode.string (IO.DirGetAppUserDataDirectory filename)
-    Debug.todo "dirGetAppUserDataDirectory"
+    IO (\s -> ( s, IO.Pure (s.homedir ++ "/." ++ filename) ))
 
 
 dirGetModificationTime : FilePath -> IO Time.Posix
@@ -1066,16 +1065,7 @@ type ThreadId
 
 forkIO : IO () -> IO ThreadId
 forkIO ioArg =
-    -- IO
-    --     (\next ->
-    --         Decode.succeed
-    --             ( IO.Process (next ThreadId)
-    --             , IO.NoOp
-    --             , Just ioArg
-    --             )
-    --     )
-    -- FIXME !!! forkIO
-    IO (\s -> ( s, IO.Pure ThreadId ))
+    IO (\s -> ( s, IO.ForkIO (\() -> IO.pure ThreadId) ioArg ))