Merge pull request #43 from sfultong/leveldb-simplified

Leveldb simplified

node/src/Node.hs

@@ -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

node/src/Unison/Node/LeveldbStore.hs

@@ -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)

node/unison-node.cabal

@@ -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

stack.yaml

@@ -4,7 +4,7 @@ packages:
 - shared
 - node
 
-resolver: lts-3.10
+resolver: lts-5.9
 
 extra-deps:
   - applicative-extras-0.1.8