mirror of
https://github.com/unisonweb/unison.git
synced 2024-09-11 10:35:57 +03:00
Merge pull request #43 from sfultong/leveldb-simplified
Leveldb simplified
This commit is contained in:
commit
1d80b2eaa8
@ -1,4 +1,4 @@
|
||||
{-# LANGUAGE PatternSynonyms #-}
|
||||
{-# LANGUAGE PatternSynonyms, CPP #-}
|
||||
|
||||
module Main where
|
||||
|
||||
@ -10,7 +10,11 @@ import Unison.Node.Store (Store)
|
||||
import Unison.Var (Var)
|
||||
import qualified Unison.ABT as ABT
|
||||
import qualified Unison.Node.BasicNode as BasicNode
|
||||
#ifdef leveldb
|
||||
import qualified Unison.Node.LeveldbStore as DBStore
|
||||
#else
|
||||
import qualified Unison.Node.FileStore as FileStore
|
||||
#endif
|
||||
import qualified Unison.NodeServer as NodeServer
|
||||
import qualified Unison.Reference as Reference
|
||||
import qualified Unison.Symbol as Symbol
|
||||
@ -21,8 +25,15 @@ hash :: Var v => Term.Term v -> Reference
|
||||
hash (Term.Ref' r) = r
|
||||
hash t = Reference.Derived (ABT.hash t)
|
||||
|
||||
store :: IO (Store IO (Symbol.Symbol View.DFO))
|
||||
#ifdef leveldb
|
||||
store = DBStore.make "store"
|
||||
#else
|
||||
store = FileStore.make "store"
|
||||
#endif
|
||||
|
||||
main :: IO ()
|
||||
main = do
|
||||
store <- FileStore.make "store" :: IO (Store IO (Symbol.Symbol View.DFO))
|
||||
node <- BasicNode.make hash store
|
||||
store' <- store
|
||||
node <- BasicNode.make hash store'
|
||||
NodeServer.server 8080 node
|
||||
|
93
node/src/Unison/Node/LeveldbStore.hs
Normal file
93
node/src/Unison/Node/LeveldbStore.hs
Normal file
@ -0,0 +1,93 @@
|
||||
module Unison.Node.LeveldbStore where
|
||||
|
||||
import Control.Applicative
|
||||
import Control.Monad.Catch
|
||||
import Control.Monad.IO.Class
|
||||
import Data.Set (Set)
|
||||
import System.FilePath ((</>))
|
||||
import Data.Aeson (ToJSON(..),FromJSON(..))
|
||||
import Data.ByteString (ByteString)
|
||||
import Data.Text.Encoding (decodeUtf8, encodeUtf8)
|
||||
import Unison.Hash (Hash)
|
||||
--import Unison.Metadata (Metadata)
|
||||
import Unison.Note (Noted,Note)
|
||||
import Unison.Node.Store (Store, Store(..))
|
||||
import Unison.Reference (Reference)
|
||||
import qualified Data.Aeson as Aeson
|
||||
import qualified Database.LevelDB.Base as DB
|
||||
import qualified Database.LevelDB.Iterator as IT
|
||||
--import qualified Data.ByteString as ByteString
|
||||
import qualified Data.ByteString.Lazy as LazyByteString
|
||||
import qualified Data.Set as Set
|
||||
import qualified Unison.Hash as Hash
|
||||
import qualified Unison.Note as Note
|
||||
import qualified Unison.Reference as Reference
|
||||
|
||||
-- | Create a 'Store' rooted at the given path.
|
||||
make :: (MonadIO m, MonadMask m, Ord v, ToJSON v, FromJSON v) => FilePath -> m (Store m v)
|
||||
make root =
|
||||
let
|
||||
dbOptions = DB.defaultOptions { DB.createIfMissing = True }
|
||||
|
||||
hashesIn :: (MonadIO m, MonadMask m) =>
|
||||
(ByteString -> Reference) -> DB.DB -> Noted m (Set Reference)
|
||||
hashesIn f db =
|
||||
let keyToReference it = fmap (fmap f) (DB.iterKey it)
|
||||
referenceList l it = keyToReference it >>=
|
||||
maybe (pure l) (\i -> referenceList (i:l) it)
|
||||
referenceSet it = Set.fromList <$> referenceList [] it
|
||||
runSet = IT.withIter db DB.defaultReadOptions referenceSet
|
||||
in Note.lift runSet
|
||||
|
||||
n :: Either String a -> Either Note a
|
||||
n (Left e) = Left (Note.note e)
|
||||
n (Right a) = Right a
|
||||
|
||||
maybeToEither b Nothing = Left b
|
||||
maybeToEither _ (Just a) = Right a
|
||||
|
||||
read :: (MonadIO m, FromJSON a) => (h -> ByteString) -> DB.DB -> h -> Noted m a
|
||||
read f db h = Note.noted $
|
||||
(n . (>>= Aeson.eitherDecodeStrict) . maybeToEither "knf")
|
||||
<$> DB.get db DB.defaultReadOptions (f h)
|
||||
|
||||
write :: (MonadIO m, ToJSON a) => (h -> ByteString) -> DB.DB -> h -> a -> Noted m ()
|
||||
write f db h v = Note.lift $
|
||||
DB.put db DB.defaultWriteOptions (f h) (LazyByteString.toStrict (Aeson.encode v))
|
||||
|
||||
read' :: (MonadIO m, FromJSON a) => DB.DB -> Hash -> Noted m a
|
||||
read' = read Hash.toBytes
|
||||
|
||||
write' :: (MonadIO m, ToJSON a) => DB.DB -> Hash -> a -> Noted m ()
|
||||
write' = write Hash.toBytes
|
||||
|
||||
hashes :: (MonadIO m, MonadMask m) =>
|
||||
DB.DB -> DB.DB -> Maybe (Set Reference) -> Noted m (Set Reference)
|
||||
hashes termsDB builtinMetadataDB limit =
|
||||
let limitf = maybe id Set.intersection limit
|
||||
in liftA2 Set.union
|
||||
(limitf <$> hashesIn (Reference.Derived . Hash.fromBytes) termsDB)
|
||||
(limitf <$> hashesIn (Reference.Builtin . decodeUtf8) builtinMetadataDB)
|
||||
|
||||
in do
|
||||
termsDB <- DB.open (root </> "terms") dbOptions
|
||||
metadataDB <- DB.open (root </> "metadata") dbOptions
|
||||
builtinTypesDB <- DB.open (root </> "builtinTypes") dbOptions
|
||||
builtinMetadataDB <- DB.open (root </> "builtinMetadata") dbOptions
|
||||
|
||||
pure $ Store
|
||||
(hashes termsDB builtinMetadataDB) -- hashes
|
||||
(read' termsDB) -- readTerm
|
||||
(write' termsDB) -- writeTerm
|
||||
(\r -> case r of -- typeOfTerm
|
||||
Reference.Derived h -> read' termsDB h
|
||||
Reference.Builtin b -> read encodeUtf8 builtinTypesDB b)
|
||||
(\r -> case r of -- annotateTerm
|
||||
Reference.Derived h -> write' termsDB h
|
||||
Reference.Builtin b -> write encodeUtf8 builtinTypesDB b)
|
||||
(\r -> case r of -- readMetadata
|
||||
Reference.Derived h -> read' metadataDB h
|
||||
Reference.Builtin b -> read encodeUtf8 builtinMetadataDB b)
|
||||
(\r -> case r of -- writeMetadata
|
||||
Reference.Derived h -> write' metadataDB h
|
||||
Reference.Builtin b -> write encodeUtf8 builtinMetadataDB b)
|
@ -36,6 +36,10 @@ flag quiet
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
flag leveldb
|
||||
manual: True
|
||||
default: False
|
||||
|
||||
library
|
||||
hs-source-dirs: src
|
||||
|
||||
@ -94,6 +98,9 @@ library
|
||||
wai-extra,
|
||||
wai-middleware-static
|
||||
|
||||
if flag(leveldb)
|
||||
build-depends: exceptions, leveldb-haskell
|
||||
|
||||
ghc-options: -Wall -fno-warn-name-shadowing -threaded -rtsopts -with-rtsopts=-N
|
||||
|
||||
if flag(optimized)
|
||||
@ -141,6 +148,10 @@ executable node
|
||||
, wai-extra
|
||||
, wai-middleware-static
|
||||
|
||||
if flag(leveldb)
|
||||
build-depends: exceptions, leveldb-haskell
|
||||
cpp-options: -Dleveldb
|
||||
|
||||
test-suite tests
|
||||
type: exitcode-stdio-1.0
|
||||
main-is: Suite.hs
|
||||
|
@ -4,7 +4,7 @@ packages:
|
||||
- shared
|
||||
- node
|
||||
|
||||
resolver: lts-3.10
|
||||
resolver: lts-5.9
|
||||
|
||||
extra-deps:
|
||||
- applicative-extras-0.1.8
|
||||
|
Loading…
Reference in New Issue
Block a user