use backend REST library for frontend

2 files changed, 114 insertions, 48 deletions

diff --git a/backend/lib/ACMS/API/REST.hs b/backend/lib/ACMS/API/REST.hs
new file mode 100644
index 0000000..6aca780
--- /dev/null
+++ b/backend/lib/ACMS/API/REST.hs
@@ -0,0 +1,75 @@
+{-# LANGUAGE OverloadedStrings #-}
+
+module ACMS.API.REST where
+
+#ifndef ghcjs_HOST_OS
+import Network.HTTP.Simple
+#else
+import Data.ByteString.Char8 qualified as B
+import Data.Maybe
+import Data.String
+import JavaScript.Web.XMLHttpRequest
+import Miso.String qualified as J
+#endif
+import Control.Monad.Catch (MonadThrow)
+import Data.Aeson qualified as A
+import Data.ByteString.Lazy.Char8 qualified as LB
+import Data.ByteString.Lazy.UTF8 qualified as LB
+import Data.Function ((&))
+import Miso (JSM)
+import Miso.String (MisoString)
+
+schemaVersion :: (APIMonad m, A.FromJSON a) => m a
+schemaVersion =
+  "http://localhost:8081/api/rest/schemaVersion"
+    & fetch
+    >>= A.throwDecode
+
+listCollections :: (APIMonad m) => m [MisoString]
+listCollections =
+  "http://localhost:8081/api/rest/collection"
+    & fetch
+    >>= A.throwDecode
+
+createCollection :: (APIMonad m) => MisoString -> m ()
+createCollection collection =
+  "http://localhost:8081/api/rest/collections"
+    & setRequestMethod "POST"
+    & setRequestBodyLBS (A.encode (A.toJSON collection))
+    & fetch
+    >>= A.throwDecode
+
+class (MonadThrow m) => APIMonad m where
+  fetch :: Request -> m LB.ByteString
+
+instance APIMonad JSM where
+  fetch req = LB.fromStrict . getResponseBody <$> httpBS req
+
+#ifdef ghcjs_HOST_OS
+
+httpBS :: Request -> JSM (Response B.ByteString)
+httpBS req = xhrByteString req
+
+instance IsString Request where
+  fromString uri =
+    Request
+      { reqMethod = GET,
+        reqURI = J.pack uri,
+        reqLogin = Nothing,
+        reqHeaders = [],
+        reqWithCredentials = False,
+        reqData = NoData
+      }
+
+setRequestMethod :: B.ByteString -> Request -> Request
+setRequestMethod "POST" req = req {reqMethod = POST}
+
+setRequestBodyLBS :: LB.ByteString -> Request -> Request
+setRequestBodyLBS body req = req {reqData = StringData (J.pack (LB.toString body))}
+
+getResponseBody :: Response B.ByteString -> B.ByteString
+getResponseBody = fromMaybe "" . contents
+#else
+instance APIMonad IO where
+  fetch req = LB.fromStrict . getResponseBody <$> httpBS req
+#endif
diff --git a/backend/lib/ACMS/API/REST/Collection.hs b/backend/lib/ACMS/API/REST/Collection.hs
index c22b6ba..e0df21b 100644
--- a/backend/lib/ACMS/API/REST/Collection.hs
+++ b/backend/lib/ACMS/API/REST/Collection.hs
@@ -2,68 +2,59 @@
 
 module ACMS.API.REST.Collection where
 
+#ifndef ghcjs_HOST_OS
+import Network.HTTP.Simple
+#else
+import ACMS.API.REST (setRequestMethod, setRequestBodyLBS, getResponseBody)
+import Data.ByteString.Char8 qualified as B
+import Data.Maybe
+import JavaScript.Web.XMLHttpRequest
+import Miso.String qualified as J
+#endif
+import ACMS.API.REST (APIMonad, fetch)
 import Data.Aeson qualified as A
-import Data.Aeson.KeyMap qualified as AM
-import Data.ByteString.Lazy.UTF8 qualified as LB
 import Data.Function ((&))
 import Data.String (fromString)
-import Data.Text qualified as T
-import Network.HTTP.Simple
+import Miso.String (MisoString)
 import Text.Printf (printf)
-import Data.UUID qualified as U
-import Data.UUID.V4 qualified as U
 
-type CollectionName = T.Text
-
-list :: T.Text -> IO [A.Object]
+list :: (APIMonad m) => MisoString -> m [A.Object]
 list c =
-  "http://localhost:8081"
-    & setRequestMethod "POST"
-    & setRequestBodyLBS (LB.fromString (printf "SELECT %s FROM %s" c c))
-    & httpLBS
-    >>= A.throwDecode . getResponseBody
+  fromString (printf "http://localhost:8081/api/rest/collection/%s" c)
+    & fetch
+    >>= A.throwDecode
 
-read :: T.Text -> T.Text -> IO [A.Object]
+read :: (APIMonad m) => MisoString -> MisoString -> m [A.Object]
 read c i =
-  "http://localhost:8081"
-    & setRequestMethod "POST"
-    & setRequestBodyLBS
-      (LB.fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
-    & httpLBS
-    >>= A.throwDecode . getResponseBody
+  fromString (printf "http://localhost:8081/api/rest/collection/%s/%s" c i)
+    & fetch
+    >>= A.throwDecode
 
-update :: T.Text -> T.Text -> A.Object -> IO ()
+update :: (APIMonad m) => MisoString -> MisoString -> A.Object -> m ()
 update c i o =
-  "http://localhost:8081"
-    & setRequestMethod "POST"
-    & setRequestBodyLBS
-      (LB.fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (A.encode o)) c i))
-    & httpLBS
-    >>= A.throwDecode . getResponseBody
+  fromString (printf "http://localhost:8081/api/rest/collection/%s/%s" c i)
+    & setRequestMethod "PUT"
+    & setRequestBodyLBS (A.encode o)
+    & fetch
+    >>= A.throwDecode
 
