diff options
Diffstat (limited to 'backend')
| -rw-r--r-- | backend/LICENSE | 30 | ||||
| -rw-r--r-- | backend/app/Main.hs | 510 | ||||
| -rw-r--r-- | backend/backend.cabal | 86 | ||||
| -rw-r--r-- | backend/lib/ACMS/API/Fetch.hs | 63 | ||||
| -rw-r--r-- | backend/lib/ACMS/API/Query.hs | 17 | ||||
| -rw-r--r-- | backend/lib/ACMS/API/REST.hs | 33 | ||||
| -rw-r--r-- | backend/lib/ACMS/API/REST/Collection.hs | 51 | ||||
| -rw-r--r-- | backend/lib/ACMS/API/REST/Collection/Paginated.hs | 33 |
8 files changed, 0 insertions, 823 deletions
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 |