aboutsummaryrefslogtreecommitdiffstats
path: root/backend
diff options
context:
space:
mode:
Diffstat (limited to 'backend')
-rw-r--r--backend/app/Main.hs113
-rw-r--r--backend/app/Route.hs14
-rw-r--r--backend/backend.cabal43
-rw-r--r--backend/lib/ACMS/API/REST.hs75
-rw-r--r--backend/lib/ACMS/API/REST/Collection.hs87
5 files changed, 211 insertions, 121 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs
index a81d769..445b3d1 100644
--- a/backend/app/Main.hs
+++ b/backend/app/Main.hs
@@ -1,6 +1,8 @@
+{-# LANGUAGE ApplicativeDo #-}
{-# LANGUAGE NamedFieldPuns #-}
+{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE RecordWildCards #-}
-{-# LANGUAGE ApplicativeDo #-}
+
module Main where
import AutoTypes qualified as U
@@ -11,13 +13,19 @@ import Control.Concurrent.STM
import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Aeson qualified as J
+import Data.Aeson.KeyMap qualified as JM
import Data.Attoparsec.Char8 as P
+import Data.ByteString.Char8 qualified as B
import Data.ByteString.Lazy.UTF8 qualified as LB
+import Data.ByteString.UTF8 qualified as B
import Data.Map qualified as M
import Data.Map.Merge.Strict qualified as M
import Data.Maybe
import Data.String (IsString (fromString))
import Data.Tagged (Tagged (..))
+import Data.Text qualified as T
+import Data.UUID qualified as U
+import Data.UUID.V4 qualified as U
import Debug.Trace
import Git qualified as G
import Git.Libgit2 qualified as GB
@@ -29,11 +37,12 @@ import Options.Applicative qualified as A
import Route qualified as R
import Safe
import Store qualified as Q
-import System.Directory (setCurrentDirectory, doesDirectoryExist, makeAbsolute)
+import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory)
import System.Exit
import System.FilePath
import System.INotify
import System.IO qualified as IO
+import Text.Printf (printf)
import Version
data Args = Args
@@ -44,8 +53,8 @@ args :: A.Parser Args
args = Args <$> cmd'
data Cmd = Serve
- { serverPort :: Int
- , contentRepositoryPath :: FilePath
+ { serverPort :: Int,
+ contentRepositoryPath :: FilePath
}
cmd' :: A.Parser Cmd
@@ -222,36 +231,66 @@ main = do
logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".")
- W.runEnv serverPort $ \req respond -> do
- case P.parseOnly R.parser (W.rawPathInfo req) of
- Right (R.SchemaJson path) -> do
- repo <- atomically (readTMVar repoT)
- let [c] = filter ((== path) . (.path)) (last repo.commits).collections
- respond . W.responseLBS W.status200 [] $
- J.encode (fromAutoTypes path c.schema)
- Right R.Query -> do
- q <-
- fromString @Q.Query . LB.toString
- <$> W.lazyRequestBody req
- r <- liftIO $ Q.withStore root ref do Q.query q
- respond . W.responseLBS W.status200 [] $ J.encode r
- Right R.SchemaVersion -> do
- repo <- atomically (readTMVar repoT)
- respond $
- W.responseLBS W.status200 [] $
- J.encode (last repo.commits).schemaVersion
- Right R.Collections -> do
- if
- | W.requestMethod req == "POST" -> do
- Right collection <- J.eitherDecode <$> W.lazyRequestBody req
- Q.withStore root ref do
- Q.writeFile (collection </> ".gitkeep") ""
- Q.commit
- respond $ W.responseLBS W.status200 [] "{}"
- | W.requestMethod req == "GET" -> do
- repo <- atomically (readTMVar repoT)
- respond $
- W.responseLBS W.status200 [] $
- J.encode (map (.path) (last repo.commits).collections)
- (traceShowId -> !_) ->
- respond $ W.responseLBS W.status200 [] "not implemented"
+ W.runEnv serverPort . restApi root ref repoT $
+ ( \req respond -> do
+ case P.parseOnly R.parser (W.rawPathInfo req) of
+ Right R.Query -> do
+ q <-
+ fromString @Q.Query . LB.toString
+ <$> W.lazyRequestBody req
+ r <- liftIO $ Q.withStore root ref do Q.query q
+ respond . W.responseLBS W.status200 [] $ J.encode r
+ (traceShowId -> !_) ->
+ respond $ W.responseLBS W.status200 [] "not implemented"
+ )
+
+restApi :: String -> T.Text -> TMVar Repo -> W.Middleware
+restApi root ref repoT app req respond =
+ case traceShowId (drop 1 (B.split '/' (W.rawPathInfo req))) of
+ ("api" : "rest" : rs) ->
+ case (W.requestMethod req, rs) of
+ ("GET", ["schemaVersion"]) -> do
+ repo <- atomically (readTMVar repoT)
+ respond $
+ W.responseLBS W.status200 [] $
+ J.encode (last repo.commits).schemaVersion
+ ("GET", ["collection"]) -> do
+ repo <- atomically (readTMVar repoT)
+ respond $
+ W.responseLBS W.status200 [] $
+ J.encode (map (.path) (last repo.commits).collections)
+ ("POST", ["collection"]) -> do
+ Right collection <- J.eitherDecode <$> W.lazyRequestBody req
+ Q.withStore root ref do
+ Q.writeFile (collection </> ".gitkeep") ""
+ Q.commit
+ respond $ W.responseLBS W.status200 [] "{}"
+ ("GET", ["collection", B.toString -> c]) -> do
+ respond . W.responseLBS W.status200 [] . J.encode
+ =<< Q.withStore root ref do
+ Q.query (fromString (printf "SELECT %s FROM %s" c c))
+ ("GET", ["collection", B.toString -> c, B.toString -> i]) -> do
+ respond . W.responseLBS W.status200 [] . J.encode
+ =<< Q.withStore root ref do
+ Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i))
+ ("PUT", ["collection", B.toString -> c, B.toString -> i]) -> do
+ o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
+ respond . W.responseLBS W.status200 [] . J.encode
+ =<< Q.withStore root ref do
+ Q.query (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName == \"%s\"" c (LB.toString (J.encode o)) c i))
+ ("POST", ["collection", B.toString -> c]) -> do
+ i <- ((<> ".json") . U.toText) <$> U.nextRandom
+ o <- J.throwDecode @J.Object =<< W.lazyRequestBody req
+ respond . W.responseLBS W.status200 [] . J.encode
+ =<< Q.withStore root ref do
+ Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String i) o))) c))
+ ("DELETE", ["collection", B.toString -> c, B.toString -> i]) -> do
+ respond . W.responseLBS W.status200 [] . J.encode
+ =<< Q.withStore root ref do
+ Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i))
+ ("GET", ["collection", B.toString -> c, "schema"]) -> do
+ repo <- atomically (readTMVar repoT)
+ let [collection] = filter ((== c) . (.path)) (last repo.commits).collections
+ respond . W.responseLBS W.status200 [] $
+ J.encode (fromAutoTypes c collection.schema)
+ _ -> app req respond
diff --git a/backend/app/Route.hs b/backend/app/Route.hs
index 61fa699..59c5342 100644
--- a/backend/app/Route.hs
+++ b/backend/app/Route.hs
@@ -3,19 +3,11 @@ module Route (Route (..), parser) where
import Data.Attoparsec.Char8 qualified as P
data Route
- = SchemaJson String
- | Query
- | SchemaVersion
- | Collections
+ = Query
deriving (Show)
parser :: P.Parser Route
parser =
- ( P.choice
- [ pure Collections <* P.string "/collections",
- pure SchemaVersion <* P.string "/schemaVersion",
- SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
- pure Query <* P.string "/"
- ]
- )
+ pure Query
+ <* P.string "/"
<* P.endOfInput
diff --git a/backend/backend.cabal b/backend/backend.cabal
index f92dd46..b2ca82b 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -8,42 +8,31 @@ author: Alexander Foremny
build-type: Simple
library
- exposed-modules: ACMS.API.REST.Collection
+ exposed-modules:
+ ACMS.API.REST
+ ACMS.API.REST.Collection
+
hs-source-dirs: lib
default-language: GHC2021
default-extensions:
- BlockArguments LambdaCase OverloadedStrings ViewPatterns
+ CPP BlockArguments LambdaCase OverloadedStrings ViewPatterns
OverloadedRecordDot NoFieldSelectors MultiWayIf
ghc-options: -Wall -threaded
build-depends:
aeson,
- astore,
- attoparsec,
- autotypes,
base,
bytestring,
- common,
- containers,
- directory,
- filepath,
- gitlib,
- gitlib-libgit2,
- hinotify,
- hlibgit2,
- http-conduit,
- http-types,
- mtl,
- optparse-applicative,
- safe,
- split,
- stm,
- tagged,
+ exceptions,
+ miso,
text,
- utf8-string,
- uuid,
- wai,
- warp
+ utf8-string
+
+ if arch(javascript)
+ build-depends: ghcjs-base
+
+ else
+ build-depends: http-conduit
executable backend
main-is: Main.hs
@@ -79,5 +68,9 @@ executable backend
tagged,
text,
utf8-string,
+ uuid,
wai,
warp
+
+ if arch(javascript)
+ buildable: False
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