diff --git a/CHANGELOG.md b/CHANGELOG.md new file mode 100644 --- /dev/null +++ b/CHANGELOG.md diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2020 Francesco Burelli + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/cbits/finalizer.c b/cbits/finalizer.c new file mode 100644 --- /dev/null +++ b/cbits/finalizer.c @@ -0,0 +1,8 @@ +#include "finalizer.h" +#include + +void finalizerJQL(JQL* jql) { + JQL* jqlCopy = jql; + jql_destroy(jql); + free(jqlCopy); +} diff --git a/cbits/finalizer.h b/cbits/finalizer.h new file mode 100644 --- /dev/null +++ b/cbits/finalizer.h @@ -0,0 +1,3 @@ +#include + +void finalizerJQL(JQL* jql); diff --git a/ejdb2-binding.cabal b/ejdb2-binding.cabal new file mode 100644 --- /dev/null +++ b/ejdb2-binding.cabal @@ -0,0 +1,79 @@ +cabal-version: 2.4 +name: ejdb2-binding +category: Database +description: Binding to EJDB2 C library, an embedded JSON noSQL database. Package requires libejdb2 to build. Please see the README on GitHub at +synopsis: Binding to EJDB2 C library, an embedded JSON noSQL database +version: 0.1.0.0 +license: MIT +license-file: LICENSE +homepage: https://github.com/cescobaz/ejdb2haskell#readme +bug-reports: https://github.com/cescobaz/ejdb2haskell/issues +copyright: 2020 Francesco Burelli +author: Francesco Burelli +maintainer: francesco.burelli@protonmail.com +extra-source-files: CHANGELOG.md + cbits/finalizer.h + cbits/finalizer.c + test/read-only-db + +source-repository head + type: git + location: https://github.com/cescobaz/ejdb2haskell + +library + exposed-modules: Database.EJDB2 + , Database.EJDB2.Query + , Database.EJDB2.Meta + , Database.EJDB2.CollectionMeta + , Database.EJDB2.IndexMeta + , Database.EJDB2.Options + , Database.EJDB2.HTTP + , Database.EJDB2.WAL + , Database.EJDB2.KV + other-modules: + Database.EJDB2.JBL + , Database.EJDB2.Result + , Database.EJDB2.IndexMode + , Database.EJDB2.QueryConstructor + , Database.EJDB2.Bindings.EJDB2 + , Database.EJDB2.Bindings.JQL + , Database.EJDB2.Bindings.JBL + , Database.EJDB2.Bindings.Types.EJDB + , Database.EJDB2.Bindings.Types.EJDBExec + , Database.EJDB2.Bindings.Types.EJDBDoc + build-depends: base ^>=4.12.0.0 + , bytestring ^>=0.10.10.0 + , aeson ^>=1.4.6.0 + , unordered-containers ^>=0.2.10.0 + build-tool-depends: hsc2hs:hsc2hs + extra-libraries: ejdb2 + pkgconfig-depends: libejdb2 + c-sources: cbits/finalizer.c + install-includes: finalizer.h + include-dirs: cbits + hs-source-dirs: src + default-language: Haskell2010 + +test-suite ejdb2haskell-test + default-language: Haskell2010 + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Main.hs + other-modules: + Asserts + Plant + GetTests + QueryTests + PutTests + DeleteTests + CollectionTests + IndexTests + OnlineBackupTests + build-depends: base ^>=4.12.0.0 + , tasty ^>=1.2.3 + , tasty-hunit ^>=0.10.0.2 + , aeson ^>=1.4.6.0 + , unordered-containers ^>=0.2.10.0 + , vector ^>=0.12.1.2 + , directory ^>=1.3.6.0 + , ejdb2-binding diff --git a/src/Database/EJDB2.hs b/src/Database/EJDB2.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2.hs @@ -0,0 +1,323 @@ +module Database.EJDB2 + ( init + , Database + , KV.readonlyOpenFlags + , KV.truncateOpenFlags + , KV.noTrimOnCloseOpenFlags + , minimalOptions + , open + , close + , getById + , getCount + , getList + , getList' + , putNew + , put + , mergeOrPut + , patch + , delete + , ensureCollection + , removeCollection + , renameCollection + , getMeta + , IndexMode.IndexMode + , IndexMode.uniqueIndexMode + , IndexMode.strIndexMode + , IndexMode.f64IndexMode + , IndexMode.i64IndexMode + , ensureIndex + , removeIndex + , onlineBackup + ) where + +import Control.Exception +import Control.Monad + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import Data.IORef +import Data.Int +import Data.Word + +import Database.EJDB2.Bindings.EJDB2 +import Database.EJDB2.Bindings.JBL +import Database.EJDB2.Bindings.Types.EJDB +import Database.EJDB2.Bindings.Types.EJDBDoc as EJDBDoc +import Database.EJDB2.Bindings.Types.EJDBExec as EJDBExec +import qualified Database.EJDB2.IndexMode as IndexMode +import Database.EJDB2.JBL +import qualified Database.EJDB2.KV as KV +import Database.EJDB2.Options as Options +import Database.EJDB2.Query +import Database.EJDB2.QueryConstructor +import Database.EJDB2.Result + +import Foreign +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc +import Foreign.Ptr +import Foreign.Storable + +import Prelude hiding ( init ) + +-- | Reference to database. You can create it by 'open'. +data Database = Database (Ptr EJDB) EJDB + +-- | Create minimal 'Options' for opening a database: just path to file and opening mode. +minimalOptions :: String -- ^ Database file path + -> [KV.OpenFlags] -- ^ Open mode + -> Options -- ^ Options to use in 'open' + +minimalOptions path openFlags = + Options.zero { kv = KV.zero { KV.path = Just path, KV.oflags = openFlags } + } + +{-| + ejdb2 initialization routine. + + /Must be called before using any of ejdb API function./ +-} +init :: IO () +init = c_ejdb_init >>= checkRC + +{-| + Open storage file. + + Storage can be opened only by one single process at time. + + /Remember to release database by 'close' when database is no longer required./ +-} +open :: Options -> IO Database +open opts = do + ejdbPtr <- malloc + optsB <- build opts + with optsB $ \optsPtr -> do + result <- decodeRC <$> c_ejdb_open optsPtr ejdbPtr + if result == Ok + then Database ejdbPtr <$> peek ejdbPtr + else free ejdbPtr >> fail (show result) + +{-| + Closes storage and frees up all resources. +-} +close :: Database -> IO () +close (Database ejdbPtr _) = do + result <- decodeRC <$> c_ejdb_close ejdbPtr + if result == Ok then free ejdbPtr else fail $ show result + +-- | Retrieve document identified by given id from collection. +getById :: Aeson.FromJSON a + => Database + -> String -- ^ Collection name + -> Int64 -- ^ Document identifier. Not zero + -> IO (Maybe a) +getById (Database _ ejdb) collection id = alloca $ \jblPtr -> + finally (do + rc <- withCString collection $ \cCollection -> + c_ejdb_get ejdb cCollection (CIntMax id) jblPtr + let result = decodeRC rc + case result of + Ok -> peek jblPtr >>= decode + ErrorNotFound -> return Nothing + _ -> fail $ show result) + (c_jbl_destroy jblPtr) + +-- | Executes a given query and returns the number of documents. +getCount :: Database -> Query -> IO Int64 +getCount (Database _ ejdb) (Query jql _ _) = alloca $ + \countPtr -> c_ejdb_count ejdb jql countPtr 0 >>= checkRC >> peek countPtr + >>= \(CIntMax int) -> return int + +{-| + Executes a given query and builds a query result as list of tuple with id and document. +-} +getList :: Aeson.FromJSON a => Database -> Query -> IO [(Int64, Maybe a)] +getList = exec Database.EJDB2.visitor + +visitor :: Aeson.FromJSON a => IORef [(Int64, Maybe a)] -> EJDBExecVisitor +visitor ref _ docPtr _ = do + doc <- peek docPtr + value <- decode (raw doc) + modifyIORef' ref $ \list -> (fromIntegral $ EJDBDoc.id doc, value) : list + return 0 + +{-| + Executes a given query and builds a query result as list of documents with id injected as attribute. +-} +getList' :: Aeson.FromJSON a => Database -> Query -> IO [Maybe a] +getList' = exec Database.EJDB2.visitor' + +visitor' :: Aeson.FromJSON a => IORef [Maybe a] -> EJDBExecVisitor +visitor' ref _ docPtr _ = do + doc <- peek docPtr + value <- decode' (raw doc) (fromIntegral $ EJDBDoc.id doc) + modifyIORef' ref $ \list -> value : list + return 0 + +exec :: (IORef [a] -> EJDBExecVisitor) -> Database -> Query -> IO [a] +exec visitor (Database _ ejdb) (Query jql _ _) = do + ref <- newIORef [] + visitor <- mkEJDBExecVisitor (visitor ref) + let exec = EJDBExec.zero { db = ejdb, q = jql, EJDBExec.visitor = visitor } + finally (with exec $ \execPtr -> do + c_ejdb_exec execPtr >>= checkRC + reverse <$> readIORef ref) + (freeHaskellFunPtr visitor) + +{-| + Save new document into collection under new generated identifier. +-} +putNew :: Aeson.ToJSON a + => Database + -> String -- ^ Collection name + -> a -- ^ Document + -> IO Int64 -- ^ New document identifier. Not zero + +putNew (Database _ ejdb) collection obj = encode obj $ + \doc -> withCString collection $ \cCollection -> alloca $ \idPtr -> + c_ejdb_put_new ejdb cCollection doc idPtr >>= checkRC >> peek idPtr + >>= \(CIntMax int) -> return int + +{-| + Save a given document under specified id. +-} +put :: Aeson.ToJSON a + => Database + -> String -- ^ Collection name + -> a -- ^ Document + -> Int64 -- ^ Document identifier. Not zero + -> IO () +put (Database _ ejdb) collection obj id = + encode obj $ \doc -> withCString collection $ \cCollection -> + c_ejdb_put ejdb cCollection doc (CIntMax id) >>= checkRC + +{-| + Apply JSON merge patch (rfc7396) to the document identified by id or insert new document under specified id. + + /This is an atomic operation./ +-} +mergeOrPut :: Aeson.ToJSON a + => Database + -> String -- ^ Collection name + -> a -- ^ JSON merge patch conformed to rfc7396 specification + -> Int64 -- ^ Document identifier. Not zero + -> IO () +mergeOrPut (Database _ ejdb) collection obj id = withCString collection $ + \cCollection -> BS.useAsCString (encodeToByteString obj) $ \jsonPatch -> + c_ejdb_merge_or_put ejdb cCollection jsonPatch (CIntMax id) >>= checkRC + +{-| + Apply rfc6902\/rfc7396 JSON patch to the document identified by id. +-} +patch :: Aeson.ToJSON a + => Database + -> String -- ^ Collection name + -> a -- ^ JSON patch conformed to rfc6902 or rfc7396 specification + -> Int64 -- ^ Document identifier. Not zero + -> IO () +patch (Database _ ejdb) collection obj id = withCString collection $ + \cCollection -> BS.useAsCString (encodeToByteString obj) $ \jsonPatch -> + c_ejdb_patch ejdb cCollection jsonPatch (CIntMax id) >>= checkRC + +{-| + Remove document identified by given id from collection coll. +-} +delete :: Database + -> String -- ^ Collection name + -> Int64 -- ^ Document identifier. Not zero + -> IO () +delete (Database _ ejdb) collection id = withCString collection $ + \cCollection -> c_ejdb_del ejdb cCollection (CIntMax id) >>= checkRC + +{-| + Create collection with given name if it has not existed before +-} +ensureCollection :: Database + -> String -- ^ Collection name + -> IO () +ensureCollection (Database _ ejdb) collection = + withCString collection (c_ejdb_ensure_collection ejdb >=> checkRC) + +{-| + Remove collection under the given name. +-} +removeCollection :: Database + -> String -- ^ Collection name + -> IO () +removeCollection (Database _ ejdb) collection = + withCString collection (c_ejdb_remove_collection ejdb >=> checkRC) + +{-| + Rename collection to new name. +-} +renameCollection :: Database + -> String -- ^ Old collection name + -> String -- ^ New collection name + -> IO () +renameCollection (Database _ ejdb) collection newCollection = + withCString collection $ \cCollection -> + withCString newCollection + (c_ejdb_rename_collection ejdb cCollection >=> checkRC) + +{-| + Returns JSON document describing database structure. You can use the convenient data 'Database.EJDB2.Meta.Meta' +-} +getMeta :: Aeson.FromJSON a + => Database + -> IO (Maybe a) -- ^ JSON object describing ejdb storage. See data 'Database.EJDB2.Meta.Meta' + +getMeta (Database _ ejdb) = alloca $ \jblPtr -> c_ejdb_get_meta ejdb jblPtr + >>= checkRC >> finally (peek jblPtr >>= decode) (c_jbl_destroy jblPtr) + +{-| + Create index with specified parameters if it has not existed before. + + /Index path must be fully specified as rfc6901 JSON pointer and must not countain unspecified *\/** element in middle sections./ + + > ensureIndex database "mycoll" "/address/street" [uniqueIndexMode | strIndexMode] +-} +ensureIndex :: Database + -> String -- ^ Collection name + -> String -- ^ rfc6901 JSON pointer to indexed field + -> [IndexMode.IndexMode] -- ^ Index mode + -> IO () +ensureIndex (Database _ ejdb) collection path indexMode = + withCString collection $ \cCollection -> withCString path $ + \cPath -> c_ejdb_ensure_index ejdb cCollection cPath mode >>= checkRC + where + mode = IndexMode.unIndexMode $ IndexMode.combineIndexMode indexMode + +{-| + Remove index if it has existed before. +-} +removeIndex :: Database + -> String -- ^ Collection name + -> String -- ^ rfc6901 JSON pointer to indexed field + -> [IndexMode.IndexMode] -- ^ Index mode + -> IO () +removeIndex (Database _ ejdb) collection path indexMode = + withCString collection $ \cCollection -> withCString path $ + \cPath -> c_ejdb_remove_index ejdb cCollection cPath mode >>= checkRC + where + mode = IndexMode.unIndexMode $ IndexMode.combineIndexMode indexMode + +{-| + Creates an online database backup image and copies it into the specified target file. + During online backup phase read/write database operations are allowed and not + blocked for significant amount of time. Backup finish time is placed into result + as number of milliseconds since epoch. + + Online backup guaranties what all records before timestamp will + be stored in backup image. Later, online backup image can be + opened as ordinary database file. + + /In order to avoid deadlocks: close all opened database cursors before calling this method or do call in separate thread./ +-} +onlineBackup :: Database + -> String -- ^ Backup file path + -> IO Word64 -- ^ Backup completion timestamp + +onlineBackup (Database _ ejdb) filePath = withCString filePath $ \cFilePath -> + alloca $ \timestampPtr -> c_ejdb_online_backup ejdb timestampPtr cFilePath + >>= checkRC >> peek timestampPtr >>= \(CUIntMax t) -> return t diff --git a/src/Database/EJDB2/Bindings/EJDB2.hs b/src/Database/EJDB2/Bindings/EJDB2.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Bindings/EJDB2.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Database.EJDB2.Bindings.EJDB2 where + +import Database.EJDB2.Bindings.JBL +import Database.EJDB2.Bindings.JQL +import Database.EJDB2.Bindings.Types.EJDB +import Database.EJDB2.Bindings.Types.EJDBDoc +import Database.EJDB2.Bindings.Types.EJDBExec +import Database.EJDB2.Options +import Database.EJDB2.Result + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_init" c_ejdb_init :: IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_open" c_ejdb_open + :: Ptr OptionsB -> Ptr EJDB -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_close" c_ejdb_close + :: Ptr EJDB -> IO RC + +foreign import ccall "wrapper" mkEJDBExecVisitor + :: EJDBExecVisitor -> IO EJDB_EXEC_VISITOR + +foreign import ccall "ejdb2/ejdb2.h ejdb_exec" c_ejdb_exec + :: Ptr EJDBExec -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_get" c_ejdb_get + :: EJDB -> CString -> CIntMax -> Ptr JBL -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_count" c_ejdb_count + :: EJDB -> JQL -> Ptr CIntMax -> CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_put_new" c_ejdb_put_new + :: EJDB -> CString -> JBL -> Ptr CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_put" c_ejdb_put + :: EJDB -> CString -> JBL -> CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_merge_or_put" c_ejdb_merge_or_put + :: EJDB -> CString -> CString -> CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_patch" c_ejdb_patch + :: EJDB -> CString -> CString -> CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_del" c_ejdb_del + :: EJDB -> CString -> CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_ensure_collection" c_ejdb_ensure_collection + :: EJDB -> CString -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_remove_collection" c_ejdb_remove_collection + :: EJDB -> CString -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_rename_collection" c_ejdb_rename_collection + :: EJDB -> CString -> CString -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_ensure_index" c_ejdb_ensure_index + :: EJDB -> CString -> CString -> CUChar -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_remove_index" c_ejdb_remove_index + :: EJDB -> CString -> CString -> CUChar -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_get_meta" c_ejdb_get_meta + :: EJDB -> Ptr JBL -> IO RC + +foreign import ccall unsafe "ejdb2/ejdb2.h ejdb_online_backup" c_ejdb_online_backup + :: EJDB -> Ptr CUIntMax -> CString -> IO RC diff --git a/src/Database/EJDB2/Bindings/JBL.hs b/src/Database/EJDB2/Bindings/JBL.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Bindings/JBL.hs @@ -0,0 +1,30 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.Bindings.JBL where + +import Database.EJDB2.Result + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +type JBL = Ptr () + +type JBLNode = Ptr () + +type JBLPrintFlags = CUChar + +type JBLJSONPrinter = Ptr CChar -> CInt -> CChar -> CInt -> Ptr () -> IO RC + +foreign import ccall "wrapper" mkJBLJSONPrinter + :: JBLJSONPrinter -> IO (FunPtr JBLJSONPrinter) + +foreign import ccall "ejdb2/jbl.h jbl_as_json" c_jbl_as_json + :: JBL -> FunPtr JBLJSONPrinter -> Ptr () -> JBLPrintFlags -> IO RC + +foreign import ccall unsafe "ejdb2/jbl.h jbl_destroy" c_jbl_destroy + :: Ptr JBL -> IO () + +foreign import ccall "ejdb2/jbl.h jbl_from_json" c_jbl_from_json + :: Ptr JBL -> CString -> IO RC + diff --git a/src/Database/EJDB2/Bindings/JQL.hs b/src/Database/EJDB2/Bindings/JQL.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Bindings/JQL.hs @@ -0,0 +1,38 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Database.EJDB2.Bindings.JQL where + +import Database.EJDB2.Result + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +type JQL = Ptr () + +foreign import ccall unsafe "ejdb2/jql.h jql_create" c_jql_create + :: Ptr JQL -> CString -> CString -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_set_bool" c_jql_set_bool + :: JQL -> CString -> CInt -> CBool -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_set_i64" c_jql_set_i64 + :: JQL -> CString -> CInt -> CIntMax -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_set_f64" c_jql_set_f64 + :: JQL -> CString -> CInt -> CDouble -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_set_str" c_jql_set_str + :: JQL -> CString -> CInt -> CString -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_set_regexp" c_jql_set_regexp + :: JQL -> CString -> CInt -> CString -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_set_null" c_jql_set_null + :: JQL -> CString -> CInt -> IO RC + +foreign import ccall unsafe "ejdb2/jql.h jql_destroy" c_jql_destroy + :: Ptr JQL -> IO () + +foreign import ccall "finalizer.h &finalizerJQL" p_finalizerJQL + :: FunPtr (Ptr JQL -> IO ()) diff --git a/src/Database/EJDB2/Bindings/Types/EJDB.hs b/src/Database/EJDB2/Bindings/Types/EJDB.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Bindings/Types/EJDB.hs @@ -0,0 +1,5 @@ +module Database.EJDB2.Bindings.Types.EJDB where + +import Foreign + +type EJDB = Ptr () diff --git a/src/Database/EJDB2/Bindings/Types/EJDBDoc.hsc b/src/Database/EJDB2/Bindings/Types/EJDBDoc.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Bindings/Types/EJDBDoc.hsc @@ -0,0 +1,33 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.Bindings.Types.EJDBDoc where + +import Foreign +import Foreign.C.Types + +import Database.EJDB2.Bindings.JBL + +#include + +data EJDBDoc = EJDBDoc { id :: !CIntMax + , raw :: !JBL + , node :: !JBLNode + , next :: !(Ptr EJDBDoc) + , prev :: !(Ptr EJDBDoc) } + +instance Storable EJDBDoc where + sizeOf _ = #{size struct _EJDB_DOC} + alignment _ = #{alignment struct _EJDB_DOC} + peek ptr = do + id <- #{peek struct _EJDB_DOC, id} ptr + raw <- #{peek struct _EJDB_DOC, raw} ptr + node <- #{peek struct _EJDB_DOC, node} ptr + next <- #{peek struct _EJDB_DOC, next} ptr + prev <- #{peek struct _EJDB_DOC, prev} ptr + return $ EJDBDoc id raw node next prev + poke ptr (EJDBDoc id raw node next prev) = do + #{poke struct _EJDB_DOC, id} ptr id + #{poke struct _EJDB_DOC, raw} ptr raw + #{poke struct _EJDB_DOC, node} ptr node + #{poke struct _EJDB_DOC, next} ptr next + #{poke struct _EJDB_DOC, prev} ptr prev diff --git a/src/Database/EJDB2/Bindings/Types/EJDBExec.hsc b/src/Database/EJDB2/Bindings/Types/EJDBExec.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Bindings/Types/EJDBExec.hsc @@ -0,0 +1,80 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.Bindings.Types.EJDBExec where + + +import Prelude hiding ( log ) + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +import Database.EJDB2.Bindings.Types.EJDB +import Database.EJDB2.Bindings.JQL +import Database.EJDB2.Bindings.Types.EJDBDoc +import Database.EJDB2.Result + +#include + +type EJDBExecVisitor = Ptr EJDBExec -> Ptr EJDBDoc -> Ptr CIntMax -> IO RC +type EJDB_EXEC_VISITOR = FunPtr EJDBExecVisitor + +type IWXSTR = Ptr () +type IWPOOL = Ptr () + +data EJDBExec = EJDBExec { db :: !EJDB + , q :: !JQL + , visitor :: !EJDB_EXEC_VISITOR + , opaque :: !(Ptr ()) + , skip :: !CIntMax + , limit :: !CIntMax + , cnt :: !CIntMax + , log :: !IWXSTR + , pool :: !IWPOOL } + +minimal :: EJDB -> JQL -> EJDB_EXEC_VISITOR -> EJDBExec +minimal db q visitor = EJDBExec { db = db + , q = q + , visitor = visitor + , opaque = nullPtr + , skip = 0 + , limit = 0 + , cnt = 0 + , log = nullPtr + , pool = nullPtr } + +zero :: EJDBExec +zero = EJDBExec { db = nullPtr + , q = nullPtr + , visitor = nullFunPtr + , opaque = nullPtr + , skip = 0 + , limit = 0 + , cnt = 0 + , log = nullPtr + , pool = nullPtr } + +instance Storable EJDBExec where + sizeOf _ = #{size EJDB_EXEC} + alignment _ = #{alignment EJDB_EXEC} + peek ptr = do + db <- #{peek EJDB_EXEC, db} ptr + q <- #{peek EJDB_EXEC, q} ptr + visitor <- #{peek EJDB_EXEC, visitor} ptr + opaque <- #{peek EJDB_EXEC, opaque} ptr + skip <- #{peek EJDB_EXEC, skip} ptr + limit <- #{peek EJDB_EXEC, limit} ptr + cnt <- #{peek EJDB_EXEC, cnt} ptr + log <- #{peek EJDB_EXEC, log} ptr + pool <- #{peek EJDB_EXEC, pool} ptr + return $ EJDBExec db q visitor opaque skip limit cnt log pool + poke ptr (EJDBExec db q visitor opaque skip limit cnt log pool) = do + #{poke EJDB_EXEC, db} ptr db + #{poke EJDB_EXEC, q} ptr q + #{poke EJDB_EXEC, visitor} ptr visitor + #{poke EJDB_EXEC, opaque} ptr opaque + #{poke EJDB_EXEC, skip} ptr skip + #{poke EJDB_EXEC, limit} ptr limit + #{poke EJDB_EXEC, cnt} ptr cnt + #{poke EJDB_EXEC, log} ptr log + #{poke EJDB_EXEC, pool} ptr pool diff --git a/src/Database/EJDB2/CollectionMeta.hs b/src/Database/EJDB2/CollectionMeta.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/CollectionMeta.hs @@ -0,0 +1,23 @@ + +{-# LANGUAGE DeriveGeneric #-} + +module Database.EJDB2.CollectionMeta where + +import Data.Aeson ( FromJSON ) +import Data.Int + +import Database.EJDB2.IndexMeta + +import GHC.Generics + +-- | Metadata about collection. +data CollectionMeta = + CollectionMeta { name :: String -- ^ Collection name + , dbid :: Int64 -- ^ Collection database ID + , rnum :: Int64 -- ^ Number of documents in collection + , indexes :: [IndexMeta] -- ^ List of collections indexes + } + deriving ( Eq, Generic, Show ) + +instance FromJSON CollectionMeta + diff --git a/src/Database/EJDB2/HTTP.hsc b/src/Database/EJDB2/HTTP.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/HTTP.hsc @@ -0,0 +1,105 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.HTTP + ( Options(..) + , zero + , OptionsB + , options + , build + ) where + +import Foreign +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Utils +import Data.Int + +#include + +-- | EJDB HTTP\/Websocket Server options. +data Options = Options { enabled :: !Bool -- ^ If HTTP\/Websocket endpoint enabled. Default: false + , port :: !Int32 -- ^ Listen port number, required + , bind :: Maybe String -- ^ Listen IP\/host. Default: /localhost/ + , accessToken :: Maybe String -- ^ Server access token passed in /X-Access-Token/ header. Default: zero + , blocking :: !Bool -- ^ Block 'open' thread until http service finished. +-- Otherwise HTTP servee started in background. + + , readAnon :: !Bool -- ^ Allow anonymous read-only database access + , maxBodySize :: !Word64 -- ^ Maximum WS\/HTTP API body size. Default: 64Mb, Min: 512K + } + +-- | Create default 'Options' +zero :: Options +zero = Options { enabled = False + , port = 0 + , bind = Nothing + , accessToken = Nothing + , blocking = False + , readAnon = False + , maxBodySize = 0 + } + +-- | Storable version of Options +data OptionsB = OptionsB { options :: Options + , bindPtr :: ForeignPtr CChar + , accessTokenPtr :: ForeignPtr CChar + , accessTokenLen :: CSize + } + +-- | Create Storable version of Options +build :: Options -> IO OptionsB +build options = do + bindPtr <- maybeNew newCString (bind options) + >>= newForeignPtr finalizerFree + (accessTokenPtr, accessTokenLen) <- case (accessToken options) of + Nothing -> return (nullPtr, 0) + Just value -> newCStringLen value + accessTokenFPtr <- newForeignPtr finalizerFree accessTokenPtr + return OptionsB { options = options + , bindPtr = bindPtr + , accessTokenPtr = accessTokenFPtr + , accessTokenLen = CSize $ fromIntegral accessTokenLen + } + + +instance Storable OptionsB where + sizeOf _ = #{size EJDB_HTTP} + alignment _ = #{alignment EJDB_HTTP} + peek ptr = do + enabled <- #{peek EJDB_HTTP, enabled} ptr :: IO CInt + port <- #{peek EJDB_HTTP, port} ptr + bindPtr <- #{peek EJDB_HTTP, bind} ptr + bindFPtr <- newForeignPtr finalizerFree nullPtr + bind <- maybePeek peekCString bindPtr + access_token <- #{peek EJDB_HTTP, access_token} ptr + access_token_len <- #{peek EJDB_HTTP, access_token_len} ptr + accessTokenFPtr <- newForeignPtr finalizerFree nullPtr + accessToken <- maybePeek (\ptr -> peekCStringLen (ptr, access_token_len)) access_token + blocking <- #{peek EJDB_HTTP, blocking} ptr :: IO CInt + read_anon <- #{peek EJDB_HTTP, read_anon} ptr :: IO CInt + max_body_size <- #{peek EJDB_HTTP, max_body_size} ptr + return $ OptionsB + (Options + (toBool enabled) + port + bind + accessToken + (toBool blocking) + (toBool read_anon) + max_body_size) + bindFPtr accessTokenFPtr (CSize $ fromIntegral access_token_len) + poke ptr (OptionsB + (Options enabled port _ _ blocking read_anon max_body_size) + bindPtr accessTokenPtr accessTokenLen) = do + #{poke EJDB_HTTP, enabled} ptr (fromBool enabled :: CInt) + #{poke EJDB_HTTP, port} ptr port + withForeignPtr bindPtr $ \cBind -> + #{poke EJDB_HTTP, bind} ptr cBind + withForeignPtr accessTokenPtr $ \access_token -> + #{poke EJDB_HTTP, access_token} ptr access_token + #{poke EJDB_HTTP, access_token_len} ptr accessTokenLen + #{poke EJDB_HTTP, blocking} ptr (fromBool blocking :: CInt) + #{poke EJDB_HTTP, read_anon} ptr (fromBool read_anon :: CInt) + #{poke EJDB_HTTP, max_body_size} ptr max_body_size + + diff --git a/src/Database/EJDB2/IndexMeta.hs b/src/Database/EJDB2/IndexMeta.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/IndexMeta.hs @@ -0,0 +1,21 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Database.EJDB2.IndexMeta where + +import Data.Aeson ( FromJSON ) +import Data.Int + +import GHC.Generics + +-- | Metadata abount collection index. +data IndexMeta = + IndexMeta { ptr :: String -- ^ rfc6901 JSON pointer to indexed field + , mode :: Int64 -- ^ Index mode + , idbf :: Int64 -- ^ Index flags + , dbid :: Int64 -- ^ Index database ID + , rnum :: Int64 -- ^ Number records stored in index database + } + deriving ( Eq, Generic, Show ) + +instance FromJSON IndexMeta + diff --git a/src/Database/EJDB2/IndexMode.hsc b/src/Database/EJDB2/IndexMode.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/IndexMode.hsc @@ -0,0 +1,38 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.IndexMode where + + +import Foreign +import Foreign.C.String +import Foreign.C.Types + + +#include +-- | Index creation mode. +newtype IndexMode = IndexMode { unIndexMode :: CUChar } + +-- | Marks index is unique, no duplicated values allowed. +uniqueIndexMode = IndexMode #{const EJDB_IDX_UNIQUE} +-- | Index values have string type. +-- +-- Type conversion will be performed on atempt to save value with other type. +strIndexMode = IndexMode #{const EJDB_IDX_STR} +-- | Index values have signed integer 64 bit wide type. +-- +-- Type conversion will be performed on atempt to save value with other type. +i64IndexMode = IndexMode #{const EJDB_IDX_I64} +-- | Index value have floating point type. +-- /Internally floating point numbers are converted to string with precision of 6 digits after decimal point./ +f64IndexMode = IndexMode #{const EJDB_IDX_F64} + +allIndexMode :: [IndexMode] +allIndexMode = [uniqueIndexMode, strIndexMode, i64IndexMode , f64IndexMode] + +combineIndexMode :: [IndexMode] -> IndexMode +combineIndexMode = IndexMode . foldr ((.|.) . unIndexMode) 0 + +unCombineIndexMode :: IndexMode -> [IndexMode] +unCombineIndexMode (IndexMode (CUChar oflags)) = filter f allIndexMode + where + f = \(IndexMode (CUChar value)) -> value .&. oflags /= 0 diff --git a/src/Database/EJDB2/JBL.hs b/src/Database/EJDB2/JBL.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/JBL.hs @@ -0,0 +1,78 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Database.EJDB2.JBL ( decode, decode', encode, encodeToByteString ) where + +import Control.Exception + +import qualified Data.Aeson as Aeson +import qualified Data.ByteString as BS +import qualified Data.ByteString.Lazy as BSL +import qualified Data.HashMap.Strict as Map +import Data.IORef +import Data.Int + +import Database.EJDB2.Bindings.JBL +import qualified Database.EJDB2.Result as Result + +import Foreign +import Foreign.C.Types +import Foreign.Marshal.Array + +decode :: Aeson.FromJSON a => JBL -> IO (Maybe a) +decode jbl = Aeson.decode <$> decodeToByteString jbl + +decode' :: Aeson.FromJSON a => JBL -> Int64 -> IO (Maybe a) +decode' jbl id = parse . setId id <$> decode jbl + +decodeToByteString :: JBL -> IO BSL.ByteString +decodeToByteString jbl = do + ref <- newIORef BSL.empty + thePrinter <- mkJBLJSONPrinter (printer ref) + c_jbl_as_json jbl thePrinter nullPtr 0 + >>= Result.checkRCFinally (freeHaskellFunPtr thePrinter) + BSL.reverse <$> readIORef ref + +parse :: Aeson.FromJSON a => Maybe Aeson.Value -> Maybe a +parse Nothing = Nothing +parse (Just value) = case Aeson.fromJSON value of + Aeson.Success v -> Just v + Aeson.Error _ -> Nothing + +setId :: Int64 -> Maybe Aeson.Value -> Maybe Aeson.Value +setId id (Just (Aeson.Object map)) = + Just (Aeson.Object (Map.insert "id" (Aeson.Number $ fromIntegral id) map)) +setId _ Nothing = Nothing +setId _ value = value + +printer :: IORef BSL.ByteString -> JBLJSONPrinter +printer ref _ 0 (CChar ch) _ _ = do + modifyIORef' ref $ \string -> BSL.cons word string + return 0 + where + word = fromIntegral ch +printer ref buffer size _ _ _ + | size > 0 = do + array <- peekArray (fromIntegral size) buffer + printerArray ref array + | otherwise = do + array <- peekArray0 (CChar 0) buffer + printerArray ref array + +printerArray :: IORef BSL.ByteString -> [CChar] -> IO Result.RC +printerArray ref array = do + modifyIORef' ref $ \string -> + foldl (\result (CChar ch) -> BSL.cons (fromIntegral ch) result) + string + array + return 0 + +encode :: Aeson.ToJSON a => a -> (JBL -> IO b) -> IO b +encode obj f = do + let byteString = encodeToByteString obj + BS.useAsCString byteString $ \string -> alloca $ \jblPtr -> + finally (c_jbl_from_json jblPtr string >>= Result.checkRC >> peek jblPtr + >>= f) + (c_jbl_destroy jblPtr) + +encodeToByteString :: Aeson.ToJSON a => a -> BS.ByteString +encodeToByteString obj = BSL.toStrict $ Aeson.encode obj diff --git a/src/Database/EJDB2/KV.hsc b/src/Database/EJDB2/KV.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/KV.hsc @@ -0,0 +1,110 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.KV + ( OpenFlags + , readonlyOpenFlags + , truncateOpenFlags + , noTrimOnCloseOpenFlags + , Options(..) + , zero + , OptionsB + , build + , options + ) where + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +import qualified Database.EJDB2.WAL as WAL + +#include +-- | Database file open modes. +newtype OpenFlags = OpenFlags { unOpenFlags :: CUChar } + +-- | Open storage file in read-only mode. +readonlyOpenFlags :: OpenFlags +readonlyOpenFlags = OpenFlags #{const IWKV_RDONLY} + +-- | Truncate storage file on open. +truncateOpenFlags :: OpenFlags +truncateOpenFlags = OpenFlags #{const IWKV_TRUNC} + +noTrimOnCloseOpenFlags :: OpenFlags +noTrimOnCloseOpenFlags = OpenFlags #{const IWKV_NO_TRIM_ON_CLOSE} + +allOpenFlags :: [OpenFlags] +allOpenFlags = [readonlyOpenFlags, truncateOpenFlags, noTrimOnCloseOpenFlags] + +combineOpenFlags :: [OpenFlags] -> OpenFlags +combineOpenFlags = OpenFlags . foldr ((.|.) . unOpenFlags) 0 + +unCombineOpenFlags :: OpenFlags -> [OpenFlags] +unCombineOpenFlags (OpenFlags (CUChar oflags)) = filter f allOpenFlags + where + f = \(OpenFlags (CUChar value)) -> value .&. oflags /= 0 + +-- | IWKV storage open options +data Options = + Options { path :: Maybe String -- ^ Path to database file + , randomSeed :: !Word32 -- ^ Random seed used for iwu random generator + , fmtVersion :: !Int32 -- ^ Database storage format version. Leave it as zero for the latest supported format. Used only for newly created databases + , oflags :: ![OpenFlags] -- ^ Database file open modes + , fileLockFailFast :: !Bool -- ^ Do not wait and raise error if database is locked by another process + , wal :: !WAL.Options + } + +-- | Create default Options +zero :: Options +zero = Options { path = Nothing + , randomSeed = 0 + , fmtVersion = 0 + , oflags = [] + , fileLockFailFast = False + , wal = WAL.zero + } + +-- | Storable version of Options +data OptionsB = + OptionsB { options :: Options + , pathPtr :: ForeignPtr CChar + } + +-- | Create Storable version of Options +build :: Options -> IO OptionsB +build options = do + pathPtr <- maybeNew newCString (path options) + pathFPtr <- newForeignPtr finalizerFree pathPtr + return OptionsB { options = options + , pathPtr = pathFPtr + } + +instance Storable OptionsB where + sizeOf _ = #{size IWKV_OPTS} + alignment _ = #{alignment IWKV_OPTS} + peek ptr = do + pathPtr <- #{peek IWKV_OPTS, path} ptr + pathFPtr <- newForeignPtr finalizerFree nullPtr -- I'm just reading the pointer, I'm not responsable to free memory about this pointer. + path <- maybePeek peekCString pathPtr + random_seed <- #{peek IWKV_OPTS, random_seed} ptr + fmt_version <- #{peek IWKV_OPTS, fmt_version} ptr + oflags <- #{peek IWKV_OPTS, oflags} ptr + file_lock_fail_fast <- #{peek IWKV_OPTS, file_lock_fail_fast} ptr + wal <- #{peek IWKV_OPTS, wal} ptr + let options = Options + path + random_seed + fmt_version + (unCombineOpenFlags $ OpenFlags oflags) + file_lock_fail_fast + wal + return $ OptionsB options pathFPtr + poke ptr (OptionsB (Options path random_seed fmt_version oflags file_lock_fail_fast wal) pathPtr) = do + withForeignPtr pathPtr $ \cPath -> + #{poke IWKV_OPTS, path} ptr cPath + #{poke IWKV_OPTS, random_seed} ptr random_seed + #{poke IWKV_OPTS, fmt_version} ptr fmt_version + #{poke IWKV_OPTS, oflags} ptr (unOpenFlags $ combineOpenFlags oflags) + #{poke IWKV_OPTS, file_lock_fail_fast} ptr file_lock_fail_fast + #{poke IWKV_OPTS, wal} ptr wal + diff --git a/src/Database/EJDB2/Meta.hs b/src/Database/EJDB2/Meta.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Meta.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Database.EJDB2.Meta where + +import Data.Aeson ( FromJSON ) +import Data.Int + +import Database.EJDB2.CollectionMeta + +import GHC.Generics hiding ( Meta ) + +-- | Metadata about database. +data Meta = + Meta { version :: String -- ^ EJDB engine version + , file :: String -- ^ Path to storage file + , size :: Int64 -- ^ Storage file size in bytes + , collections :: [CollectionMeta] -- ^ List of collections + } + deriving ( Eq, Generic, Show ) + +instance FromJSON Meta + diff --git a/src/Database/EJDB2/Options.hsc b/src/Database/EJDB2/Options.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Options.hsc @@ -0,0 +1,65 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.Options + ( Options(..), zero, OptionsB, options, build ) where + +import Data.ByteString.Char8 + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +import qualified Database.EJDB2.KV as KV +import qualified Database.EJDB2.HTTP as HTTP + +#include + +-- | EJDB open options +data Options = Options { kv :: !KV.Options -- ^ IWKV storage options + , http :: !HTTP.Options -- ^ HTTP/Websocket server options + , noWal :: !Bool -- ^ Do not use write-ahead-log. Default: false + , sortBufferSz :: !Word32 -- ^ Max sorting buffer size. If exceeded an overflow temp file for sorted data will created. Default 16Mb, min: 1Mb + , documentBufferSz :: !Word32 -- ^ Initial size of buffer in bytes used to process/store document during query execution. Default 64Kb, min: 16Kb + } + +-- | Create default Options +zero :: Options +zero = Options { kv = KV.zero + , http = HTTP.zero + , noWal = False + , sortBufferSz = 0 + , documentBufferSz = 0 + } + +-- | Storable version of 'Options' +data OptionsB = OptionsB { options :: Options + , kvB :: !KV.OptionsB + , httpB :: !HTTP.OptionsB + } + +-- | Create Storable version of 'Options' +build :: Options -> IO OptionsB +build options = do + kvB <- KV.build (kv options) + httpB <- HTTP.build (http options) + return $ OptionsB options kvB httpB + +instance Storable OptionsB where + sizeOf _ = #{size EJDB_OPTS} + alignment _ = #{alignment EJDB_OPTS} + peek ptr = do + kvB <- #{peek EJDB_OPTS, kv} ptr + let kv = KV.options kvB + httpB <- #{peek EJDB_OPTS, http} ptr + let http = HTTP.options httpB + (CBool no_wal) <- #{peek EJDB_OPTS, no_wal} ptr + (CUInt sort_buffer_sz) <- #{peek EJDB_OPTS, sort_buffer_sz} ptr + (CUInt document_buffer_sz) <- #{peek EJDB_OPTS, document_buffer_sz} ptr + return $ OptionsB (Options kv http (toBool no_wal) sort_buffer_sz document_buffer_sz) kvB httpB + poke ptr (OptionsB (Options _ http noWal sort_buffer_sz document_buffer_sz) kvB httpB) = do + #{poke EJDB_OPTS, kv} ptr kvB + #{poke EJDB_OPTS, http} ptr httpB + #{poke EJDB_OPTS, no_wal} ptr (CBool $ fromBool noWal) + #{poke EJDB_OPTS, sort_buffer_sz} ptr (CUInt sort_buffer_sz) + #{poke EJDB_OPTS, document_buffer_sz} ptr (CUInt document_buffer_sz) + diff --git a/src/Database/EJDB2/Query.hs b/src/Database/EJDB2/Query.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Query.hs @@ -0,0 +1,156 @@ +module Database.EJDB2.Query + ( Query + , fromString + , setBool + , setBoolAtIndex + , setI64 + , setI64AtIndex + , setF64 + , setF64AtIndex + , setString + , setStringAtIndex + , setRegex + , setRegexAtIndex + , setNull + , setNullAtIndex + ) where + +import qualified Data.Bool as Bool +import Data.IORef +import Data.Int + +import Database.EJDB2.Bindings.JQL +import Database.EJDB2.QueryConstructor +import Database.EJDB2.Result + +import Foreign +import Foreign.C.String +import Foreign.C.Types +import Foreign.Marshal.Alloc + +-- | Create query object from specified text query. Collection must be specified in query. +fromString :: String -- ^ Query text + -> IO Query +fromString string = do + jqlPtr <- malloc + withCString string $ \cString -> do + c_jql_create jqlPtr nullPtr cString >>= checkRC + jql <- peek jqlPtr + jqlFPtr <- newForeignPtr p_finalizerJQL jqlPtr + ioRef <- newIORef [] + return $ Query jql jqlFPtr ioRef + +-- | Bind bool to query placeholder +setBool :: Bool + -> String -- ^ Placeholder + -> Query + -> IO () +setBool bool placeholder (Query jql _ _) = + withCString placeholder $ \cPlaceholder -> + c_jql_set_bool jql cPlaceholder 0 (CBool (Bool.bool 0 1 bool)) >>= checkRC + +-- | Bind bool to query at specified index +setBoolAtIndex :: Bool + -> Int -- ^ Index + -> Query + -> IO () +setBoolAtIndex bool index (Query jql _ _) = + c_jql_set_bool jql + nullPtr + (CInt $ fromIntegral index) + (CBool (Bool.bool 0 1 bool)) >>= checkRC + +-- | Bind number to query placeholder +setI64 :: Int64 + -> String -- ^ Placeholder + -> Query + -> IO () +setI64 number placeholder (Query jql _ _) = withCString placeholder $ + \cPlaceholder -> c_jql_set_i64 jql cPlaceholder 0 (CIntMax number) + >>= checkRC + +-- | Bind number to query at specified index +setI64AtIndex :: Int64 + -> Int -- ^ Index + -> Query + -> IO () +setI64AtIndex number index (Query jql _ _) = + c_jql_set_i64 jql nullPtr (CInt $ fromIntegral index) (CIntMax number) + >>= checkRC + +-- | Bind 'Double' to query placeholder +setF64 :: Double + -> String -- ^ Placeholder + -> Query + -> IO () +setF64 number placeholder (Query jql _ _) = withCString placeholder $ + \cPlaceholder -> c_jql_set_f64 jql cPlaceholder 0 (CDouble number) + >>= checkRC + +-- | Bind 'Double' to query at specified index +setF64AtIndex :: Double + -> Int -- ^ Index + -> Query + -> IO () +setF64AtIndex number index (Query jql _ _) = + c_jql_set_f64 jql nullPtr (CInt $ fromIntegral index) (CDouble number) + >>= checkRC + +newCStringInIORef :: String -> IORef [ForeignPtr CChar] -> IO CString +newCStringInIORef string ioRef = do + cString <- newCString string + cStringPtr <- newForeignPtr finalizerFree cString + modifyIORef' ioRef ((:) cStringPtr) + return cString + +-- | Bind string to query placeholder +setString :: String + -> String -- ^ Placeholder + -> Query + -> IO () +setString string placeholder (Query jql _ ioRef) = do + cString <- newCStringInIORef string ioRef + withCString placeholder $ + \cPlaceholder -> c_jql_set_str jql cPlaceholder 0 cString >>= checkRC + +-- | Bind string to query at specified index +setStringAtIndex :: String + -> Int -- ^ Index + -> Query + -> IO () +setStringAtIndex string index (Query jql _ ioRef) = do + cString <- newCStringInIORef string ioRef + c_jql_set_str jql nullPtr (CInt $ fromIntegral index) cString >>= checkRC + +-- | Bind regex to query placeholder +setRegex :: String -- ^ Regex + -> String -- ^ Placeholder + -> Query + -> IO () +setRegex string placeholder (Query jql _ ioRef) = do + cString <- newCStringInIORef string ioRef + withCString placeholder $ + \cPlaceholder -> c_jql_set_regexp jql cPlaceholder 0 cString >>= checkRC + +-- | Bind regex to query at specified index +setRegexAtIndex :: String -- ^ Regex + -> Int -- ^ Index + -> Query + -> IO () +setRegexAtIndex string index (Query jql _ ioRef) = do + cString <- newCStringInIORef string ioRef + c_jql_set_regexp jql nullPtr (CInt $ fromIntegral index) cString >>= checkRC + +-- | Bind /null/ value to query placeholder +setNull :: String -- ^ Placeholder + -> Query + -> IO () +setNull placeholder (Query jql _ _) = withCString placeholder $ + \cPlaceholder -> c_jql_set_null jql cPlaceholder 0 >>= checkRC + +-- | Bind /null/ value to query at specified index +setNullAtIndex :: Int -- ^ Index + -> Query + -> IO () +setNullAtIndex index (Query jql _ _) = + c_jql_set_null jql nullPtr (CInt $ fromIntegral index) >>= checkRC diff --git a/src/Database/EJDB2/QueryConstructor.hs b/src/Database/EJDB2/QueryConstructor.hs new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/QueryConstructor.hs @@ -0,0 +1,14 @@ +module Database.EJDB2.QueryConstructor ( Query(..) ) where + +import Data.IORef + +import Database.EJDB2.Bindings.JQL + +import Foreign +import Foreign.C.Types + +-- | Query handle +data Query = Query { jql :: JQL + , jqlPtr :: ForeignPtr JQL + , strings :: IORef [ForeignPtr CChar] + } diff --git a/src/Database/EJDB2/Result.hsc b/src/Database/EJDB2/Result.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/Result.hsc @@ -0,0 +1,172 @@ +{-# LANGUAGE CPP #-} +module Database.EJDB2.Result where + +import Foreign +import Foreign.C.Types + +#include + +type RC = CUIntMax + +checkRC :: RC -> IO () +checkRC rc = do + let result = decodeRC rc + if result == Ok then return () else fail $ show result + +checkRCFinally :: IO a -> RC -> IO a +checkRCFinally computation rc = do + let result = decodeRC rc + if result == Ok + then computation + else do + computation + fail $ show result + +data Result = + Ok -- ^ No error. + | ErrorFail -- ^ Unspecified error. + | ErrorErrno -- ^ Error with expected errno status set. + | ErrorIoErrno -- ^ IO error with expected errno status set. + | ErrorNotExists -- ^ Resource is not exists. + | ErrorReadonly -- ^ Resource is readonly. + | ErrorAlreadyOpened -- ^ Resource is already opened. + | ErrorThreading -- ^ Threading error. + | ErrorThreadingErrno -- ^ Threading error with errno status set. + | ErrorAssertion -- ^ Generic assertion error. + | ErrorInvalidHandle -- ^ Invalid HANDLE value. + | ErrorOutOfBounds -- ^ Invalid bounds specified. + | ErrorNotImplemented -- ^ Method is not implemented. + | ErrorAlloc -- ^ Memory allocation failed. + | ErrorInvalidState -- ^ Illegal state error. + | ErrorNotAligned -- ^ Argument is not aligned properly. + | ErrorFalse -- ^ Request rejection/false response. + | ErrorInvalidArgs -- ^ Invalid function arguments. + | ErrorOverflow -- ^ Overflow. + | ErrorInvalidValue -- ^ Invalid value. + | ErrorNotFound -- ^ Key not found (IWKV_ERROR_NOTFOUND) + | ErrorKeyExists -- ^ Key already exists (IWKV_ERROR_KEY_EXISTS) + | ErrorMaxkvsz -- ^ Size of Key+value must be not greater than 0xfffffff bytes (IWKV_ERROR_MAXKVSZ) + | ErrorCorrupted -- ^ Database file invalid or corrupted (IWKV_ERROR_CORRUPTED) + | ErrorDupValueSize -- ^ Value size is not compatible for insertion into sorted values array (IWKV_ERROR_DUP_VALUE_SIZE) + | ErrorKeyNumValueSize -- ^ Given key is not compatible to storage as number (IWKV_ERROR_KEY_NUM_VALUE_SIZE) + | ErrorIncompatibleDbMode -- ^ Incorpatible database open mode (IWKV_ERROR_INCOMPATIBLE_DB_MODE) + | ErrorIncompatibleDbFormat -- ^ Incompatible database format version, please migrate database data (IWKV_ERROR_INCOMPATIBLE_DB_FORMAT) + | ErrorCorruptedWalFile -- ^ Corrupted WAL file (IWKV_ERROR_CORRUPTED_WAL_FILE) + | ErrorValueCannotBeIncremented -- ^ Stored value cannot be incremented/descremented (IWKV_ERROR_VALUE_CANNOT_BE_INCREMENTED) + | ErrorWalModeRequired -- ^ Operation requires WAL enabled database. (IWKV_ERROR_WAL_MODE_REQUIRED) + | ErrorBackupInProgress -- ^ Backup operation in progress. (IWKV_ERROR_BACKUP_IN_PROGRESS) + | ErrorInvalidBuffer -- ^ Invalid JBL buffer (JBLERRORINVALIDBUFFER) + | ErrorCreation -- ^ Cannot create JBL object (JBLERRORCREATION) + | ErrorInvalid -- ^ Invalid JBL object (JBLERRORINVALID) + | ErrorParseJson -- ^ Failed to parse JSON string (JBLERRORPARSEJSON) + | ErrorParseUnquotedString -- ^ Unquoted JSON string (JBLERRORPARSEUNQUOTEDSTRING) + | ErrorParseInvalidCodepoint -- ^ Invalid unicode codepoint/escape sequence (JBLERRORPARSEINVALIDCODEPOINT) + | ErrorParseInvalidUtf8 -- ^ Invalid utf8 string (JBLERRORPARSEINVALIDUTF8) + | ErrorJsonPointer -- ^ Invalid JSON pointer (rfc6901) path (JBLERRORJSONPOINTER) + | ErrorPathNotFound -- ^ JSON object not matched the path specified (JBLERRORPATHNOTFOUND) + | ErrorPatchInvalid -- ^ Invalid JSON patch specified (JBLERRORPATCHINVALID) + | ErrorPatchInvalidOp -- ^ Invalid JSON patch operation specified (JBLERRORPATCHINVALIDOP) + | ErrorPatchNovalue -- ^ No value specified in JSON patch (JBLERRORPATCHNOVALUE) + | ErrorPatchTargetInvalid -- ^ Could not find target object to set value (JBLERRORPATCHTARGETINVALID) + | ErrorPatchInvalidValue -- ^ Invalid value specified by patch (JBLERRORPATCHINVALIDVALUE) + | ErrorPatchInvalidArrayIndex -- ^ Invalid array index in JSON patch path (JBLERRORPATCHINVALIDARRAYINDEX) + | ErrorNotAnObject -- ^ JBL is not an object (JBLERRORNOTANOBJECT) + | ErrorPatchTestFailed -- ^ JSON patch test operation failed (JBLERRORPATCHTESTFAILED) + | ErrorInvalidCollectionName -- ^ Invalid collection name + | ErrorInvalidCollectionMeta -- ^ Invalid collection metadata + | ErrorInvalidCollectionIndexMeta -- ^ Invalid collection index metadata + | ErrorInvalidIndexMode -- ^ Invalid index mode specified + | ErrorMismatchedIndexUniquenessMode -- ^ Index exists but mismatched uniqueness constraint + | ErrorUniqueIndexConstraintViolated -- ^ Unique index constraint violated + | ErrorCollectionNotFound -- ^ Collection not found + | ErrorTargetCollectionExists -- ^ Target collection exists + | ErrorPatchJsonNotObject -- ^ Patch JSON must be an object (map) + | ErrorQueryParse -- ^ Query parsing error (JQL_ERROR_QUERY_PARSE) + | ErrorInvalidPlaceholder -- ^ Invalid placeholder position (JQL_ERROR_INVALID_PLACEHOLDER) + | ErrorUnsetPlaceholder -- ^ Found unset placeholder (JQL_ERROR_UNSET_PLACEHOLDER) + | ErrorRegexpInvalid -- ^ Invalid regular expression (JQL_ERROR_REGEXP_INVALID) + | ErrorRegexpCharset -- ^ Invalid regular expression: expected ']' at end of character set (JQL_ERROR_REGEXP_CHARSET) + | ErrorRegexpSubexp -- ^ Invalid regular expression: expected ')' at end of subexpression (JQL_ERROR_REGEXP_SUBEXP) + | ErrorRegexpSubmatch -- ^ Invalid regular expression: expected '}' at end of submatch (JQL_ERROR_REGEXP_SUBMATCH) + | ErrorRegexpEngine -- ^ Illegal instruction in compiled regular expression (please report this bug) (JQL_ERROR_REGEXP_ENGINE) + | ErrorSkipAlreadySet -- ^ Skip clause already specified (JQL_ERROR_SKIP_ALREADY_SET) + | ErrorLimitAlreadySet -- ^ Limit clause already specified (JQL_ERROR_SKIP_ALREADY_SET) + | ErrorOrderbyMaxLimit -- ^ Reached max number of asc/desc order clauses: 64 (JQL_ERROR_ORDERBY_MAX_LIMIT) + | ErrorNoCollection -- ^ No collection specified in query (JQL_ERROR_NO_COLLECTION) + | ErrorInvalidPlaceholderValueType -- ^ Invalid type of placeholder value (JQL_ERROR_INVALID_PLACEHOLDER_VALUE_TYPE) + deriving ( Eq, Show ) + +decodeRC :: RC -> Result +decodeRC rc = case rc of + #{const IW_OK} -> Ok + #{const IW_ERROR_FAIL} -> ErrorFail + #{const IW_ERROR_ERRNO} -> ErrorErrno + #{const IW_ERROR_IO_ERRNO} -> ErrorIoErrno + #{const IW_ERROR_NOT_EXISTS} -> ErrorNotExists + #{const IW_ERROR_READONLY} -> ErrorReadonly + #{const IW_ERROR_ALREADY_OPENED} -> ErrorAlreadyOpened + #{const IW_ERROR_THREADING} -> ErrorThreading + #{const IW_ERROR_THREADING_ERRNO} -> ErrorThreadingErrno + #{const IW_ERROR_ASSERTION} -> ErrorAssertion + #{const IW_ERROR_INVALID_HANDLE} -> ErrorInvalidHandle + #{const IW_ERROR_OUT_OF_BOUNDS} -> ErrorOutOfBounds + #{const IW_ERROR_NOT_IMPLEMENTED} -> ErrorNotImplemented + #{const IW_ERROR_ALLOC} -> ErrorAlloc + #{const IW_ERROR_INVALID_STATE} -> ErrorInvalidState + #{const IW_ERROR_NOT_ALIGNED} -> ErrorNotAligned + #{const IW_ERROR_FALSE} -> ErrorFalse + #{const IW_ERROR_INVALID_ARGS} -> ErrorInvalidArgs + #{const IW_ERROR_OVERFLOW} -> ErrorOverflow + #{const IW_ERROR_INVALID_VALUE} -> ErrorInvalidValue + #{const IWKV_ERROR_NOTFOUND} -> ErrorNotFound + #{const IWKV_ERROR_KEY_EXISTS} -> ErrorKeyExists + #{const IWKV_ERROR_MAXKVSZ} -> ErrorMaxkvsz + #{const IWKV_ERROR_CORRUPTED} -> ErrorCorrupted + #{const IWKV_ERROR_DUP_VALUE_SIZE} -> ErrorDupValueSize + #{const IWKV_ERROR_KEY_NUM_VALUE_SIZE} -> ErrorKeyNumValueSize + #{const IWKV_ERROR_INCOMPATIBLE_DB_MODE} -> ErrorIncompatibleDbMode + #{const IWKV_ERROR_INCOMPATIBLE_DB_FORMAT} -> ErrorIncompatibleDbFormat + #{const IWKV_ERROR_CORRUPTED_WAL_FILE} -> ErrorCorruptedWalFile + #{const IWKV_ERROR_VALUE_CANNOT_BE_INCREMENTED} -> ErrorValueCannotBeIncremented + #{const IWKV_ERROR_WAL_MODE_REQUIRED} -> ErrorWalModeRequired + #{const IWKV_ERROR_BACKUP_IN_PROGRESS} -> ErrorBackupInProgress + #{const JBL_ERROR_INVALID_BUFFER} -> ErrorInvalidBuffer + #{const JBL_ERROR_CREATION} -> ErrorCreation + #{const JBL_ERROR_INVALID} -> ErrorInvalid + #{const JBL_ERROR_PARSE_JSON} -> ErrorParseJson + #{const JBL_ERROR_PARSE_UNQUOTED_STRING} -> ErrorParseUnquotedString + #{const JBL_ERROR_PARSE_INVALID_CODEPOINT} -> ErrorParseInvalidCodepoint + #{const JBL_ERROR_PARSE_INVALID_UTF8} -> ErrorParseInvalidUtf8 + #{const JBL_ERROR_JSON_POINTER} -> ErrorJsonPointer + #{const JBL_ERROR_PATH_NOTFOUND} -> ErrorPathNotFound + #{const JBL_ERROR_PATCH_INVALID} -> ErrorPatchInvalid + #{const JBL_ERROR_PATCH_INVALID_OP} -> ErrorPatchInvalidOp + #{const JBL_ERROR_PATCH_NOVALUE} -> ErrorPatchNovalue + #{const JBL_ERROR_PATCH_TARGET_INVALID} -> ErrorPatchTargetInvalid + #{const JBL_ERROR_PATCH_INVALID_VALUE} -> ErrorPatchInvalidValue + #{const JBL_ERROR_PATCH_INVALID_ARRAY_INDEX} -> ErrorPatchInvalidArrayIndex + #{const JBL_ERROR_NOT_AN_OBJECT} -> ErrorNotAnObject + #{const JBL_ERROR_PATCH_TEST_FAILED} -> ErrorPatchTestFailed + #{const EJDB_ERROR_INVALID_COLLECTION_NAME} -> ErrorInvalidCollectionName + #{const EJDB_ERROR_INVALID_COLLECTION_META} -> ErrorInvalidCollectionMeta + #{const EJDB_ERROR_INVALID_COLLECTION_INDEX_META} -> ErrorInvalidCollectionIndexMeta + #{const EJDB_ERROR_INVALID_INDEX_MODE} -> ErrorInvalidIndexMode + #{const EJDB_ERROR_MISMATCHED_INDEX_UNIQUENESS_MODE} -> ErrorMismatchedIndexUniquenessMode + #{const EJDB_ERROR_UNIQUE_INDEX_CONSTRAINT_VIOLATED} -> ErrorUniqueIndexConstraintViolated + #{const EJDB_ERROR_COLLECTION_NOT_FOUND} -> ErrorCollectionNotFound + #{const EJDB_ERROR_TARGET_COLLECTION_EXISTS} -> ErrorTargetCollectionExists + #{const EJDB_ERROR_PATCH_JSON_NOT_OBJECT} -> ErrorPatchJsonNotObject + #{const JQL_ERROR_QUERY_PARSE} -> ErrorQueryParse + #{const JQL_ERROR_INVALID_PLACEHOLDER} -> ErrorInvalidPlaceholder + #{const JQL_ERROR_UNSET_PLACEHOLDER} -> ErrorUnsetPlaceholder + #{const JQL_ERROR_REGEXP_INVALID} -> ErrorRegexpInvalid + #{const JQL_ERROR_REGEXP_CHARSET} -> ErrorRegexpCharset + #{const JQL_ERROR_REGEXP_SUBEXP} -> ErrorRegexpSubexp + #{const JQL_ERROR_REGEXP_SUBMATCH} -> ErrorRegexpSubmatch + #{const JQL_ERROR_REGEXP_ENGINE} -> ErrorRegexpEngine + #{const JQL_ERROR_SKIP_ALREADY_SET} -> ErrorSkipAlreadySet + #{const JQL_ERROR_LIMIT_ALREADY_SET} -> ErrorLimitAlreadySet + #{const JQL_ERROR_ORDERBY_MAX_LIMIT} -> ErrorOrderbyMaxLimit + #{const JQL_ERROR_NO_COLLECTION} -> ErrorNoCollection + #{const JQL_ERROR_INVALID_PLACEHOLDER_VALUE_TYPE} -> ErrorInvalidPlaceholderValueType + _ -> error $ "Database.EJDB2.Bindings.IW.decodeRC " ++ show rc diff --git a/src/Database/EJDB2/WAL.hsc b/src/Database/EJDB2/WAL.hsc new file mode 100644 --- /dev/null +++ b/src/Database/EJDB2/WAL.hsc @@ -0,0 +1,60 @@ +{-# LANGUAGE CPP #-} + +module Database.EJDB2.WAL (Options(..), zero) where + + +import Foreign +import Foreign.C.String +import Foreign.C.Types + +import Database.EJDB2.Result + +#include + +-- | Write ahead log (WAL) options. +data Options = Options { enabled :: !Bool -- ^ WAL enabled + , checkCRCOnCheckpoint :: !Bool -- ^ Check CRC32 sum of data blocks during checkpoint. Default: false + , savepointTimeoutSec :: !Word32 -- ^ Savepoint timeout seconds. Default: 10 sec + , checkpointTimeoutSec :: !Word32 -- ^ Checkpoint timeout seconds. Default: 300 sec (5 min); + , walBufferSz :: !Word64 -- ^ WAL file intermediate buffer size. Default: 8Mb + , checkpointBufferSz :: !Word8 -- ^ Checkpoint buffer size in bytes. Default: 1Gb + , walLockInterceptor :: !(FunPtr (CBool -> Ptr () -> IO RC)) -- ^ Optional function called before acquiring and after releasing. +-- exclusive database lock byAL checkpoint thread. +-- In the case of 'before loc first argument will be set to true + , walLockInterceptorOpaque :: !(Ptr ()) -- ^ Opaque data for 'walLockInterceptor' + } + +-- | Create default Options +zero :: Options +zero = Options { enabled = False + , checkCRCOnCheckpoint = False + , savepointTimeoutSec = 0 + , checkpointTimeoutSec = 0 + , walBufferSz = 0 + , checkpointBufferSz = 0 + , walLockInterceptor = nullFunPtr + , walLockInterceptorOpaque = nullPtr + } + +instance Storable Options where + sizeOf _ = #{size IWKV_WAL_OPTS} + alignment _ = #{alignment IWKV_WAL_OPTS} + peek ptr = do + enabled <- #{peek IWKV_WAL_OPTS, enabled} ptr + check_crc_on_checkpoint <- #{peek IWKV_WAL_OPTS, check_crc_on_checkpoint} ptr + savepoint_timeout_sec <- #{peek IWKV_WAL_OPTS, savepoint_timeout_sec} ptr + checkpoint_timeout_sec <- #{peek IWKV_WAL_OPTS, checkpoint_timeout_sec} ptr + wal_buffer_sz <- #{peek IWKV_WAL_OPTS, wal_buffer_sz} ptr + checkpoint_buffer_sz <- #{peek IWKV_WAL_OPTS, checkpoint_buffer_sz} ptr + wal_lock_interceptor <- #{peek IWKV_WAL_OPTS, wal_lock_interceptor} ptr + wal_lock_interceptor_opaque <- #{peek IWKV_WAL_OPTS, wal_lock_interceptor_opaque} ptr + return $ Options enabled check_crc_on_checkpoint savepoint_timeout_sec checkpoint_timeout_sec wal_buffer_sz checkpoint_buffer_sz wal_lock_interceptor wal_lock_interceptor_opaque + poke ptr (Options enabled check_crc_on_checkpoint savepoint_timeout_sec checkpoint_timeout_sec wal_buffer_sz checkpoint_buffer_sz wal_lock_interceptor wal_lock_interceptor_opaque) = do + #{poke IWKV_WAL_OPTS, enabled} ptr enabled + #{poke IWKV_WAL_OPTS, check_crc_on_checkpoint} ptr check_crc_on_checkpoint + #{poke IWKV_WAL_OPTS, savepoint_timeout_sec} ptr savepoint_timeout_sec + #{poke IWKV_WAL_OPTS, checkpoint_timeout_sec} ptr checkpoint_timeout_sec + #{poke IWKV_WAL_OPTS, wal_buffer_sz} ptr wal_buffer_sz + #{poke IWKV_WAL_OPTS, checkpoint_buffer_sz} ptr checkpoint_buffer_sz + #{poke IWKV_WAL_OPTS, wal_lock_interceptor} ptr wal_lock_interceptor + #{poke IWKV_WAL_OPTS, wal_lock_interceptor_opaque} ptr wal_lock_interceptor_opaque diff --git a/test/Asserts.hs b/test/Asserts.hs new file mode 100644 --- /dev/null +++ b/test/Asserts.hs @@ -0,0 +1,16 @@ +module Asserts ( assertException ) where + +import Control.Exception +import Control.Monad + +import Test.Tasty.HUnit + +-- https://stackoverflow.com/questions/6147435/is-there-an-assertexception-in-any-of-the-haskell-test-frameworks +assertException :: (Exception e, Eq e, Show a) => e -> IO a -> IO () +assertException ex action = handleJust isWanted (const $ return ()) $ do + a <- action + assertFailure $ "Expected exception: " ++ show ex + ++ ", but got execution success: " ++ show a + where + isWanted = guard . (== ex) + diff --git a/test/CollectionTests.hs b/test/CollectionTests.hs new file mode 100644 --- /dev/null +++ b/test/CollectionTests.hs @@ -0,0 +1,72 @@ +module CollectionTests ( tests ) where + +import Asserts + +import Database.EJDB2 +import Database.EJDB2.Options +import qualified Database.EJDB2.Query as Query + +import Plant + +import Prelude hiding ( id ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testDatabaseOpts) close $ \databaseIO -> + testGroup "collection" + [ removeTest databaseIO + , renameTest databaseIO + , ensureTest databaseIO + ] + +testDatabaseOpts :: Options +testDatabaseOpts = minimalOptions "./test/collection-db" [ truncateOpenFlags ] + +removeTest :: IO Database -> TestTree +removeTest databaseIO = testCase "removeTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + removeCollection database "plants" + count <- Query.fromString "@plants/*" >>= getCount database + count @?= 0 + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +renameTest :: IO Database -> TestTree +renameTest databaseIO = testCase "renameTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + renameCollection database "plants" "vegetables" + count <- Query.fromString "@plants/*" >>= getCount database + count @?= 0 + storedPlant <- getById database "vegetables" id + storedPlant @?= Just plant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +ensureTest :: IO Database -> TestTree +ensureTest databaseIO = testCase "ensureTest" $ do + database <- databaseIO + _ <- putNew database "plants" plant + ensureCollection database "vegetables" + assertException (userError "ErrorTargetCollectionExists") + (renameCollection database "plants" "vegetables") + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } diff --git a/test/DeleteTests.hs b/test/DeleteTests.hs new file mode 100644 --- /dev/null +++ b/test/DeleteTests.hs @@ -0,0 +1,41 @@ +module DeleteTests ( tests ) where + +import Asserts + +import Database.EJDB2 +import Database.EJDB2.Options + +import Plant + +import Prelude hiding ( id ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testDatabaseOpts) close $ \databaseIO -> + testGroup "delete" + [ deleteTest databaseIO, deleteNotExistingTest databaseIO ] + +testDatabaseOpts :: Options +testDatabaseOpts = minimalOptions "./test/delete-db" [ truncateOpenFlags ] + +deleteTest :: IO Database -> TestTree +deleteTest databaseIO = testCase "deleteTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + delete database "plants" id + storedPlant <- getById database "plants" id :: IO (Maybe Plant) + storedPlant @?= Nothing + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +deleteNotExistingTest :: IO Database -> TestTree +deleteNotExistingTest databaseIO = testCase "deleteNotExistingTest" $ do + database <- databaseIO + assertException (userError "ErrorNotFound") (delete database "plants" 42) diff --git a/test/GetTests.hs b/test/GetTests.hs new file mode 100644 --- /dev/null +++ b/test/GetTests.hs @@ -0,0 +1,143 @@ +module GetTests ( tests ) where + +import Asserts + +import Control.Exception +import Control.Monad + +import Data.Aeson ( Value ) +import Data.Int + +import Database.EJDB2 +import Database.EJDB2.Options +import qualified Database.EJDB2.Query as Query + +import Plant + +import Prelude hiding ( id ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testReadOnlyDatabaseOpts) close $ \databaseIO -> + testGroup "get" + [ getByIdTest databaseIO + , getByIdNotFoundTest databaseIO + , getCountTest databaseIO + , getListTest databaseIO + , getListTest' databaseIO + , getByIdFromNotExistingCollectionTest databaseIO + , getListFromNotExistingCollectionTest databaseIO + ] + +testReadOnlyDatabaseOpts :: Options +testReadOnlyDatabaseOpts = + minimalOptions "./test/read-only-db" [ readonlyOpenFlags ] + +getByIdTest :: IO Database -> TestTree +getByIdTest databaseIO = testCase "getById" $ do + database <- databaseIO + plant <- getById database "plants" 1 + plant @?= Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +getByIdNotFoundTest :: IO Database -> TestTree +getByIdNotFoundTest databaseIO = testCase "getById - not found" $ do + database <- databaseIO + plant <- getById database "plants" 42 + plant @?= (Nothing :: Maybe Plant) + +getCountTest :: IO Database -> TestTree +getCountTest databaseIO = testCase "getCount" $ do + database <- databaseIO + count <- Query.fromString "@plants/*" >>= getCount database + count @?= 4 + +getListTestQuery :: IO Query.Query +getListTestQuery = do + query <- Query.fromString "@plants/[isTree=:tree] | asc /name" + Query.setBool False "tree" query + return query + +getListTest :: IO Database -> TestTree +getListTest databaseIO = testCase "getList" $ do + database <- databaseIO + plants <- getListTestQuery >>= getList database + plants + @?= [ ( 2 + , Just nothingPlant { id = Nothing + , name = Just "gentiana brentae" + , isTree = Just False + , year = Just 2008 + , description = Just "violet 🌺flower" + } + ) + , ( 3 + , Just nothingPlant { id = Nothing + , name = Just "leontopodium" + , isTree = Just False + , year = Just 1817 + , description = + Just "tipical alpine flower" + } + ) + , ( 4 + , Just nothingPlant { id = Nothing + , name = + Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ) + ] + +getListTest' :: IO Database -> TestTree +getListTest' databaseIO = testCase "getList'" $ do + database <- databaseIO + plants <- getListTestQuery >>= getList' database + plants @?= [ Just nothingPlant { id = Just 2 + , name = Just "gentiana brentae" + , isTree = Just False + , year = Just 2008 + , description = Just "violet 🌺flower" + } + , Just nothingPlant { id = Just 3 + , name = Just "leontopodium" + , isTree = Just False + , year = Just 1817 + , description = Just "tipical alpine flower" + } + , Just nothingPlant { id = Just 4 + , name = Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = + Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ] + +getByIdFromNotExistingCollectionTest :: IO Database -> TestTree +getByIdFromNotExistingCollectionTest databaseIO = + testCase "getByIdFromNotExistingCollection" $ do + database <- databaseIO + assertException (userError "ErrorNotExists") -- this happens only with readonlyOpenFlags + (getById database "noexisting" 1 :: IO (Maybe Value)) + +-- on ejdb_exec there is no error if collection doesn't exists +-- https://github.com/Softmotions/ejdb/blob/40fb43a30e410b4f1bce68f79f397ce44c272c78/src/ejdb2.c#L821 +getListFromNotExistingCollectionTest :: IO Database -> TestTree +getListFromNotExistingCollectionTest databaseIO = + testCase "getListFromNotExistingCollectionTest" $ do + database <- databaseIO + query <- Query.fromString "@noexisting/[isTree=:tree] | asc /name" + Query.setBool False "tree" query + list <- getList database query :: IO [(Int64, Maybe Value)] + list @?= [] diff --git a/test/IndexTests.hs b/test/IndexTests.hs new file mode 100644 --- /dev/null +++ b/test/IndexTests.hs @@ -0,0 +1,52 @@ +module IndexTests ( tests ) where + +import Asserts + +import qualified Data.Aeson as Aeson + +import Database.EJDB2 +import qualified Database.EJDB2.CollectionMeta as CollectionMeta +import qualified Database.EJDB2.Meta as Meta +import Database.EJDB2.Options + +import Plant + +import Prelude hiding ( id ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testDatabaseOpts) close $ \databaseIO -> + testGroup "index" + [ getMetaTest databaseIO, createAndRemoveIndexTest databaseIO ] + +testDatabaseOpts :: Options +testDatabaseOpts = minimalOptions "./test/index-db" [ truncateOpenFlags ] + +getMetaTest :: IO Database -> TestTree +getMetaTest databaseIO = testCase "getMetaTest" $ do + database <- databaseIO + Just meta <- getMeta database + let (major : '.' : minor : '.' : _) = Meta.version meta + [ major, '.', minor ] @?= "2.0" + +createAndRemoveIndexTest :: IO Database -> TestTree +createAndRemoveIndexTest databaseIO = testCase "createAndRemoveIndexTest" $ do + database <- databaseIO + ensureCollection database "plants" + ensureIndex database "plants" "/name" mode + indexesCount <- getIndexesCount database + indexesCount @?= 1 + removeIndex database "plants" "/name" mode + indexesCountLast <- getIndexesCount database + indexesCountLast @?= 0 + where + mode = [ uniqueIndexMode, strIndexMode ] + +getIndexesCount :: Database -> IO Int +getIndexesCount database = do + Just meta <- getMeta database + let indexes = CollectionMeta.indexes $ head $ Meta.collections meta + return $ length indexes + diff --git a/test/Main.hs b/test/Main.hs new file mode 100644 --- /dev/null +++ b/test/Main.hs @@ -0,0 +1,35 @@ +module Main ( main ) where + +import CollectionTests + +import Database.EJDB2 + +import DeleteTests + +import GetTests + +import IndexTests + +import OnlineBackupTests + +import Prelude hiding ( init ) + +import PutTests + +import QueryTests + +import Test.Tasty + +main :: IO () +main = init >> defaultMain Main.tests + +tests :: TestTree +tests = testGroup "ejdb2" + [ GetTests.tests + , QueryTests.tests + , PutTests.tests + , DeleteTests.tests + , CollectionTests.tests + , IndexTests.tests + , OnlineBackupTests.tests + ] diff --git a/test/OnlineBackupTests.hs b/test/OnlineBackupTests.hs new file mode 100644 --- /dev/null +++ b/test/OnlineBackupTests.hs @@ -0,0 +1,53 @@ +module OnlineBackupTests ( tests ) where + +import Control.Exception +import Control.Monad + +import Database.EJDB2 +import Database.EJDB2.Options + +import Plant + +import Prelude hiding ( id ) + +import System.Directory + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testDatabaseOpts) close $ + \databaseIO -> testGroup "onlineBackup" [ onlineBackupTest databaseIO ] + +testDatabaseOpts :: Options +testDatabaseOpts = + minimalOptions "./test/onlinebackup-db" [ truncateOpenFlags ] + +backupFilePath :: String +backupFilePath = "./test/onlinebackup-backup-db" + +onlineBackupTest :: IO Database -> TestTree +onlineBackupTest databaseIO = testCase "onlineBackupTest" $ do + doesFileExist backupFilePath + >>= \exists -> when exists $ removeFile backupFilePath + database <- databaseIO + id <- putNew database "plants" plant + _ <- onlineBackup database backupFilePath + backupFileExists <- doesFileExist backupFilePath + backupFileExists @? "backup file exists" + databaseLast <- open $ minimalOptions backupFilePath [ readonlyOpenFlags ] + catch (do + backupPlant <- getById databaseLast "plants" id + backupPlant @?= Just plant + close databaseLast) + (\e -> do + close databaseLast + throw (e :: IOException)) + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + diff --git a/test/Plant.hs b/test/Plant.hs new file mode 100644 --- /dev/null +++ b/test/Plant.hs @@ -0,0 +1,25 @@ +{-# LANGUAGE DeriveGeneric #-} + +module Plant where + +import Data.Aeson ( FromJSON, ToJSON ) + +import GHC.Generics + +import Prelude hiding ( id ) + +data Plant = Plant { id :: Maybe Int + , name :: Maybe String + , isTree :: Maybe Bool + , year :: Maybe Int + , description :: Maybe String + , ratio :: Maybe Double + } + deriving ( Eq, Generic, Show ) + +instance FromJSON Plant + +instance ToJSON Plant + +nothingPlant :: Plant +nothingPlant = Plant Nothing Nothing Nothing Nothing Nothing Nothing diff --git a/test/PutTests.hs b/test/PutTests.hs new file mode 100644 --- /dev/null +++ b/test/PutTests.hs @@ -0,0 +1,144 @@ +{-# LANGUAGE OverloadedStrings #-} + +module PutTests ( tests ) where + +import qualified Data.Aeson as Aeson +import qualified Data.HashMap.Strict as Map +import qualified Data.Vector as Vector + +import Database.EJDB2 +import Database.EJDB2.Options + +import Plant + +import Prelude hiding ( id ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testDatabaseOpts) close $ \databaseIO -> + testGroup "put" + [ putNewTest databaseIO + , putOnNewIdTest databaseIO + , putOnExistingIdTest databaseIO + , mergeOrPutNewTest databaseIO + , mergeOrPutExistingTest databaseIO + , patchTest databaseIO + ] + +testDatabaseOpts :: Options +testDatabaseOpts = minimalOptions "./test/put-db" [ truncateOpenFlags ] + +putNewTest :: IO Database -> TestTree +putNewTest databaseIO = testCase "putNewTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + storedPlant <- getById database "plants" id + storedPlant @?= Just plant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +putOnNewIdTest :: IO Database -> TestTree +putOnNewIdTest databaseIO = testCase "putOnNewIdTest" $ do + database <- databaseIO + put database "plants" plant 42 + storedPlant <- getById database "plants" 42 + storedPlant @?= Just plant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +putOnExistingIdTest :: IO Database -> TestTree +putOnExistingIdTest databaseIO = testCase "putOnExistingIdTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + put database "plants" lastPlant id + storedPlant <- getById database "plants" id + storedPlant @?= Just lastPlant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + + lastPlant = plant { description = Just "a tipical christmas tree" } + +mergeOrPutNewTest :: IO Database -> TestTree +mergeOrPutNewTest databaseIO = testCase "mergeOrPutNewTest" $ do + database <- databaseIO + mergeOrPut database "plants" plant 4242 + storedPlant <- getById database "plants" 4242 + storedPlant @?= Just plant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + +mergeOrPutExistingTest :: IO Database -> TestTree +mergeOrPutExistingTest databaseIO = testCase "mergeOrPutExistingTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + mergeOrPut database "plants" jsonPatch id + storedPlant <- getById database "plants" id + storedPlant @?= Just lastPlant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + + jsonPatch = Aeson.Object $ + Map.fromList [ ("year", Aeson.Null) + , ("description", "a tipical christmas tree") + ] + + lastPlant = + plant { year = Nothing, description = Just "a tipical christmas tree" } + +patchTest :: IO Database -> TestTree +patchTest databaseIO = testCase "patchTest" $ do + database <- databaseIO + id <- putNew database "plants" plant + patch database "plants" jsonPatch id + storedPlant <- getById database "plants" id + storedPlant @?= Just lastPlant + where + plant = nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + + jsonPatch = Aeson.Array $ + Vector.fromList [ Aeson.Object $ Map.fromList [ ("op", "remove") + , ("path", "/year") + ] + , Aeson.Object $ + Map.fromList [ ("op", "replace") + , ("path", "/description") + , ( "value" + , "a tipical christmas tree" + ) + ] + ] + + lastPlant = + plant { year = Nothing, description = Just "a tipical christmas tree" } diff --git a/test/QueryTests.hs b/test/QueryTests.hs new file mode 100644 --- /dev/null +++ b/test/QueryTests.hs @@ -0,0 +1,306 @@ +module QueryTests ( tests ) where + +import Asserts + +import Data.Aeson ( Value ) +import Data.Int + +import Database.EJDB2 +import Database.EJDB2.Options +import qualified Database.EJDB2.Query as Query + +import Plant + +import Prelude hiding ( id ) + +import Test.Tasty +import Test.Tasty.HUnit + +tests :: TestTree +tests = withResource (open testReadOnlyDatabaseOpts) close $ \databaseIO -> + testGroup "get" + [ getListWithBoolQueryTest databaseIO + , getListWithI64QueryTest databaseIO + , getListWithI64AtIndexQueryTest databaseIO + , getListWithF64QueryTest databaseIO + , getListWithF64AtIndexQueryTest databaseIO + , getListWithStringQueryTest databaseIO + , getListWithStringAtIndexQueryTest databaseIO + , getListWithRegexQueryTest databaseIO + , getListWithRegexAtIndexQueryTest databaseIO + , getListWithNullQueryTest databaseIO + , getListWithNullAtIndexQueryTest databaseIO + , getListWithMixedQueryTest databaseIO + , getListWithTwoStringsQueryTest databaseIO + ] + +testReadOnlyDatabaseOpts :: Options +testReadOnlyDatabaseOpts = + minimalOptions "./test/read-only-db" [ readonlyOpenFlags ] + +getListWithBoolQueryTest :: IO Database -> TestTree +getListWithBoolQueryTest databaseIO = testCase "getListWithBoolQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[isTree=:?] | asc /name" + Query.setBoolAtIndex False 0 query + plants <- getList database query + plants + @?= [ ( 2 + , Just nothingPlant { id = Nothing + , name = Just "gentiana brentae" + , isTree = Just False + , year = Just 2008 + , description = Just "violet 🌺flower" + } + ) + , ( 3 + , Just nothingPlant { id = Nothing + , name = Just "leontopodium" + , isTree = Just False + , year = Just 1817 + , description = + Just "tipical alpine flower" + } + ) + , ( 4 + , Just nothingPlant { id = Nothing + , name = + Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ) + ] + +getListWithI64QueryTest :: IO Database -> TestTree +getListWithI64QueryTest databaseIO = testCase "getListWithI64Query" $ do + database <- databaseIO + query <- Query.fromString "@plants/[year>:year] | asc /name" + Query.setI64 1800 "year" query + plants <- getList database query + plants + @?= [ ( 2 + , Just nothingPlant { id = Nothing + , name = Just "gentiana brentae" + , isTree = Just False + , year = Just 2008 + , description = Just "violet 🌺flower" + } + ) + , ( 3 + , Just nothingPlant { id = Nothing + , name = Just "leontopodium" + , isTree = Just False + , year = Just 1817 + , description = + Just "tipical alpine flower" + } + ) + ] + +getListWithI64AtIndexQueryTest :: IO Database -> TestTree +getListWithI64AtIndexQueryTest databaseIO = testCase "getListWithI64AtIndexQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[year>:?] | asc /name" + Query.setI64AtIndex 1800 0 query + plants <- getList database query + plants + @?= [ ( 2 + , Just nothingPlant { id = Nothing + , name = Just "gentiana brentae" + , isTree = Just False + , year = Just 2008 + , description = Just "violet 🌺flower" + } + ) + , ( 3 + , Just nothingPlant { id = Nothing + , name = Just "leontopodium" + , isTree = Just False + , year = Just 1817 + , description = + Just "tipical alpine flower" + } + ) + ] + +getListWithF64QueryTest :: IO Database -> TestTree +getListWithF64QueryTest databaseIO = testCase "getListWithF64Query" $ do + database <- databaseIO + query <- Query.fromString "@plants/[ratio > :ratio] | asc /name" + Query.setF64 1.6 "ratio" query + plants <- getList database query + plants @?= [ ( 4 + , Just nothingPlant { id = Nothing + , name = + Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ) + ] + +getListWithF64AtIndexQueryTest :: IO Database -> TestTree +getListWithF64AtIndexQueryTest databaseIO = + testCase "getListWithF64AtIndexQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[ratio > :?] | asc /name" + Query.setF64AtIndex 1.6 0 query + plants <- getList database query + plants @?= [ ( 4 + , Just nothingPlant { id = Nothing + , name = + Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ) + ] + +getListWithStringQueryTest :: IO Database -> TestTree +getListWithStringQueryTest databaseIO = testCase "getListWithStringQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[name=:name] | asc /name" + Query.setString "pinus" "name" query + plants <- getList database query + plants @?= [ ( 1 + , Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + ) + ] + +getListWithStringAtIndexQueryTest :: IO Database -> TestTree +getListWithStringAtIndexQueryTest databaseIO = + testCase "getListWithStringAtIndexQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[name=:?] | asc /name" + Query.setStringAtIndex "pinus" 0 query + plants <- getList database query + plants @?= [ ( 1 + , Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + ) + ] + +getListWithRegexQueryTest :: IO Database -> TestTree +getListWithRegexQueryTest databaseIO = testCase "getListWithRegexQuery" $ do + database <- databaseIO + query + <- Query.fromString "@plants/[description re :description ] | asc /name" + Query.setRegex ".*Italy.*" "description" query + plants <- getList database query + plants @?= [ ( 4 + , Just nothingPlant { id = Nothing + , name = + Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ) + ] + +getListWithRegexAtIndexQueryTest :: IO Database -> TestTree +getListWithRegexAtIndexQueryTest databaseIO = + testCase "getListWithRegexAtIndexQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[description re :?] | asc /name" + Query.setRegexAtIndex "very.*Italy" 0 query + plants <- getList database query + plants @?= [ ( 4 + , Just nothingPlant { id = Nothing + , name = + Just "leucanthemum vulgare" + , isTree = Just False + , year = Just 1778 + , description = Just "very common flower in Italy πŸ•" + , ratio = Just 1.618 + } + ) + ] + +getListWithNullQueryTest :: IO Database -> TestTree +getListWithNullQueryTest databaseIO = testCase "getListWithNullQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[ratio=:ratio] | asc /name" + Query.setNull "ratio" query + plants <- getList database query + plants @?= [ ( 1 + , Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + , ratio = Nothing + } + ) + ] + +getListWithNullAtIndexQueryTest :: IO Database -> TestTree +getListWithNullAtIndexQueryTest databaseIO = + testCase "getListWithNullAtIndexQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[ratio=:?] | asc /name" + Query.setNullAtIndex 0 query + plants <- getList database query + plants @?= [ ( 1 + , Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + , ratio = Nothing + } + ) + ] + +getListWithMixedQueryTest :: IO Database -> TestTree +getListWithMixedQueryTest databaseIO = testCase "getListWithMixedQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[year>:year] and /[isTree=:?] and /[name=:?] | asc /name" + Query.setI64 1700 "year" query + Query.setBoolAtIndex True 0 query + Query.setStringAtIndex "pinus" 1 query + plants <- getList database query + plants @?= [ ( 1 + , Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + ) + ] + +getListWithTwoStringsQueryTest :: IO Database -> TestTree +getListWithTwoStringsQueryTest databaseIO = + testCase "getListWithTwoStringsQuery" $ do + database <- databaseIO + query <- Query.fromString "@plants/[description re :descr] and /[name=:name] | asc /name" + Query.setRegex ".*wow.*" "descr" query + Query.setString "pinus" "name" query + plants <- getList database query + plants @?= [ ( 1 + , Just nothingPlant { id = Nothing + , name = Just "pinus" + , isTree = Just True + , year = Just 1753 + , description = Just "wow 🌲" + } + ) + ] diff --git a/test/read-only-db b/test/read-only-db new file mode 100644 Binary files /dev/null and b/test/read-only-db differ