aboutsummaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--backend/app/Main.hs69
-rw-r--r--backend/app/Route.hs21
-rw-r--r--backend/backend.cabal3
-rw-r--r--frontend/app/Api.hs10
-rw-r--r--frontend/app/Page/NewCollection.hs17
5 files changed, 74 insertions, 46 deletions
diff --git a/backend/app/Main.hs b/backend/app/Main.hs
index 59eab03..a3d30c2 100644
--- a/backend/app/Main.hs
+++ b/backend/app/Main.hs
@@ -9,30 +9,26 @@ import Control.Monad
import Control.Monad.Trans (liftIO)
import Data.Aeson qualified as J
import Data.Attoparsec.Char8 as P
-import Data.ByteString.Char8 qualified as B
-import Data.ByteString.Lazy.Char8 qualified as LB
import Data.ByteString.Lazy.UTF8 qualified as LB
-import Data.ByteString.UTF8 qualified as B
-import Data.List
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 (..), untag)
+import Data.Tagged (Tagged (..))
import Debug.Trace
import Git qualified as G
import Git.Libgit2 qualified as GB
-import Network.HTTP.Types.Method qualified as W
+import Network.HTTP.Types
import Network.HTTP.Types.Status qualified as W
import Network.Wai qualified as W
import Network.Wai.Handler.Warp qualified as W
import Options.Applicative qualified as A
+import Route qualified as R
import Safe
import Store qualified as Q
import System.Directory (setCurrentDirectory)
import System.FilePath
import System.INotify
-import Text.Printf (printf)
import Version
data Args = Args
@@ -87,17 +83,17 @@ fromAutoTypes path (U.Object ps) =
("$id", J.toJSON @String (path <> ".schema.json")),
("title", J.toJSON @String path),
("type", J.toJSON @String "object"),
- ("properties", J.toJSON (M.mapWithKey toProperty ps))
+ ("properties", J.toJSON (M.map toProperty ps))
]
where
- toProperty k (U.Scalar "string") = "string" :: String
- toProperty k (U.Option (Just (U.Scalar "string"))) = "string?" :: String
+ toProperty (U.Scalar "string") = "string" :: String
+ toProperty (U.Option (Just (U.Scalar "string"))) = "string?" :: String
watch :: TMVar Repo -> FilePath -> G.RefName -> IO ()
watch repoT root ref = do
i <- initINotify
qT <- newTQueueIO
- wd <-
+ _ <-
addWatch i [MoveIn] ".git/refs/heads" $ \e ->
atomically (writeTQueue qT e)
forever do
@@ -114,16 +110,13 @@ initRepo root ref = do
repo <- G.openRepository GB.lgFactory G.defaultRepositoryOptions {G.repoPath = root}
G.runRepository GB.lgFactory repo do
Just cid <- fmap Tagged <$> G.resolveReference ref
- c <- G.lookupCommit cid
cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid
fmap (Repo . reverse) $
foldM
( \cs c -> do
let cid = G.commitOid c
- fs <-
- fmap (filter ((== ".json") . takeExtension)) . liftIO $
- Q.withStore root ref do
- Q.withCommit cid (Q.listFiles "/")
+ fs <- liftIO $ Q.withStore root ref do
+ Q.withCommit cid (Q.listFiles "/")
let cls =
M.toList . M.unionsWith (++) $
map (\f -> M.singleton (takeDirectory f) [f]) fs
@@ -204,45 +197,35 @@ main = do
A.execParser (A.info (args <**> A.helper) A.idm) >>= \case
Args {cmd = Serve} -> do
W.runEnv 8081 $ \req respond -> do
- case P.parseOnly routeP (W.rawPathInfo req) of
- Right (SchemaJson path) -> 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 Query -> do
+ 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 SchemaVersion -> do
+ Right R.SchemaVersion -> do
repo <- atomically (readTMVar repoT)
respond $
W.responseLBS W.status200 [] $
J.encode (last repo.commits).schemaVersion
- Right ListCollections -> do
- repo <- atomically (readTMVar repoT)
- respond $
- W.responseLBS W.status200 [] $
- J.encode (map (.path) (last repo.commits).collections)
+ 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"
-
-data Route
- = SchemaJson String
- | Query
- | SchemaVersion
- | ListCollections
- deriving (Show)
-
-routeP :: P.Parser Route
-routeP =
- ( P.choice
- [ pure ListCollections <* P.string "/collections",
- pure SchemaVersion <* P.string "/schemaVersion",
- SchemaJson <$> (P.string "/" *> P.manyTill P.anyChar (P.string ".schema.json")),
- pure Query <* P.string "/"
- ]
- )
- <* P.endOfInput
diff --git a/backend/app/Route.hs b/backend/app/Route.hs
new file mode 100644
index 0000000..61fa699
--- /dev/null
+++ b/backend/app/Route.hs
@@ -0,0 +1,21 @@
+module Route (Route (..), parser) where
+
+import Data.Attoparsec.Char8 qualified as P
+
+data Route
+ = SchemaJson String
+ | Query
+ | SchemaVersion
+ | Collections
+ 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 "/"
+ ]
+ )
+ <* P.endOfInput
diff --git a/backend/backend.cabal b/backend/backend.cabal
index 058efc7..b1b1344 100644
--- a/backend/backend.cabal
+++ b/backend/backend.cabal
@@ -10,10 +10,11 @@ build-type: Simple
executable backend
main-is: Main.hs
hs-source-dirs: app
+ other-modules: Route
default-language: GHC2021
default-extensions:
BlockArguments LambdaCase OverloadedStrings ViewPatterns
- OverloadedRecordDot NoFieldSelectors
+ OverloadedRecordDot NoFieldSelectors MultiWayIf
ghc-options: -Wall -threaded
build-depends:
diff --git a/frontend/app/Api.hs b/frontend/app/Api.hs
index 2aa23c9..2b7598a 100644
--- a/frontend/app/Api.hs
+++ b/frontend/app/Api.hs
@@ -2,6 +2,7 @@
module Api
( fetchCollections,
+ createCollection,
fetchSchema,
fetchSchemaVersion,
fetchPosts,
@@ -33,6 +34,15 @@ fetchCollections :: JSM (Either String [String])
fetchCollections =
A.eitherDecode <$> fetch (fromString "http://localhost:8081/collections")
+createCollection :: String -> JSM (Either String ())
+createCollection collection =
+ A.eitherDecode
+ <$> fetch
+ ( fromString "http://localhost:8081/collections"
+ & setRequestMethod "POST"
+ & setRequestBodyLBS (A.encode (A.toJSON collection))
+ )
+
fetchSchemaVersion :: JSM (Either String Version)
fetchSchemaVersion =
A.eitherDecode <$> fetch (fromString "http://localhost:8081/schemaVersion")
diff --git a/frontend/app/Page/NewCollection.hs b/frontend/app/Page/NewCollection.hs
index b105689..282d36e 100644
--- a/frontend/app/Page/NewCollection.hs
+++ b/frontend/app/Page/NewCollection.hs
@@ -7,9 +7,12 @@ module Page.NewCollection
)
where
+import Api
+import Data.Aeson qualified as A
import Data.Text qualified as T
import Form qualified as F
import Miso
+import Miso.String (toMisoString)
data Model = Model
{ input :: T.Text
@@ -24,19 +27,29 @@ data Action
= NoOp
| FormChanged T.Text
| FormSubmitted T.Text
+ | CollectionCreated (Either String ())
deriving (Eq, Show)
updateModel :: Action -> Model -> Effect Action Model
updateModel NoOp m = noEff m
updateModel (FormChanged input) m = noEff m {input}
-updateModel (FormSubmitted _) m = noEff m
+updateModel (FormSubmitted collection) m =
+ m <# do
+ CollectionCreated <$> createCollection (T.unpack collection)
+updateModel (CollectionCreated (Left err)) m =
+ m <# do
+ pure NoOp <* consoleLog (toMisoString err)
+-- TODO reload collections in main app
+updateModel (CollectionCreated (Right _)) m = noEff m
viewModel :: Model -> View Action
viewModel m = do
div_ [] $
[ h3_ [] [text "new collection"],
either FormChanged FormSubmitted
- <$> F.runForm collectionForm m.input
+ <$> F.runForm collectionForm m.input,
+ pre_ [] [text (toMisoString (A.encode m.input))],
+ pre_ [] [text (toMisoString (A.encode (collectionForm.fill m.input)))]
]
collectionForm :: F.Form T.Text T.Text
generated by cgit v1.2.3 (git 2.25.1) at 2025-01-23 09:35:36 +0000