diff options
40 files changed, 1274 insertions, 646 deletions
@@ -26,7 +26,7 @@ reload run backend: ```shell -cabal run backend -- serve --port 8081 ./blog +acms serve blog ``` open browser at `http://localhost:8080`. diff --git a/cli/CHANGELOG.md b/acms/CHANGELOG.md index b733b96..ff5d9e1 100644 --- a/cli/CHANGELOG.md +++ b/acms/CHANGELOG.md @@ -1,4 +1,4 @@ -# Revision history for cli +# Revision history for acms ## 0.1.0.0 -- YYYY-mm-dd diff --git a/backend/LICENSE b/acms/LICENSE index c90516a..ba1f71e 100644 --- a/backend/LICENSE +++ b/acms/LICENSE @@ -1,6 +1,5 @@ -Copyright (c) 2024, Alexander Foremny +Copyright (c) 2025, 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: @@ -13,7 +12,7 @@ modification, are permitted provided that the following conditions are met: disclaimer in the documentation and/or other materials provided with the distribution. - * Neither the name of Alexander Foremny nor the names of other + * 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. @@ -21,7 +20,7 @@ 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, +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 diff --git a/acms/acms.cabal b/acms/acms.cabal new file mode 100644 index 0000000..96e3f99 --- /dev/null +++ b/acms/acms.cabal @@ -0,0 +1,122 @@ +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, + wai-app-static, + wai-cors, + 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..3dd339c --- /dev/null +++ b/acms/app/Main.hs @@ -0,0 +1,131 @@ +module Main where + +import ACMS.ACMS qualified +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 + | ServeCmd ServeOpts + +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", + O.command "serve" . O.info serveCmd $ + O.progDesc "Serve content repository" + ] + +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 + +data ServeOpts = ServeOpts + { serverPort :: Int, + contentRepositoryPath :: FilePath + } + +serveCmd :: O.Parser Cmd +serveCmd = + ServeCmd + <$> ( ServeOpts + <$> O.option + O.auto + ( O.metavar "PORT" + <> O.showDefault + <> O.value 8081 + <> O.long "port" + <> O.short 'p' + <> O.help "The server port" + ) + <*> O.strArgument + ( O.metavar "PATH" + <> O.help "Path to the content repository" + ) + ) + +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 + Args {cmd = ServeCmd (ServeOpts {serverPort, contentRepositoryPath})} -> + ACMS.ACMS.run ACMS.ACMS.Config {serverPort, contentRepositoryPath} diff --git a/backend/app/Main.hs b/acms/src/ACMS/ACMS.hs index 0985a3a..c0046f4 100644 --- a/backend/app/Main.hs +++ b/acms/src/ACMS/ACMS.hs @@ -1,80 +1,59 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE NamedFieldPuns #-} -{-# LANGUAGE NondecreasingIndentation #-} -{-# LANGUAGE RecordWildCards #-} -{-# OPTIONS_GHC -fno-warn-name-shadowing #-} - -module Main where +module ACMS.ACMS + ( Config (..), + run, + ) +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 (Exception, SomeException, catch, displayException) +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 (find) +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.Application.Static import Network.Wai.Handler.Warp qualified as W -import Options.Applicative qualified as A +import Network.Wai.Middleware.Cors (simpleCors) import Safe import Store qualified as Q -import System.Directory (doesDirectoryExist, makeAbsolute, setCurrentDirectory) +import System.Directory (makeAbsolute) import System.Environment import System.Exit import System.FilePath import System.INotify import System.IO qualified as IO +import System.IO.Unsafe (unsafePerformIO) import System.Random import Text.Printf (printf) import Version +import WaiAppStatic.Types (unsafeToPiece) 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] } @@ -83,7 +62,8 @@ data Repo = Repo data Commit = Commit { id :: G.CommitOid GB.LgRepo, collections :: [Collection], - schemaVersion :: Version + schemaVersion :: Version, + refMap :: RefMap } deriving (Show) @@ -134,15 +114,22 @@ watch repoT root ref = do let loop = maybe (pure ()) (const loop) =<< tryReadTQueue qT readTQueue qT >> loop repo' <- atomically do takeTMVar repoT - catch + catches ( do repo <- initRepo root ref atomically do putTMVar repoT repo ) - ( \(e :: SomeException) -> do - printf "warning: %s\n" (displayException e) - 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 @@ -161,11 +148,16 @@ initRepo root ref = do M.toList . M.unionsWith (++) $ map (\f -> M.singleton (takeDirectory f) [f]) fs colls <- forM cls $ \(path, files) -> do - (value : values) <- 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' value values + 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 @@ -186,7 +178,7 @@ initRepo root ref = do Just Minor -> Version major' (minor' + 1) 0 Just Patch -> Version major' minor' (patch' + 1) Nothing -> Version major' minor' patch' - c = Commit cid colls schemaVersion + c = Commit cid colls schemaVersion refMap pure (c : cs) ) [] @@ -230,42 +222,124 @@ data SchemaDifference logStderr :: String -> IO () logStderr = IO.hPutStrLn IO.stderr -main :: IO () -main = do - uuidSeed <- lookupEnv "UUID_SEED" - maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed +data RefMap = RefMap + { references :: M.Map FilePath (S.Set FilePath), + referencees :: M.Map FilePath (S.Set FilePath) + } + deriving (Show) - A.execParser (A.info (args <**> A.helper) A.idm) >>= \case - Args {cmd = Serve {contentRepositoryPath, serverPort}} -> do - contentRepositoryPath' <- makeAbsolute contentRepositoryPath - contentRepositoryPathExists <- doesDirectoryExist (contentRepositoryPath' </> ".git") +data ReferenceViolation + = ReferenceViolation + { referencee :: FilePath, + referencees :: S.Set FilePath + } + deriving (Show) - unless contentRepositoryPathExists $ do - logStderr $ "Content repository '" ++ contentRepositoryPath ++ "' is not a git repository." - exitFailure +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) - setCurrentDirectory contentRepositoryPath' - let root = "." - ref = "refs/heads/master" - repoT <- newEmptyTMVarIO - _ <- forkIO do watch repoT root ref +data Config = Config + { serverPort :: Int, + contentRepositoryPath :: FilePath + } - logStderr ("Serving " ++ contentRepositoryPath' ++ " on port " ++ show serverPort ++ ".") +run :: Config -> IO () +run (Config {serverPort, contentRepositoryPath}) = do + uuidSeed <- lookupEnv "UUID_SEED" + maybe (pure ()) (setStdGen . mkStdGen) $ readMay =<< uuidSeed - stopM <- newEmptyMVar - mapM_ - ( \hostPref -> flip forkFinally (either throwIO (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.. - takeMVar stopM + root <- makeAbsolute contentRepositoryPath + let ref = "refs/heads/master" + repoT <- newEmptyTMVarIO + + -- create repository if it does not exist + catch + (Q.withStore root ref (pure ())) + ( \(e :: G.GitException) -> do + case e of + G.RepositoryCannotAccess _ -> do + logStderr "error: cannot open content repository: the content repository is not a Git repository" + exitWith (ExitFailure 1) + _ -> throwIO e + ) + + 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 + ) + . simpleCors + . adminPanel + . 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 + +adminPanel :: W.Middleware +adminPanel app req resp = + maybe + (app req resp) + ( \root -> case W.pathInfo req of + ("admin" : pathInfo) -> + staticApp + ( (defaultWebAppSettings root) + { ssAddTrailingSlash = True, + ssIndices = [unsafeToPiece "index.html"] + } + ) + req + { W.pathInfo = pathInfo + } + resp + _ -> app req resp + ) + (unsafePerformIO (lookupEnv "APPROOT")) data InvalidSchemaVersion = InvalidSchemaVersion String deriving (Show) @@ -292,8 +366,8 @@ queryApi root ref repoT app req resp = 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 - =<< Q.withStore root ref do Q.query q + 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 @@ -335,40 +409,57 @@ restApi root ref repoT app req resp = do Q.commit resp $ W.responseLBS W.status200 [] "{}" ("GET", ["collection", c]) -> do - resp . W.responseLBS W.status200 [] . J.encode + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query (fromString (printf "SELECT %s FROM %s" c c)) + 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 . headMay + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( Q.withStore root ref $ Q.withCommit rev do - Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) + 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 . headMay + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( 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)) - [J.Object r] <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) - _ <- Q.query (fromString (printf "INSERT %s INTO %s" (LB.toString (J.encode (dropNulls r))) c)) - Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) + _ <- 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 <- ((<> ".json") . U.toText) <$> getUUID + i <- U.toText <$> getUUID o <- fmap dropNulls . J.throwDecode @J.Object =<< W.lazyRequestBody req - resp . W.responseLBS W.status200 [] . J.encode + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( 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)) - headMay <$> Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) + _ <- 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 . headMay + resp . W.responseLBS W.status200 [] . J.encode . fileNameToId . head =<< ( Q.withStore root ref do - r <- Q.query (fromString (printf "SELECT %s FROM %s WHERE %s.$fileName == \"%s\"" c c c i)) - Q.query (fromString (printf "DELETE FROM %s WHERE %s.$fileName == \"%s\"" c c i)) + 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." @@ -392,3 +483,29 @@ dropNulls = (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/lib/ACMS/API/REST.hs b/acms/src/ACMS/API/Fetch.hs index 44c307c..02e3e80 100644 --- a/backend/lib/ACMS/API/REST.hs +++ b/acms/src/ACMS/API/Fetch.hs @@ -1,6 +1,16 @@ -{-# LANGUAGE OverloadedStrings #-} - -module ACMS.API.REST where +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 @@ -10,38 +20,11 @@ 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.Aeson qualified as A import Data.ByteString.Lazy.Char8 qualified as LB -import Data.Function ((&)) -import Data.String (IsString (fromString)) import Miso (JSM) -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 class (MonadThrow m) => APIMonad m where fetch :: Request -> m LB.ByteString @@ -50,7 +33,6 @@ 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 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/backend/lib/ACMS/API/REST/Collection.hs b/acms/src/ACMS/API/REST/Collection.hs index b3faf19..0ed96fd 100644 --- a/backend/lib/ACMS/API/REST/Collection.hs +++ b/acms/src/ACMS/API/REST/Collection.hs @@ -1,17 +1,7 @@ -{-# LANGUAGE OverloadedStrings #-} - module ACMS.API.REST.Collection where -#ifndef ghcjs_HOST_OS -import Network.HTTP.Simple -#else -import ACMS.API.REST (setRequestMethod, setRequestBodyLBS, getResponseBody) -import Data.ByteString.Char8 qualified as B -import Data.Maybe -import JavaScript.Web.XMLHttpRequest -import Miso.String qualified as J -#endif -import ACMS.API.REST (APIMonad, fetch, restRequest) +import ACMS.API.Fetch +import ACMS.API.REST (restRequest) import Collection import Data.Aeson qualified as A import Data.Function ((&)) 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/common/src/Collection.hs b/acms/src/Collection.hs index a23fd31..6ad4e7a 100644 --- a/common/src/Collection.hs +++ b/acms/src/Collection.hs @@ -1,31 +1,26 @@ -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE ViewPatterns #-} module Collection where -import Data.Text qualified as T +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 :: T.Text} +newtype Collection = Collection {name :: MisoString} deriving (Read, Eq, Show) data CollectionItem = CollectionItem { collection :: Collection, itemFileName :: FilePath - } deriving (Eq) + } + deriving (Eq) instance Read CollectionItem where readPrec = R.lift $ do - (Collection . T.pack -> collection) <- R.munch (/= '/') + (Collection . toMisoString -> collection) <- R.munch (/= '/') _ <- R.string "/" - itemFileName <- do - itemFileName <- R.munch (liftA2 (&&) (/= '.') (/= '/')) - fileExt <- R.string ".json" - pure (itemFileName <> fileExt) + itemFileName <- R.munch (const True) pure CollectionItem {..} instance Show CollectionItem where show (CollectionItem {collection = Collection cn, itemFileName}) = - show (cn <> "/" <> T.pack itemFileName) + show (cn <> "/" <> toMisoString itemFileName) diff --git a/common/src/Version.hs b/acms/src/Version.hs index 6970968..6970968 100644 --- a/common/src/Version.hs +++ b/acms/src/Version.hs 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/autotypes/app/Main.hs b/autotypes/app/Main.hs index d9fa7f4..5ebb30d 100644 --- a/autotypes/app/Main.hs +++ b/autotypes/app/Main.hs @@ -3,6 +3,7 @@ module Main where import AutoTypes.Unify as U import Data.Aeson (Value, decodeFileStrict', encode) import qualified Data.ByteString.Lazy as B +import Data.Maybe import System.Environment (getArgs) import System.FilePath (takeFileName) @@ -10,7 +11,7 @@ main :: IO () main = do filePaths <- getArgs types <- - mapM + mapMaybeM ( \filePath -> do Just value <- decodeFileStrict' filePath pure (U.fromJson value) @@ -25,3 +26,5 @@ main = do ) ) ) + +mapMaybeM = (fmap catMaybes .) . mapM diff --git a/autotypes/autotypes.cabal b/autotypes/autotypes.cabal index 819794b..5264f64 100644 --- a/autotypes/autotypes.cabal +++ b/autotypes/autotypes.cabal @@ -1,57 +1,37 @@ cabal-version: 2.4 name: autotypes version: 0.1.0.0 - --- A short (one-line) description of the package. --- synopsis: - --- A longer description of the package. --- description: - --- A URL where users can report bugs. --- bug-reports: - --- The license under which the package is released. --- license: -author: Alexander Foremny maintainer: aforemny@posteo.de - --- A copyright notice. --- copyright: --- category: +author: Alexander Foremny extra-source-files: CHANGELOG.md library exposed-modules: - AutoTypes - AutoTypes.Unify - - -- Modules included in this library but not exported. - -- other-modules: + AutoTypes + AutoTypes.Unify - -- LANGUAGE extensions used by modules in this package. - -- other-extensions: - build-depends: - aeson, - aeson-pretty, - aeson-qq, - base, - bytestring, - containers, - filepath, - text, - time, - vector hs-source-dirs: src default-language: Haskell2010 + ghc-options: -fno-warn-x-partial + build-depends: + aeson, + aeson-pretty, + aeson-qq, + base, + bytestring, + containers, + filepath, + text, + time, + vector executable autotypes - main-is: Main.hs - hs-source-dirs: app - default-language: Haskell2010 - build-depends: - aeson, - autotypes, - base, - bytestring, - filepath + main-is: Main.hs + hs-source-dirs: app + default-language: Haskell2010 + build-depends: + aeson, + autotypes, + base, + bytestring, + filepath diff --git a/autotypes/src/AutoTypes.hs b/autotypes/src/AutoTypes.hs index ddc948c..493fe11 100644 --- a/autotypes/src/AutoTypes.hs +++ b/autotypes/src/AutoTypes.hs @@ -6,6 +6,7 @@ where import qualified AutoTypes.Unify as U import Data.Aeson (Value, decodeFileStrict', encode) +import Data.Maybe import Data.Maybe (fromJust) import System.Environment (getArgs) import System.FilePath (takeFileName) @@ -17,7 +18,7 @@ autoTypes fp fps = autoTypes' <$> go fp <*> mapM go (fp : fps) autoTypes' :: Value -> [Value] -> U.T autoTypes' t' ts' = - let types = map U.fromJson (t' : ts') + let types = mapMaybe U.fromJson (t' : ts') in head ( foldr1 (\ls rs -> (concat [U.unify1 l r | l <- ls, r <- rs])) diff --git a/autotypes/src/AutoTypes/Unify.hs b/autotypes/src/AutoTypes/Unify.hs index bfbd05b..1d6263d 100644 --- a/autotypes/src/AutoTypes/Unify.hs +++ b/autotypes/src/AutoTypes/Unify.hs @@ -4,6 +4,7 @@ module AutoTypes.Unify ( T (..), + Scalar (..), toString, fromJson, unify1, @@ -16,12 +17,13 @@ import qualified Data.Aeson as A import qualified Data.Aeson.Encode.Pretty as A import qualified Data.Aeson.Key as K import qualified Data.Aeson.KeyMap as KM -import qualified Data.ByteString.Lazy.Char8 as BL import Data.Aeson.QQ +import qualified Data.ByteString.Lazy.Char8 as BL import Data.List (intercalate, nub) import Data.Map (Map) import qualified Data.Map as M import qualified Data.Map.Merge.Lazy as M +import Data.Maybe import qualified Data.Set as S import qualified Data.Text as T import Data.Time.Clock @@ -31,14 +33,14 @@ import Debug.Trace import System.FilePath (takeDirectory) import Prelude hiding (null) -data ScalarType +data Scalar = String | Number | DateTime | Bool deriving (Eq, Ord, Show) -scalarTypeString :: ScalarType -> String +scalarTypeString :: Scalar -> String scalarTypeString String = "string" scalarTypeString Number = "number" scalarTypeString DateTime = "datetime" @@ -48,7 +50,7 @@ data T = List (Maybe T) | Object (Map String T) | Option (Maybe T) - | Scalar ScalarType + | Scalar Scalar | Union (S.Set T) | Reference String deriving (Eq, Ord, Show) @@ -175,31 +177,31 @@ unify (Option Nothing) (Option (Just r)) = Right (Option (Just r)) unify (Option (Just l)) (Option (Just r)) = Option . Just <$> unify l r -} -object :: Map String T -> T -object = Object +object :: Map String T -> Maybe T +object = Just . Object -list :: Maybe T -> T -list = List +list :: Maybe T -> Maybe T +list = Just . List -string, number, bool, dateTime, null :: T -string = Scalar String -number = Scalar Number -bool = Scalar Bool -dateTime = Scalar DateTime -null = Option Nothing +string, number, bool, dateTime, null :: Maybe T +string = Just (Scalar String) +number = Just (Scalar Number) +bool = Just (Scalar Bool) +dateTime = Just (Scalar DateTime) +null = Nothing data InferException = InferException [T] deriving (Show) instance Exception InferException -fromJson :: A.Value -> T +fromJson :: A.Value -> Maybe T fromJson (A.Object kvs) = case map (first K.toString) (KM.toList kvs) of - [("$ref", A.String i)] -> Reference (takeDirectory (T.unpack i)) - _ -> object (M.mapKeys K.toString (M.map fromJson (KM.toMap kvs))) + [("$ref", A.String i)] -> Just (Reference (takeDirectory (T.unpack i))) + _ -> object (M.mapKeys K.toString (M.mapMaybe fromJson (KM.toMap kvs))) fromJson t@(A.Array vs) = - let ts = map fromJson (V.toList vs) + let ts = mapMaybe fromJson (V.toList vs) in case nub ts of [] -> list Nothing [t] -> list (Just t) @@ -211,6 +213,7 @@ fromJson (A.Number _) = number fromJson (A.Bool _) = bool fromJson A.Null = null +{- object1 = [aesonQQ|{ "firstName": "firstName", @@ -263,7 +266,7 @@ main = ) ) ) - ) + )-} -- >>= unify (fromJson object2) -- >>= unify (fromJson object4) diff --git a/backend/backend.cabal b/backend/backend.cabal deleted file mode 100644 index c8bff6f..0000000 --- a/backend/backend.cabal +++ /dev/null @@ -1,78 +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.REST - ACMS.API.REST.Collection - - hs-source-dirs: lib - 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, - optparse-applicative, - random, - safe, - split, - stm, - tagged, - text, - utf8-string, - uuid, - wai, - warp - - if arch(javascript) - buildable: False 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 961f54f..0000000 --- a/cli/app/Main.hs +++ /dev/null @@ -1,92 +0,0 @@ -{-# LANGUAGE ApplicativeDo #-} -{-# LANGUAGE BlockArguments #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE ViewPatterns #-} -{-# LANGUAGE NoFieldSelectors #-} - -module Main where - -import Collection -import ACMS.API.REST.Collection qualified -import Control.Applicative ((<**>)) -import Data.Aeson qualified as J -import Data.Aeson.Encode.Pretty qualified as J -import Data.ByteString.Lazy 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 - -cmd_ :: O.Parser Cmd -cmd_ = - O.hsubparser . mconcat $ - [ O.command "collection" . O.info collectionCmd $ - O.progDesc "Manage content collections" - ] - -data CollectionCmd - = CollectionAdd Collection - | CollectionView CollectionItem - | CollectionEdit CollectionItem - | CollectionDelete CollectionItem - | -- - 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 "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") - -main :: IO () -main = - O.execParser (O.info (args <**> O.helper) O.idm) >>= \case - Args - { cmd = CollectionCmd cmd - } -> case cmd of - CollectionAdd collection -> do - 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 - CollectionSchema collection -> - LB.putStr . J.encodePretty @J.Value - =<< ACMS.API.REST.Collection.schema collection diff --git a/cli/cli.cabal b/cli/cli.cabal deleted file mode 100644 index 5617808..0000000 --- a/cli/cli.cabal +++ /dev/null @@ -1,27 +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 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 2c98a47..0000000 --- a/common/common.cabal +++ /dev/null @@ -1,22 +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, - split, - text diff --git a/default.nix b/default.nix index 9e66c80..6c17444 100644 --- a/default.nix +++ b/default.nix @@ -1,37 +1,84 @@ -{ pkgs ? import sources.nixpkgs { overlays = [ (import ./pkgs { }) ]; } +{ pkgs ? import sources.nixpkgs { + overlays = [ + (import ./pkgs { }) + (self: super: { + haskell = super.haskell // { + packageOverrides = self.lib.composeManyExtensions [ + super.haskell.packageOverrides + (self: super: { + ghcWithPackages = super.ghcWithPackages.override { + installDocumentation = false; # XXX true (default) + }; + }) + ]; + }; + }) + ]; + } , sources ? import ./nix/sources.nix }: let - haskellPackages = pkgs.haskell.packages.ghc98; - jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc98; + haskellPackages = pkgs.haskell.packages.ghc910; + jsHaskellPackages = pkgs.pkgsCross.ghcjs.haskell.packages.ghc910; + lib = pkgs.lib; in rec { - inherit (haskellPackages) backend cli; + inherit (haskellPackages) acms; inherit (jsHaskellPackages) frontend; - shell = haskellPackages.shellFor { - packages = _: [ - haskellPackages.autotypes - haskellPackages.backend - haskellPackages.cli - haskellPackages.common - haskellPackages.cli - haskellPackages.frontend - ]; - buildInputs = [ - haskellPackages.astore - haskellPackages.autotypes - haskellPackages.cabal-install - haskellPackages.haskell-language-server - haskellPackages.ormolu - pkgs.niv - (pkgs.writeScriptBin "reload" '' - set -efu - ${haskellPackages.ghcid.bin}/bin/ghcid -c \ - '${haskellPackages.cabal-install}/bin/cabal new-repl' \ - -T ':run Main.main' - '') + shell = pkgs.mkShell { + inputsFrom = [ + (jsHaskellPackages.shellFor { + packages = _: [ + jsHaskellPackages.acms + jsHaskellPackages.autotypes + jsHaskellPackages.frontend + ]; + }) + (haskellPackages.shellFor { + packages = _: [ + haskellPackages.acms + haskellPackages.autotypes + haskellPackages.frontend + ]; + withHoogle = true; + withHaddock = true; + }) + (pkgs.mkShell { + buildInputs = [ + haskellPackages.astore + haskellPackages.autotypes + haskellPackages.cabal-install + haskellPackages.haskell-language-server + haskellPackages.ormolu + pkgs.niv + pkgs.pkg-config + (pkgs.writeScriptBin "reload" '' + set -efu + ${haskellPackages.ghcid.bin}/bin/ghcid -c \ + '${haskellPackages.cabal-install}/bin/cabal new-repl' \ + -T ':run Main.main' + '') + (pkgs.writeScriptBin "acms" '' + set -efu + exec ${haskellPackages.cabal-install}/bin/cabal run acms -- "$@" + '') + (pkgs.writeScriptBin "format" '' + set -efu + git ls-files | grep .hs$ | while read -r fn; do + ${haskellPackages.ormolu}/bin/ormolu -i "$fn" || : + done + '') + (pkgs.writeScriptBin "git-hook-precommit" '' + set -efux + cd ${lib.escapeShellArg (toString ./.)} + nix-build . -A acms -A frontend --no-out-link + nix-build tests.nix --no-out-link + '') + ]; + shellHook = '' + export EM_CACHE="${toString ./.}/.emcache" # nixos/nixpkgs#282509 + ''; + }) ]; - withHoogle = true; - withHaddock = true; }; } diff --git a/docs/api-reference.md b/docs/api-reference.md index 248ab8c..fd09ecc 100644 --- a/docs/api-reference.md +++ b/docs/api-reference.md @@ -17,11 +17,11 @@ curl -X POST http://localhost:8081/api/rest/collection/entity --data @- <<'EOF' EOF ``` -Note that the created entity is returned, including the meta field `$fileName`. +Note that the created entity is returned, including the meta field `$id`. ```json { - "$fileName": "9474f0eb-06d7-4fd8-b89e-0ce996962508.json", + "$id": "9474f0eb-06d7-4fd8-b89e-0ce996962508", "description": "Description of entity 1", "name": "Entity 1" } @@ -40,7 +40,7 @@ EOF ```json { - "$fileName": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b.json", + "$id": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b", "description": "Description of entity 2", "name": "Entity 2" } @@ -61,7 +61,7 @@ As one would expect, the schema lists the fields `name`, `description` as requir "$id": "entity.schema.json", "$schema": "https://json-schema.org/draft/2020-12/schema", "properties": { - "$fileName": { + "$id": { "type": "string" }, "description": { @@ -72,7 +72,7 @@ As one would expect, the schema lists the fields `name`, `description` as requir } }, "required": [ - "$fileName", + "$id", "description", "name" ], @@ -83,15 +83,15 @@ As one would expect, the schema lists the fields `name`, `description` as requir ### Retrieving a single collection entity -Single collection entities can be retrieved using their unique `$fileName` identifier. +Single collection entities can be retrieved using their unique `$id` identifier. ```console -curl http://localhost:8081/api/rest/collection/entity/9474f0eb-06d7-4fd8-b89e-0ce996962508.json | jq . +curl http://localhost:8081/api/rest/collection/entity/9474f0eb-06d7-4fd8-b89e-0ce996962508 | jq . ``` ```json { - "$fileName": "9474f0eb-06d7-4fd8-b89e-0ce996962508.json", + "$id": "9474f0eb-06d7-4fd8-b89e-0ce996962508", "description": "Description of entity 1", "name": "Entity 1" } @@ -108,12 +108,12 @@ curl http://localhost:8081/api/rest/collection/entity | jq . ```json [ { - "$fileName": "9474f0eb-06d7-4fd8-b89e-0ce996962508.json", + "$id": "9474f0eb-06d7-4fd8-b89e-0ce996962508", "description": "Description of entity 1", "name": "Entity 1" }, { - "$fileName": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b.json", + "$id": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b", "description": "Description of entity 2", "name": "Entity 2" } @@ -125,7 +125,7 @@ curl http://localhost:8081/api/rest/collection/entity | jq . Updating a collection entity is possible by send only select fields. ```console -curl -X PUT http://localhost:8081/api/rest/collection/entity/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b.json --data @- <<'EOF' | jq . +curl -X PUT http://localhost:8081/api/rest/collection/entity/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b --data @- <<'EOF' | jq . { "description": "Entity 2 description" } @@ -136,7 +136,7 @@ The endpoint returns the full, updated entity. ```json { - "$fileName": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b.json", + "$id": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b", "description": "Entity 2 description", "name": "Entity 2" } @@ -145,7 +145,7 @@ The endpoint returns the full, updated entity. Fields can be deleted setting them their values to `null`. ```console -curl -X PUT http://localhost:8081/api/rest/collection/entity/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b.json --data @- <<'EOF' | jq . +curl -X PUT http://localhost:8081/api/rest/collection/entity/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b --data @- <<'EOF' | jq . { "description": null } @@ -156,7 +156,7 @@ Again, the response contains the full entity after the update. ```json { - "$fileName": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b.json", + "$id": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b", "name": "Entity 2" } ``` @@ -176,7 +176,7 @@ curl http://localhost:8081/api/rest/collection/entity/schema | jq . "$id": "entity.schema.json", "$schema": "https://json-schema.org/draft/2020-12/schema", "properties": { - "$fileName": { + "$id": { "type": "string" }, "description": { @@ -187,7 +187,7 @@ curl http://localhost:8081/api/rest/collection/entity/schema | jq . } }, "required": [ - "$fileName", + "$id", "name" ], "title": "entity", @@ -208,12 +208,12 @@ curl http://localhost:8081/api/rest/schemaVersion | jq . ### Deleting collection entities ```console -curl -X DELETE http://localhost:8081/api/rest/collection/entity/9474f0eb-06d7-4fd8-b89e-0ce996962508.json | jq . +curl -X DELETE http://localhost:8081/api/rest/collection/entity/9474f0eb-06d7-4fd8-b89e-0ce996962508 | jq . ``` ```json { - "$fileName": "9474f0eb-06d7-4fd8-b89e-0ce996962508.json", + "$id": "9474f0eb-06d7-4fd8-b89e-0ce996962508", "description": "Description of entity 1", "name": "Entity 1" } diff --git a/docs/get-started-cli.md b/docs/get-started-cli.md index 22c0a0f..46ee2cb 100644 --- a/docs/get-started-cli.md +++ b/docs/get-started-cli.md @@ -25,7 +25,7 @@ Take note of the `$fileName` in the output. Note that it should be different for ```json { - "$fileName": "9474f0eb-06d7-4fd8-b89e-0ce996962508.json", + "$id": "9474f0eb-06d7-4fd8-b89e-0ce996962508", "description": "Welcome to Biscotte restaurant! Restaurant Biscotte offers a cuisine based on fresh, quality products, often local, organic when possible, and always produced by passionate producers.", "name": "Biscotte Restaurant" } @@ -37,7 +37,7 @@ Take note of the `$fileName` in the output. Note that it should be different for acms collection add category <<'EOF' { "name": "French Food", - "restaurant": { "$ref": "restaurant/9474f0eb-06d7-4fd8-b89e-0ce996962508.json" } + "restaurant": { "$ref": "restaurant/9474f0eb-06d7-4fd8-b89e-0ce996962508" } } EOF ``` @@ -46,7 +46,7 @@ EOF acms collection add category <<'EOF' { "name": "Brunch", - "restaurant": { "$ref": "restaurant/9474f0eb-06d7-4fd8-b89e-0ce996962508.json" } + "restaurant": { "$ref": "restaurant/9474f0eb-06d7-4fd8-b89e-0ce996962508" } } EOF ``` @@ -68,7 +68,7 @@ curl 'http://localhost:8081/api/query' --data ' LEFT JOIN category ON - category.restaurant == restaurant.$fileName + category.restaurant == restaurant.$id ' | jq . ``` diff --git a/docs/tutorial-achat.md b/docs/tutorial-achat.md new file mode 100644 index 0000000..82a2bcf --- /dev/null +++ b/docs/tutorial-achat.md @@ -0,0 +1,100 @@ +## authentication + +TODO + +## create user + +```console +acms collection add user <<'EOF' +{ + "username": "joe" +} +EOF +``` + +```json +{ + "$id": "9474f0eb-06d7-4fd8-b89e-0ce996962508", + "username": "joe" +} +``` + +## create chat + +```console +acms collection add chat <<'EOF' +{ + "title": "how does acms work?" +} +EOF +``` + +## list chats + +```console +acms collection list chat +``` + +```json +{ + "$id": "ccccc18c-f3dc-4f98-b4d2-290ef76adb6b", + "title": "how does acms work?" +} +``` + +## create chat message + +```console +acms collection add chat-message <<'EOF' +{ + "chat": { + "$ref": "chat/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b" + }, + "message": "please see the [docs]()", + "user": { + "$ref": "user/9474f0eb-06d7-4fd8-b89e-0ce996962508" + } +} +EOF +``` + +```json +{ + "$id": "6dc0bf04-b453-4396-9efc-0b8b8f338d9c", + "chat": { + "$ref": "chat/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b" + }, + "message": "please see the [docs]()", + "user": { + "$ref": "user/9474f0eb-06d7-4fd8-b89e-0ce996962508" + } +} +``` + +## list chat messages + +```console +acms query <<'EOF' +SELECT + chat-message +FROM + chat-message +WHERE + chat-message.chat.$ref == "chat/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b" +EOF +``` + +```json +[ + { + "$id": "6dc0bf04-b453-4396-9efc-0b8b8f338d9c", + "chat": { + "$ref": "chat/ccccc18c-f3dc-4f98-b4d2-290ef76adb6b" + }, + "message": "please see the [docs]()", + "user": { + "$ref": "user/9474f0eb-06d7-4fd8-b89e-0ce996962508" + } + } +] +``` diff --git a/frontend/app/Form/Input.hs b/frontend/app/Form/Input.hs index 7619326..040b961 100644 --- a/frontend/app/Form/Input.hs +++ b/frontend/app/Form/Input.hs @@ -1,19 +1,128 @@ module Form.Input ( inputText, inputNumber, + inputUnion, + TypeName (..), + Type (..), + typeName, + stringToTypeName, ) where +import Control.Applicative +import Control.Arrow (first, second) +import Data.Aeson qualified as A +import Data.Map qualified as M +import Data.Maybe (fromMaybe) import Form.Internal +import GHC.Generics (Generic) import Miso import Miso.String (MisoString, fromMisoString, null, strip, toMisoString) +data TypeName = StringType | NumberType + deriving (Eq, Ord, Generic) + +instance IsEmpty (TypeName, M.Map TypeName MisoString) where + isEmpty (k, kvs) = isEmpty (fromMaybe "" (M.lookup k kvs)) + +instance A.FromJSON TypeName + +instance A.ToJSON TypeName + +instance A.FromJSONKey TypeName + +instance A.ToJSONKey TypeName + +data Type = IsNumber Double | IsString MisoString + +instance A.ToJSON Type where + toJSON (IsNumber x) = A.Number (realToFrac x) + toJSON (IsString x) = A.String (fromMisoString x) + +instance A.FromJSON Type where + parseJSON = \case + A.Number x -> pure (IsNumber (realToFrac x)) + A.String x -> pure (IsString (toMisoString x)) + _ -> fail "" + +typeName :: Type -> TypeName +typeName (IsNumber _) = NumberType +typeName (IsString _) = StringType + +stringToTypeName :: MisoString -> TypeName +stringToTypeName "number" = NumberType +stringToTypeName "string" = StringType +stringToTypeName _ = StringType + +inputUnion :: MisoString -> [TypeName] -> Form (TypeName, M.Map TypeName MisoString) (Maybe Type) +inputUnion label types = + foldl1 (<|>) + <$> mapM + ( \case + StringType -> + mapValues + ( \(selectedType, typeInputs) -> + ( selectedType == StringType, + M.findWithDefault "" StringType typeInputs + ) + ) + ( \(checked, inputString) (selectedType, typeInputs) -> + ( if checked then StringType else selectedType, + M.insert StringType inputString typeInputs + ) + ) + $ fmap (fmap IsString) + $ withRadio + $ inputText label + NumberType -> + mapValues + ( \(selectedType, typeInputs) -> + ( selectedType == NumberType, + M.findWithDefault "" NumberType typeInputs + ) + ) + ( \(checked, inputString) (selectedType, typeInputs) -> + ( if checked then NumberType else selectedType, + M.insert NumberType inputString typeInputs + ) + ) + $ fmap (fmap IsNumber) + $ withRadio + $ inputNumber label + ) + types + +radio :: Form Bool Bool +radio = + Form + { view = \checked -> + [ div_ [] $ + [ input_ + [ type_ "radio", + checked_ checked, + onClick (not checked) + ] + ] + ], + fill = Right + } + +withRadio :: Form i o -> Form (Bool, i) (Maybe o) +withRadio form = + (\(checked, x) -> if checked then Just x else Nothing) + <$> liftA2 + (,) + (mapValues fst (first . const) radio) + (mapValues snd (second . const) form) + inputNumber :: MisoString -> Form MisoString Double inputNumber label = let parse :: MisoString -> Either MisoString Double parse i = let i' = strip i - in if Miso.String.null i' then Left "required" else Right (read (fromMisoString i')) + in if Miso.String.null i' + then Left "required" + else Right (read (fromMisoString i')) in Form { view = \i -> [ div_ [] $ @@ -42,7 +151,7 @@ inputText label = in if Miso.String.null i' then Left "required" else Right i' in Form { view = \i -> - [ div_ [] $ + [ div_ [class_ "input text"] $ [ label_ [] $ [ text label, div_ [] $ @@ -51,7 +160,7 @@ inputText label = value_ i, onInput id ], - div_ [] $ + div_ [class_ "error-helper"] $ [either text (\_ -> text "") (parse i)] ] ] diff --git a/frontend/app/Form/Internal.hs b/frontend/app/Form/Internal.hs index 35d59e7..6677b2d 100644 --- a/frontend/app/Form/Internal.hs +++ b/frontend/app/Form/Internal.hs @@ -3,6 +3,7 @@ module Form.Internal mapValues, runForm, optional, + IsEmpty (..), ) where diff --git a/frontend/app/Main.hs b/frontend/app/Main.hs index e4729b4..bf8ada3 100644 --- a/frontend/app/Main.hs +++ b/frontend/app/Main.hs @@ -7,6 +7,7 @@ import Language.Javascript.JSaddle.Warp as JSaddle #endif import ACMS.API.REST as API.REST +import Control.Monad (join) import Control.Monad.Catch import Control.Monad.Trans import Data.Bifunctor @@ -20,6 +21,7 @@ import NeatInterpolation qualified as Q import Page (Page, initialPage, updatePage, viewPage) import Page qualified as Page import Route (parseURI) +import Route qualified import Version data Model @@ -189,7 +191,7 @@ header { nav, main { min-height: 100%; } nav { - flex: 0 0 200px; } + flex: 0 0 260px; } main { flex: 1 1 auto; } @@ -236,6 +238,96 @@ table { th, td { border-top: 1px solid gray; border-bottom: 1px solid gray; } + +/* menu */ +nav { + padding: 16px 0 0; } + +nav ol { + list-style-type: none; + line-height: 32px; + padding: 0; + margin: 0; } + +nav { + display: flex; + flex-flow: column nowrap; + height: calc(100vh - 64px); } + +nav section { + display: flex; + flex-flow: column nowrap; } + +nav section > span { + line-height: 32px; + padding-left: 8px; } + +nav section > span:not(:first-child) { + margin-top: 24px; } + +nav li { + white-space: pre; + overflow: hidden; + text-overflow: ellipsis; } + +nav li { + display: flex; } + +nav li a { + flex: 0 0 100%; + padding: 4px 8px 4px; + color: black; + text-decoration: none; } + +nav li a.active { + background-color: lightgray; } + +nav li a:hover, nav li a:active { + background-color: whitesmoke; } + +/* main scrolling */ +main { + max-height: calc(100vh - 64px);} + +/* table */ +table td { + white-space: pre; + overflow: hidden; + text-overflow: ellipsis; + max-width: 480px; } + +/* form */ +.input label { + display: block; + padding-left: 6px; } + +.input .error-helper { + display: block; + padding-left: 6px; } + +.input label > div { + margin-left: -6px; + margin-right: -6px; } + +.input input { + font-size: 1rem; + margin-top: 4px; + margin-bottom: 4px; } + +.input input[type=text] { + padding: 2px 6px; } + +form { + margin: -12px 0; } + +.error-helper { + color: red; + line-height: 1rem; + height: 1rem; } + +.input { + margin: 12px 0; } + |] ) ] @@ -270,7 +362,18 @@ viewCollections s = [ li_ [] [ a_ - [href_ (toMisoString ("#collection/" <> collection))] + ( concat + [ [href_ (toMisoString ("#collection/" <> collection))], + if ( fmap Page.route + . join + . fmap (either (\_ -> Nothing) Just) + $ s.page + ) + == Just (Route.ListCollection collection) + then [class_ "active"] + else [] + ] + ) [text (toMisoString collection)] ] | collection <- s.collections diff --git a/frontend/app/Page.hs b/frontend/app/Page.hs index e1c8415..ed1e44d 100644 --- a/frontend/app/Page.hs +++ b/frontend/app/Page.hs @@ -4,6 +4,7 @@ module Page initialPage, updatePage, viewPage, + route, ) where @@ -13,8 +14,8 @@ import Data.Bifunctor import Data.Default import Data.Function import Effect (Eff) -import Miso -import Miso.String (fromMisoString) +import Miso hiding (route) +import Miso.String (MisoString, fromMisoString) import Page.EditValue qualified as EditValue import Page.ListCollection qualified as ListCollection import Page.NewCollection qualified as NewCollection @@ -23,8 +24,8 @@ import Route qualified as Route data Page = Home - | ListCollection ListCollection.Model - | EditValue EditValue.Model + | ListCollection MisoString ListCollection.Model + | EditValue MisoString MisoString EditValue.Model | NewCollection NewCollection.Model deriving (Show, Eq) @@ -36,24 +37,30 @@ instance Default Page where initialPage :: Route -> JSM (Either SomeException Page) initialPage Route.Home = pure (Right Home) initialPage (Route.ListCollection c) = - fmap ListCollection <$> ListCollection.initialModel (Collection (fromMisoString c)) + fmap (ListCollection c) <$> ListCollection.initialModel (Collection (fromMisoString c)) initialPage (Route.EditValue c f) = - fmap EditValue <$> EditValue.initialModel (CollectionItem (Collection (fromMisoString c)) (fromMisoString f)) + fmap (EditValue c f) <$> EditValue.initialModel (CollectionItem (Collection (fromMisoString c)) (fromMisoString f)) initialPage Route.NewCollection = fmap NewCollection <$> NewCollection.initialModel +route :: Page -> Route +route Home = Route.Home +route (ListCollection c _) = Route.ListCollection c +route (EditValue c f _) = Route.EditValue c f +route (NewCollection _) = Route.NewCollection + update__handleListCollection :: ListCollection.Action -> Action update__handleListCollection action = Action $ \case - ListCollection m -> + ListCollection c m -> ListCollection.updateModel action m - & first (bimap update__handleListCollection ListCollection) + & first (bimap update__handleListCollection (ListCollection c)) p -> (noEff p, []) update__handleEditValue :: EditValue.Action -> Action update__handleEditValue action = Action $ \case - EditValue m -> + EditValue c f m -> EditValue.updateModel action m - & first (bimap update__handleEditValue EditValue) + & first (bimap update__handleEditValue (EditValue c f)) p -> (noEff p, []) update__handleNewCollection :: NewCollection.Action -> Action @@ -68,6 +75,6 @@ updatePage (Action f) m = f m viewPage :: Page -> View Action viewPage Home = text "home" -viewPage (ListCollection m) = update__handleListCollection <$> ListCollection.viewModel m -viewPage (EditValue m) = update__handleEditValue <$> EditValue.viewModel m +viewPage (ListCollection _ m) = update__handleListCollection <$> ListCollection.viewModel m +viewPage (EditValue _ _ m) = update__handleEditValue <$> EditValue.viewModel m viewPage (NewCollection m) = update__handleNewCollection <$> NewCollection.viewModel m 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/app/Page/ListCollection.hs b/frontend/app/Page/ListCollection.hs index 6b999f0..9e3caaa 100644 --- a/frontend/app/Page/ListCollection.hs +++ b/frontend/app/Page/ListCollection.hs @@ -8,26 +8,28 @@ module Page.ListCollection where import ACMS.API.REST.Collection qualified as API.REST.Collection +import ACMS.API.REST.Collection.Paginated (Paginated (..)) +import ACMS.API.REST.Collection.Paginated qualified as API.REST.Collection.Paginated +import Collection import Control.Monad.Catch (SomeException, try) import Data.Aeson qualified as A import Data.Aeson.KeyMap qualified as AM import Effect (Eff) import Miso import Schema -import Collection data Model = Model { collection :: Collection, input :: A.Object, schema :: Schema, - posts :: [A.Object] + posts :: Paginated A.Object } deriving (Show, Eq) initialModel :: Collection -> JSM (Either SomeException Model) initialModel collection = do schema' <- try (API.REST.Collection.schema collection) - posts' <- try (API.REST.Collection.list collection) + posts' <- try (API.REST.Collection.Paginated.list (API.REST.Collection.Paginated.Pagination 10 0) collection) pure do schema <- schema' posts <- posts' @@ -41,7 +43,7 @@ updateModel (Action f) m = f m viewModel :: Model -> View Action viewModel m = div_ [] $ - [ h3_ [] [text "entities"], + [ h3_ [] [text m.collection.name], schemaTable m.collection.name m.schema m.posts, h3_ [] [text "schema"], viewSchema m.schema diff --git a/frontend/app/Schema.hs b/frontend/app/Schema.hs index b1618d3..5265d57 100644 --- a/frontend/app/Schema.hs +++ b/frontend/app/Schema.hs @@ -1,3 +1,5 @@ +{-# OPTIONS_GHC -fno-warn-type-defaults #-} + module Schema ( Schema, viewSchema, @@ -6,22 +8,26 @@ module Schema ) where -#ifdef ghcjs_HOST_OS -import Data.Text qualified as T -#endif +import ACMS.API.REST.Collection.Paginated (Paginated (..)) import Control.Applicative ((<|>)) import Data.Aeson qualified as A +import Data.Aeson.Encoding.Internal qualified as AE import Data.Aeson.Key qualified as AK import Data.Aeson.KeyMap qualified as AM -import Data.List import Data.Map qualified as M import Data.Maybe import Data.Scientific (fromFloatDigits) import Data.Set qualified as S +import Data.Text qualified as T +import Data.Time.Clock +import Data.Time.Format +import Data.Time.Format.ISO8601 import Form qualified as F import Miso import Miso.String (MisoString, fromMisoString, intercalate, toMisoString) import Route +import Safe +import Text.Printf data Schema = Schema { id :: MisoString, @@ -45,45 +51,61 @@ instance A.FromJSON Schema where #ifdef ghcjs_HOST_OS instance A.FromJSONKey MisoString where - parseJSON = fromMisoString @T.Text <$> parseJSON + fromJSONKey = A.FromJSONKeyText toMisoString + +instance A.ToJSONKey MisoString where + toJSONKey = + A.ToJSONKeyText + (AK.fromText . fromMisoString) + (AE.key . AK.fromText . fromMisoString) #endif data Property - = Type MisoString + = Type MisoString (Maybe MisoString) | Reference MisoString + | Union [MisoString] deriving (Show, Eq) instance A.FromJSON Property where parseJSON = A.withObject "Property" $ \v -> - (Type <$> v A..: "type") + (Type <$> v A..: "type" <*> v A..:? "format") <|> (Reference <$> v A..: "$ref") + <|> (fmap Union $ traverse (A..: "type") =<< v A..: "oneOf") viewSchema :: Schema -> View action viewSchema schema = ol_ [] $ ( \(k, v) -> - li_ [] $ - [ text (toMisoString k), - text ":", - text - ( case v of - Type v -> toMisoString v - Reference v -> "reference to " <> toMisoString v - ), - text (if k `S.member` schema.required then "" else "?") - ] + let v' = case v of + Type "string" (Just "date-time") -> "datetime" + Type v Nothing -> toMisoString v + Type v (Just f) -> toMisoString v <> " (" <> f <> ")" + Reference v -> "reference to " <> toMisoString v + Union vs -> Miso.String.intercalate " or " vs + required = k `S.member` schema.required + in li_ [] $ + [ text (toMisoString k), + text + ( ":" + <> ( if ' ' `T.elem` fromMisoString v' && not required + then "(" <> v' <> ")" + else v' + ) + <> (if required then "" else "?") + ) + ] ) <$> (M.toList schema.properties) -schemaTable :: MisoString -> Schema -> [A.Object] -> View action -schemaTable collection schema values = - table_ [] [thead, tbody] +schemaTable :: MisoString -> Schema -> Paginated A.Object -> View action +schemaTable collection schema paginated = + table_ [] [thead, tbody, tfoot] where thead = thead_ [] $ [ tr_ [] $ [ th_ [] [text (toMisoString k)] - | k <- M.keys schema.properties + | k <- M.keys schema.properties ] ] tbody = @@ -91,45 +113,109 @@ schemaTable collection schema values = [ tr_ [] [ td_ [] $ - [ case (k, getO (AK.fromText (fromMisoString k)) value) of - ("$fileName", A.String fn) -> + [ case (k, p, getO (AK.fromText (fromMisoString k)) value) of + ("$id", _, A.String fn) -> a_ [ href_ (routeToMisoString (EditValue collection (toMisoString fn))) ] [ text (toMisoString fn) ] - (_, v) -> + (_, Type "string" (Just "date-time"), v) -> + text $ + case v of + A.String + (iso8601ParseM @Maybe @UTCTime . T.unpack -> Just t) -> + toMisoString (formatTime defaultTimeLocale "%c" t) + _ -> toMisoString (A.encode v) + (_, _, v) -> text $ case v of A.String s -> toMisoString s _ -> toMisoString (A.encode v) ] - | k <- M.keys schema.properties + | (k, p) <- M.assocs schema.properties ] - | value <- values + | value <- paginated.data_ ] + tfoot = + let page, lastPage, perPage :: Int + page = 1 + lastPage = ceiling (fromIntegral paginated.count / fromIntegral perPage) + perPage = 15 + in tfoot_ [] $ + [ tr_ [] $ + [ td_ [colspan_ "999"] $ + [ text (toMisoString (printf "Page %d of %d (%d total results)" page lastPage paginated.count :: String)) + ] + ] + ] schemaForm :: Schema -> F.Form A.Object A.Object schemaForm schema = - let handleOptional k toJson form - | toMisoString (AK.toText k) `S.member` schema.required = toJson <$> form - | otherwise = maybe A.Null toJson <$> F.optional form - typeForm k (Type "number") = - Just $ handleOptional k (A.Number . fromFloatDigits) $ F.inputNumber (toMisoString (AK.toString k)) - typeForm k (Type "string") = - Just $ - handleOptional k (A.String . fromMisoString) $ - F.inputText (toMisoString (AK.toString k)) - typeForm _ (Reference _) = Nothing - in fmap mergeJson . sequence . catMaybes $ - ( \((AK.fromText . fromMisoString) -> k, v) -> - fmap (AM.singleton k) - . F.mapValues (getO k) (setO k) - . F.mapValues fromJson toJson - <$> typeForm k v - ) - <$> (M.toList schema.properties) + fmap mergeJson . sequence . catMaybes $ + ( \((AK.fromText . fromMisoString) -> k, v) -> + case v of + Type "string" Nothing -> + Just $ + if toMisoString (AK.toText k) `S.member` schema.required + then + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) $ + fmap (A.String . fromMisoString) . F.mapValues fromJson toJson $ + F.inputText (toMisoString (AK.toString k)) + ) + else + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) + $ fmap (maybe A.Null (A.String . fromMisoString)) + . F.mapValues fromJson toJson + $ F.optional (F.inputText (toMisoString (AK.toString k))) + ) + Type "number" Nothing -> + Just $ + if toMisoString (AK.toText k) `S.member` schema.required + then + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) $ + fmap ((A.Number . fromFloatDigits)) . F.mapValues fromJson toJson $ + F.inputNumber (toMisoString (AK.toString k)) + ) + else + AM.singleton k + <$> ( F.mapValues (getO k) (setO k) + $ fmap (maybe A.Null (A.Number . fromFloatDigits)) + . F.mapValues fromJson toJson + $ F.optional (F.inputNumber (toMisoString (AK.toString k))) + ) + Reference _ -> Nothing + Union (map F.stringToTypeName -> typeStrings) -> + let inputFromOutput = \case + A.String x -> pure (F.StringType, M.singleton F.StringType (toMisoString x)) + A.Number x -> pure (F.NumberType, M.singleton F.NumberType (toMisoString (show x))) + _ -> fail "" + inputFromInput = A.fromJSON + inputDef = + ( fromMaybe F.StringType (headMay typeStrings), + M.empty + ) + in Just $ + if toMisoString (AK.toText k) `S.member` schema.required + then + AM.singleton k + <$> ( fmap A.toJSON $ + F.mapValues (getInput k inputFromOutput inputFromInput inputDef) (setInput k A.toJSON) $ + F.inputUnion (toMisoString (AK.toString k)) typeStrings + ) + else + AM.singleton k + <$> ( fmap A.toJSON $ + F.mapValues (getInput k inputFromOutput inputFromInput inputDef) (setInput k A.toJSON) $ + F.optional (F.inputUnion (toMisoString (AK.toString k)) typeStrings) + ) + _ -> Nothing + ) + <$> (M.toList schema.properties) mergeJson :: [A.Object] -> A.Object mergeJson = foldl' mergeObject AM.empty @@ -139,15 +225,41 @@ mergeObject kvs kvs' = AM.union kvs kvs' fromJson :: A.Value -> MisoString fromJson (A.String x) = toMisoString x -fromJson (A.Number x) = toMisoString (show x) fromJson _ = "" toJson :: MisoString -> A.Value -> A.Value -toJson x _ - | otherwise = A.String (fromMisoString x) +toJson x _ = A.String (fromMisoString x) getO :: AK.Key -> A.Object -> A.Value getO k kvs = fromMaybe A.Null (AM.lookup k kvs) setO :: AK.Key -> A.Value -> A.Object -> A.Object setO k v kvs = AM.insert k v kvs + +-- | Used in `mapValues (getInput ...) (setInput ..)`. +-- +-- Suppose *input" is an `A.Object`, this function is concerned with getting a sub-form model from within that object, given a *key* and the *subform's type*. +-- +-- The input model can be in three different states: +-- +-- - (1) The input object has been converted from an output model, no modification has been done on it. The value in question corresponds to the output model, which may be different from the corresponding form value. +-- - (2) The input object had been modified, and so the value in question conforms structurally to the input value. +-- - (3) The input object is in an undefined state, ie. this should not happen. +-- +-- The first three arguments `(A.Value -> A.Result i)`, `(A.Value -> A.Result i)`, `i` correspond to these cases and are tested for in order of (2), (1), (3). +getInput :: + AK.Key -> + (A.Value -> A.Result i) -> + (A.Value -> A.Result i) -> + i -> + A.Object -> + i +getInput k f1 f2 f3 kvs = + let v = getO k kvs + in case f2 v <|> f1 v of + A.Error _ -> f3 + A.Success x -> x + +setInput :: AK.Key -> (i -> A.Value) -> i -> A.Object -> A.Object +setInput k f i kvs = + setO k (f i) kvs diff --git a/frontend/frontend.cabal b/frontend/frontend.cabal index baa11e4..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, @@ -50,6 +49,7 @@ executable frontend scientific, split, text, + time, utf8-string if !arch(javascript) diff --git a/nix/sources.json b/nix/sources.json index bef3f88..d2b20a1 100644 --- a/nix/sources.json +++ b/nix/sources.json @@ -2,7 +2,7 @@ "json2sql": { "branch": "main", "repo": "git@code.nomath.org:~/json2sql", - "rev": "ea241da2457aa9992cad7d64796d1ef40b0264b0", + "rev": "1e75f8998e8ba9c88ce6dbf7e809e30c233eb611", "type": "git" }, "nixpkgs": { @@ -11,10 +11,10 @@ "homepage": null, "owner": "NixOS", "repo": "nixpkgs", - "rev": "a7d95e2b0029b8ee30facbe664b62968c59b46a6", - "sha256": "0vprwa4h794bjd92arjnzdm8lb8mg3xvpfmqbk723zcxnvmpnafn", + "rev": "632f04521e847173c54fa72973ec6c39a371211c", + "sha256": "16l9l6jbx2xy751p2nbz14fd9qgk9qsns38pihr5g12fk7361fsi", "type": "tarball", - "url": "https://github.com/NixOS/nixpkgs/archive/a7d95e2b0029b8ee30facbe664b62968c59b46a6.tar.gz", + "url": "https://github.com/NixOS/nixpkgs/archive/632f04521e847173c54fa72973ec6c39a371211c.tar.gz", "url_template": "https://github.com/<owner>/<repo>/archive/<rev>.tar.gz" }, "sh": { diff --git a/pkgs/default.nix b/pkgs/default.nix index 7dce871..fd7290f 100644 --- a/pkgs/default.nix +++ b/pkgs/default.nix @@ -1,17 +1,40 @@ -{ sources ? import ../nix/sources.nix }: +{ sources ? import ../nix/sources.nix +}: (self: super: - let pkgs = self; in + let + pkgs = self; + haskellLib = pkgs.haskell.lib; + in { haskell = super.haskell // { - packageOverrides = self: super: { - 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; - }; + packageOverrides = pkgs.lib.composeManyExtensions [ + super.haskell.packageOverrides + (self: super: { + acms = (self.callCabal2nix "acms" ../acms { }).overrideAttrs (oldAttrs: + pkgs.lib.optionalAttrs pkgs.stdenv.isx86_64 + { + nativeBuildInputs = (oldAttrs.nativeBuildInputs or [ ]) ++ [ pkgs.makeWrapper ]; + postInstall = (oldAttrs.postInstall or "") + '' + wrapProgram $out/bin/acms \ + --set-default APPROOT ${pkgs.pkgsCross.ghcjs.haskell.packages.ghc910.frontend} + ''; + }); + astore = haskellLib.doJailbreak (self.callCabal2nix "astore" sources.json2sql { }); + autotypes = self.callCabal2nix "autotypes" ../autotypes { }; + frontend = (self.callCabal2nix "frontend" ../frontend { }).overrideAttrs (_: { + installPhase = '' + cp -a dist/build/frontend/frontend.jsexe $out + ''; + }); + sh = haskellLib.dontCheck (self.callCabal2nix "sh" sources.sh { }); + repline = haskellLib.doJailbreak super.repline; + uuid = haskellLib.doJailbreak super.uuid; + websockets = haskellLib.doJailbreak super.websockets; + hinotify = super.hinotify.overrideAttrs (_: { + version = "0.4.2"; + src = builtins.fetchTarball "https://hackage.haskell.org/package/hinotify-0.4.2/hinotify-0.4.2.tar.gz"; + }); + }) + ]; }; }) @@ -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 ' @@ -81,4 +81,5 @@ in { api-reference = makeDocTest "api-reference" ./docs/api-reference.md; get-started-cli = makeDocTest "get-started-cli" ./docs/get-started-cli.md; + tutorial-achat = makeDocTest "tutorial-achat" ./docs/tutorial-achat.md; } |