From caf72faccc04e647c27e1b5eef85c515949d8210 Mon Sep 17 00:00:00 2001 From: Alexander Foremny Date: Thu, 20 Feb 2025 12:29:35 +0100 Subject: consolidate `backend, cli, common` -> `acms` --- acms/CHANGELOG.md | 5 + acms/LICENSE | 29 ++ acms/acms.cabal | 120 +++++ acms/app/Main.hs | 101 +++++ acms/src/ACMS/ACMS.hs | 503 +++++++++++++++++++++ acms/src/ACMS/API/Fetch.hs | 61 +++ acms/src/ACMS/API/Query.hs | 15 + acms/src/ACMS/API/REST.hs | 31 ++ acms/src/ACMS/API/REST/Collection.hs | 49 +++ acms/src/ACMS/API/REST/Collection/Paginated.hs | 30 ++ acms/src/Collection.hs | 26 ++ acms/src/Version.hs | 47 ++ acms/test/Main.hs | 4 + backend/LICENSE | 30 -- backend/app/Main.hs | 510 ---------------------- backend/backend.cabal | 86 ---- backend/lib/ACMS/API/Fetch.hs | 63 --- backend/lib/ACMS/API/Query.hs | 17 - backend/lib/ACMS/API/REST.hs | 33 -- backend/lib/ACMS/API/REST/Collection.hs | 51 --- backend/lib/ACMS/API/REST/Collection/Paginated.hs | 33 -- cli/CHANGELOG.md | 5 - cli/LICENSE | 26 -- cli/app/Main.hs | 109 ----- cli/cli.cabal | 28 -- common/CHANGELOG.md | 5 - common/LICENSE | 30 -- common/common.cabal | 23 - common/src/Collection.hs | 30 -- common/src/Version.hs | 47 -- default.nix | 7 +- frontend/app/Form/Input.hs | 2 +- frontend/app/Page/EditValue.hs | 2 +- frontend/frontend.cabal | 3 +- pkgs/default.nix | 4 +- tests.nix | 14 +- 36 files changed, 1034 insertions(+), 1145 deletions(-) create mode 100644 acms/CHANGELOG.md create mode 100644 acms/LICENSE create mode 100644 acms/acms.cabal create mode 100644 acms/app/Main.hs create mode 100644 acms/src/ACMS/ACMS.hs create mode 100644 acms/src/ACMS/API/Fetch.hs create mode 100644 acms/src/ACMS/API/Query.hs create mode 100644 acms/src/ACMS/API/REST.hs create mode 100644 acms/src/ACMS/API/REST/Collection.hs create mode 100644 acms/src/ACMS/API/REST/Collection/Paginated.hs create mode 100644 acms/src/Collection.hs create mode 100644 acms/src/Version.hs create mode 100644 acms/test/Main.hs delete mode 100644 backend/LICENSE delete mode 100644 backend/app/Main.hs delete mode 100644 backend/backend.cabal delete mode 100644 backend/lib/ACMS/API/Fetch.hs delete mode 100644 backend/lib/ACMS/API/Query.hs delete mode 100644 backend/lib/ACMS/API/REST.hs delete mode 100644 backend/lib/ACMS/API/REST/Collection.hs delete mode 100644 backend/lib/ACMS/API/REST/Collection/Paginated.hs delete mode 100644 cli/CHANGELOG.md delete mode 100644 cli/LICENSE delete mode 100644 cli/app/Main.hs delete mode 100644 cli/cli.cabal delete mode 100644 common/CHANGELOG.md delete mode 100644 common/LICENSE delete mode 100644 common/common.cabal delete mode 100644 common/src/Collection.hs delete mode 100644 common/src/Version.hs diff --git a/acms/CHANGELOG.md b/acms/CHANGELOG.md new file mode 100644 index 0000000..ff5d9e1 --- /dev/null +++ b/acms/CHANGELOG.md @@ -0,0 +1,5 @@ +# Revision history for acms + +## 0.1.0.0 -- YYYY-mm-dd + +* First version. Released on an unsuspecting world. diff --git a/acms/LICENSE b/acms/LICENSE new file mode 100644 index 0000000..ba1f71e --- /dev/null +++ b/acms/LICENSE @@ -0,0 +1,29 @@ +Copyright (c) 2025, Alexander Foremny + + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of the copyright holder nor the names of its + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/acms/acms.cabal b/acms/acms.cabal new file mode 100644 index 0000000..fc599ec --- /dev/null +++ b/acms/acms.cabal @@ -0,0 +1,120 @@ +cabal-version: 3.4 +name: acms +version: 0.1.0.0 +license: BSD-3-Clause +license-file: LICENSE +maintainer: aforemny@posteo.de +author: Alexander Foremny +build-type: Simple +extra-doc-files: CHANGELOG.md + +common commons + default-extensions: + ApplicativeDo + BlockArguments + CPP + DuplicateRecordFields + LambdaCase + MultiWayIf + NamedFieldPuns + NoFieldSelectors + NondecreasingIndentation + OverloadedRecordDot + OverloadedStrings + RecordWildCards + TypeApplications + ViewPatterns + + ghc-options: -Wall -threaded -fno-warn-name-shadowing -fno-warn-x-partial + default-language: GHC2021 + +library + import: commons + exposed-modules: + ACMS.API.Query + ACMS.API.REST + ACMS.API.REST.Collection + ACMS.API.REST.Collection.Paginated + Collection + Version + + hs-source-dirs: src + other-modules: ACMS.API.Fetch + build-depends: + aeson, + base, + bytestring, + exceptions, + miso, + split, + text, + utf8-string + + if arch(javascript) + build-depends: ghcjs-base + + else + exposed-modules: ACMS.ACMS + build-depends: + aeson, + astore, + attoparsec, + autotypes, + base, + bytestring, + containers, + directory, + exceptions, + filepath, + gitlib, + gitlib-libgit2, + hinotify, + hlibgit2, + http-conduit, + http-types, + mtl, + non-empty, + optparse-applicative, + random, + regex, + regex-base, + regex-pcre, + safe, + split, + stm, + tagged, + text, + utf8-string, + uuid, + vector, + wai, + warp + + +executable acms + import: commons + main-is: Main.hs + hs-source-dirs: app + build-depends: + acms, + aeson, + aeson-pretty, + base, + bytestring, + filepath, + optparse-applicative, + sh, + text, + utf8-string + + if arch(javascript) + buildable: False + +test-suite acms-test + import: commons + type: exitcode-stdio-1.0 + main-is: Main.hs + hs-source-dirs: test + build-depends: + base, + acms diff --git a/acms/app/Main.hs b/acms/app/Main.hs new file mode 100644 index 0000000..9759660 --- /dev/null +++ b/acms/app/Main.hs @@ -0,0 +1,101 @@ +module Main where + +import ACMS.API.Query qualified +import ACMS.API.REST.Collection qualified +import Collection +import Control.Applicative ((<**>)) +import Data.Aeson qualified as J +import Data.Aeson.Encode.Pretty qualified as J +import Data.ByteString.Lazy.Char8 qualified as LB +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.Text qualified as T +import Options.Applicative qualified as O + +newtype Args = Args + { cmd :: Cmd + } + +args :: O.Parser Args +args = Args <$> cmd_ + +data Cmd + = CollectionCmd CollectionCmd + | QueryCmd + +cmd_ :: O.Parser Cmd +cmd_ = + O.hsubparser . mconcat $ + [ O.command "collection" . O.info collectionCmd $ + O.progDesc "Manage content collections", + O.command "query" . O.info queryCmd $ + O.progDesc "Manage content through queries" + ] + +data CollectionCmd + = CollectionAdd Collection + | CollectionView CollectionItem + | CollectionEdit CollectionItem + | CollectionDelete CollectionItem + | -- + CollectionList Collection + | CollectionSchema Collection + +collectionCmd :: O.Parser Cmd +collectionCmd = do + fmap CollectionCmd . O.hsubparser . mconcat $ + [ O.command "add" . O.info (CollectionAdd <$> collectionArg) $ + O.progDesc "Add an entity", + O.command "view" . O.info (CollectionView <$> collectionItemArg) $ + O.progDesc "View an entity", + O.command "edit" . O.info (CollectionEdit <$> collectionItemArg) $ + O.progDesc "Edit an entity", + O.command "delete" . O.info (CollectionDelete <$> collectionItemArg) $ + O.progDesc "Delete an entity", + -- + O.command "list" . O.info (CollectionList <$> collectionArg) $ + O.progDesc "List entities", + O.command "schema" . O.info (CollectionSchema <$> collectionArg) $ + O.progDesc "Show the collection's schema" + ] + +collectionItemArg :: O.Parser CollectionItem +collectionItemArg = + O.argument O.auto (O.metavar "COLLECTION_PATH") + +collectionArg :: O.Parser Collection +collectionArg = + Collection . T.pack <$> O.strArgument (O.metavar "COLLECTION_NAME") + +queryCmd :: O.Parser Cmd +queryCmd = pure QueryCmd + +main :: IO () +main = + O.execParser (O.info (args <**> O.helper) O.idm) >>= \case + Args {cmd = CollectionCmd cmd} -> case cmd of + CollectionAdd collection -> + LB.putStr . J.encodePretty + =<< ACMS.API.REST.Collection.create collection + =<< J.throwDecode + =<< LB.getContents + CollectionView collectionItem -> + LB.putStr . J.encodePretty + =<< ACMS.API.REST.Collection.read collectionItem + CollectionDelete collectionItem -> + LB.putStr . J.encodePretty + =<< ACMS.API.REST.Collection.delete collectionItem + CollectionEdit collectionItem -> + LB.putStr . J.encodePretty + =<< ACMS.API.REST.Collection.update collectionItem + =<< J.throwDecode + =<< LB.getContents + CollectionList collection -> + mapM_ (LB.putStrLn . J.encodePretty) + =<< ACMS.API.REST.Collection.list collection + CollectionSchema collection -> + LB.putStr . J.encodePretty @J.Value + =<< ACMS.API.REST.Collection.schema collection + Args {cmd = QueryCmd} -> + LB.putStr . J.encodePretty @J.Value + =<< ACMS.API.Query.query . LB.toString + =<< LB.getContents diff --git a/acms/src/ACMS/ACMS.hs b/acms/src/ACMS/ACMS.hs new file mode 100644 index 0000000..12f8866 --- /dev/null +++ b/acms/src/ACMS/ACMS.hs @@ -0,0 +1,503 @@ +module ACMS.ACMS where + +import AutoTypes qualified as U +import AutoTypes.Unify qualified as U +import Control.Applicative ((<**>)) +import Control.Concurrent +import Control.Concurrent.STM +import Control.Exception (throwIO) +import Control.Monad +import Control.Monad.Catch +import Control.Monad.Trans (liftIO) +import Data.Aeson qualified as J +import Data.Aeson.Key qualified as JK +import Data.Aeson.KeyMap qualified as JM +import Data.Bifunctor +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.ByteString.UTF8 qualified as B +import Data.Function (on, (&)) +import Data.List +import Data.Map qualified as M +import Data.Map.Merge.Strict qualified as M +import Data.Maybe +import Data.Set qualified as S +import Data.String (IsString (fromString)) +import Data.Tagged (Tagged (..), untag) +import Data.Text qualified as T +import Data.UUID qualified as U +import Data.UUID.V4 qualified as U +import Data.Vector qualified as V +import Git qualified as G +import Git.Libgit2 qualified as GB +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 Safe +import Store qualified as Q +import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) +import System.Environment +import System.Exit +import System.FilePath +import System.INotify +import System.IO qualified as IO +import System.Random +import Text.Printf (printf) +import Version + +getUUID :: IO U.UUID +getUUID = maybe U.nextRandom (const randomIO) =<< lookupEnv "UUID_SEED" + +data Args = Args + { cmd :: Cmd + } + +args :: A.Parser Args +args = Args <$> cmd' + +data Cmd = Serve + { serverPort :: Int, + contentRepositoryPath :: FilePath + } + +cmd' :: A.Parser Cmd +cmd' = + A.hsubparser . mconcat $ + [ A.command "serve" . A.info serveCmd $ + A.progDesc "Run webserver" + ] + +serveCmd :: A.Parser Cmd +serveCmd = do + serverPort <- A.option A.auto (A.metavar "PORT" <> A.showDefault <> A.value 8081 <> A.long "port" <> A.short 'p' <> A.help "The server port") + contentRepositoryPath <- A.strArgument (A.metavar "PATH" <> A.help "Path to the content repository") + pure Serve {..} + +data Repo = Repo + { commits :: [Commit] + } + deriving (Show) + +data Commit = Commit + { id :: G.CommitOid GB.LgRepo, + collections :: [Collection], + schemaVersion :: Version, + refMap :: RefMap + } + deriving (Show) + +sameCommit :: Commit -> Commit -> Bool +sameCommit = (==) `on` (G.renderOid . untag . (.id)) + +data Collection = Collection + { path :: FilePath, + files :: [FilePath], + schema :: U.T + } + deriving (Show) + +data Schema = Schema {unSchema :: J.Value} + deriving (Show) + +instance J.ToJSON Schema where + toJSON = J.toJSON . (.unSchema) + +fromAutoTypes :: String -> U.T -> Schema +fromAutoTypes path (U.Object ps) = + Schema $ + J.object + [ ("$schema", J.toJSON @String "https://json-schema.org/draft/2020-12/schema"), + ("$id", J.toJSON @String (path <> ".schema.json")), + ("title", J.toJSON @String path), + ("type", J.toJSON @String "object"), + ("properties", J.toJSON ps), + ("required", J.toJSON (M.keys (M.filter isRequired ps))) + ] + where + isRequired (U.Option _) = False + isRequired _ = True +fromAutoTypes _ _ = error "Only JSON objects are supported." + +watch :: TMVar Repo -> FilePath -> G.RefName -> IO () +watch repoT root ref = do + i <- initINotify + qT <- newTQueueIO + _ <- + addWatch i [Create, MoveIn] ".git/refs/heads" $ \e -> do + when (e.filePath == B.fromString (takeBaseName (T.unpack ref))) do + atomically (writeTQueue qT e) + repo <- initRepo root ref + atomically do putTMVar repoT repo + forever do + _ <- atomically do + let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT + readTQueue qT >> loop + repo' <- atomically do takeTMVar repoT + catches + ( do + repo <- initRepo root ref + atomically do putTMVar repoT repo + ) + [ Handler + ( \(e :: ReferenceViolation) -> do + atomically do putTMVar repoT repo' + throwIO e + ), + Handler + ( \(e :: SomeException) -> do + printf "debug: %s\n" (displayException e) + atomically do putTMVar repoT repo' + ) + ] + pure () + +initRepo :: FilePath -> G.RefName -> IO Repo +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 + cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid + fmap (Repo . reverse) $ + foldM + ( \cs c -> do + let cid = G.commitOid c + 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 + colls <- forM cls $ \(path, files) -> do + J.Array (V.toList -> (value : values)) <- do + liftIO . Q.withStore root ref . Q.withCommit cid $ do + Q.query (fromString ("SELECT " <> path <> " FROM " <> path)) + let schema = + U.autoTypes' + (fileNameToId value) + (fileNameToId <$> values) + pure $ Collection path files schema + refMap <- liftIO . Q.withStore root ref . Q.withCommit cid $ do + buildRefMap + let schemaVersion = + case headMay cs of + Nothing -> Version 1 0 0 + Just c' -> + let Version major' minor' patch' = c'.schemaVersion + schemas' = + M.fromList + ( (\coll -> (coll.path, coll.schema)) + <$> c'.collections + ) + schemas = + M.fromList + ( (\coll -> (coll.path, coll.schema)) + <$> c.collections + ) + in case compareSchemas schemas' schemas of + Just Major -> Version (major' + 1) 0 0 + Just Minor -> Version major' (minor' + 1) 0 + Just Patch -> Version major' minor' (patch' + 1) + Nothing -> Version major' minor' patch' + c = Commit cid colls schemaVersion refMap + pure (c : cs) + ) + [] + cs + +compareSchemas :: + M.Map String U.T -> + M.Map String U.T -> + Maybe SchemaDifference +compareSchemas schemas' schemas = + maximumMay + . catMaybes + . M.elems + . M.map (uncurry compareSchemas') + $ M.merge + (M.mapMissing (\_ schema' -> (Just schema', Nothing))) + (M.mapMissing (\_ schema -> (Nothing, Just schema))) + (M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema))) + schemas' + schemas + where + compareSchemas' Nothing Nothing = Nothing + compareSchemas' Nothing (Just _) = Just Minor + compareSchemas' (Just _) Nothing = Just Major + compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema + +compareSchema :: U.T -> U.T -> Maybe SchemaDifference +compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts +compareSchema t' t + | t' == t = Nothing + | t' `elem` (U.unify1 t' t) = Just Patch + | t `elem` U.unify1 t' t = Just Minor + | otherwise = Just Major + +data SchemaDifference + = Major + | Minor + | Patch + deriving (Show, Eq, Ord) + +logStderr :: String -> IO () +logStderr = IO.hPutStrLn IO.stderr + +data RefMap = RefMap + { references :: M.Map FilePath (S.Set FilePath), + referencees :: M.Map FilePath (S.Set FilePath) + } + deriving (Show) + +data ReferenceViolation + = ReferenceViolation + { referencee :: FilePath, + referencees :: S.Set FilePath + } + deriving (Show) + +instance Exception ReferenceViolation + +buildRefMap :: Q.StoreM RefMap +buildRefMap = do + allIds <- + S.fromList + . map ((,) <$> takeDirectory <*> (dropExtension . takeBaseName)) + <$> Q.listFiles "" + refMap <- + foldl' + ( \refMap (referencee, reference) -> + RefMap + { references = M.insertWith S.union referencee (S.singleton reference) refMap.references, + referencees = M.insertWith S.union reference (S.singleton referencee) refMap.referencees + } + ) + (RefMap M.empty M.empty) + . concat + <$> mapM + ( \(c, i) -> do + v@(J.Object _) <- head <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE (T.pack i)))) + pure (map (c i,) (collectReferences v)) + ) + (S.toList allIds) + checkRefMap allIds refMap + pure refMap + where + collectReferences (J.Object kvs) = + case map (first JK.toString) (JM.toList kvs) of + [("$ref", J.String i)] -> [T.unpack i] + _ -> concat (JM.elems (JM.map collectReferences kvs)) + collectReferences (J.Array vs) = concatMap collectReferences vs + collectReferences _ = [] + + checkRefMap allIds (RefMap {referencees}) = do + mapM_ + ( \(reference, referencees) -> + when (not (reference `S.member` S.map (uncurry ()) allIds)) do + liftIO (throwIO (ReferenceViolation reference referencees)) + ) + (M.toList referencees) + +main :: IO () +main = do + uuidSeed <- lookupEnv "UUID_SEED" + maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed + + A.execParser (A.info (args <**> A.helper) A.idm) >>= \case + Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do + contentRepositoryPath' <- makeAbsolute contentRepositoryPath + contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' ".git") + + unless contentRepositoryPathExists $ do + logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository." + exitFailure + + setCurrentDirectory contentRepositoryPath' + + let root = "." + ref = "refs/heads/master" + repoT <- newEmptyTMVarIO + + stopM <- newEmptyMVar + flip forkFinally (putMVar stopM) do watch repoT root ref + mapM + ( \hostPref -> flip forkFinally (putMVar stopM) do + W.runSettings + ( W.defaultSettings + & W.setPort serverPort + & W.setHost hostPref + ) + . restApi root ref repoT + . queryApi root ref repoT + $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found")) + ) + ["!4", "::1"] -- XXX note !6 does not work.. + logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") + either throwIO pure =<< takeMVar stopM + +data InvalidSchemaVersion = InvalidSchemaVersion String + deriving (Show) + +instance Exception InvalidSchemaVersion + +queryApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware +queryApi root ref repoT app req resp = do + schemaVersion <- + case find ((== "schemaVersion") . fst) (W.queryString req) of + Nothing -> pure Nothing + Just (_, Nothing) -> throwIO (InvalidSchemaVersion "") + Just (_, Just (B.toString -> v)) -> + case versionFromString v of + Just v -> pure (Just v) + Nothing -> throwIO (InvalidSchemaVersion v) + repo <- atomically (readTMVar repoT) + let lastCompatibleCommit = lastCompatible schemaVersion repo.commits + lastCommit = last repo.commits + case W.pathInfo req of + ["api", "query"] -> + case W.requestMethod req of + "POST" -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ + error "not implemented" + q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId + =<< Q.withStore root ref do Q.query @J.Value q + _ -> do + error "not implemented" + _ -> app req resp + +restApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware +restApi root ref repoT app req resp = do + schemaVersion <- + case find ((== "schemaVersion") . fst) (W.queryString req) of + Nothing -> pure Nothing + Just (_, Nothing) -> throwIO (InvalidSchemaVersion "") + Just (_, Just (B.toString -> v)) -> + case versionFromString v of + Just v -> pure (Just v) + Nothing -> throwIO (InvalidSchemaVersion v) + repo <- atomically (readTMVar repoT) + let lastCompatibleCommit = lastCompatible schemaVersion repo.commits + rev = lastCompatibleCommit.id + lastCommit = last repo.commits + case W.pathInfo req of + ("api" : "rest" : rs) -> + case (W.requestMethod req, rs) of + ("GET", ["schemaVersion"]) -> do + resp . W.responseLBS W.status200 [] $ + J.encode lastCompatibleCommit.schemaVersion + ("GET", ["collection"]) -> do + resp . W.responseLBS W.status200 [] $ + J.encode (map (.path) lastCompatibleCommit.collections) + ("GET", ["collection", T.unpack -> c, "schema"]) -> do + case find ((== c) . (.path)) lastCompatibleCommit.collections of + Nothing -> error "not implemented" + Just collection -> + resp . W.responseLBS W.status200 [] $ + J.encode (fromAutoTypes c collection.schema) + ("POST", ["collection"]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" + Right collection <- J.eitherDecode <$> W.lazyRequestBody req + Q.withStore root ref do + Q.writeFile (collection ".gitkeep") "" + Q.commit + resp $ W.responseLBS W.status200 [] "{}" + ("GET", ["collection", c]) -> do + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId + =<< ( Q.withStore root ref $ Q.withCommit rev do + Q.query @J.Value (fromString (printf "SELECT %s FROM %s" c c)) + ) + ("GET", ["collection", c, "paginated", read @Int . T.unpack -> limit, read @Int . T.unpack -> offset]) -> do + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId + =<< ( Q.withStore root ref $ Q.withCommit rev do + Q.query @J.Value + ( fromString + ( printf + "SELECT %s FROM %s%s%s" + c + c + (printf " LIMIT %d" limit :: String) + (printf " OFFSET %d" offset :: String) + ) + ) + ) + ("GET", ["collection", c, i]) -> do + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head + =<< ( Q.withStore root ref $ Q.withCommit rev do + Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + ) + ("PUT", ["collection", c, i]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" + o <- J.throwDecode @J.Object =<< W.lazyRequestBody req + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head + =<< ( Q.withStore root ref do + _ <- Q.query @J.Value (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName =~ /^%s\\.json$/" c (LB.toString (J.encode o)) c (escapePCRE i))) + J.Array (V.toList -> [J.Object r]) <- Q.query @J.Value (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c)) + _ <- buildRefMap + Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + ) + ("POST", ["collection", c]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" + i <- U.toText <$> getUUID + o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head + =<< ( Q.withStore root ref do + _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String (i <> ".json")) o))) c)) + _ <- buildRefMap + Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + ) + ("DELETE", ["collection", c, i]) -> do + when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head + =<< ( Q.withStore root ref do + r <- Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) + Q.query @J.Value (fromString (printf "DELETE FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c (escapePCRE i))) + _ <- buildRefMap + pure r + ) + (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported." + _ -> app req resp + +lastCompatible :: Maybe Version -> [Commit] -> Commit +lastCompatible Nothing commits = last commits +lastCompatible (Just v) commits + | isCompatible v (last commits) = last commits + | otherwise = lastCompatible (Just v) (init commits) + +isCompatible :: Version -> Commit -> Bool +isCompatible v c = c.schemaVersion <= v + +dropNulls :: J.Object -> J.Object +dropNulls = + JM.mapMaybe + ( \v -> + case v of + J.Null -> Nothing + (J.Object v') -> Just (J.Object (dropNulls v')) + _ -> Just v + ) + +escapePCRE :: T.Text -> T.Text +escapePCRE = T.pack . escapePCRE' . T.unpack + +escapePCRE' :: String -> String +escapePCRE' [] = [] +escapePCRE' (c : cs) = + ((if c `elem` (".^$*+?()[{\\|" :: String) then ('\\' :) else id) [c]) + <> escapePCRE' cs + +fileNameToId :: J.Value -> J.Value +fileNameToId (J.Array xs) = J.Array (V.map fileNameToId xs) +fileNameToId (J.Object kvs) = + J.Object + ( JM.foldrWithKey + ( \k v -> + case (k, v) of + ("$fileName", J.String v) -> + JM.insert "$id" (J.String (T.pack (dropExtension (T.unpack v)))) + _ -> + JM.insert k (fileNameToId v) + ) + JM.empty + $ kvs + ) +fileNameToId v = v diff --git a/acms/src/ACMS/API/Fetch.hs b/acms/src/ACMS/API/Fetch.hs new file mode 100644 index 0000000..02e3e80 --- /dev/null +++ b/acms/src/ACMS/API/Fetch.hs @@ -0,0 +1,61 @@ +module ACMS.API.Fetch + ( APIMonad(fetch), +#ifndef ghcjs_HOST_OS + Network.HTTP.Simple.Request, + Network.HTTP.Simple.setRequestMethod, + Network.HTTP.Simple.setRequestBodyLBS, +#else + JavaScript.Web.XMLHttpRequest.Request, + setRequestMethod, + setRequestBodyLBS, +#endif + ) +where + +#ifndef ghcjs_HOST_OS +import Network.HTTP.Simple +#else +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.Maybe +import Data.String +import JavaScript.Web.XMLHttpRequest +import Miso.String qualified as J +import Data.ByteString qualified as B +#endif +import Control.Monad.Catch (MonadThrow) +import Data.ByteString.Lazy.Char8 qualified as LB +import Miso (JSM) + +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/acms/src/ACMS/API/Query.hs b/acms/src/ACMS/API/Query.hs new file mode 100644 index 0000000..e668a80 --- /dev/null +++ b/acms/src/ACMS/API/Query.hs @@ -0,0 +1,15 @@ +module ACMS.API.Query where + +import ACMS.API.Fetch +import Data.Aeson qualified as A +import Data.ByteString.Lazy.UTF8 qualified as LB +import Data.Function ((&)) +import Data.String (IsString (fromString)) + +query :: (APIMonad m) => String -> m A.Value +query q = + fromString ("http://localhost:8081/api/query") + & setRequestMethod "POST" + & setRequestBodyLBS (LB.fromString q) + & fetch + >>= A.throwDecode diff --git a/acms/src/ACMS/API/REST.hs b/acms/src/ACMS/API/REST.hs new file mode 100644 index 0000000..e8c2c0c --- /dev/null +++ b/acms/src/ACMS/API/REST.hs @@ -0,0 +1,31 @@ +module ACMS.API.REST where + +import ACMS.API.Fetch +import Data.Aeson qualified as A +import Data.Function ((&)) +import Data.String (IsString (fromString)) +import Miso.String (MisoString) + +restRequest :: String -> Request +restRequest endpoint = + fromString ("http://localhost:8081/api/rest" <> endpoint) + +schemaVersion :: (APIMonad m, A.FromJSON a) => m a +schemaVersion = + restRequest "/schemaVersion" + & fetch + >>= A.throwDecode + +listCollections :: (APIMonad m) => m [MisoString] +listCollections = + restRequest "/collection" + & fetch + >>= A.throwDecode + +createCollection :: (APIMonad m) => MisoString -> m () +createCollection collection = + restRequest "/collections" + & setRequestMethod "POST" + & setRequestBodyLBS (A.encode (A.toJSON collection)) + & fetch + >>= A.throwDecode diff --git a/acms/src/ACMS/API/REST/Collection.hs b/acms/src/ACMS/API/REST/Collection.hs new file mode 100644 index 0000000..0ed96fd --- /dev/null +++ b/acms/src/ACMS/API/REST/Collection.hs @@ -0,0 +1,49 @@ +module ACMS.API.REST.Collection where + +import ACMS.API.Fetch +import ACMS.API.REST (restRequest) +import Collection +import Data.Aeson qualified as A +import Data.Function ((&)) +import Text.Printf (printf) + +list :: (APIMonad m) => Collection -> m [A.Object] +list c = + restRequest (printf "/collection/%s" c.name) + & fetch + >>= A.throwDecode + +read :: (APIMonad m) => CollectionItem -> m (Maybe A.Object) +read ci = + restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName) + & fetch + >>= A.throwDecode + +update :: (APIMonad m) => CollectionItem -> A.Object -> m A.Object +update ci o = + restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName) + & setRequestMethod "PUT" + & setRequestBodyLBS (A.encode o) + & fetch + >>= A.throwDecode + +create :: (APIMonad m) => Collection -> A.Object -> m A.Object +create c o = do + restRequest (printf "/collection/%s" c.name) + & setRequestMethod "POST" + & setRequestBodyLBS (A.encode o) + & fetch + >>= A.throwDecode + +delete :: (APIMonad m) => CollectionItem -> m A.Object +delete ci = + restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName) + & setRequestMethod "DELETE" + & fetch + >>= A.throwDecode + +schema :: (APIMonad m) => (A.FromJSON a) => Collection -> m a +schema c = + restRequest (printf "/collection/%s/schema" c.name) + & fetch + >>= A.throwDecode diff --git a/acms/src/ACMS/API/REST/Collection/Paginated.hs b/acms/src/ACMS/API/REST/Collection/Paginated.hs new file mode 100644 index 0000000..487fe69 --- /dev/null +++ b/acms/src/ACMS/API/REST/Collection/Paginated.hs @@ -0,0 +1,30 @@ +module ACMS.API.REST.Collection.Paginated where + +import ACMS.API.Fetch +import ACMS.API.REST (restRequest) +import Collection +import Data.Aeson qualified as A +import Data.Function ((&)) +import GHC.Generics (Generic) +import Text.Printf (printf) + +data Pagination = Pagination + { limit :: Int, + offset :: Int + } + +data Paginated a = Paginated + { count :: Int, + data_ :: [a] + } + deriving (Eq, Show, Generic) + +instance (A.FromJSON a) => A.FromJSON (Paginated a) + +instance (A.ToJSON a) => A.ToJSON (Paginated a) + +list :: (APIMonad m) => Pagination -> Collection -> m (Paginated A.Object) +list p c = + restRequest (printf "/collection/%s/paginated/%d/%d" c.name p.limit p.offset) + & fetch + >>= A.throwDecode diff --git a/acms/src/Collection.hs b/acms/src/Collection.hs new file mode 100644 index 0000000..6ad4e7a --- /dev/null +++ b/acms/src/Collection.hs @@ -0,0 +1,26 @@ +module Collection where + +import Miso.String (MisoString, toMisoString) +import Text.ParserCombinators.ReadP qualified as R +import Text.ParserCombinators.ReadPrec qualified as R +import Text.Read (Read (..)) + +newtype Collection = Collection {name :: MisoString} + deriving (Read, Eq, Show) + +data CollectionItem = CollectionItem + { collection :: Collection, + itemFileName :: FilePath + } + deriving (Eq) + +instance Read CollectionItem where + readPrec = R.lift $ do + (Collection . toMisoString -> collection) <- R.munch (/= '/') + _ <- R.string "/" + itemFileName <- R.munch (const True) + pure CollectionItem {..} + +instance Show CollectionItem where + show (CollectionItem {collection = Collection cn, itemFileName}) = + show (cn <> "/" <> toMisoString itemFileName) diff --git a/acms/src/Version.hs b/acms/src/Version.hs new file mode 100644 index 0000000..6970968 --- /dev/null +++ b/acms/src/Version.hs @@ -0,0 +1,47 @@ +module Version + ( Version (..), + versionToString, + versionFromText, + versionFromString, + ) +where + +import Data.Aeson qualified as A +import Data.Aeson.Types qualified as A +import Data.Function (on) +import Data.List +import Data.List.Split +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Data.Text qualified as T + +data Version = Version Int Int Int + deriving (Show, Eq) + +instance Ord Version where + compare = compare `on` toTriple + +toTriple :: Version -> (Int, Int, Int) +toTriple (Version major minor patch) = (major, minor, patch) + +instance A.ToJSON Version where + toJSON = A.toJSON . versionToString + +instance A.FromJSON Version where + parseJSON (A.String (versionFromText -> Just version)) = pure version + parseJSON v = A.typeMismatch "version" v + +versionToString :: Version -> String +versionToString (Version major minor patch) = + intercalate "." (map show [major, minor, patch]) + +versionFromString :: String -> Maybe Version +versionFromString (map read . splitOn "." -> [major, minor, patch]) = + Just (Version major minor patch) +versionFromString _ = Nothing + +versionFromText :: T.Text -> Maybe Version +versionFromText = versionFromString . T.unpack + +instance IsString Version where + fromString = fromMaybe (error "") . versionFromString diff --git a/acms/test/Main.hs b/acms/test/Main.hs new file mode 100644 index 0000000..3e2059e --- /dev/null +++ b/acms/test/Main.hs @@ -0,0 +1,4 @@ +module Main (main) where + +main :: IO () +main = putStrLn "Test suite not yet implemented." diff --git a/backend/LICENSE b/backend/LICENSE deleted file mode 100644 index c90516a..0000000 --- a/backend/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2024, Alexander Foremny - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Alexander Foremny nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/backend/app/Main.hs b/backend/app/Main.hs deleted file mode 100644 index c9db2ea..0000000 --- a/backend/app/Main.hs +++ /dev/null @@ -1,510 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE DuplicateRecordFields #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Main where - -import AutoTypes qualified as U -import AutoTypes.Unify qualified as U -import Control.Applicative ((<**>)) -import Control.Concurrent -import Control.Concurrent.STM -import Control.Exception (throwIO) -import Control.Monad -import Control.Monad.Catch -import Control.Monad.Trans (liftIO) -import Data.Aeson qualified as J -import Data.Aeson.Key qualified as JK -import Data.Aeson.KeyMap qualified as JM -import Data.Bifunctor -import Data.ByteString.Lazy.UTF8 qualified as LB -import Data.ByteString.UTF8 qualified as B -import Data.Function (on, (&)) -import Data.List -import Data.Map qualified as M -import Data.Map.Merge.Strict qualified as M -import Data.Maybe -import Data.Set qualified as S -import Data.String (IsString (fromString)) -import Data.Tagged (Tagged (..), untag) -import Data.Text qualified as T -import Data.UUID qualified as U -import Data.UUID.V4 qualified as U -import Data.Vector qualified as V -import Git qualified as G -import Git.Libgit2 qualified as GB -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 Safe -import Store qualified as Q -import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) -import System.Environment -import System.Exit -import System.FilePath -import System.INotify -import System.IO qualified as IO -import System.Random -import Text.Printf (printf) -import Version - -getUUID :: IO U.UUID -getUUID = maybe U.nextRandom (const randomIO) =<< lookupEnv "UUID_SEED" - -data Args = Args - { cmd :: Cmd - } - -args :: A.Parser Args -args = Args <$> cmd' - -data Cmd = Serve - { serverPort :: Int, - contentRepositoryPath :: FilePath - } - -cmd' :: A.Parser Cmd -cmd' = - A.hsubparser . mconcat $ - [ A.command "serve" . A.info serveCmd $ - A.progDesc "Run webserver" - ] - -serveCmd :: A.Parser Cmd -serveCmd = do - serverPort <- A.option A.auto (A.metavar "PORT" <> A.showDefault <> A.value 8081 <> A.long "port" <> A.short 'p' <> A.help "The server port") - contentRepositoryPath <- A.strArgument (A.metavar "PATH" <> A.help "Path to the content repository") - pure Serve {..} - -data Repo = Repo - { commits :: [Commit] - } - deriving (Show) - -data Commit = Commit - { id :: G.CommitOid GB.LgRepo, - collections :: [Collection], - schemaVersion :: Version, - refMap :: RefMap - } - deriving (Show) - -sameCommit :: Commit -> Commit -> Bool -sameCommit = (==) `on` (G.renderOid . untag . (.id)) - -data Collection = Collection - { path :: FilePath, - files :: [FilePath], - schema :: U.T - } - deriving (Show) - -data Schema = Schema {unSchema :: J.Value} - deriving (Show) - -instance J.ToJSON Schema where - toJSON = J.toJSON . (.unSchema) - -fromAutoTypes :: String -> U.T -> Schema -fromAutoTypes path (U.Object ps) = - Schema $ - J.object - [ ("$schema", J.toJSON @String "https://json-schema.org/draft/2020-12/schema"), - ("$id", J.toJSON @String (path <> ".schema.json")), - ("title", J.toJSON @String path), - ("type", J.toJSON @String "object"), - ("properties", J.toJSON ps), - ("required", J.toJSON (M.keys (M.filter isRequired ps))) - ] - where - isRequired (U.Option _) = False - isRequired _ = True -fromAutoTypes _ _ = error "Only JSON objects are supported." - -watch :: TMVar Repo -> FilePath -> G.RefName -> IO () -watch repoT root ref = do - i <- initINotify - qT <- newTQueueIO - _ <- - addWatch i [Create, MoveIn] ".git/refs/heads" $ \e -> do - when (e.filePath == B.fromString (takeBaseName (T.unpack ref))) do - atomically (writeTQueue qT e) - repo <- initRepo root ref - atomically do putTMVar repoT repo - forever do - _ <- atomically do - let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT - readTQueue qT >> loop - repo' <- atomically do takeTMVar repoT - catches - ( do - repo <- initRepo root ref - atomically do putTMVar repoT repo - ) - [ Handler - ( \(e :: ReferenceViolation) -> do - atomically do putTMVar repoT repo' - throwIO e - ), - Handler - ( \(e :: SomeException) -> do - printf "debug: %s\n" (displayException e) - atomically do putTMVar repoT repo' - ) - ] - pure () - -initRepo :: FilePath -> G.RefName -> IO Repo -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 - cs <- mapM G.lookupCommit =<< G.listCommits Nothing cid - fmap (Repo . reverse) $ - foldM - ( \cs c -> do - let cid = G.commitOid c - 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 - colls <- forM cls $ \(path, files) -> do - J.Array (V.toList -> (value : values)) <- do - liftIO . Q.withStore root ref . Q.withCommit cid $ do - Q.query (fromString ("SELECT " <> path <> " FROM " <> path)) - let schema = - U.autoTypes' - (fileNameToId value) - (fileNameToId <$> values) - pure $ Collection path files schema - refMap <- liftIO . Q.withStore root ref . Q.withCommit cid $ do - buildRefMap - let schemaVersion = - case headMay cs of - Nothing -> Version 1 0 0 - Just c' -> - let Version major' minor' patch' = c'.schemaVersion - schemas' = - M.fromList - ( (\coll -> (coll.path, coll.schema)) - <$> c'.collections - ) - schemas = - M.fromList - ( (\coll -> (coll.path, coll.schema)) - <$> c.collections - ) - in case compareSchemas schemas' schemas of - Just Major -> Version (major' + 1) 0 0 - Just Minor -> Version major' (minor' + 1) 0 - Just Patch -> Version major' minor' (patch' + 1) - Nothing -> Version major' minor' patch' - c = Commit cid colls schemaVersion refMap - pure (c : cs) - ) - [] - cs - -compareSchemas :: - M.Map String U.T -> - M.Map String U.T -> - Maybe SchemaDifference -compareSchemas schemas' schemas = - maximumMay - . catMaybes - . M.elems - . M.map (uncurry compareSchemas') - $ M.merge - (M.mapMissing (\_ schema' -> (Just schema', Nothing))) - (M.mapMissing (\_ schema -> (Nothing, Just schema))) - (M.zipWithMatched (\_ schema' schema -> (Just schema', Just schema))) - schemas' - schemas - where - compareSchemas' Nothing Nothing = Nothing - compareSchemas' Nothing (Just _) = Just Minor - compareSchemas' (Just _) Nothing = Just Major - compareSchemas' (Just schema') (Just schema) = compareSchema schema' schema - -compareSchema :: U.T -> U.T -> Maybe SchemaDifference -compareSchema (U.Object kts') (U.Object kts) = compareSchemas kts' kts -compareSchema t' t - | t' == t = Nothing - | t' `elem` (U.unify1 t' t) = Just Patch - | t `elem` U.unify1 t' t = Just Minor - | otherwise = Just Major - -data SchemaDifference - = Major - | Minor - | Patch - deriving (Show, Eq, Ord) - -logStderr :: String -> IO () -logStderr = IO.hPutStrLn IO.stderr - -data RefMap = RefMap - { references :: M.Map FilePath (S.Set FilePath), - referencees :: M.Map FilePath (S.Set FilePath) - } - deriving (Show) - -data ReferenceViolation - = ReferenceViolation - { referencee :: FilePath, - referencees :: S.Set FilePath - } - deriving (Show) - -instance Exception ReferenceViolation - -buildRefMap :: Q.StoreM RefMap -buildRefMap = do - allIds <- - S.fromList - . map ((,) <$> takeDirectory <*> (dropExtension . takeBaseName)) - <$> Q.listFiles "" - refMap <- - foldl' - ( \refMap (referencee, reference) -> - RefMap - { references = M.insertWith S.union referencee (S.singleton reference) refMap.references, - referencees = M.insertWith S.union reference (S.singleton referencee) refMap.referencees - } - ) - (RefMap M.empty M.empty) - . concat - <$> mapM - ( \(c, i) -> do - v@(J.Object _) <- head <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE (T.pack i)))) - pure (map (c i,) (collectReferences v)) - ) - (S.toList allIds) - checkRefMap allIds refMap - pure refMap - where - collectReferences (J.Object kvs) = - case map (first JK.toString) (JM.toList kvs) of - [("$ref", J.String i)] -> [T.unpack i] - _ -> concat (JM.elems (JM.map collectReferences kvs)) - collectReferences (J.Array vs) = concatMap collectReferences vs - collectReferences _ = [] - - checkRefMap allIds (RefMap {referencees}) = do - mapM_ - ( \(reference, referencees) -> - when (not (reference `S.member` S.map (uncurry ()) allIds)) do - liftIO (throwIO (ReferenceViolation reference referencees)) - ) - (M.toList referencees) - -main :: IO () -main = do - uuidSeed <- lookupEnv "UUID_SEED" - maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed - - A.execParser (A.info (args <**> A.helper) A.idm) >>= \case - Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do - contentRepositoryPath' <- makeAbsolute contentRepositoryPath - contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' ".git") - - unless contentRepositoryPathExists $ do - logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository." - exitFailure - - setCurrentDirectory contentRepositoryPath' - - let root = "." - ref = "refs/heads/master" - repoT <- newEmptyTMVarIO - - stopM <- newEmptyMVar - flip forkFinally (putMVar stopM) do watch repoT root ref - mapM - ( \hostPref -> flip forkFinally (putMVar stopM) do - W.runSettings - ( W.defaultSettings - & W.setPort serverPort - & W.setHost hostPref - ) - . restApi root ref repoT - . queryApi root ref repoT - $ (\_ resp -> resp (W.responseLBS W.status404 [] "Not found")) - ) - ["!4", "::1"] -- XXX note !6 does not work.. - logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") - either throwIO pure =<< takeMVar stopM - -data InvalidSchemaVersion = InvalidSchemaVersion String - deriving (Show) - -instance Exception InvalidSchemaVersion - -queryApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware -queryApi root ref repoT app req resp = do - schemaVersion <- - case find ((== "schemaVersion") . fst) (W.queryString req) of - Nothing -> pure Nothing - Just (_, Nothing) -> throwIO (InvalidSchemaVersion "") - Just (_, Just (B.toString -> v)) -> - case versionFromString v of - Just v -> pure (Just v) - Nothing -> throwIO (InvalidSchemaVersion v) - repo <- atomically (readTMVar repoT) - let lastCompatibleCommit = lastCompatible schemaVersion repo.commits - lastCommit = last repo.commits - case W.pathInfo req of - ["api", "query"] -> - case W.requestMethod req of - "POST" -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ - error "not implemented" - q <- fromString @Q.Query . LB.toString <$> W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId - =<< Q.withStore root ref do Q.query @J.Value q - _ -> do - error "not implemented" - _ -> app req resp - -restApi :: FilePath -> T.Text -> TMVar Repo -> W.Middleware -restApi root ref repoT app req resp = do - schemaVersion <- - case find ((== "schemaVersion") . fst) (W.queryString req) of - Nothing -> pure Nothing - Just (_, Nothing) -> throwIO (InvalidSchemaVersion "") - Just (_, Just (B.toString -> v)) -> - case versionFromString v of - Just v -> pure (Just v) - Nothing -> throwIO (InvalidSchemaVersion v) - repo <- atomically (readTMVar repoT) - let lastCompatibleCommit = lastCompatible schemaVersion repo.commits - rev = lastCompatibleCommit.id - lastCommit = last repo.commits - case W.pathInfo req of - ("api" : "rest" : rs) -> - case (W.requestMethod req, rs) of - ("GET", ["schemaVersion"]) -> do - resp . W.responseLBS W.status200 [] $ - J.encode lastCompatibleCommit.schemaVersion - ("GET", ["collection"]) -> do - resp . W.responseLBS W.status200 [] $ - J.encode (map (.path) lastCompatibleCommit.collections) - ("GET", ["collection", T.unpack -> c, "schema"]) -> do - case find ((== c) . (.path)) lastCompatibleCommit.collections of - Nothing -> error "not implemented" - Just collection -> - resp . W.responseLBS W.status200 [] $ - J.encode (fromAutoTypes c collection.schema) - ("POST", ["collection"]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - Right collection <- J.eitherDecode <$> W.lazyRequestBody req - Q.withStore root ref do - Q.writeFile (collection ".gitkeep") "" - Q.commit - resp $ W.responseLBS W.status200 [] "{}" - ("GET", ["collection", c]) -> do - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId - =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query @J.Value (fromString (printf "SELECT %s FROM %s" c c)) - ) - ("GET", ["collection", c, "paginated", read @Int . T.unpack -> limit, read @Int . T.unpack -> offset]) -> do - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId - =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query @J.Value - ( fromString - ( printf - "SELECT %s FROM %s%s%s" - c - c - (printf " LIMIT %d" limit :: String) - (printf " OFFSET %d" offset :: String) - ) - ) - ) - ("GET", ["collection", c, i]) -> do - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - ) - ("PUT", ["collection", c, i]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - o <- J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref do - _ <- Q.query @J.Value (fromString (printf "UPDATE %s SET %s WHERE %s.$fileName =~ /^%s\\.json$/" c (LB.toString (J.encode o)) c (escapePCRE i))) - J.Array (V.toList -> [J.Object r]) <- Q.query @J.Value (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c)) - _ <- buildRefMap - Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - ) - ("POST", ["collection", c]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - i <- U.toText <$> getUUID - o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref do - _ <- Q.query @J.Value (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (JM.insert "$fileName" (J.String (i <> ".json")) o))) c)) - _ <- buildRefMap - Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - ) - ("DELETE", ["collection", c, i]) -> do - when (not (sameCommit lastCompatibleCommit lastCommit)) $ error "not implemented" - resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head - =<< ( Q.withStore root ref do - r <- Q.query @[J.Value] (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c c (escapePCRE i))) - Q.query @J.Value (fromString (printf "DELETE FROM %s WHERE %s.$fileName =~ /^%s\\.json$/" c c (escapePCRE i))) - _ <- buildRefMap - pure r - ) - (method, path) -> fail $ "Method " ++ show method ++ " on route " ++ show path ++ " not supported." - _ -> app req resp - -lastCompatible :: Maybe Version -> [Commit] -> Commit -lastCompatible Nothing commits = last commits -lastCompatible (Just v) commits - | isCompatible v (last commits) = last commits - | otherwise = lastCompatible (Just v) (init commits) - -isCompatible :: Version -> Commit -> Bool -isCompatible v c = c.schemaVersion <= v - -dropNulls :: J.Object -> J.Object -dropNulls = - JM.mapMaybe - ( \v -> - case v of - J.Null -> Nothing - (J.Object v') -> Just (J.Object (dropNulls v')) - _ -> Just v - ) - -escapePCRE :: T.Text -> T.Text -escapePCRE = T.pack . escapePCRE' . T.unpack - -escapePCRE' :: String -> String -escapePCRE' [] = [] -escapePCRE' (c : cs) = - ((if c `elem` (".^$*+?()[{\\|" :: String) then ('\\' :) else id) [c]) - <> escapePCRE' cs - -fileNameToId :: J.Value -> J.Value -fileNameToId (J.Array xs) = J.Array (V.map fileNameToId xs) -fileNameToId (J.Object kvs) = - J.Object - ( JM.foldrWithKey - ( \k v -> - case (k, v) of - ("$fileName", J.String v) -> - JM.insert "$id" (J.String (T.pack (dropExtension (T.unpack v)))) - _ -> - JM.insert k (fileNameToId v) - ) - JM.empty - $ kvs - ) -fileNameToId v = v diff --git a/backend/backend.cabal b/backend/backend.cabal deleted file mode 100644 index 6b13682..0000000 --- a/backend/backend.cabal +++ /dev/null @@ -1,86 +0,0 @@ -cabal-version: 3.4 -name: backend -version: 0.1.0.0 -license: BSD-3-Clause -license-file: LICENSE -maintainer: aforemny@posteo.de -author: Alexander Foremny -build-type: Simple - -library - exposed-modules: - ACMS.API.Query - ACMS.API.REST - ACMS.API.REST.Collection - ACMS.API.REST.Collection.Paginated - - hs-source-dirs: lib - other-modules: ACMS.API.Fetch - default-language: GHC2021 - default-extensions: - CPP BlockArguments LambdaCase OverloadedStrings ViewPatterns - OverloadedRecordDot NoFieldSelectors MultiWayIf - - ghc-options: -Wall -threaded - build-depends: - aeson, - base, - bytestring, - common, - exceptions, - miso, - text, - utf8-string - - if arch(javascript) - build-depends: ghcjs-base - - else - build-depends: http-conduit - -executable backend - main-is: Main.hs - hs-source-dirs: app - default-language: GHC2021 - default-extensions: - BlockArguments LambdaCase OverloadedStrings ViewPatterns - OverloadedRecordDot NoFieldSelectors MultiWayIf - - ghc-options: -Wall -threaded - build-depends: - aeson, - astore, - attoparsec, - autotypes, - base, - bytestring, - common, - containers, - directory, - exceptions, - filepath, - gitlib, - gitlib-libgit2, - hinotify, - hlibgit2, - http-types, - mtl, - non-empty, - optparse-applicative, - random, - regex, - regex-base, - regex-pcre, - safe, - split, - stm, - tagged, - text, - utf8-string, - uuid, - vector, - wai, - warp - - if arch(javascript) - buildable: False diff --git a/backend/lib/ACMS/API/Fetch.hs b/backend/lib/ACMS/API/Fetch.hs deleted file mode 100644 index 84330b1..0000000 --- a/backend/lib/ACMS/API/Fetch.hs +++ /dev/null @@ -1,63 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ACMS.API.Fetch - ( APIMonad(fetch), -#ifndef ghcjs_HOST_OS - Network.HTTP.Simple.Request, - Network.HTTP.Simple.setRequestMethod, - Network.HTTP.Simple.setRequestBodyLBS, -#else - JavaScript.Web.XMLHttpRequest.Request, - setRequestMethod, - setRequestBodyLBS, -#endif - ) -where - -#ifndef ghcjs_HOST_OS -import Network.HTTP.Simple -#else -import Data.ByteString.Lazy.UTF8 qualified as LB -import Data.Maybe -import Data.String -import JavaScript.Web.XMLHttpRequest -import Miso.String qualified as J -import Data.ByteString qualified as B -#endif -import Control.Monad.Catch (MonadThrow) -import Data.ByteString.Lazy.Char8 qualified as LB -import Miso (JSM) - -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/Query.hs b/backend/lib/ACMS/API/Query.hs deleted file mode 100644 index ab2cabc..0000000 --- a/backend/lib/ACMS/API/Query.hs +++ /dev/null @@ -1,17 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ACMS.API.Query where - -import ACMS.API.Fetch -import Data.Aeson qualified as A -import Data.ByteString.Lazy.UTF8 qualified as LB -import Data.Function ((&)) -import Data.String (IsString (fromString)) - -query :: (APIMonad m) => String -> m A.Value -query q = - fromString ("http://localhost:8081/api/query") - & setRequestMethod "POST" - & setRequestBodyLBS (LB.fromString q) - & fetch - >>= A.throwDecode diff --git a/backend/lib/ACMS/API/REST.hs b/backend/lib/ACMS/API/REST.hs deleted file mode 100644 index 6cd2982..0000000 --- a/backend/lib/ACMS/API/REST.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ACMS.API.REST where - -import ACMS.API.Fetch -import Data.Aeson qualified as A -import Data.Function ((&)) -import Data.String (IsString (fromString)) -import Miso.String (MisoString) - -restRequest :: String -> Request -restRequest endpoint = - fromString ("http://localhost:8081/api/rest" <> endpoint) - -schemaVersion :: (APIMonad m, A.FromJSON a) => m a -schemaVersion = - restRequest "/schemaVersion" - & fetch - >>= A.throwDecode - -listCollections :: (APIMonad m) => m [MisoString] -listCollections = - restRequest "/collection" - & fetch - >>= A.throwDecode - -createCollection :: (APIMonad m) => MisoString -> m () -createCollection collection = - restRequest "/collections" - & setRequestMethod "POST" - & setRequestBodyLBS (A.encode (A.toJSON collection)) - & fetch - >>= A.throwDecode diff --git a/backend/lib/ACMS/API/REST/Collection.hs b/backend/lib/ACMS/API/REST/Collection.hs deleted file mode 100644 index 7de1909..0000000 --- a/backend/lib/ACMS/API/REST/Collection.hs +++ /dev/null @@ -1,51 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ACMS.API.REST.Collection where - -import ACMS.API.Fetch -import ACMS.API.REST (restRequest) -import Collection -import Data.Aeson qualified as A -import Data.Function ((&)) -import Text.Printf (printf) - -list :: (APIMonad m) => Collection -> m [A.Object] -list c = - restRequest (printf "/collection/%s" c.name) - & fetch - >>= A.throwDecode - -read :: (APIMonad m) => CollectionItem -> m (Maybe A.Object) -read ci = - restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName) - & fetch - >>= A.throwDecode - -update :: (APIMonad m) => CollectionItem -> A.Object -> m A.Object -update ci o = - restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName) - & setRequestMethod "PUT" - & setRequestBodyLBS (A.encode o) - & fetch - >>= A.throwDecode - -create :: (APIMonad m) => Collection -> A.Object -> m A.Object -create c o = do - restRequest (printf "/collection/%s" c.name) - & setRequestMethod "POST" - & setRequestBodyLBS (A.encode o) - & fetch - >>= A.throwDecode - -delete :: (APIMonad m) => CollectionItem -> m A.Object -delete ci = - restRequest (printf "/collection/%s/%s" ci.collection.name ci.itemFileName) - & setRequestMethod "DELETE" - & fetch - >>= A.throwDecode - -schema :: (APIMonad m) => (A.FromJSON a) => Collection -> m a -schema c = - restRequest (printf "/collection/%s/schema" c.name) - & fetch - >>= A.throwDecode diff --git a/backend/lib/ACMS/API/REST/Collection/Paginated.hs b/backend/lib/ACMS/API/REST/Collection/Paginated.hs deleted file mode 100644 index 159754a..0000000 --- a/backend/lib/ACMS/API/REST/Collection/Paginated.hs +++ /dev/null @@ -1,33 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} - -module ACMS.API.REST.Collection.Paginated where - -import ACMS.API.Fetch -import ACMS.API.REST (restRequest) -import Collection -import Data.Aeson qualified as A -import Data.Function ((&)) -import GHC.Generics (Generic) -import Text.Printf (printf) - -data Pagination = Pagination - { limit :: Int, - offset :: Int - } - -data Paginated a = Paginated - { count :: Int, - data_ :: [a] - } - deriving (Eq, Show, Generic) - -instance (A.FromJSON a) => A.FromJSON (Paginated a) - -instance (A.ToJSON a) => A.ToJSON (Paginated a) - -list :: (APIMonad m) => Pagination -> Collection -> m (Paginated A.Object) -list p c = - restRequest (printf "/collection/%s/paginated/%d/%d" c.name p.limit p.offset) - & fetch - >>= A.throwDecode diff --git a/cli/CHANGELOG.md b/cli/CHANGELOG.md deleted file mode 100644 index b733b96..0000000 --- a/cli/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for cli - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/cli/LICENSE b/cli/LICENSE deleted file mode 100644 index 9128a61..0000000 --- a/cli/LICENSE +++ /dev/null @@ -1,26 +0,0 @@ -Copyright (c) 2024, Alexander Foremny -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are -met: - -1. Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - -2. Redistributions in binary form must reproduce the above copyright - notice, this list of conditions and the following disclaimer in the - documentation and/or other materials provided with the - distribution. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/cli/app/Main.hs b/cli/app/Main.hs deleted file mode 100644 index 12ba7c5..0000000 --- a/cli/app/Main.hs +++ /dev/null @@ -1,109 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoFieldSelectors #-} - -module Main where - -import ACMS.API.Query qualified -import ACMS.API.REST.Collection qualified -import Collection -import Control.Applicative ((<**>)) -import Data.Aeson qualified as J -import Data.Aeson.Encode.Pretty qualified as J -import Data.ByteString.Lazy.Char8 qualified as LB -import Data.ByteString.Lazy.UTF8 qualified as LB -import Data.Text qualified as T -import Options.Applicative qualified as O - -newtype Args = Args - { cmd :: Cmd - } - -args :: O.Parser Args -args = Args <$> cmd_ - -data Cmd - = CollectionCmd CollectionCmd - | QueryCmd - -cmd_ :: O.Parser Cmd -cmd_ = - O.hsubparser . mconcat $ - [ O.command "collection" . O.info collectionCmd $ - O.progDesc "Manage content collections", - O.command "query" . O.info queryCmd $ - O.progDesc "Manage content through queries" - ] - -data CollectionCmd - = CollectionAdd Collection - | CollectionView CollectionItem - | CollectionEdit CollectionItem - | CollectionDelete CollectionItem - | -- - CollectionList Collection - | CollectionSchema Collection - -collectionCmd :: O.Parser Cmd -collectionCmd = do - fmap CollectionCmd . O.hsubparser . mconcat $ - [ O.command "add" . O.info (CollectionAdd <$> collectionArg) $ - O.progDesc "Add an entity", - O.command "view" . O.info (CollectionView <$> collectionItemArg) $ - O.progDesc "View an entity", - O.command "edit" . O.info (CollectionEdit <$> collectionItemArg) $ - O.progDesc "Edit an entity", - O.command "delete" . O.info (CollectionDelete <$> collectionItemArg) $ - O.progDesc "Delete an entity", - -- - O.command "list" . O.info (CollectionList <$> collectionArg) $ - O.progDesc "List entities", - O.command "schema" . O.info (CollectionSchema <$> collectionArg) $ - O.progDesc "Show the collection's schema" - ] - -collectionItemArg :: O.Parser CollectionItem -collectionItemArg = - O.argument O.auto (O.metavar "COLLECTION_PATH") - -collectionArg :: O.Parser Collection -collectionArg = - Collection . T.pack <$> O.strArgument (O.metavar "COLLECTION_NAME") - -queryCmd :: O.Parser Cmd -queryCmd = pure QueryCmd - -main :: IO () -main = - O.execParser (O.info (args <**> O.helper) O.idm) >>= \case - Args {cmd = CollectionCmd cmd} -> case cmd of - CollectionAdd collection -> - LB.putStr . J.encodePretty - =<< ACMS.API.REST.Collection.create collection - =<< J.throwDecode - =<< LB.getContents - CollectionView collectionItem -> - LB.putStr . J.encodePretty - =<< ACMS.API.REST.Collection.read collectionItem - CollectionDelete collectionItem -> - LB.putStr . J.encodePretty - =<< ACMS.API.REST.Collection.delete collectionItem - CollectionEdit collectionItem -> - LB.putStr . J.encodePretty - =<< ACMS.API.REST.Collection.update collectionItem - =<< J.throwDecode - =<< LB.getContents - CollectionList collection -> - mapM_ (LB.putStrLn . J.encodePretty) - =<< ACMS.API.REST.Collection.list collection - CollectionSchema collection -> - LB.putStr . J.encodePretty @J.Value - =<< ACMS.API.REST.Collection.schema collection - Args {cmd = QueryCmd} -> - LB.putStr . J.encodePretty @J.Value - =<< ACMS.API.Query.query . LB.toString - =<< LB.getContents diff --git a/cli/cli.cabal b/cli/cli.cabal deleted file mode 100644 index 3d0934e..0000000 --- a/cli/cli.cabal +++ /dev/null @@ -1,28 +0,0 @@ -cabal-version: 3.4 -name: cli -version: 0.1.0.0 -license: BSD-2-Clause -license-file: LICENSE -maintainer: aforemny@posteo.de -author: Alexander Foremny -build-type: Simple -extra-doc-files: CHANGELOG.md - -executable acms - main-is: Main.hs - hs-source-dirs: app - other-modules: - default-language: GHC2021 - ghc-options: -Wall - build-depends: - aeson, - aeson-pretty, - backend, - base, - bytestring, - common, - filepath, - optparse-applicative, - sh, - text, - utf8-string diff --git a/common/CHANGELOG.md b/common/CHANGELOG.md deleted file mode 100644 index 47b7089..0000000 --- a/common/CHANGELOG.md +++ /dev/null @@ -1,5 +0,0 @@ -# Revision history for common - -## 0.1.0.0 -- YYYY-mm-dd - -* First version. Released on an unsuspecting world. diff --git a/common/LICENSE b/common/LICENSE deleted file mode 100644 index c90516a..0000000 --- a/common/LICENSE +++ /dev/null @@ -1,30 +0,0 @@ -Copyright (c) 2024, Alexander Foremny - -All rights reserved. - -Redistribution and use in source and binary forms, with or without -modification, are permitted provided that the following conditions are met: - - * Redistributions of source code must retain the above copyright - notice, this list of conditions and the following disclaimer. - - * Redistributions in binary form must reproduce the above - copyright notice, this list of conditions and the following - disclaimer in the documentation and/or other materials provided - with the distribution. - - * Neither the name of Alexander Foremny nor the names of other - contributors may be used to endorse or promote products derived - from this software without specific prior written permission. - -THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS -"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT -LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR -A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT -OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, -SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT -LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, -DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY -THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT -(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE -OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/common/common.cabal b/common/common.cabal deleted file mode 100644 index d67e5d6..0000000 --- a/common/common.cabal +++ /dev/null @@ -1,23 +0,0 @@ -cabal-version: 3.4 -name: common -version: 0.2.0 -license: BSD-3-Clause -license-file: LICENSE -maintainer: aforemny@posteo.de -author: Alexander Foremny -build-type: Simple -extra-doc-files: CHANGELOG.md - -library - exposed-modules: Version, - Collection - hs-source-dirs: src - default-language: GHC2021 - default-extensions: ViewPatterns - ghc-options: -Wall - build-depends: - aeson, - base, - miso, - split, - text diff --git a/common/src/Collection.hs b/common/src/Collection.hs deleted file mode 100644 index 418278d..0000000 --- a/common/src/Collection.hs +++ /dev/null @@ -1,30 +0,0 @@ -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} - -module Collection where - -import Miso.String (MisoString, toMisoString) -import Text.ParserCombinators.ReadP qualified as R -import Text.ParserCombinators.ReadPrec qualified as R -import Text.Read (Read (..)) - -newtype Collection = Collection {name :: MisoString} - deriving (Read, Eq, Show) - -data CollectionItem = CollectionItem - { collection :: Collection, - itemFileName :: FilePath - } - deriving (Eq) - -instance Read CollectionItem where - readPrec = R.lift $ do - (Collection . toMisoString -> collection) <- R.munch (/= '/') - _ <- R.string "/" - itemFileName <- R.munch (const True) - pure CollectionItem {..} - -instance Show CollectionItem where - show (CollectionItem {collection = Collection cn, itemFileName}) = - show (cn <> "/" <> toMisoString itemFileName) diff --git a/common/src/Version.hs b/common/src/Version.hs deleted file mode 100644 index 6970968..0000000 --- a/common/src/Version.hs +++ /dev/null @@ -1,47 +0,0 @@ -module Version - ( Version (..), - versionToString, - versionFromText, - versionFromString, - ) -where - -import Data.Aeson qualified as A -import Data.Aeson.Types qualified as A -import Data.Function (on) -import Data.List -import Data.List.Split -import Data.Maybe (fromMaybe) -import Data.String (IsString (..)) -import Data.Text qualified as T - -data Version = Version Int Int Int - deriving (Show, Eq) - -instance Ord Version where - compare = compare `on` toTriple - -toTriple :: Version -> (Int, Int, Int) -toTriple (Version major minor patch) = (major, minor, patch) - -instance A.ToJSON Version where - toJSON = A.toJSON . versionToString - -instance A.FromJSON Version where - parseJSON (A.String (versionFromText -> Just version)) = pure version - parseJSON v = A.typeMismatch "version" v - -versionToString :: Version -> String -versionToString (Version major minor patch) = - intercalate "." (map show [major, minor, patch]) - -versionFromString :: String -> Maybe Version -versionFromString (map read . splitOn "." -> [major, minor, patch]) = - Just (Version major minor patch) -versionFromString _ = Nothing - -versionFromText :: T.Text -> Maybe Version -versionFromText = versionFromString . T.unpack - -instance IsString Version where - fromString = fromMaybe (error "") . versionFromString diff --git a/default.nix b/default.nix index 2f99f59..43fff14 100644 --- a/default.nix +++ b/default.nix @@ -6,15 +6,12 @@ let jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc98; in rec { - inherit (haskellPackages) backend cli; + inherit (haskellPackages) acms; inherit (jsHaskellPackages) frontend; shell = haskellPackages.shellFor { packages = _: [ + haskellPackages.acms haskellPackages.autotypes - haskellPackages.backend - haskellPackages.cli - haskellPackages.common - haskellPackages.cli haskellPackages.frontend ]; buildInputs = [ diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs index 0b4f1ca..040b961 100644 --- a/frontend/app/Form/Input.hs +++ b/frontend/app/Form/Input.hs @@ -160,7 +160,7 @@ inputText label = value_ i, onInput id ], - div_ [ class_ "error-helper" ] $ + div_ [class_ "error-helper"] $ [either text (\_ -> text "") (parse i)] ] ] diff --git a/frontend/app/Page/EditValue.hs b/frontend/app/Page/EditValue.hs index 942d9db..8a7ca15 100644 --- a/frontend/app/Page/EditValue.hs +++ b/frontend/app/Page/EditValue.hs @@ -8,6 +8,7 @@ module Page.EditValue where import ACMS.API.REST.Collection qualified as API.REST.Collection +import Collection import Control.Monad.Catch (SomeException, try) import Data.Aeson qualified as A import Data.Aeson.KeyMap qualified as AM @@ -17,7 +18,6 @@ import Form qualified as F import Miso import Miso.String (toMisoString) import Schema -import Collection data Model = Model { collectionItem :: CollectionItem, diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index c4affab..fb0ad6a 100644 --- a/frontend/frontend.cabal +++ b/frontend/frontend.cabal @@ -34,12 +34,11 @@ executable frontend -fno-warn-orphans build-depends: + acms, aeson, attoparsec, - backend, base, bytestring, - common, containers, data-default, exceptions, diff --git a/pkgs/default.nix b/pkgs/default.nix index 7dce871..f893125 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -4,11 +4,9 @@ { haskell = super.haskell // { packageOverrides = self: super: { + acms = self.callCabal2nix "acms" ../acms { }; astore = self.callCabal2nix "astore" sources.json2sql { }; autotypes = self.callCabal2nix "autotypes" ../autotypes { }; - backend = self.callCabal2nix "backend" ../backend { }; - cli = self.callCabal2nix "cli" ../cli { }; - common = self.callCabal2nix "common" ../common { }; frontend = self.callCabal2nix "frontend" ../frontend { }; sh = pkgs.haskell.lib.dontCheck (self.callCabal2nix "sh" sources.sh { }); websockets = pkgs.haskell.lib.doJailbreak super.websockets; diff --git a/tests.nix b/tests.nix index b62bd7f..e7cdf82 100644 --- a/tests.nix +++ b/tests.nix @@ -10,22 +10,22 @@ let { machine = { lib, pkgs, nodes, ... }: { environment.systemPackages = [ ]; - systemd.services.backend.wantedBy = [ "multi-user.target" ]; - systemd.services.backend.preStart = '' + systemd.services.acms.wantedBy = [ "multi-user.target" ]; + systemd.services.acms.preStart = '' export HOME=$(mktemp -d) ${pkgs.git}/bin/git config --global user.email "you@example.com" ${pkgs.git}/bin/git config --global user.name "Your Name" ${pkgs.git}/bin/git init ${pkgs.git}/bin/git commit -m init --allow-empty ''; - systemd.services.backend.script = '' - UUID_SEED=0 ${haskellPackages.backend}/bin/backend serve . + systemd.services.acms.script = '' + UUID_SEED=0 ${haskellPackages.acms}/bin/acms serve . ''; }; }; testScript = '' start_all(); - machine.wait_for_unit("backend"); + machine.wait_for_unit("acms"); machine.succeed("${pkgs.bash}/bin/bash ${makeDocTestScript n i}"); ''; @@ -49,8 +49,8 @@ let cd "$tmp" export ACMS_CONTENT=$PWD/content # TODO export PATH=${pkgs.lib.makeBinPath [ - haskellPackages.cli - pkgs.jq + haskellPackages.acms + pkgs.jq ]}''${PATH+:$PATH} EOF cat ${i} | pandoc --to json | jq -c ' -- cgit v1.2.3