diff options
Diffstat (limited to 'backend')
| -rw-r--r-- | backend/app/Main.hs | 69 | ||||
| -rw-r--r-- | backend/app/Route.hs | 21 | ||||
| -rw-r--r-- | backend/backend.cabal | 3 |
3 files changed, 49 insertions, 44 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: |