diff options
Diffstat (limited to 'backend/app/Main.hs')
| -rw-r--r-- | backend/app/Main.hs | 113 |
1 files changed, 76 insertions, 37 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 |