Skip to content

Commit a566aa2

Browse files
cblpcblp
authored
Add Swarm as a component (#55)
1 parent acd43ff commit a566aa2

12 files changed

+272
-5
lines changed

‎.gitignore

+2
Original file line numberDiff line numberDiff line change
@@ -1 +1,3 @@
1+
_artifacts/
2+
_build/
13
.stack-work/

‎.travis.yml

+13-4
Original file line numberDiff line numberDiff line change
@@ -11,6 +11,7 @@ language: generic
1111
# Caching so the next build will be fast too.
1212
cache:
1313
directories:
14+
- _build
1415
- $HOME/.local/bin
1516
- $HOME/.stack
1617

@@ -29,7 +30,12 @@ before_install:
2930
|| (travis_retry curl -L https://www.stackage.org/stack/linux-x86_64
3031
| tar xz --wildcards --strip-components=1 -C ~/.local/bin '*/stack')
3132
- export STACK="stack --no-terminal --install-ghc"
32-
- export STACK_BUILD_DEPS="$STACK build --test --only-dependencies"
33+
- export EXPORTED_PACKAGES="ron ron-rdt ron-schema ron-storage"
34+
- >
35+
function build_deps {
36+
# (cd _build && cmake .. && make) &&
37+
$STACK build --test --only-dependencies
38+
}
3339
3440
script:
3541
# Build the package, its tests, and its docs and run the tests
@@ -38,15 +44,15 @@ script:
3844
matrix:
3945
include:
4046
- compiler: GHC 8.6
41-
install: $STACK_BUILD_DEPS
47+
install: build_deps
4248
- compiler: GHC 8.4
4349
env: STACK_YAML="ghc-8.4.yaml"
44-
install: $STACK_BUILD_DEPS
50+
install: build_deps
4551
- name: hlint
4652
install: $STACK build hlint
4753
script: $STACK exec -- hlint .
4854
- name: haddock
49-
script: $STACK haddock --no-haddock-deps
55+
script: $STACK haddock --no-haddock-deps $EXPORTED_PACKAGES
5056
- name: 'cabal check: ron'
5157
install: $STACK install cabal-install
5258
script: cd ron && cabal check
@@ -59,6 +65,9 @@ matrix:
5965
- name: 'cabal check: ron-storage'
6066
install: $STACK install cabal-install
6167
script: cd ron-storage && cabal check
68+
# - name: 'cabal check: swarm'
69+
# install: $STACK install cabal-install
70+
# script: cd swarm && cabal check
6271
- name: weeder
6372
install: $STACK build weeder
6473
script: $STACK exec -- weeder

‎BUILD.md

+27
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,27 @@
1+
## Toolchain
2+
3+
1. For pure Haskell libraries:
4+
5+
1. [stack](https://haskellstack.org)
6+
7+
2. For external C++ components
8+
9+
1. [CMake](https://cmake.org)
10+
11+
12+
## Everything except `swarm`
13+
14+
Everything except `swarm` is pure Haskell. So build it with
15+
16+
$ stack build <component name>
17+
18+
19+
## `swarm`
20+
21+
1. Build external C++ components out-of-tree
22+
23+
$ (cd _build && cmake .. && make)
24+
25+
2. Build `swarm`
26+
27+
$ stack build swarm

‎CMakeLists.txt

+10
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,10 @@
1+
cmake_minimum_required(VERSION 3.0)
2+
include(ExternalProject)
3+
4+
set(RON_CXX_INSTALL_DIR "${CMAKE_SOURCE_DIR}/swarm/_artifacts/")
5+
ExternalProject_Add(
6+
ron-cxx
7+
GIT_REPOSITORY https://github.com/gritzko/ron-cxx.git
8+
GIT_TAG dev
9+
CMAKE_ARGS -DCMAKE_INSTALL_PREFIX:PATH=${RON_CXX_INSTALL_DIR}
10+
)

‎_build/.gitignore

Whitespace-only changes.

‎ghc-8.4.yaml

+4
Original file line numberDiff line numberDiff line change
@@ -6,11 +6,15 @@ packages:
66
- ron-schema
77
- ron-storage
88
- ron-test
9+
- swarm
910
- examples
1011

1112
extra-deps:
1213
# ron-schema:
1314
- hedn-0.2.0.0
1415

16+
# swarm:
17+
- inline-c-cpp-0.3.0.1
18+
1519
# hedn:
1620
- megaparsec-7.0.4

‎ghc-8.6.yaml

+1
Original file line numberDiff line numberDiff line change
@@ -6,6 +6,7 @@ packages:
66
- ron-schema
77
- ron-storage
88
- ron-test
9+
- swarm
910
- examples
1011

1112
extra-deps:

‎swarm/lib/Swarm/DB/Replica.hs

+102
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,102 @@
1+
{-# LANGUAGE FunctionalDependencies #-}
2+
{-# LANGUAGE NamedFieldPuns #-}
3+
{-# LANGUAGE OverloadedStrings #-}
4+
{-# LANGUAGE QuasiQuotes #-}
5+
{-# LANGUAGE TemplateHaskell #-}
6+
7+
module Swarm.DB.Replica (
8+
Replica (get),
9+
) where
10+
11+
import Control.Exception (mask_)
12+
import qualified Data.ByteString as BS
13+
import qualified Data.Map.Strict as Map
14+
import Foreign (FinalizerPtr, ForeignPtr, Ptr, allocaArray,
15+
newForeignPtr, peekElemOff, wordPtrToPtr)
16+
import Language.C.Inline.Context (ctxTypesTable)
17+
import qualified Language.C.Inline.Cpp as Cpp
18+
import Language.C.Types (TypeSpecifier (TypeName))
19+
20+
import RON.UUID (UUID (UUID))
21+
22+
import Swarm.RON.Status (Status (Status, code, comment), StatusC)
23+
import qualified Swarm.RON.Status as Status
24+
import Swarm.RON.Text (TextFrame (TextFrame), TextFrameC)
25+
26+
-- | Tag for 'Ptr' to @ron::Replica<TextFrame>@
27+
data TextReplicaC
28+
29+
-- | Equivalent of @ron::Replica<TextFrame>@
30+
newtype TextReplica = TextReplica (Ptr TextReplicaC)
31+
32+
$(Cpp.context
33+
$ Cpp.cppCtx
34+
<> Cpp.fptrCtx
35+
<> mempty
36+
{ ctxTypesTable = Map.fromList
37+
[ (TypeName "Status" , [t| StatusC |])
38+
, (TypeName "TextFrame" , [t| TextFrameC |])
39+
, (TypeName "TextReplica", [t| TextReplicaC |])
40+
]
41+
}
42+
)
43+
Cpp.include "<swarm/db/replica.hpp>"
44+
Cpp.include "<swarm/ron/status.hpp>"
45+
Cpp.include "<swarm/ron/text.hpp>"
46+
Cpp.verbatim "typedef ron::Status Status;"
47+
Cpp.verbatim "typedef ron::TextFrame TextFrame;"
48+
Cpp.verbatim "typedef ron::Replica<ron::TextFrame> TextReplica;"
49+
50+
-- | @class ron::Replica<>@
51+
class Replica replica frame | frame -> replica, replica -> frame where
52+
53+
-- | @ron::Replica::Get()@
54+
get :: UUID -> replica -> IO (Either Status frame)
55+
56+
instance Replica TextReplica TextFrame where
57+
58+
get (UUID x y) (TextReplica replicaP) = do
59+
frameFP <- newTextFrame
60+
status <- do
61+
statusFP <- mask_ $ do
62+
statusP <- [Cpp.exp| Status * {
63+
new Status(
64+
$(TextReplica * replicaP)
65+
->Get(
66+
* $fptr-ptr:(TextFrame * frameFP),
67+
{$(uint64_t x), $(uint64_t y)}
68+
)
69+
)
70+
} |]
71+
newForeignPtr deleteStatus statusP
72+
allocaArray 4 $ \arena -> do
73+
[Cpp.block| void {
74+
uint64_t * const arena = $(uint64_t * arena);
75+
uint64_t & x = arena[0];
76+
uint64_t & y = arena[1];
77+
uint64_t & ptr = arena[2];
78+
uint64_t & len = arena[3];
79+
Status & status = * $fptr-ptr:(Status * statusFP);
80+
x = uint64_t(status.code().value());
81+
y = uint64_t(status.code().origin());
82+
ptr = uintptr_t(status.comment().data());
83+
len = status.comment().length();
84+
} |]
85+
code <- UUID <$> peekElemOff arena 0 <*> peekElemOff arena 1
86+
ptr <- wordPtrToPtr . fromIntegral <$> peekElemOff arena 2
87+
len <- fromIntegral <$> peekElemOff arena 3
88+
comment <- BS.packCStringLen (ptr, len)
89+
pure Status{code, comment}
90+
pure $ case status of
91+
Status code _ | code == Status.ok -> Right $ TextFrame frameFP
92+
_ -> Left status
93+
94+
newTextFrame :: IO (ForeignPtr TextFrameC)
95+
newTextFrame = mask_ $ do
96+
p <- [Cpp.exp| TextFrame * { new TextFrame } |]
97+
newForeignPtr deleteTextFrame p
98+
99+
foreign import ccall "&deleteStatus" deleteStatus :: FinalizerPtr StatusC
100+
101+
foreign import ccall "&deleteTextFrame" deleteTextFrame
102+
:: FinalizerPtr TextFrameC

‎swarm/lib/Swarm/RON/Status.hs

+55
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,55 @@
1+
{-# LANGUAGE OverloadedStrings #-}
2+
{-# LANGUAGE QuasiQuotes #-}
3+
{-# LANGUAGE TemplateHaskell #-}
4+
5+
module Swarm.RON.Status (
6+
Status (..),
7+
StatusC,
8+
ok,
9+
) where
10+
11+
import Data.ByteString (ByteString)
12+
import qualified Language.C.Inline.Cpp as Cpp
13+
14+
import RON.UUID (UUID (UUID))
15+
16+
Cpp.context Cpp.cppCtx
17+
Cpp.include "<swarm/ron/status.hpp>"
18+
19+
-- | Tag for 'Ptr' to @ron::Status@
20+
data StatusC
21+
22+
-- | Equivalent of @ron::Status@
23+
data Status = Status{code :: UUID, comment :: ByteString}
24+
25+
ok :: UUID
26+
ok = UUID
27+
[Cpp.pure| uint64_t { uint64_t(ron::Status::OK.code().value ()) } |]
28+
[Cpp.pure| uint64_t { uint64_t(ron::Status::OK.code().origin()) } |]
29+
30+
-- | ENDOFFRAME
31+
-- | NOT_IMPLEMENTED
32+
-- | NOT_FOUND
33+
-- | BAD_STATE
34+
-- | BADARGS
35+
-- | BADSYNTAX
36+
-- | DB_FAIL
37+
-- | IOFAIL
38+
-- | BADFRAME
39+
-- | BADID
40+
-- | BADREF
41+
-- | BADVALUE
42+
43+
-- | NOTYPE
44+
-- | NOTOPEN
45+
46+
-- | CHAINBREAK
47+
-- | HASHBREAK
48+
-- | TREEBREAK
49+
-- | CAUSEBREAK
50+
51+
-- | TREEGAP
52+
-- | YARNGAP
53+
54+
-- | REPEAT
55+
-- | REORDER

‎swarm/lib/Swarm/RON/Text.hs

+12
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,12 @@
1+
module Swarm.RON.Text (
2+
TextFrame (..),
3+
TextFrameC,
4+
) where
5+
6+
import Foreign (ForeignPtr)
7+
8+
-- | Tag for 'Ptr' to @ron::TextFrame@
9+
data TextFrameC
10+
11+
-- | Equivalent of @ron::TextFrame@
12+
newtype TextFrame = TextFrame (ForeignPtr TextFrameC)

‎swarm/swarm.cabal

+35
Original file line numberDiff line numberDiff line change
@@ -0,0 +1,35 @@
1+
cabal-version: 2.2
2+
3+
name: swarm
4+
version: 0
5+
6+
category: Distributed Systems, Database
7+
license: BSD-3-Clause
8+
maintainer: Yuriy Syrovetskiy <haskell@cblp.su>
9+
synopsis: SwarmDB connector
10+
11+
description:
12+
Haskell binding to the embedded distributed database SwarmDB
13+
http://replicated.cc/swarm/
14+
15+
build-type: Simple
16+
17+
library
18+
build-depends:
19+
-- global
20+
base >= 4.10 && < 4.13,
21+
bytestring,
22+
containers,
23+
inline-c,
24+
inline-c-cpp,
25+
-- project
26+
ron,
27+
include-dirs:
28+
_artifacts/include
29+
/usr/include/botan-2
30+
default-language: Haskell2010
31+
exposed-modules:
32+
Swarm.DB.Replica
33+
Swarm.RON.Status
34+
Swarm.RON.Text
35+
hs-source-dirs: lib

‎test/script

+11-1
Original file line numberDiff line numberDiff line change
@@ -10,4 +10,14 @@ ghc_warnings=(
1010
)
1111
ghc_options=(${ghc_warnings[*]} -Werror)
1212

13-
${STACK:-stack} test --ghc-options="${ghc_options[*]}"
13+
packages=(
14+
ron
15+
ron-rdt
16+
ron-schema
17+
ron-storage
18+
ron-test
19+
# swarm
20+
examples
21+
)
22+
23+
${STACK:-stack} test --ghc-options="${ghc_options[*]}" ${packages[*]}

0 commit comments

Comments
 (0)