-create :: T.Text -> A.Object -> IO U.UUID
+create :: (APIMonad m) => MisoString -> A.Object -> m A.Object
 create c o = do
-  uuid <- U.nextRandom
-  let i = U.toText uuid <> ".json"
-  response <- "http://localhost:8081"
+  fromString (printf "http://localhost:8081/api/rest/collection/%s" c)
     & setRequestMethod "POST"
-    & setRequestBodyLBS
-      (LB.fromString (printf "INSERT %s INTO %s" (LB.toString (A.encode (AM.insert "$fileName" (A.String i) o))) c))
-    & httpLBS
-  uuid <$ A.throwDecode @() (getResponseBody response)
+    & setRequestBodyLBS (A.encode o)
+    & fetch
+    >>= A.throwDecode
 
-delete :: T.Text -> T.Text -> IO [A.Object]
+delete :: (APIMonad m) => MisoString -> MisoString -> m [A.Object]
 delete c i =
-  "http://localhost:8081"
-    & setRequestMethod "POST"
-    & setRequestBodyLBS
-      (LB.fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
-    & httpLBS
-    >>= A.throwDecode . getResponseBody
+  fromString (printf "http://localhost:8081/api/rest/collection/%s/%s" c i)
+    & setRequestMethod "DELETE"
+    & fetch
+    >>= A.throwDecode
 
-schema :: T.Text -> IO A.Value
+schema :: (APIMonad m) => (A.FromJSON a) => MisoString -> m a
 schema c =
-  fromString (printf "http://localhost:8081/%s.schema.json" c)
-    & setRequestMethod "POST"
-    & httpLBS
-    >>= A.throwDecode . getResponseBody
+  fromString (printf "http://localhost:8081/api/rest/collection/%s/schema" c)
+    & fetch
+    >>= A.throwDecode