Permalink
Browse files

Merge pull request #90 from input-output-hk/adinapoli/immutable-store…

…-poc

Data store for the immutable part of the blockchain
  • Loading branch information...
adinapoli-iohk committed Dec 6, 2018
2 parents a7fba89 + 91f4430 commit 52fa340238d5a9a4a88e189c9c145dc817071d96
@@ -10,10 +10,12 @@ doc/protocols.toc
cabal.project.local*
cabal.project.local~
dist-newstyle/
dist/
*.swp
*.swo
*~
result*
tags
.stack-work/
*.tix
@@ -17,6 +17,12 @@ source-repository head
library
hs-source-dirs: src
if os(windows)
hs-Source-Dirs: src-win32/
else
hs-Source-Dirs: src-unix/
-- At this experiment/prototype stage everything is exposed.
-- This has to be tidied up once the design becomes clear.
exposed-modules:
@@ -96,11 +102,19 @@ library
-- TODO rename.
Ouroboros.Network.ChainSyncExamples
-- Storing things on disk
Ouroboros.Storage.Immutable.DB
Ouroboros.Storage.FS.Class
Ouroboros.Storage.FS.Sim
Ouroboros.Storage.FS.IO
Ouroboros.Storage.Util
other-modules:
Ouroboros.Network.ByteChannel
Ouroboros.Network.Codec
Ouroboros.Network.Framing
Ouroboros.Network.MsgChannel
Ouroboros.Storage.IO
default-language: Haskell2010
other-extensions: BangPatterns,
DataKinds,
@@ -134,7 +148,10 @@ library
clock >=0.7 && <0.8,
containers >=0.6 && <0.7,
cryptonite >=0.25 && <0.26,
directory < 1.5,
exceptions < 0.11,
fingertree >=0.1 && <0.2,
filepath < 1.5.0.0,
free >=5.1 && <5.2,
hashable >=1.2 && <1.3,
memory >=0.14 && <0.15,
@@ -155,6 +172,10 @@ library
void >=0.7 && <0.8,
QuickCheck >=2.12 && <2.13
if os(windows)
Build-depends: Win32
else
Build-depends: unix
ghc-options: -Wall
-Wno-unticked-promoted-constructors
@@ -259,3 +280,30 @@ test-suite test-consensus
typed-transitions
ghc-options: -Wall
-fno-ignore-asserts
test-suite test-storage
type: exitcode-stdio-1.0
hs-source-dirs: test-storage
default-language: Haskell2010
main-is: Main.hs
other-modules:
Test.Ouroboros.Storage
Test.Ouroboros.Storage.Immutable.Sim
build-depends: base,
ouroboros-network,
QuickCheck,
bytestring,
containers,
cryptonite,
directory,
exceptions,
filepath,
mtl,
tasty,
tasty-expected-failure,
tasty-hunit,
tasty-quickcheck,
temporary
ghc-options: -Wall
-fno-ignore-asserts
13 pkg.nix
@@ -1,8 +1,9 @@
{ mkDerivation, aeson, array, base, base16-bytestring, bytestring, cborg
, clock, containers, cryptonite, fingertree, free, hashable, memory, mtl
, network, pipes, process, psqueues, QuickCheck, random, semigroups, stdenv
, stm, serialise, string-conv, tasty, tasty-expected-failure, tasty-quickcheck
, text, transformers, typed-transitions, unliftio, void, nixpkgs
, stm, serialise, string-conv, tasty, tasty-expected-failure, tasty-hunit
, tasty-quickcheck, temporary, text, transformers, typed-transitions, unliftio
, void, nixpkgs
}:
mkDerivation {
pname = "ouroboros-network";
@@ -13,14 +14,14 @@ mkDerivation {
array aeson base base16-bytestring bytestring cborg clock containers
cryptonite fingertree free hashable memory mtl network pipes process
psqueues QuickCheck random semigroups serialise stm string-conv tasty
tasty-quickcheck text transformers typed-transitions unliftio void
tasty-quickcheck tasty-hunit temporary text transformers typed-transitions
unliftio void
];
testHaskellDepends = [
array base bytestring cborg clock containers
fingertree free hashable mtl process QuickCheck random semigroups stm tasty
tasty-expected-failure tasty-quickcheck text transformers void
tasty-expected-failure tasty-quickcheck text transformers typed-transitions
void
tasty-expected-failure tasty-hunit tasty-quickcheck temporary text
transformers typed-transitions void
];
description = "A networking layer for the Ouroboros blockchain protocol";
license = stdenv.lib.licenses.mit;
@@ -0,0 +1,101 @@
{-# LANGUAGE LambdaCase #-}
module Ouroboros.Storage.IO (
FHandle --opaque(TM)
, open
, truncate
, seek
, read
, write
, close
) where
import Prelude hiding (read, truncate)
import Control.Concurrent.MVar (MVar, modifyMVar, newMVar, withMVar)
import Control.Exception (throwIO)
import Data.ByteString (ByteString)
import Data.ByteString.Internal as Internal
import Data.Word (Word32, Word64, Word8)
import Foreign (Ptr)
import System.IO (IOMode (..), SeekMode (..))
import System.Posix (Fd (..), OpenFileFlags (..), OpenMode (..),
closeFd, fdReadBuf, fdSeek, fdWriteBuf, openFd,
stdFileMode)
import System.Posix.Files (setFdSize)
-- A thin wrapper over a POSIX 'Fd', guarded by an MVar so that we can
-- implement 'close' as an idempotent operation.
newtype FHandle = FHandle (MVar (Maybe Fd))
-- | Some sensible defaults for the 'OpenFileFlags'. Note that the 'unix'
-- package /already/ exports a smart constructor called @defaultFileFlags@
-- already, but we define our own to not be depedent by whichever default
-- choice unix's library authors made, and to be able to change our minds
-- later if necessary.
-- In particular, we are interested in the 'append' and 'exclusive' flags,
-- which were largely the reason why we introduced this low-level module.
defaultFileFlags :: OpenFileFlags
defaultFileFlags = OpenFileFlags {
append = False
, exclusive = False
, noctty = False
, nonBlock = False
, trunc = False
}
-- | Opens a file from disk.
open :: FilePath -> IOMode -> IO FHandle
open filename ioMode = do
let (openMode, fileMode, fileFlags)
| ioMode == ReadMode = ( ReadOnly
, Nothing
, defaultFileFlags)
| ioMode == AppendMode = ( WriteOnly
, Just stdFileMode
, defaultFileFlags { append = True })
| otherwise = ( ReadWrite
, Just stdFileMode
, defaultFileFlags)
fd <- openFd filename openMode fileMode fileFlags
FHandle <$> newMVar (Just fd)
-- | Writes the data pointed by the input 'Ptr Word8' into the input 'FHandle'.
write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32
write (FHandle fdVar) data' bytes =
withMVar fdVar $ \case
Nothing -> throwIO (userError "write: the FHandle is closed.")
Just fd -> fmap fromIntegral . fdWriteBuf fd data'
$ fromIntegral bytes
-- | Seek within the file. Returns the offset within the file after the seek.
seek :: FHandle -> SeekMode -> Word64 -> IO Word64
seek (FHandle fdVar) seekMode bytes =
withMVar fdVar $ \case
Nothing -> throwIO (userError "seek: the FHandle is closed.")
Just fd -> fromIntegral <$> fdSeek fd seekMode (fromIntegral bytes)
-- | Reads a given number of bytes from the input 'FHandle'.
read :: FHandle -> Int -> IO ByteString
read (FHandle fdVar) bytes =
withMVar fdVar $ \case
Nothing -> throwIO (userError "read: the FHandle is closed.")
Just fd -> Internal.createUptoN bytes $ \ptr ->
fromIntegral <$> fdReadBuf fd ptr (fromIntegral bytes)
-- | Truncates the file managed by the input 'FHandle' to the input size.
truncate :: FHandle -> Word64 -> IO ()
truncate (FHandle fdVar) size =
withMVar fdVar $ \case
Nothing -> throwIO (userError "truncate: the FHandle is closed.")
Just fd -> setFdSize fd (fromIntegral size)
-- | Closes a 'FHandle'. It's nice to be slightly more lenient here, as the
-- 'hClose' equivalent from 'System.IO' allows for this operation to be
-- idempotent.
close :: FHandle -> IO ()
close (FHandle fdVar) =
modifyMVar fdVar $ \case
Nothing -> return (Nothing, ())
Just fd -> closeFd fd >> return (Nothing, ())
@@ -0,0 +1,53 @@
module Ouroboros.Storage.IO (
FHandle --opaque(TM)
, open
, truncate
, seek
, read
, write
, close
) where
import Prelude hiding (read, truncate)
import Control.Exception (IOException, SomeException)
import qualified Control.Exception as E
import Control.Exception.Extensible (throw, try)
import Data.Word (Word32, Word8)
import Foreign (Ptr)
import System.Directory (createDirectoryIfMissing, removeFile)
import System.IO
import System.Win32 (HANDLE, cREATE_ALWAYS, closeHandle, createFile,
fILE_ATTRIBUTE_NORMAL, fILE_SHARE_NONE, flushFileBuffers,
gENERIC_ALL, gENERIC_READ, gENERIC_WRITE, win32_WriteFile)
data FHandle = FHandle HANDLE
open :: FilePath -> IOMode -> IO FHandle
open filename ioMode = do
let accessMode
| ioMode == ReadMode = gENERIC_READ
| ioMode == AppendMode = gENERIC_WRITE
| otherwise = gENERIC_ALL
fmap FHandle $ createFile filename
accessMode
fILE_SHARE_NONE -- TODO: this is wrong, needs to be changed.
Nothing
cREATE_ALWAYS -- TODO: ditto, ReadMode should enforce is there.
fILE_ATTRIBUTE_NORMAL
Nothing
write :: FHandle -> Ptr Word8 -> Word32 -> IO Word32
write (FHandle handle) data' length = win32_WriteFile handle data' length Nothing
seek :: FHandle -> SeekMode -> Word64 -> IO Word64
seek = error "seek: needs a Windows hero to implement."
read :: FHandle -> Int -> IO ByteString
read = error "read: needs a Windows hero to implement."
truncate :: FHandle -> Word64 -> IO ()
truncate = error "truncate: needs a Windows hero to implement."
close :: FHandle -> IO ()
close (FHandle handle) = closeHandle handle
@@ -16,6 +16,7 @@ module Ouroboros.Consensus.Util (
, chunks
, byteStringChunks
, lazyByteStringChunks
, whenJust
-- * Decorating one value with another
, DecoratedWith(..)
, Decorates(..)
@@ -75,6 +76,11 @@ lazyByteStringChunks n bs
| otherwise = let (chunk, bs') = Lazy.splitAt (fromIntegral n) bs
in chunk : lazyByteStringChunks n bs'
whenJust :: Applicative f => Maybe a -> (a -> f ()) -> f ()
whenJust (Just x) f = f x
whenJust Nothing _ = pure ()
{-# INLINE whenJust #-}
{-------------------------------------------------------------------------------
Decorating one value with another
-------------------------------------------------------------------------------}
Oops, something went wrong.

0 comments on commit 52fa340

Please sign in to comment.