├── .gitignore
├── .travis.yml
├── CHANGELOG.md
├── Database
├── RethinkDB.hs
└── RethinkDB
│ ├── Datum.hs
│ ├── Doctest.hs
│ ├── Driver.hs
│ ├── Functions.hs
│ ├── Functions.hs-boot
│ ├── Geospatial.hs
│ ├── JSON.hs
│ ├── MapReduce.hs
│ ├── MapReduce.hs-boot
│ ├── Network.hs
│ ├── NoClash.hs
│ ├── ReQL.hs
│ ├── ReQL.hs-boot
│ ├── Time.hs
│ ├── Types.hs
│ ├── Wire.hs
│ └── Wire
│ ├── Datum.hs
│ ├── Frame.hs
│ ├── Query.hs
│ ├── Response.hs
│ ├── Term.hs
│ └── VersionDummy.hs
├── Debug.hs
├── LICENSE
├── README.md
├── Setup.hs
├── bench
└── Bench.hs
├── check-instances.sh
├── doctests.hs
├── doctests.sh
├── proto2hs.hs
├── ql2.proto
├── rethinkdb.cabal
├── stack-7.10.yaml
├── stack.yaml
├── update-bounds.sh
└── upload-haddocks.sh
/.gitignore:
--------------------------------------------------------------------------------
1 | *~
2 | *.o
3 | *.hi
4 | *.prof
5 | *.aux
6 | *.hp
7 | *.eventlog
8 | dist/
9 | \#*#
10 | .#*
11 | *.o-boot
12 | *.hi-boot
13 | .cabal-sandbox/
14 | cabal.sandbox.config
15 | .ghci
16 | .lvimrc
17 | *.nix
18 | *.drv
19 | .DS_Store
20 | .stack-work/
21 | rethinkdb_data
22 |
--------------------------------------------------------------------------------
/.travis.yml:
--------------------------------------------------------------------------------
1 | # This file has been generated -- see https://github.com/hvr/multi-ghc-travis
2 | language: c
3 | # sudo: false
4 |
5 | cache:
6 | directories:
7 | - $HOME/.cabsnap
8 | - $HOME/.cabal/packages
9 |
10 | before_cache:
11 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/build-reports.log
12 | - rm -fv $HOME/.cabal/packages/hackage.haskell.org/00-index.tar
13 |
14 | matrix:
15 | include:
16 | - env: CABALVER=1.18 GHCVER=7.6.3 NOBENCH=YES
17 | compiler: ": #GHC 7.6.3"
18 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.6.3], sources: [hvr-ghc]}}
19 | - env: CABALVER=1.18 GHCVER=7.8.4
20 | compiler: ": #GHC 7.8.4"
21 | addons: {apt: {packages: [cabal-install-1.18,ghc-7.8.4], sources: [hvr-ghc]}}
22 | - env: CABALVER=1.22 GHCVER=7.10.3
23 | compiler: ": #GHC 7.10.3"
24 | addons: {apt: {packages: [cabal-install-1.22,ghc-7.10.3], sources: [hvr-ghc]}}
25 | - env: CABALVER=1.24 GHCVER=8.0.2
26 | compiler: ": #GHC 8.0.2"
27 | addons: {apt: {packages: [cabal-install-1.24,ghc-8.0.2], sources: [hvr-ghc]}}
28 |
29 | before_script:
30 | - source /etc/lsb-release && echo "deb http://download.rethinkdb.com/apt $DISTRIB_CODENAME main" | sudo tee /etc/apt/sources.list.d/rethinkdb.list
31 | - wget -qO- http://download.rethinkdb.com/apt/pubkey.gpg | sudo apt-key add -
32 | - sudo apt-get update -q
33 | - sudo apt-get install rethinkdb
34 | - rethinkdb --bind all &
35 |
36 | before_install:
37 | - unset CC
38 | - export PATH=/opt/ghc/$GHCVER/bin:/opt/cabal/$CABALVER/bin:$PATH
39 | - CABALOPTS="--enable-tests"
40 | # - if [ ! "x$NOBENCH" = "xYES" ]; then
41 | # CABALOPTS="$CABALOPTS --enable-benchmarks";
42 | # fi
43 |
44 | install:
45 | - cabal --version
46 | - echo "$(ghc --version) [$(ghc --print-project-git-commit-id 2> /dev/null || echo '?')]"
47 | - if [ -f $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz ];
48 | then
49 | zcat $HOME/.cabal/packages/hackage.haskell.org/00-index.tar.gz >
50 | $HOME/.cabal/packages/hackage.haskell.org/00-index.tar;
51 | fi
52 | - travis_retry cabal update -v
53 | - sed -i 's/^jobs:/-- jobs:/' ${HOME}/.cabal/config
54 | - cabal install --only-dependencies $CABALOPTS --dry -v > installplan.txt
55 | - sed -i -e '1,/^Resolving /d' installplan.txt; cat installplan.txt
56 |
57 | # check whether current requested install-plan matches cached package-db snapshot
58 | - if diff -u installplan.txt $HOME/.cabsnap/installplan.txt;
59 | then
60 | echo "cabal build-cache HIT";
61 | rm -rfv .ghc;
62 | cp -a $HOME/.cabsnap/ghc $HOME/.ghc;
63 | cp -a $HOME/.cabsnap/lib $HOME/.cabsnap/share $HOME/.cabsnap/bin $HOME/.cabal/;
64 | else
65 | echo "cabal build-cache MISS";
66 | rm -rf $HOME/.cabsnap;
67 | mkdir -p $HOME/.ghc $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin;
68 | cabal install --only-dependencies $CABALOPTS;
69 | fi
70 |
71 | # snapshot package-db on cache miss
72 | - if [ ! -d $HOME/.cabsnap ];
73 | then
74 | echo "snapshotting package-db to build-cache";
75 | mkdir $HOME/.cabsnap;
76 | cp -a $HOME/.ghc $HOME/.cabsnap/ghc;
77 | cp -a $HOME/.cabal/lib $HOME/.cabal/share $HOME/.cabal/bin installplan.txt $HOME/.cabsnap/;
78 | fi
79 |
80 | # Here starts the actual work to be performed for the package under test;
81 | # any command which exits with a non-zero exit code causes the build to fail.
82 | script:
83 | - if [ -f configure.ac ]; then autoreconf -i; fi
84 | - cabal configure $CABALOPTS -v2 # -v2 provides useful information for debugging
85 | - cabal build # this builds all libraries and executables (including tests/benchmarks)
86 | - cabal test
87 | - cabal check
88 | - cabal sdist # tests that a source-distribution can be generated
89 |
90 | # Check that the resulting source distribution can be built & installed.
91 | # If there are no other `.tar.gz` files in `dist`, this can be even simpler:
92 | # `cabal install --force-reinstalls dist/*-*.tar.gz`
93 | - SRC_TGZ=$(cabal info . | awk '{print $2;exit}').tar.gz &&
94 | (cd dist && cabal install --force-reinstalls "$SRC_TGZ")
95 |
96 | # EOF
97 |
--------------------------------------------------------------------------------
/CHANGELOG.md:
--------------------------------------------------------------------------------
1 | # Changelog
2 | # Changelog
3 |
4 | ## 2.2.0.9
5 | - Fix doctest for GHC 8.0.2
6 | - Version bump: `vector`
7 | - Add note about merge, closes #56
8 |
9 | ## 2.2.0.8
10 | - Fix for GHC 8.0.2
11 | - Version bump: `aeson`
12 |
13 | ## 2.2.0.7
14 | - Add `nth` function
15 | - Version bump: `aeson`
16 | - Consolidate durability
17 | - Socket deprecation
18 |
19 | ## 2.2.0.6
20 | - Version bump: `data-default`
21 | - Update travis config
22 | - Don't escape error messages, closes #59
23 |
24 | ## 2.2.0.5
25 | - Fix compilation of benchmarks
26 | - Initial support for GHC 8.0
27 |
28 | ## 2.2.0.4
29 | - Version bump: `data-default`
30 |
31 | ## 2.2.0.3
32 | - Version bump: `aeson`
33 |
34 | ## 2.2.0.2
35 | - Clean up and fix tests/examples
36 |
37 | ## 2.2.0.1
38 | - Added support for aeson 0.10
39 |
40 | ## 2.2.0.0
41 | - Added support for RethinkDB 2.2
42 | - Added new commands `serverInfo`, `uuid5` and `value`
43 |
44 | ## 2.1.0.2
45 | - Change bounds on vector dependency
46 |
47 | ## 2.1.0.1
48 | - Fix synopsis in rethinkdb.cabal file
49 |
50 | ## 2.1.0.0
51 | - Added support for new RethinkDB 2.1 features (http://rethinkdb.com/blog/2.1-release/)
52 | - Added new ReQL terms `floor`, `ceil`, and `round`
53 | - Changed `UseOutdated` optarg to `ReadMode` optarg
54 | - Enabled TCP Keepalive
55 |
56 | ## 2.0.0.0
57 | - Added support for new RethinkDB 2.0 features (http://rethinkdb.com/blog/2.0-release/)
58 | - switch forEach args to match map
59 | - Added support for ghc 7.10
60 | - use Text instead of String for dbCreate and indexCreate for consistency
61 | - Make Line and Polygon new types
62 |
63 | ## 1.16.0.0
64 | - Improved the doctests
65 | - Added IPv6 support
66 | - Added support for new RethinkDB 1.16 features (http://rethinkdb.com/blog/1.16-release/)
67 |
68 | ## 1.15.2.1
69 | - Fix `FromDatum Rational` instance
70 | - Increase upper bound for `network`
71 | - Replace "mempty" with a better error message in `FromDatum` instances
72 | - Removed broken `FromJSON` and `ToJSON` instances for `LonLat`
73 | - Support `Line` and `Polygon` in `FromDatum (Vector a)`
74 | - Added `FromDatum` and `ToDatum` for `LonLat`
75 |
76 | ## 1.15.2.0
77 | - group and mapReduce generate more efficient code
78 | - Set NoDelay socket option, which significantly improves performance.
79 | - Fix broken indexStatus and indexWait commands.
80 | - Fix and improve benchmark script.
81 |
82 | ## 1.15.1.0
83 | - Fix compile error with GHC 7.8
84 | - Simplify `Result` instances
85 | - Add documentation to `run`
86 | - Replace the `Result (Either a b)` instance with something more useful
87 |
88 | ## 1.15.0.0
89 | - Redesigned and improved most of the API. This release is not backwards compatible.
90 | - Added all missing ReQL operations for RethinkDB 1.15 such as binary data, http, changes and geospatial operations
91 | - Switched to the JSON protocol
92 |
93 | ## 1.8.0.5
94 | - Added many examples to the haddock documentation
95 | - Fixed cursor bug: replaced readMVar with takeMVar
96 | - Explicitly call hClose
97 | - Don't call cursor finalizer twice
98 | - Added the missing non_atomic flag
99 | - Fixed a bug in groupBy that caused the reduction not to be finalised
100 | - Fixed a bug that caused some queries not to be finalised on the server
101 | - Adjusted the Expr instance for (->) to avoid ambiguity
102 | - Generalized the Bound type used by during and used it to fix the broken between function
103 | - Fix the broken order of arguments in eqJoin
104 | - Renamed mergeRightLeft to mergeLeftRight
105 | - Renamed distinct to nub
106 | - Changed run' to return JSON instead of Value because it has a better Show instance
107 | - Made Javascript instances for (->) more liberal
108 | - Made update and replace accept functions that don't return ReQL explicitly
109 | - Added support for multi-indexes
110 | - Renamed member to elem
111 | - Made js monomorphic
112 | - Set fixity of (:=) to 0
113 | - Added Expr instance for tuples
114 | - Made hasFields, withFields and json more monomorphic
115 | - Added the missing (-) method to Num ReQL
116 |
117 | ## 1.8.0.4
118 | - Added a `WriteResponse` type with a `FromJSON` instance to easily parse the return value of write operations
119 | - `returnVals` was broken. It now works and the returned `WriteResponse` contains the new and old values
120 |
121 | ## 1.8.0.3
122 | - Fixed bug in time deserialisation
123 |
124 | ## 1.8.0.2
125 | - Added the Database.RethinkDB.NoClash module that can be imported unqualified.
126 | - Add some missing exports to Database.RethinkDB: RunOptions, UTCTime and ZondeTime
127 | - Fix bugs in tableList, take and (=~)
128 | - Added README.md
129 |
130 | ## 1.8.0.1
131 | This new release of the Haskell driver for RethinkDB is compatible with rethinkdb 1.8 and above.
132 |
133 | It is a complete rewrite from version 0.1. See the Haddock documentation for details.
134 |
--------------------------------------------------------------------------------
/Database/RethinkDB.hs:
--------------------------------------------------------------------------------
1 | -- | Haskell client driver for RethinkDB
2 | --
3 | -- Based upon the official Javascript, Python and Ruby API:
4 | --
5 | -- /How to use/
6 | --
7 | -- > {-# LANGUAGE OverloadedStrings #-}
8 | -- > import qualified Database.RethinkDB as R
9 | -- > import qualified Database.RethinkDB.NoClash
10 |
11 | module Database.RethinkDB (
12 |
13 | -- * Accessing RethinkDB
14 |
15 | connect,
16 | RethinkDBHandle,
17 | close,
18 | use,
19 | serverInfo,
20 | run, run', runOpts,
21 | ReQL,
22 | Datum(..),
23 | ToDatum(..), FromDatum(..), fromDatum,
24 | RunFlag(..),
25 | noReplyWait,
26 | RethinkDBError(..),
27 | ErrorCode(..),
28 | Response,
29 | Result(..),
30 |
31 | -- * Cursors
32 |
33 | next, collect, collect', each,
34 | Cursor,
35 |
36 | -- * Manipulating databases
37 |
38 | Database(..),
39 | dbCreate, dbDrop, dbList,
40 |
41 | -- * Manipulating Tables
42 |
43 | Table(..),
44 | tableCreate, tableDrop, tableList,
45 | indexCreate, indexDrop, indexList,
46 | indexRename, indexStatus, indexWait,
47 | changes, includeStates, includeInitial,
48 |
49 | -- * Writing data
50 |
51 | WriteResponse(..),
52 | Change(..),
53 | insert,
54 | update, replace, delete,
55 | sync,
56 | returnChanges, nonAtomic,
57 | durability, Durability,
58 | conflict, ConflictResolution(..),
59 |
60 | -- * Selecting data
61 |
62 | db, table,
63 | get, getAll,
64 | filter, between, minval, maxval,
65 | Bound(..),
66 |
67 | -- * Joins
68 |
69 | innerJoin, outerJoin, eqJoin, zip,
70 | Index(..),
71 |
72 | -- * Transformations
73 |
74 | map, zipWith, zipWithN,
75 | withFields, concatMap,
76 | orderBy, asc, desc,
77 | skip, limit, slice, nth,
78 | indexesOf, isEmpty, union, sample,
79 |
80 | -- * Aggregation
81 |
82 | group,
83 | reduce, reduce0,
84 | distinct, contains,
85 | mapReduce,
86 |
87 | -- * Aggregators
88 |
89 | count, sum, avg,
90 | min, max, argmin, argmax,
91 |
92 | -- * Document manipulation
93 |
94 | pluck, without,
95 | merge,
96 | append, prepend,
97 | difference,
98 | setInsert, setUnion, setIntersection, setDifference,
99 | (!), (!?),
100 | hasFields,
101 | insertAt, spliceAt, deleteAt, changeAt, keys, values,
102 | literal, remove,
103 | Attribute(..),
104 |
105 | -- * String manipulation
106 |
107 | match, upcase, downcase,
108 | split, splitOn, splitMax,
109 |
110 | -- * Math and logic
111 |
112 | (+), (-), (*), (/), mod,
113 | (&&), (||),
114 | (==), (/=), (>), (>=), (<), (<=),
115 | not,
116 | random, randomTo, randomFromTo,
117 | floor, ceil, round,
118 |
119 | -- * Dates and times
120 |
121 | now, time, epochTime, iso8601, inTimezone, during,
122 | timezone, date, timeOfDay, year, month, day, dayOfWeek,
123 | dayOfYear, hours, minutes, seconds,
124 | toIso8601, toEpochTime,
125 |
126 | -- * Control structures
127 |
128 | args, apply, js, branch, forEach,
129 | range, rangeFromTo, rangeAll,
130 | error,
131 | handle, Expr(..), coerceTo,
132 | asArray, asString, asNumber, asObject, asBool,
133 | typeOf, info, json, toJSON, uuid, uuid5,
134 | http,
135 | HttpOptions(..), HttpResultFormat(..),
136 | HttpMethod(..), PaginationStrategy(..),
137 |
138 | -- * Geospatial commands
139 |
140 | circle, distance, fill, geoJSON,
141 | toGeoJSON, getIntersecting,
142 | getNearest, includes, intersects,
143 | line, point, polygon, polygonSub,
144 | LonLat(..), GeoLine(..), GeoPolygon(..),
145 | maxResults, maxDist, unit, numVertices,
146 | Unit(..),
147 |
148 | -- * Administration
149 |
150 | config, rebalance, reconfigure,
151 | status, wait,
152 |
153 | -- * Helpers
154 |
155 | ex, str, num, (#), note, empty,
156 | def
157 |
158 | ) where
159 |
160 | import Prelude ()
161 |
162 | import Database.RethinkDB.ReQL
163 | import Database.RethinkDB.Network
164 | import Database.RethinkDB.Types
165 | import Database.RethinkDB.Driver
166 | import Database.RethinkDB.Functions
167 | import Database.RethinkDB.Time
168 | import Database.RethinkDB.Geospatial
169 | import Database.RethinkDB.Datum hiding (Result)
170 | import Data.Default
171 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Datum.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE CPP, OverloadedStrings, PatternGuards, DefaultSignatures, FlexibleInstances #-}
2 | #if __GLASGOW_HASKELL__ < 710
3 | {-# LANGUAGE OverlappingInstances #-}
4 | #define PRAGMA_OVERLAPPING
5 | #else
6 | #define PRAGMA_OVERLAPPING {-# OVERLAPPING #-}
7 | #endif
8 |
9 | module Database.RethinkDB.Datum (
10 | parse, Parser, Result(..),
11 | Datum(..), ToDatum(..), FromDatum(..), fromDatum,
12 | LonLat(..), Array, Object, GeoLine(..), GeoPolygon(..),
13 | (.=), (.:), (.:?),
14 | encode, decode, eitherDecode,
15 | resultToMaybe, resultToEither,
16 | object
17 | ) where
18 |
19 | import qualified Data.Aeson as J
20 | import qualified Data.Aeson.Types as J
21 | import Data.Aeson.Types (Parser, Result(..), FromJSON(..), parse, ToJSON(..), Value)
22 | import Data.Aeson (fromJSON)
23 | import qualified Data.ByteString as SB
24 | import qualified Data.ByteString.Lazy as LB
25 | import Data.Time
26 | import Data.Time.Clock.POSIX
27 | import qualified Data.Text as ST
28 | import qualified Data.Text.Lazy as LT
29 | import Data.Text.Encoding (encodeUtf8)
30 | import qualified Data.HashMap.Strict as HM
31 | import Data.Monoid
32 | import Data.List
33 | import Data.Vector (Vector)
34 | import qualified Data.Vector as V
35 | import qualified Data.ByteString.Base64 as Base64
36 | import Control.Applicative
37 | import Data.Scientific
38 | import Data.Int
39 | import Data.Word
40 | import qualified Data.ByteString.Char8 as Char8
41 | import Control.Monad
42 | import qualified Data.Map as Map
43 | import Data.Ratio
44 | import qualified Data.Set as Set
45 |
46 | -- | A ReQL value
47 | data Datum =
48 | Null |
49 | Bool Bool |
50 | String ST.Text |
51 | Number Double |
52 | Array Array |
53 | Object Object |
54 | Time ZonedTime |
55 | Point LonLat |
56 | Line GeoLine |
57 | Polygon GeoPolygon |
58 | Binary SB.ByteString
59 |
60 | class FromDatum a where
61 | parseDatum :: Datum -> Parser a
62 | default parseDatum :: FromJSON a => Datum -> Parser a
63 | parseDatum = parseJSON . toJSON
64 |
65 | errorExpected :: Show d => String -> d -> J.Parser x
66 | errorExpected t d = fail $ "Expected " ++ t ++ " but found " ++ take 100 (show d)
67 |
68 | instance FromDatum a => FromDatum [a] where
69 | parseDatum (Array v) = mapM parseDatum $ V.toList v
70 | parseDatum d = errorExpected "Array" d
71 |
72 | instance FromDatum Datum where
73 | parseDatum = return
74 |
75 | instance FromDatum () where
76 | parseDatum (Array a) | V.null a = return ()
77 | parseDatum d = errorExpected "Array" d
78 |
79 | instance (FromDatum a, FromDatum b) => FromDatum (a, b) where
80 | parseDatum (Array xs) | [a,b] <- V.toList xs =
81 | (,) <$> parseDatum a <*> parseDatum b
82 | parseDatum d = errorExpected "Array" d
83 |
84 | instance (FromDatum a, FromDatum b, FromDatum c) => FromDatum (a, b, c) where
85 | parseDatum (Array xs) | [a,b,c] <- V.toList xs =
86 | (,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c
87 | parseDatum d = errorExpected "Array" d
88 |
89 | instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d) => FromDatum (a, b, c, d) where
90 | parseDatum (Array xs) | [a,b,c,d] <- V.toList xs =
91 | (,,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c <*> parseDatum d
92 | parseDatum d = errorExpected "Array" d
93 |
94 | instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d, FromDatum e) => FromDatum (a, b, c, d, e) where
95 | parseDatum (Array xs) | [a,b,c,d,e] <- V.toList xs =
96 | (,,,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c <*> parseDatum d <*> parseDatum e
97 | parseDatum d = errorExpected "Array" d
98 |
99 | instance (FromDatum a, FromDatum b) => FromDatum (Either a b) where
100 | parseDatum (Object o) =
101 | Left <$> o .: "Left"
102 | <|> Right <$> o .: "Right"
103 | parseDatum d = errorExpected "Object" d
104 |
105 | instance FromDatum SB.ByteString where
106 | parseDatum (Binary b) = return b
107 | parseDatum d = errorExpected "Binary" d
108 |
109 | instance FromDatum LB.ByteString where
110 | parseDatum (Binary b) = return $ LB.fromStrict b
111 | parseDatum d = errorExpected "Binary" d
112 |
113 | instance FromDatum a => FromDatum (HM.HashMap ST.Text a) where
114 | parseDatum (Object o) =
115 | fmap HM.fromList . sequence . map (\(k,v) -> (,) k <$> parseDatum v) $ HM.toList o
116 | parseDatum d = errorExpected "Object" d
117 |
118 | instance FromDatum a => FromDatum (HM.HashMap [Char] a) where
119 | parseDatum (Object o) =
120 | fmap HM.fromList . sequence . map (\(k,v) -> (,) (ST.unpack k) <$> parseDatum v) $ HM.toList o
121 | parseDatum d = errorExpected "Object" d
122 |
123 | instance FromDatum a => FromDatum (Map.Map ST.Text a) where
124 | parseDatum (Object o) =
125 | fmap Map.fromList . mapM (\(k,v) -> (,) k <$> parseDatum v) $ HM.toList o
126 | parseDatum d = errorExpected "Object" d
127 |
128 | instance FromDatum a => FromDatum (Map.Map [Char] a) where
129 | parseDatum (Object o) =
130 | fmap Map.fromList . mapM (\(k,v) -> (,) (ST.unpack k) <$> parseDatum v) $ HM.toList o
131 | parseDatum d = errorExpected "Object" d
132 |
133 | instance FromDatum a => FromDatum (Maybe a) where
134 | parseDatum Null = return Nothing
135 | parseDatum d = Just <$> parseDatum d
136 |
137 | instance (Ord a, FromDatum a) => FromDatum (Set.Set a) where
138 | parseDatum (Array a) = fmap Set.fromList . mapM parseDatum $ V.toList a
139 | parseDatum d = errorExpected "Array" d
140 |
141 | instance FromDatum ZonedTime where
142 | parseDatum (Time t) = return t
143 | parseDatum d = errorExpected "Time" d
144 |
145 | instance FromDatum UTCTime where
146 | parseDatum (Time t) = return $ zonedTimeToUTC t
147 | parseDatum d = errorExpected "Time" d
148 |
149 | instance FromDatum a => FromDatum (Vector a) where
150 | parseDatum (Array v) = fmap V.fromList . mapM parseDatum $ V.toList v
151 | parseDatum d = errorExpected "Array" d
152 |
153 | instance FromDatum GeoLine where
154 | parseDatum (Line l) = return l
155 | parseDatum d = errorExpected "Line" d
156 |
157 | instance FromDatum GeoPolygon where
158 | parseDatum (Polygon p) = return p
159 | parseDatum d = errorExpected "Polygon" d
160 |
161 | instance FromDatum LonLat where
162 | parseDatum (Point l) = return l
163 | parseDatum d = errorExpected "Point" d
164 |
165 | instance FromDatum Float
166 | instance PRAGMA_OVERLAPPING FromDatum String
167 | instance FromDatum Int
168 | instance FromDatum Int8
169 | instance FromDatum Int16
170 | instance FromDatum Int32
171 | instance FromDatum Int64
172 | instance FromDatum Word
173 | instance FromDatum Word8
174 | instance FromDatum Word16
175 | instance FromDatum Word32
176 | instance FromDatum Word64
177 | instance FromDatum Double
178 | instance FromDatum Bool
179 | instance FromDatum J.Value
180 | instance FromDatum Char
181 | instance FromDatum Integer
182 | instance FromDatum LT.Text
183 | instance FromDatum ST.Text
184 | instance FromDatum (Ratio Integer)
185 |
186 | type Array = Vector Datum
187 | type Object = HM.HashMap ST.Text Datum
188 | newtype GeoLine = GeoLine { geoLinePoints :: Vector LonLat }
189 | deriving (Eq, Ord)
190 | newtype GeoPolygon = GeoPolygon { geoPolygonLines :: Vector (Vector LonLat) }
191 | deriving (Eq, Ord)
192 |
193 | data LonLat = LonLat { longitude, latitude :: Double }
194 | deriving (Eq, Ord)
195 |
196 | instance Eq Datum where
197 | Null == Null = True
198 | Bool a == Bool b = a == b
199 | String a == String b = a == b
200 | Number a == Number b = a == b
201 | Array a == Array b = a == b
202 | Object a == Object b = a == b
203 | Time a == Time b = zonedTimeToUTC a == zonedTimeToUTC b
204 | Point a == Point b = a == b
205 | Line a == Line b = a == b
206 | Polygon a == Polygon b = a == b
207 | Binary a == Binary b = a == b
208 | _ == _ = False
209 |
210 | instance Show LonLat where
211 | show (LonLat lon lat) = "LonLat " ++ showDouble lon ++ " " ++ showDouble lat
212 |
213 | instance Show Datum where
214 | show Null = "null"
215 | show (Bool True) = "true"
216 | show (Bool False) = "false"
217 | show (Number d) = showDouble d
218 | show (String t) = show t
219 | show (Array v) = "[" ++ intercalate "," (map show $ V.toList v) ++ "]"
220 | show (Object o) = "{" ++ intercalate "," (map (\(k,v) -> show k ++ ":" ++ show v) $ HM.toList o) ++ "}"
221 | show (Time t) = "Time<" ++ show t ++ ">"
222 | show (Point p) = "Point<" ++ showLonLat p ++ ">"
223 | show (Line l) = "Line<[" ++ intercalate "],[" (map showLonLat $ V.toList $ geoLinePoints l) ++ "]>"
224 | show (Polygon p) = "Polygon<[" ++ intercalate "],[" (map (\x -> "[" ++ intercalate "],[" (map showLonLat $ V.toList x) ++ "]") (V.toList $ geoPolygonLines p)) ++ "]>"
225 | show (Binary b) = "Binary<" ++ show b ++ ">"
226 |
227 | showLonLat :: LonLat -> String
228 | showLonLat (LonLat a b) = showDouble a ++ "," ++ showDouble b
229 |
230 | showDouble :: Double -> String
231 | showDouble d = let s = show d in if ".0" `isSuffixOf` s then init (init s) else s
232 |
233 | fromDatum :: FromDatum a => Datum -> Result a
234 | fromDatum = parse parseDatum
235 |
236 | class ToDatum a where
237 | toDatum :: a -> Datum
238 | default toDatum :: ToJSON a => a -> Datum
239 | toDatum = toJSONDatum
240 |
241 | instance ToDatum a => ToDatum [a] where
242 | toDatum = Array . V.fromList . map toDatum
243 |
244 | instance ToDatum a => ToDatum (V.Vector a) where
245 | toDatum = Array . V.map toDatum
246 |
247 | instance ToDatum Datum where
248 | toDatum = id
249 |
250 | instance ToDatum () where
251 | toDatum _ = Array $ V.empty
252 |
253 | instance (ToDatum a, ToDatum b) => ToDatum (a, b) where
254 | toDatum (a, b) = Array $ V.fromList [toDatum a, toDatum b]
255 |
256 | instance (ToDatum a, ToDatum b, ToDatum c) => ToDatum (a, b, c) where
257 | toDatum (a, b, c) = Array $ V.fromList [toDatum a, toDatum b, toDatum c]
258 |
259 | instance (ToDatum a, ToDatum b, ToDatum c, ToDatum d) => ToDatum (a, b, c, d) where
260 | toDatum (a, b, c, d) = Array $ V.fromList [toDatum a, toDatum b, toDatum c, toDatum d]
261 |
262 | instance (ToDatum a, ToDatum b, ToDatum c, ToDatum d, ToDatum e) => ToDatum (a, b, c, d, e) where
263 | toDatum (a, b, c, d, e) = Array $ V.fromList [toDatum a, toDatum b, toDatum c, toDatum d, toDatum e]
264 |
265 | instance ToDatum a => ToDatum (HM.HashMap ST.Text a) where
266 | toDatum = Object . HM.map toDatum
267 |
268 | instance ToDatum a => ToDatum (HM.HashMap [Char] a) where
269 | toDatum = Object . HM.fromList . map (\(k, v) -> (ST.pack k, toDatum v)) . HM.toList
270 |
271 | instance ToDatum a => ToDatum (Map.Map ST.Text a) where
272 | toDatum = Object . HM.fromList . Map.toList . Map.map toDatum
273 |
274 | instance ToDatum a => ToDatum (Map.Map [Char] a) where
275 | toDatum = Object . HM.fromList . map (\(k, v) -> (ST.pack k, toDatum v)) . Map.toList
276 |
277 | instance ToDatum ZonedTime where
278 | toDatum = Time
279 |
280 | instance ToDatum UTCTime where
281 | toDatum = Time . utcToZonedTime utc
282 |
283 | instance (ToDatum a, ToDatum b) => ToDatum (Either a b) where
284 | toDatum (Left a) = Object $ HM.fromList [("Left", toDatum a)]
285 | toDatum (Right b) = Object $ HM.fromList [("Right", toDatum b)]
286 |
287 | instance ToDatum LB.ByteString where
288 | toDatum = Binary . LB.toStrict
289 |
290 | instance ToDatum SB.ByteString where
291 | toDatum = Binary
292 |
293 | instance ToDatum a => ToDatum (Maybe a) where
294 | toDatum Nothing = Null
295 | toDatum (Just a) = toDatum a
296 |
297 | instance ToDatum a => ToDatum (Set.Set a) where
298 | toDatum = Array . V.fromList . map toDatum . Set.toList
299 |
300 | instance ToDatum (Ratio Integer) where
301 | toDatum a = toDatum (toDouble a)
302 | where toDouble :: Rational -> Double
303 | toDouble = fromRational
304 |
305 | instance ToDatum LonLat where
306 | toDatum l = Point l
307 |
308 | instance ToDatum Value
309 | instance ToDatum Int
310 | instance ToDatum Int8
311 | instance ToDatum Int16
312 | instance ToDatum Int32
313 | instance ToDatum Int64
314 | instance ToDatum Word
315 | instance ToDatum Word8
316 | instance ToDatum Word16
317 | instance ToDatum Word32
318 | instance ToDatum Word64
319 | instance ToDatum Char
320 | instance PRAGMA_OVERLAPPING ToDatum [Char]
321 | instance ToDatum Integer
322 | instance ToDatum ST.Text
323 | instance ToDatum LT.Text
324 | instance ToDatum Bool
325 | instance ToDatum Double
326 | instance ToDatum Float
327 |
328 | toJSONDatum :: ToJSON a => a -> Datum
329 | toJSONDatum a = case toJSON a of
330 | J.Object o ->
331 | let asObject = Object $ HM.map toJSONDatum o
332 | ptype = HM.lookup "$reql_type$" o
333 | in case ptype of
334 | Just "GEOMETRY" |
335 | Just t <- HM.lookup "type" o,
336 | Just c <- HM.lookup "coordinates" o ->
337 | case t of
338 | "Point" | Success [lon, lat] <- fromJSON c -> Point (LonLat lon lat)
339 | "LineString" | Success l <- V.mapM toLonLat =<< fromJSON c -> Line (GeoLine l)
340 | "Polygon" | Success p <- V.mapM (V.mapM toLonLat) =<< fromJSON c -> Polygon (GeoPolygon p)
341 | _ -> asObject
342 | Just "TIME" |
343 | Just (J.Number ts) <- HM.lookup "epoch_time" o,
344 | Just (J.String tz) <- HM.lookup "timezone" o,
345 | Just tz' <- parseTimeZone (ST.unpack tz) ->
346 | Time $ utcToZonedTime tz' (posixSecondsToUTCTime . fromRational . toRational $ ts)
347 | Just "BINARY" |
348 | Just (J.String b64) <- HM.lookup "data" o,
349 | Right dat <- Base64.decode (encodeUtf8 b64) ->
350 | Binary dat
351 | _ -> asObject
352 | J.Null -> Null
353 | J.Bool b -> Bool b
354 | J.Number s -> Number (toRealFloat s)
355 | J.String t -> String t
356 | J.Array v -> Array (fmap toJSONDatum v)
357 | where
358 | toLonLat [lon, lat] = J.Success $ LonLat lon lat
359 | toLonLat _ = J.Error "expected a pair"
360 | instance J.FromJSON Datum where
361 | parseJSON = return . toJSONDatum
362 |
363 | instance ToJSON Datum where
364 | toJSON Null = J.Null
365 | toJSON (Bool b) = J.Bool b
366 | toJSON (Number d) = J.Number $ realToFrac d
367 | toJSON (String t) = J.String t
368 | toJSON (Array v) = J.Array $ V.map toJSON v
369 | toJSON (Object o) = J.Object $ HM.map toJSON o
370 | toJSON (Time ts@(ZonedTime _ tz)) = J.object [
371 | "$reql_type$" J..= ("TIME" :: ST.Text),
372 | "epoch_time" J..= (realToFrac (utcTimeToPOSIXSeconds (zonedTimeToUTC ts)) :: Double),
373 | "timezone" J..= timeZoneOffsetString tz]
374 | toJSON (Point p) = J.object [
375 | "$reql_type$" J..= ("GEOMETRY" :: ST.Text),
376 | "type" J..= ("Point" :: ST.Text),
377 | "coordinates" J..= pointToPair p]
378 | toJSON (Line l) = J.object [
379 | "$reql_type$" J..= ("GEOMETRY" :: ST.Text),
380 | "type" J..= ("LineString" :: ST.Text),
381 | "coordinates" J..= V.map pointToPair (geoLinePoints l)]
382 | toJSON (Polygon p) = J.object [
383 | "$reql_type$" J..= ("GEOMETRY" :: ST.Text),
384 | "type" J..= ("Polygon" :: ST.Text),
385 | "coordinates" J..= V.map (V.map pointToPair) (geoPolygonLines p)]
386 | toJSON (Binary b) = J.object [
387 | "$reql_type$" J..= ("BINARY" :: ST.Text),
388 | "data" J..= Char8.unpack (Base64.encode b)]
389 |
390 | pointToPair :: LonLat -> (Double, Double)
391 | pointToPair (LonLat lon lat) = (lon, lat)
392 |
393 | parseTimeZone :: String -> Maybe TimeZone
394 | parseTimeZone "Z" = Just utc
395 | parseTimeZone tz = minutesToTimeZone <$> case tz of
396 | ('-':tz') -> negate <$> go tz'
397 | ('+':tz') -> go tz'
398 | _ -> go tz
399 | where
400 | go tz' =
401 | let (h, _:m) = break (==':') tz' in
402 | case (reads h, reads m) of
403 | ([(hh, "")], [(mm, "")]) -> Just $ hh * 60 + mm
404 | _ -> Nothing
405 |
406 | -- ReQL datums are compared alphabetically by type name. Objects are
407 | -- compared field by field in alphabetical order.
408 | instance Ord Datum where
409 | compare (Object a) (Object b) =
410 | compare (sort $ HM.keys a) (sort $ HM.keys b) <>
411 | mconcat (map (\k -> (a HM.! k) `compare` (b HM.! k) ) (sort $ HM.keys a))
412 | compare (Array a) (Array b) = compare a b
413 | compare (String a) (String b) = compare a b
414 | compare (Number a) (Number b) = compare a b
415 | compare (Bool a) (Bool b) = compare a b
416 | compare Null Null = EQ
417 | compare (Time a) (Time b) = zonedTimeToUTC a `compare` zonedTimeToUTC b
418 | compare (Point a) (Point b) = compare a b
419 | compare (Line a) (Line b) = compare a b
420 | compare (Polygon a) (Polygon b) = compare a b
421 | compare (Binary a) (Binary b) = compare a b
422 | compare Array{} _ = LT
423 | compare _ Array{} = GT
424 | compare Bool{} _ = LT
425 | compare _ Bool{} = GT
426 | compare Null _ = LT
427 | compare _ Null = GT
428 | compare Number{} _ = LT
429 | compare _ Number{} = GT
430 | compare Object{} _ = LT
431 | compare _ Object{} = GT
432 | compare Binary{} _ = LT
433 | compare _ Binary{} = GT
434 | compare Polygon{} _ = LT
435 | compare _ Polygon{} = GT
436 | compare Line{} _ = LT
437 | compare _ Line{} = GT
438 | compare Point{} _ = LT
439 | compare _ Point{} = GT
440 | compare Time{} _ = LT
441 | compare _ Time{} = GT
442 |
443 | (.=) :: ToDatum a => ST.Text -> a -> (ST.Text, Datum)
444 | k .= v = (k, toDatum v)
445 |
446 | (.:) :: FromDatum a => HM.HashMap ST.Text Datum -> ST.Text -> Parser a
447 | o .: k = maybe (fail $ "key " ++ show k ++ "not found") parseDatum $ HM.lookup k o
448 |
449 | (.:?) :: FromDatum a => HM.HashMap ST.Text Datum -> ST.Text -> Parser (Maybe a)
450 | o .:? k = maybe (return Nothing) (fmap Just . parseDatum) $ HM.lookup k o
451 |
452 | encode :: ToDatum a => a -> LB.ByteString
453 | encode = J.encode . toDatum
454 |
455 | decode :: FromDatum a => LB.ByteString -> Maybe a
456 | decode = resultToMaybe . fromDatum <=< J.decode
457 |
458 | eitherDecode :: FromDatum a => LB.ByteString -> Either String a
459 | eitherDecode b = resultToEither . fromDatum =<< J.eitherDecode b
460 |
461 | resultToMaybe :: Result a -> Maybe a
462 | resultToMaybe (Success a) = Just a
463 | resultToMaybe (Error _) = Nothing
464 |
465 | resultToEither :: Result a -> Either String a
466 | resultToEither (Success a) = Right a
467 | resultToEither (Error s) = Left s
468 |
469 | object :: [(ST.Text, Datum)] -> Datum
470 | object = Object . HM.fromList
471 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Doctest.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | module Database.RethinkDB.Doctest (
4 | module Export,
5 | module Database.RethinkDB.Doctest
6 | ) where
7 |
8 | -- default (Datum, ReQL, String, Int, Double)
9 | -- import qualified Database.RethinkDB as R
10 |
11 | import Database.RethinkDB.NoClash as Export
12 | import Prelude as Export
13 | import Data.Text as Export (Text)
14 | import Data.Maybe as Export
15 |
16 | import Control.Exception
17 | import qualified Data.Vector as V
18 | import Data.List (sort)
19 |
20 | try' :: IO a -> IO ()
21 | try' x = (try x `asTypeOf` return (Left (undefined :: SomeException))) >> return ()
22 |
23 | doctestConnect :: IO RethinkDBHandle
24 | doctestConnect = fmap (use "doctests") $ connect "localhost" 28015 def
25 |
26 | sorted :: IO Datum -> IO Datum
27 | sorted m = fmap s m where
28 | s (Array a) = Array $ fmap s $ V.fromList $ sort $ V.toList a
29 | s (Object o) = Object $ fmap s o
30 | s d = d
31 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Driver.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings, FlexibleInstances, DefaultSignatures, GADTs, CPP #-}
2 |
3 | module Database.RethinkDB.Driver (
4 | run,
5 | run',
6 | Result(..),
7 | runOpts,
8 | RunFlag(..),
9 | Durability(..),
10 | durability,
11 | WriteResponse(..),
12 | Change(..)
13 | ) where
14 |
15 | import qualified Data.Aeson as J
16 | import Control.Monad
17 | import Control.Concurrent.MVar (MVar, takeMVar)
18 | import Data.Text (Text)
19 | #if __GLASGOW_HASKELL__ < 710
20 | import Control.Applicative ((<$>), (<*>))
21 | #endif
22 | import Data.List
23 | import Data.Maybe
24 | import Control.Exception (throwIO)
25 | import qualified Data.Map as Map
26 | import qualified Data.Set as Set
27 | import Data.Time
28 | import qualified Data.Text as ST
29 | import qualified Data.Text.Lazy as LT
30 | import qualified Data.ByteString as SB
31 | import qualified Data.ByteString.Lazy as LB
32 | import Data.Int
33 | import Data.Word
34 | import qualified Data.HashMap.Strict as HM
35 | import Data.Ratio
36 | import qualified Data.Vector as V
37 |
38 | import Database.RethinkDB.Datum hiding (Result)
39 | import Database.RethinkDB.Network
40 | import Database.RethinkDB.ReQL
41 |
42 | -- $setup
43 | -- >>> :set -XOverloadedStrings
44 | -- >>> :load Database.RethinkDB.NoClash
45 | -- >>> import qualified Database.RethinkDB as R
46 | -- >>> import Control.Exception
47 | -- >>> import Data.Text
48 | -- >>> let try' x = (try x `asTypeOf` return (Left (undefined :: SomeException))) >> return ()
49 | -- >>> h <- fmap (use "doctests") $ connect "localhost" 28015 def
50 | -- >>> try' $ run' h $ dbCreate "doctests"
51 | -- >>> try' $ run' h $ tableCreate (table "users"){ tablePrimaryKey = Just "name" }
52 | -- >>> try' $ run' h $ delete $ table "users"
53 | -- >>> run h $ table "users" # insert (R.map (\x -> ["name":=x]) ["bill", "bob", "nancy" :: Text]) :: IO WriteResponse
54 | -- {inserted:3}
55 |
56 |
57 | -- | Per-query settings
58 | data RunFlag =
59 | UseOutdated | -- ^ Deprecated. Use `ReadMode Outdated` instead
60 | ReadMode ReadMode |
61 | NoReply |
62 | Durability Durability |
63 | Profile |
64 | ArrayLimit Int
65 |
66 | data ReadMode = Majority | Single | Outdated
67 |
68 | data Durability = Hard | Soft
69 |
70 | instance Expr Durability where
71 | expr Hard = "hard"
72 | expr Soft = "soft"
73 |
74 | -- | Optional argument for soft durability writes
75 | durability :: Durability -> Attribute a
76 | durability d = "durability" := d
77 |
78 | renderOption :: RunFlag -> (Text, Datum)
79 | renderOption UseOutdated = "read_mode" .= ("outdated" :: String)
80 | renderOption (ReadMode Majority) = "read_mode" .= ("majority" :: String)
81 | renderOption (ReadMode Single) = "read_mode" .= ("single" :: String)
82 | renderOption (ReadMode Outdated) = "read_mode" .= ("outdated" :: String)
83 | renderOption NoReply = "noreply" .= True
84 | renderOption (Durability Soft) = "durability" .= ("soft" :: String)
85 | renderOption (Durability Hard) = "durability" .= ("hard" :: String)
86 | renderOption Profile = "profile" .= True
87 | renderOption (ArrayLimit n) = "array_limit" .= n
88 |
89 | -- | Run a query with the given options
90 | runOpts :: (Expr query, Result r) => RethinkDBHandle -> [RunFlag] -> query -> IO r
91 | runOpts h opts t = do
92 | let (q, bt) = buildQuery (expr t) 0 (rdbDatabase h) (map renderOption opts)
93 | r <- runQLQuery h q bt
94 | convertResult r
95 |
96 | -- | Run a given query and return a Result
97 | --
98 | -- >>> run h $ num 1 :: IO Int
99 | -- 1
100 | --
101 | -- > >>> run h $ str "foo" :: IO (Either RethinkDBError Int)
102 | -- *** Exception: RethinkDB: Unexpected response: "expected Int, encountered String"
103 | --
104 | -- >>> run h $ str "foo" :: IO (Maybe Int)
105 | -- Nothing
106 | --
107 | -- > >>> run h $ str "foo" :: IO Int
108 | -- *** Exception: RethinkDB: Unexpected response: "expected Int, encountered String"
109 | --
110 | -- >>> c <- run h $ table "users" # orderBy [asc "name"] # (!"name"):: IO (Cursor Datum)
111 | -- >>> next c
112 | -- Just "bill"
113 | -- >>> collect c
114 | -- ["bob","nancy"]
115 | run :: (Expr query, Result r) => RethinkDBHandle -> query -> IO r
116 | run h = runOpts h []
117 |
118 | -- | Run a given query and return a Datum
119 | run' :: Expr query => RethinkDBHandle -> query -> IO Datum
120 | run' = run
121 |
122 | -- | Convert the raw query response into useful values
123 | class Result r where
124 | convertResult :: MVar Response -> IO r
125 | default convertResult :: FromDatum r => MVar Response -> IO r
126 | convertResult = unsafeFromDatum <=< convertResult
127 |
128 | instance Result Response where
129 | convertResult = takeMVar
130 |
131 | instance FromDatum a => Result (Cursor a) where
132 | convertResult r = do
133 | c <- makeCursor r
134 | return c { cursorMap = unsafeFromDatum }
135 |
136 | unsafeFromDatum :: FromDatum a => Datum -> IO a
137 | unsafeFromDatum val = case fromDatum val of
138 | Error e -> throwIO (RethinkDBError ErrorUnexpectedResponse (Datum Null) e [])
139 | Success a -> return a
140 |
141 | instance FromDatum a => Result [a] where
142 | convertResult = collect <=< convertResult
143 |
144 | instance (FromDatum b, a ~ RethinkDBError) => Result (Either a b) where
145 | convertResult v = do
146 | r <- takeMVar v
147 | ed <- case r of
148 | ResponseSingle Null -> return $ Right Null
149 | ResponseSingle b -> return $ Right b
150 | ResponseError a -> return $ Left a
151 | ResponseBatch Nothing batch -> return $ Right $ toDatum batch
152 | ResponseBatch (Just _more) batch -> do
153 | rest <- collect' =<< convertResult v
154 | return $ Right $ toDatum $ batch ++ rest
155 | case ed of
156 | Left a -> return $ Left a
157 | Right d -> case fromDatum d of
158 | Success b -> return $ Right b
159 | Error a -> return $ Left $ RethinkDBError ErrorUnexpectedResponse (Datum Null) a []
160 |
161 | instance FromDatum a => Result (Maybe a) where
162 | convertResult v = do
163 | ed <- convertResult v
164 | case ed of
165 | Left _ -> return Nothing
166 | Right Null -> return Nothing
167 | Right d -> case fromDatum d of
168 | Success a -> return $ Just a
169 | Error _ -> return $ Nothing
170 |
171 | instance Result Int
172 | instance Result Double
173 | instance Result Bool
174 |
175 | instance Result () where
176 | convertResult m = do
177 | _ <- takeMVar m
178 | return ()
179 |
180 | instance Result J.Value
181 | instance Result Char
182 | instance Result Float
183 | instance Result Int8
184 | instance Result Int16
185 | instance Result Int32
186 | instance Result Int64
187 | instance Result Word
188 | instance Result Word8
189 | instance Result Word16
190 | instance Result Word32
191 | instance Result Word64
192 | instance Result Integer
193 | instance Result LB.ByteString
194 | instance Result SB.ByteString
195 | instance Result LT.Text
196 | instance Result ST.Text
197 | instance Result ZonedTime
198 | instance Result UTCTime
199 | instance (Ord a, FromDatum a) => Result (Set.Set a)
200 | instance FromDatum a => Result (V.Vector a)
201 | instance FromDatum a => Result (HM.HashMap [Char] a)
202 | instance FromDatum a => Result (HM.HashMap ST.Text a)
203 | instance FromDatum a => Result (Map.Map [Char] a)
204 | instance FromDatum a => Result (Map.Map ST.Text a)
205 | instance Result (Ratio Integer)
206 | instance Result LonLat
207 |
208 | nextFail :: FromDatum a => Cursor Datum -> IO a
209 | nextFail c = do
210 | x <- next c
211 | case x of
212 | Nothing -> throwIO $ RethinkDBError ErrorUnexpectedResponse (Datum Null) "Not enough data" []
213 | Just a -> case fromDatum a of
214 | Success b -> return b
215 | Error e -> throwIO $ RethinkDBError ErrorUnexpectedResponse (Datum Null) e []
216 |
217 | assertEnd :: Cursor a -> IO ()
218 | assertEnd c = do
219 | x <- next c
220 | case x of
221 | Nothing -> return ()
222 | Just _ -> throwIO $ RethinkDBError ErrorUnexpectedResponse (Datum Null) "Too much data" []
223 |
224 | instance (FromDatum a, FromDatum b) => Result (a, b) where
225 | convertResult r = do
226 | c <- convertResult r
227 | a <- nextFail c
228 | b <- nextFail c
229 | assertEnd c
230 | return (a, b)
231 |
232 | instance (FromDatum a, FromDatum b, FromDatum c) => Result (a, b, c) where
233 | convertResult r = do
234 | c <- convertResult r
235 | a <- nextFail c
236 | b <- nextFail c
237 | c_ <- nextFail c
238 | assertEnd c
239 | return (a, b, c_)
240 |
241 | instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d) => Result (a, b, c, d) where
242 | convertResult r = do
243 | c <- convertResult r
244 | a <- nextFail c
245 | b <- nextFail c
246 | c_ <- nextFail c
247 | d <- nextFail c
248 | assertEnd c
249 | return (a, b, c_, d)
250 |
251 | instance (FromDatum a, FromDatum b, FromDatum c, FromDatum d, FromDatum e) => Result (a, b, c, d, e) where
252 | convertResult r = do
253 | c <- convertResult r
254 | a <- nextFail c
255 | b <- nextFail c
256 | c_ <- nextFail c
257 | d <- nextFail c
258 | e <- nextFail c
259 | assertEnd c
260 | return (a, b, c_, d, e)
261 |
262 | instance Result Datum where
263 | convertResult v = do
264 | r <- takeMVar v
265 | case r of
266 | ResponseSingle datum -> return datum
267 | ResponseError e -> throwIO e
268 | ResponseBatch Nothing batch -> return $ toDatum batch
269 | ResponseBatch (Just _more) batch -> do
270 | rest <- collect' =<< convertResult v
271 | return . toDatum $ batch ++ rest
272 |
273 | instance Result WriteResponse
274 |
275 | data WriteResponse = WriteResponse {
276 | writeResponseInserted :: Int,
277 | writeResponseDeleted :: Int,
278 | writeResponseReplaced :: Int,
279 | writeResponseUnchanged :: Int,
280 | writeResponseSkipped :: Int,
281 | writeResponseErrors :: Int,
282 | writeResponseFirstError :: Maybe Text,
283 | writeResponseGeneratedKeys :: Maybe [Text],
284 | writeResponseChanges :: Maybe [Change]
285 | }
286 |
287 | data Change = Change { oldVal, newVal :: Datum }
288 |
289 | instance Show Change where
290 | show (Change old new) = "{\"old_val\":" ++ show old ++ ",\"new_val\":" ++ show new ++ "}"
291 |
292 | instance FromDatum Change where
293 | parseDatum (Object o) =
294 | Change <$> o .: "old_val" <*> o .: "new_val"
295 | parseDatum _ = mzero
296 |
297 | instance FromDatum WriteResponse where
298 | parseDatum (Object o) =
299 | WriteResponse
300 | <$> o .: "inserted"
301 | <*> o .: "deleted"
302 | <*> o .: "replaced"
303 | <*> o .: "unchanged"
304 | <*> o .: "skipped"
305 | <*> o .: "errors"
306 | <*> o .:? "first_error"
307 | <*> o .:? "generated_keys"
308 | <*> o .:? "changes"
309 | parseDatum _ = mzero
310 |
311 | instance Show WriteResponse where
312 | show wr = "{" ++
313 | intercalate "," (catMaybes [
314 | zero "inserted" writeResponseInserted,
315 | zero "deleted" writeResponseDeleted,
316 | zero "replaced" writeResponseReplaced,
317 | zero "unchanged" writeResponseUnchanged,
318 | zero "skipped" writeResponseSkipped,
319 | zero "errors" writeResponseErrors,
320 | nothing "first_error" writeResponseFirstError,
321 | nothing "generated_keys" writeResponseGeneratedKeys,
322 | nothing "changes" writeResponseChanges ]) ++
323 | "}"
324 | where
325 | go :: Show a => String -> a -> Maybe String
326 | go k v = Just $ k ++ ":" ++ show v
327 | zero k f = if f wr == 0 then Nothing else go k (f wr)
328 | nothing :: Show a => String -> (WriteResponse -> Maybe a) -> Maybe String
329 | nothing k f = maybe Nothing (go k) (f wr)
330 |
331 | -- TODO: profile
332 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Functions.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE FlexibleInstances, OverloadedStrings, GADTs #-}
2 |
3 | -- | ReQL Functions
4 | --
5 | -- ReQL was designed for dynamic languages. Many operations take
6 | -- optional positional and named arguments.
7 | --
8 | -- Optional named arguments can be added using `ex`, for example
9 | -- `upsert = ex insert ["conflict" := "update"]`
10 | --
11 | -- For optional positional arguments this module defines an extra
12 | -- function if the functionality is not available otherwise. For
13 | -- example `argmax` for `max` and `splitOn` for `split` but `skip`
14 | -- instead of `sliceFrom` and `avg . (!k)` instead of `avgOf k`.
15 |
16 | module Database.RethinkDB.Functions where
17 |
18 | import Data.Text (Text)
19 | import Control.Monad.State
20 | import Control.Applicative
21 | import Data.Maybe
22 | import Data.Default
23 | import Data.Monoid
24 |
25 | import Database.RethinkDB.Wire.Term as Term
26 | import Database.RethinkDB.ReQL
27 | import {-# SOURCE #-} Database.RethinkDB.MapReduce
28 | import Database.RethinkDB.Types
29 | import Database.RethinkDB.Datum hiding (Error)
30 |
31 | import Prelude (($), (.))
32 | import qualified Prelude as P
33 |
34 | -- $setup
35 | --
36 | -- Get the doctests ready
37 | --
38 | -- >>> :load Database.RethinkDB.Doctest
39 | -- >>> import qualified Database.RethinkDB as R
40 | -- >>> :set -XOverloadedStrings
41 | -- >>> default (Datum, ReQL, String, Int, Double)
42 | -- >>> h <- doctestConnect
43 |
44 | -- $init_doctests
45 | -- >>> try' $ run' h $ dbCreate "doctests"
46 | -- >>> try' $ run' h $ tableCreate "foo"
47 | -- >>> try' $ run' h $ delete $ table "foo"
48 | -- >>> try' $ run' h $ tableCreate "bar"
49 | -- >>> try' $ run' h $ delete $ table "bar"
50 | -- >>> try' $ run' h $ tableDrop "bar"
51 | -- >>> try' $ run' h $ tableCreate (table "posts")
52 | -- >>> try' $ run' h $ delete $ table "posts"
53 | -- >>> try' $ run' h $ tableCreate (table "places")
54 | -- >>> try' $ run' h $ delete $ table "places"
55 | -- >>> try' $ run' h $ tableCreate (table "users"){ tablePrimaryKey = Just "name" }
56 | -- >>> try' $ run' h $ delete $ table "users"
57 | -- >>> try' $ run' h $ table "users" # indexDrop "occupation"
58 | -- >>> try' $ run' h $ table "users" # indexDrop "location"
59 | -- >>> try' $ run' h $ table "users" # indexDrop "friends"
60 |
61 | -- | Create a table on the server
62 | --
63 | -- > >>> run' h $ tableCreate (table "posts") def
64 | -- > [{"created":1}]
65 | -- > >>> run' h $ tableCreate (table "users"){ tablePrimaryKey = Just "name" } def
66 | -- > [{"created":1}]
67 | -- > >>> run' h $ tableCreate (Table (Just "doctests") "bar" (Just "name")) def
68 | -- > [{"created":1}]
69 | -- > >>> run' h $ ex tableCreate ["datacenter":="orion"] (Table (Just "doctests") "bar" (Just "name")) def
70 | -- > [{"created":1}]
71 | tableCreate :: Table -> ReQL
72 | tableCreate (Table mdb table_name pkey) =
73 | withQuerySettings $ \QuerySettings{ queryDefaultDatabase = ddb } ->
74 | op' TABLE_CREATE (fromMaybe ddb mdb, table_name) $ catMaybes [
75 | ("primary_key" :=) <$> pkey ]
76 |
77 | -- | Insert a document or a list of documents into a table
78 | --
79 | -- >>> run h $ table "users" # insert (map (\x -> ["name":=x]) ["bill", "bob", "nancy" :: Text]) :: IO WriteResponse
80 | -- {inserted:3}
81 | -- >>> run h $ table "posts" # insert ["author" := str "bill", "message" := str "hi", "id" := 1] :: IO WriteResponse
82 | -- {inserted:1}
83 | -- >>> run h $ table "posts" # insert ["author" := str "bill", "message" := str "hello", "id" := 2, "flag" := str "deleted"] :: IO WriteResponse
84 | -- {inserted:1}
85 | -- >>> run h $ table "posts" # insert ["author" := str "bob", "message" := str "lorem ipsum", "id" := 3, "flag" := str "pinned"] :: IO WriteResponse
86 | -- {inserted:1}
87 | insert :: (Expr object) => object -> Table -> ReQL
88 | insert a tb = op INSERT (tb, a)
89 |
90 | -- | Add to or modify the contents of a document
91 | --
92 | -- >>> run h $ table "users" # getAll "name" [str "bob"] # update (const ["occupation" := str "tailor"]) :: IO WriteResponse
93 | -- {replaced:1}
94 | update :: (Expr selection, Expr a) => (ReQL -> a) -> selection -> ReQL
95 | update f s = op UPDATE (s, expr . f)
96 |
97 | -- | Replace a document with another
98 | --
99 | -- >>> run h $ replace (\user -> ["name" := user!"name", "occupation" := str "clothier"]) . R.filter ((R.== str "tailor") . (!?"occupation")) $ table "users" :: IO WriteResponse
100 | -- {replaced:1}
101 | replace :: (Expr selection, Expr a) => (ReQL -> a) -> selection -> ReQL
102 | replace f s = op REPLACE (s, expr . f)
103 |
104 | -- | Delete the documents
105 | --
106 | -- >>> run h $ delete . getAll "name" [str "bob"] $ table "users" :: IO WriteResponse
107 | -- {deleted:1}
108 | delete :: (Expr selection) => selection -> ReQL
109 | delete s = op Term.DELETE [s]
110 |
111 | -- | Like map but for write queries
112 | --
113 | -- >>> _ <- run' h $ table "users" # replace (without ["post_count"])
114 | -- >>> run h $ forEach (\user -> table "users" # get (user!"name") # ex update [nonAtomic] (const ["post_count" := R.count (table "posts" # R.filter (\post -> post!"author" R.== user!"name"))])) (table "users") :: IO WriteResponse
115 | -- {replaced:2}
116 | forEach :: (Expr a, Expr s) => (ReQL -> a) -> s -> ReQL
117 | forEach f s = op FOR_EACH (s, expr P.. f)
118 |
119 | -- | A table
120 | --
121 | -- >>> fmap sort $ run h $ table "users" :: IO [Datum]
122 | -- [{"post_count":2,"name":"bill"},{"post_count":0,"name":"nancy"}]
123 | table :: Text -> Table
124 | table n = Table Nothing n Nothing
125 |
126 | -- | Drop a table
127 | --
128 | -- >>> run' h $ tableDrop (table "foo")
129 | -- {"config_changes":[{"new_val":null,"old_val":{"primary_key":"id","write_acks":"majority","durability":"hard","name":"foo","shards":...,"id":...,"db":"doctests"}}],"tables_dropped":1}
130 | tableDrop :: Table -> ReQL
131 | tableDrop (Table mdb table_name _) =
132 | withQuerySettings $ \QuerySettings{ queryDefaultDatabase = ddb } ->
133 | op TABLE_DROP (fromMaybe ddb mdb, table_name)
134 |
135 | -- | List the tables in a database
136 | --
137 | -- >>> fmap sort $ run h $ tableList (db "doctests") :: IO [String]
138 | -- ["places","posts","users"]
139 | tableList :: Database -> ReQL
140 | tableList name = op TABLE_LIST [name]
141 |
142 | infixl 6 +, -
143 | infixl 7 *, /
144 |
145 | -- | Addition or concatenation
146 | --
147 | -- Use the Num instance, or a qualified operator.
148 | --
149 | -- >>> run h $ 2 + 5
150 | -- 7
151 | -- >>> run h $ str "foo" R.+ str "bar"
152 | -- "foobar"
153 | (+) :: (Expr a, Expr b) => a -> b -> ReQL
154 | (+) a b = op ADD (a, b)
155 |
156 | -- | Subtraction
157 | --
158 | -- >>> run h $ 2 - 5
159 | -- -3
160 | (-) :: (Expr a, Expr b) => a -> b -> ReQL
161 | (-) a b = op SUB (a, b)
162 |
163 | -- | Multiplication
164 | --
165 | -- >>> run h $ 2 * 5
166 | -- 10
167 | (*) :: (Expr a, Expr b) => a -> b -> ReQL
168 | (*) a b = op MUL (a, b)
169 |
170 | -- | Division
171 | --
172 | -- >>> run h $ 2 R./ 5
173 | -- 0.4
174 | (/) :: (Expr a, Expr b) => a -> b -> ReQL
175 | (/) a b = op DIV (a, b)
176 |
177 | -- | Mod
178 | --
179 | -- >>> run h $ 5 `mod` 2
180 | -- 1
181 | mod :: (Expr a, Expr b) => a -> b -> ReQL
182 | mod a b = op MOD (a, b)
183 |
184 | infixr 2 ||
185 | infixr 3 &&
186 |
187 | -- | Boolean or
188 | --
189 | -- >>> run h $ True R.|| False
190 | -- true
191 | (||) :: (Expr a, Expr b) => a -> b -> ReQL
192 | a || b = op OR (a, b)
193 |
194 | -- | Boolean and
195 | --
196 | -- >>> run h $ True R.&& False
197 | -- false
198 | (&&) :: (Expr a, Expr b) => a -> b -> ReQL
199 | a && b = op AND (a, b)
200 |
201 | infix 4 ==, /=
202 |
203 | -- | Test for equality
204 | --
205 | -- >>> run h $ ["a" := 1] R.== ["a" := 1]
206 | -- true
207 | (==) :: (Expr a, Expr b) => a -> b -> ReQL
208 | a == b = op EQ (a, b)
209 |
210 | -- | Test for inequality
211 | --
212 | -- >>> run h $ 1 R./= False
213 | -- true
214 | (/=) :: (Expr a, Expr b) => a -> b -> ReQL
215 | a /= b = op NE (a, b)
216 |
217 | infix 4 >, <, <=, >=
218 |
219 | -- | Greater than
220 | --
221 | -- >>> run h $ 3 R.> 2
222 | -- true
223 | (>) :: (Expr a, Expr b) => a -> b -> ReQL
224 | a > b = op GT (a, b)
225 |
226 | -- | Lesser than
227 | --
228 | -- >>> run h $ (str "a") R.< (str "b")
229 | -- true
230 | (<) :: (Expr a, Expr b) => a -> b -> ReQL
231 | a < b = op LT (a, b)
232 |
233 | -- | Greater than or equal to
234 | --
235 | -- >>> run h $ [1] R.>= Null
236 | -- false
237 | (>=) :: (Expr a, Expr b) => a -> b -> ReQL
238 | a >= b = op GE (a, b)
239 |
240 | -- | Lesser than or equal to
241 | --
242 | -- >>> run h $ 2 R.<= 2
243 | -- true
244 | (<=) :: (Expr a, Expr b) => a -> b -> ReQL
245 | a <= b = op LE (a, b)
246 |
247 | -- | Negation
248 | --
249 | -- >>> run h $ R.not False
250 | -- true
251 | -- >>> run h $ R.not Null
252 | -- true
253 | not :: (Expr a) => a -> ReQL
254 | not a = op NOT [a]
255 |
256 | -- * Lists and Streams
257 |
258 | -- | The size of a sequence or an array.
259 | --
260 | -- >>> run h $ count (table "users")
261 | -- 2
262 | count :: (Expr a) => a -> ReQL
263 | count e = op COUNT [e]
264 |
265 | -- | Join two sequences.
266 | --
267 | -- >>> run h $ [1,2,3] `union` ["a", "b", "c" :: Text]
268 | -- [1,2,3,"a","b","c"]
269 | union :: (Expr a, Expr b) => a -> b -> ReQL
270 | union a b = op UNION (a, b)
271 |
272 | -- | Map a function over a sequence
273 | --
274 | -- >>> run h $ R.map (!"a") [["a" := 1], ["a" := 2]]
275 | -- [1,2]
276 | map :: (Expr a, Expr b) => (ReQL -> b) -> a -> ReQL
277 | map f a = op MAP (a, expr P.. f)
278 |
279 | -- | Filter a sequence given a predicate
280 | --
281 | -- >>> run h $ R.filter (R.< 4) [3, 1, 4, 1, 5, 9, 2, 6]
282 | -- [3,1,1,2]
283 | filter :: (Expr predicate, Expr seq) => predicate -> seq -> ReQL
284 | filter f a = op' FILTER (a, f) ["default" := op ERROR ()]
285 |
286 | -- | Query all the documents whose value for the given index is in a given range
287 | --
288 | -- >>> run h $ table "users" # between "name" (Closed $ str "a") (Open $ str "c")
289 | -- [{"post_count":2,"name":"bill"}]
290 | between :: (Expr left, Expr right, Expr seq) => Index -> Bound left -> Bound right -> seq -> ReQL
291 | between i a b e =
292 | op' BETWEEN [expr e, expr $ getBound a, expr $ getBound b] $
293 | idx P.++ ["left_bound" ?:= closedOrOpen a, "right_bound" ?:= closedOrOpen b]
294 | where idx = case i of PrimaryKey -> []; Index name -> ["index" := name]
295 |
296 | -- | Append a datum to a sequence
297 | --
298 | -- >>> run h $ append 3 [1, 2]
299 | -- [1,2,3]
300 | append :: (Expr a, Expr b) => a -> b -> ReQL
301 | append a b = op APPEND (b, a)
302 |
303 | -- | Map a function of a sequence and concat the results
304 | --
305 | -- >>> run h $ concatMap id [[1, 2], [3], [4, 5]]
306 | -- [1,2,3,4,5]
307 | concatMap :: (Expr a, Expr b) => (ReQL -> b) -> a -> ReQL
308 | concatMap f e = op CONCAT_MAP (e, expr P.. f)
309 |
310 | -- | SQL-like inner join of two sequences
311 | --
312 | -- >>> sorted $ run' h $ innerJoin (\user post -> user!"name" R.== post!"author") (table "users") (table "posts") # R.zip # orderBy [asc "id"] # pluck ["name", "message"]
313 | -- [{"name":"bill","message":"hello"},{"name":"bill","message":"hi"}]
314 | innerJoin :: (Expr a, Expr b, Expr c) => (ReQL -> ReQL -> c) -> a -> b -> ReQL
315 | innerJoin f a b = op INNER_JOIN (a, b, fmap expr P.. f)
316 |
317 | -- | SQL-like outer join of two sequences
318 | --
319 | -- >>> sorted $ run' h $ outerJoin (\user post -> user!"name" R.== post!"author") (table "users") (table "posts") # R.zip # orderBy [asc "id", asc "name"] # pluck ["name", "message"]
320 | -- [{"name":"bill","message":"hello"},{"name":"bill","message":"hi"},{"name":"nancy"}]
321 | outerJoin :: (Expr a, Expr b, Expr c) => (ReQL -> ReQL -> c) -> a -> b -> ReQL
322 | outerJoin f a b = op OUTER_JOIN (a, b, fmap expr P.. f)
323 |
324 | -- | An efficient inner_join that uses a key for the left table and an index for the right table.
325 | --
326 | -- >>> sorted $ run' h $ table "posts" # eqJoin "author" (table "users") "name" # R.zip # orderBy [asc "id"] # pluck ["name", "message"]
327 | -- [{"name":"bill","message":"hello"},{"name":"bill","message":"hi"}]
328 | eqJoin :: (Expr fun, Expr right, Expr left) => fun -> right -> Index -> left -> ReQL
329 | eqJoin key right (Index idx) left = op' EQ_JOIN (left, key, right) ["index" := idx]
330 | eqJoin key right PrimaryKey left = op EQ_JOIN (left, key, right)
331 |
332 | -- | Drop elements from the head of a sequence.
333 | --
334 | -- >>> run h $ skip 2 [1, 2, 3, 4]
335 | -- [3,4]
336 | skip :: (Expr n, Expr seq) => n -> seq -> ReQL
337 | skip a b = op SKIP (b, a)
338 |
339 | -- | Limit the size of a sequence.
340 | --
341 | -- >>> run h $ limit 2 [1, 2, 3, 4]
342 | -- [1,2]
343 | limit :: (Expr n, Expr seq) => n -> seq -> ReQL
344 | limit n s = op LIMIT (s, n)
345 |
346 | -- | Cut out part of a sequence
347 | --
348 | -- >>> run h $ slice 2 4 [1, 2, 3, 4, 5]
349 | -- [3,4]
350 | slice :: (Expr a, Expr b, Expr c) => a -> b -> c -> ReQL
351 | slice n m s = op SLICE (s, n, m)
352 |
353 | -- | Get nth element of a sequence
354 | --
355 | -- >>> run h $ nth 2 [1, 2, 3, 4, 5]
356 | -- 3
357 | nth :: (Expr a, Expr seq) => a -> seq -> ReQL
358 | nth a s = op NTH (s, a)
359 |
360 | -- | Reduce a sequence to a single value
361 | --
362 | -- >>> run h $ reduce0 (+) 0 [1, 2, 3]
363 | -- 6
364 | reduce0 :: (Expr base, Expr seq, Expr a) => (ReQL -> ReQL -> a) -> base -> seq -> ReQL
365 | reduce0 f b s = op REDUCE (s `union` [b], fmap expr P.. f)
366 |
367 | -- | Reduce a non-empty sequence to a single value
368 | --
369 | -- >>> run h $ reduce (+) [1, 2, 3]
370 | -- 6
371 | reduce :: (Expr a, Expr s) => (ReQL -> ReQL -> a) -> s -> ReQL
372 | reduce f s = op REDUCE (s, fmap expr P.. f)
373 |
374 | -- | Filter out identical elements of the sequence
375 | --
376 | -- >>> fmap sort $ run h $ distinct (table "posts" ! "flag") :: IO [String]
377 | -- ["deleted","pinned"]
378 | distinct :: (Expr s) => s -> ReQL
379 | distinct s = op DISTINCT [s]
380 |
381 | -- | Merge the "left" and "right" attributes of the objects in a sequence.
382 | --
383 | -- >>> fmap sort $ run h $ table "posts" # eqJoin "author" (table "users") "name" # R.zip :: IO [Datum]
384 | -- [{"post_count":2,"flag":"deleted","name":"bill","author":"bill","id":2,"message":"hello"},{"post_count":2,"name":"bill","author":"bill","id":1,"message":"hi"}]
385 | zip :: (Expr a) => a -> ReQL
386 | zip a = op ZIP [a]
387 |
388 | -- | Order a sequence by the given keys
389 | --
390 | -- >>> run' h $ table "users" # orderBy [desc "post_count", asc "name"] # pluck ["name", "post_count"]
391 | -- [{"post_count":2,"name":"bill"},{"post_count":0,"name":"nancy"}]
392 | --
393 | -- >>> run' h $ table "users" # ex orderBy ["index":="name"] [] # pluck ["name"]
394 | -- [{"name":"bill"},{"name":"nancy"}]
395 | orderBy :: (Expr s) => [ReQL] -> s -> ReQL
396 | orderBy o s = op ORDER_BY (expr s : P.map expr o)
397 |
398 | -- | Ascending order
399 | asc :: ReQL -> ReQL
400 | asc f = op ASC [f]
401 |
402 | -- | Descending order
403 | desc :: ReQL -> ReQL
404 | desc f = op DESC [f]
405 |
406 | -- | Turn a grouping function and a reduction function into a grouped map reduce operation
407 | --
408 | -- >>> run' h $ table "posts" # orderBy [asc "id"] # group (!"author") (reduce (\a b -> a + "\n" + b) . R.map (!"message"))
409 | -- [{"group":"bill","reduction":"hi\nhello"},{"group":"bob","reduction":"lorem ipsum"}]
410 | -- >>> run' h $ table "users" # group ((!0) . splitOn "" . (!"name")) (\users -> let pc = users!"post_count" in [avg pc, R.sum pc])
411 | -- [{"group":"b","reduction":[2,2]},{"group":"n","reduction":[0,0]}]
412 | group ::
413 | (Expr group, Expr reduction, Expr seq)
414 | => (ReQL -> group) -> (ReQL -> reduction) -> seq -> ReQL
415 | group g f s = ReQL $ do
416 | mr <- termToMapReduce (expr . f)
417 | runReQL $ op UNGROUP [mr $ op GROUP (expr s, expr . g)]
418 |
419 | -- | Rewrite multiple reductions into a single map/reduce operation
420 | mapReduce :: (Expr reduction, Expr seq) => (ReQL -> reduction) -> seq -> ReQL
421 | mapReduce f s = ReQL $ do
422 | mr <- termToMapReduce (expr . f)
423 | runReQL $ mr (expr s)
424 |
425 | -- | The sum of a sequence
426 | --
427 | -- >>> run h $ sum [1, 2, 3]
428 | -- 6
429 | sum :: (Expr s) => s -> ReQL
430 | sum s = op SUM [s]
431 |
432 | -- | The average of a sequence
433 | --
434 | -- >>> run h $ avg [1, 2, 3, 4]
435 | -- 2.5
436 | avg :: (Expr s) => s -> ReQL
437 | avg s = op AVG [s]
438 |
439 | -- | Minimum value
440 | min :: Expr s => s -> ReQL
441 | min s = op MIN [s]
442 |
443 | -- | Value that minimizes the function
444 | argmin :: (Expr s, Expr a) => (ReQL -> a) -> s -> ReQL
445 | argmin f s = op MIN (s, expr . f)
446 |
447 | -- | Minimum value
448 | max :: Expr s => s -> ReQL
449 | max s = op MAX [s]
450 |
451 | -- | Floor rounds number to interger below
452 | --
453 | -- >>> run h $ R.floor 2.9
454 | -- 2
455 | floor :: Expr s => s -> ReQL
456 | floor s = op FLOOR [s]
457 |
458 | -- | Ceil rounds number to integer above
459 | --
460 | -- >>> run h $ R.ceil 2.1
461 | -- 3
462 | ceil :: Expr s => s -> ReQL
463 | ceil s = op CEIL [s]
464 |
465 | -- | Round rounds number to nearest integer
466 | --
467 | -- >>> run h $ R.round 2.5
468 | -- 3
469 | round :: Expr s => s -> ReQL
470 | round s = op ROUND [s]
471 |
472 | -- | Value that maximizes the function
473 | argmax :: (Expr s, Expr a) => (ReQL -> a) -> s -> ReQL
474 | argmax f s = op MAX (s, expr . f)
475 |
476 | -- * Accessors
477 |
478 | infixl 9 !
479 |
480 | -- | Get a single field from an object or an element of an array
481 | --
482 | -- >>> run h $ ["foo" := True] ! "foo"
483 | -- true
484 | --
485 | -- >>> run h $ [1, 2, 3] ! 0
486 | -- 1
487 | --
488 | -- Or a single field from each object in a sequence
489 | --
490 | -- >>> run h $ [["foo" := True], ["foo" := False]] ! "foo"
491 | -- [true,false]
492 | (!) :: (Expr s) => s -> ReQL -> ReQL
493 | s ! k = op BRACKET (s, k)
494 |
495 | -- | Get a single field, or null if not present
496 | --
497 | -- >>> run' h $ empty !? "foo"
498 | -- null
499 | (!?) :: (Expr s) => s -> ReQL -> ReQL
500 | s !? k = P.flip apply [expr s, k] $ \s' k' -> op DEFAULT (op BRACKET (s', k'), Null)
501 |
502 | -- | Keep only the given attributes
503 | --
504 | -- >>> run' h $ [["a" := 1, "b" := 2], ["a" := 2, "c" := 7], ["b" := 4]] # pluck ["a"]
505 | -- [{"a":1},{"a":2},{}]
506 | pluck :: (Expr o) => [ReQL] -> o -> ReQL
507 | pluck ks e = op PLUCK (cons e $ arr (P.map expr ks))
508 |
509 | -- | Remove the given attributes from an object
510 | --
511 | -- >>> run' h $ [["a" := 1, "b" := 2], ["a" := 2, "c" := 7], ["b" := 4]] # without ["a"]
512 | -- [{"b":2},{"c":7},{"b":4}]
513 | without :: (Expr o) => [ReQL] -> o -> ReQL
514 | without ks e = op WITHOUT (cons e $ arr (P.map expr ks))
515 |
516 | -- | Test if a sequence contains a given element
517 | --
518 | -- >>> run' h $ [1,2,3] # contains 1
519 | -- true
520 | contains :: (Expr x, Expr seq) => x -> seq -> ReQL
521 | contains x s = op CONTAINS (s, x)
522 |
523 | -- | Merge two objects together
524 | --
525 | -- NOTE: This driver is based on the official JavaScript driver, you are correct to expect the same semantics.
526 | -- However the order of composition is flipped by putting the first argument last.
527 | --
528 | -- >>> run' h $ merge ["a" := 1, "b" := 1] ["b" := 1, "c" := 2]
529 | -- {"a":1,"b":1,"c":2}
530 | merge :: (Expr a, Expr b) => a -> b -> ReQL
531 | merge a b = op MERGE (b, a)
532 |
533 | -- | Literal objects, in a merge or update, are not processed recursively.
534 | --
535 | -- >>> run' h $ ["a" := ["b" := 1]] # merge ["a" := literal ["c" := 2]]
536 | -- {"a":{"c":2}}
537 | literal :: Expr a => a -> ReQL
538 | literal a = op LITERAL [a]
539 |
540 | -- | Remove fields when doing a merge or update
541 | --
542 | -- >>> run' h $ ["a" := ["b" := 1]] # merge ["a" := remove]
543 | -- {}
544 | remove :: ReQL
545 | remove = op LITERAL ()
546 |
547 | -- | Evaluate a JavaScript expression
548 | --
549 | -- >>> run' h $ js "Math.PI"
550 | -- 3.141592653589793
551 | -- >>> let r_sin x = js "Math.sin" `apply` [x]
552 | -- >>> run h $ R.map r_sin [pi, pi/2]
553 | -- [1.2246...,1]
554 | js :: ReQL -> ReQL
555 | js s = op JAVASCRIPT [s]
556 |
557 | -- | Server-side if
558 | --
559 | -- >>> run h $ branch (1 R.< 2) 3 4
560 | -- 3
561 | branch :: (Expr a, Expr b, Expr c) => a -> b -> c -> ReQL
562 | branch a b c = op BRANCH (a, b, c)
563 |
564 | -- | Abort the query with an error
565 | --
566 | -- >>> run' h $ R.error (str "haha") R./ 2 + 1
567 | -- *** Exception: RethinkDB: Runtime error: haha
568 | -- in add(div({- HERE -} error("haha"), 2), 1)
569 | error :: (Expr s) => s -> ReQL
570 | error m = op ERROR [m]
571 |
572 | -- | Create a Database reference
573 | --
574 | -- >>> run' h $ db "test" # info
575 | -- {"name":"test","id":...,"type":"DB"}
576 | db :: Text -> Database
577 | db = Database
578 |
579 | -- | Create a database on the server
580 | --
581 | -- >>> run' h $ dbCreate "dev"
582 | -- {"config_changes":[{"new_val":{"name":"dev","id":...},"old_val":null}],"dbs_created":1}
583 | dbCreate :: Text -> ReQL
584 | dbCreate db_name = op DB_CREATE [expr db_name]
585 |
586 | -- | Drop a database
587 | --
588 | -- >>> run' h $ dbDrop (db "dev")
589 | -- {"config_changes":[{"new_val":null,"old_val":{"name":"dev","id":...}}],"tables_dropped":0,"dbs_dropped":1}
590 | dbDrop :: Database -> ReQL
591 | dbDrop (Database name) = op DB_DROP [name]
592 |
593 | -- | List the databases on the server
594 | --
595 | -- >>> _ <- run' h $ dbList
596 | dbList :: ReQL
597 | dbList = op DB_LIST ()
598 |
599 | -- | Create an index on the table from the given function
600 | --
601 | -- >>> run' h $ table "users" # indexCreate "occupation" (!"occupation")
602 | -- {"created":1}
603 | -- >>> run' h $ table "users" # ex indexCreate ["multi":=True] "friends" (!"friends")
604 | -- {"created":1}
605 | -- >>> run' h $ table "users" # ex indexCreate ["geo":=True] "location" (!"location")
606 | -- {"created":1}
607 | indexCreate :: (Expr fun) => Text -> fun -> Table -> ReQL
608 | indexCreate name f tbl = op INDEX_CREATE (tbl, expr name, f)
609 |
610 | -- | Get the status of the given indexes
611 | --
612 | -- > run' h $ table "users" # indexStatus []
613 | indexStatus :: Expr table => [ReQL] -> table -> ReQL
614 | indexStatus ixes tbl = op INDEX_STATUS (tbl, op ARGS [ixes])
615 |
616 | -- | Wait for an index to be built
617 | --
618 | -- > run' h $ table "users" # indexWait []
619 | indexWait :: Expr table => [ReQL] -> table -> ReQL
620 | indexWait ixes tbl = op INDEX_STATUS (tbl, op ARGS [ixes])
621 |
622 | indexRename :: Expr table => ReQL -> ReQL -> table -> ReQL
623 | indexRename from to tbl = op INDEX_RENAME (tbl, from, to)
624 |
625 | -- | Ensures that writes on a given table are written to permanent storage
626 | --
627 | -- >>> run' h $ sync (table "users")
628 | -- {"synced":1}
629 | sync :: Expr table => table -> ReQL
630 | sync tbl = op SYNC [tbl]
631 |
632 | -- | List the indexes on the table
633 | --
634 | -- >>> run' h $ indexList (table "users")
635 | -- ["friends","location","occupation"]
636 | indexList :: Table -> ReQL
637 | indexList tbl = op INDEX_LIST [tbl]
638 |
639 | -- | Drop an index
640 | --
641 | -- >>> run' h $ table "users" # indexDrop "occupation"
642 | -- {"dropped":1}
643 | indexDrop :: Key -> Table -> ReQL
644 | indexDrop name tbl = op INDEX_DROP (tbl, name)
645 |
646 | -- | Retreive documents by their indexed value
647 | --
648 | -- >>> run' h $ table "users" # getAll PrimaryKey [str "bill"]
649 | -- [{"post_count":2,"name":"bill"}]
650 | getAll :: (Expr values) => Index -> values -> Table -> ReQL
651 | getAll idx xs tbl =
652 | op' GET_ALL (tbl, op ARGS [xs]) $
653 | case idx of
654 | Index i -> ["index" := i]
655 | PrimaryKey -> []
656 |
657 | -- | Get a document by primary key
658 | --
659 | -- >>> run' h $ table "users" # get "nancy"
660 | -- {"post_count":0,"name":"nancy"}
661 | get :: Expr s => ReQL -> s -> ReQL
662 | get k e = op Term.GET (e, k)
663 |
664 | -- | Convert a value to a different type
665 | --
666 | -- >>> run h $ coerceTo "STRING" 1
667 | -- "1"
668 | coerceTo :: (Expr x) => ReQL -> x -> ReQL
669 | coerceTo t a = op COERCE_TO (a, t)
670 |
671 | -- | Convert a value to an array
672 | --
673 | -- >>> run h $ asArray $ ["a" := 1, "b" := 2] :: IO [(String, Int)]
674 | -- [("a",1),("b",2)]
675 | asArray :: Expr x => x -> ReQL
676 | asArray = coerceTo "ARRAY"
677 |
678 | -- | Convert a value to a string
679 | --
680 | -- >>> run h $ asString $ ["a" := 1, "b" := 2]
681 | -- "{\"a\":1,\"b\":2}"
682 | asString :: Expr x => x -> ReQL
683 | asString = coerceTo "STRING"
684 |
685 | -- | Convert a value to a number
686 | --
687 | -- >>> run h $ asNumber (str "34")
688 | -- 34
689 | asNumber :: Expr x => x -> ReQL
690 | asNumber = coerceTo "NUMBER"
691 |
692 | -- | Convert a value to an object
693 | --
694 | -- >>> run' h $ asObject $ [(str "a",1),("b",2)]
695 | -- {"a":1,"b":2}
696 | asObject :: Expr x => x -> ReQL
697 | asObject = coerceTo "OBJECT"
698 |
699 | -- | Convert a value to a boolean
700 | asBool :: Expr x => x -> ReQL
701 | asBool = coerceTo "BOOL"
702 |
703 | -- | Like hasFields followed by pluck
704 | --
705 | -- >>> run' h $ [["a" := 1, "b" := 2], ["a" := 2, "c" := 7], ["b" := 4]] # withFields ["a"]
706 | -- [{"a":1},{"a":2}]
707 | withFields :: Expr seq => [ReQL] -> seq -> ReQL
708 | withFields p s = op WITH_FIELDS (s, p)
709 |
710 | -- | The position in the sequence of the elements that match the predicate
711 | --
712 | -- >>> run h $ indexesOf (match "ba.") [str "foo", "bar", "baz"]
713 | -- [1,2]
714 | indexesOf :: (Expr fun, Expr seq) => fun -> seq -> ReQL
715 | indexesOf f s = op OFFSETS_OF (s, f)
716 |
717 | -- | Test if a sequence is empty
718 | --
719 | -- >>> run h $ isEmpty [1]
720 | -- false
721 | isEmpty :: Expr seq => seq -> ReQL
722 | isEmpty s = op IS_EMPTY [s]
723 |
724 | -- | Select a given number of elements from a sequence with uniform random distribution
725 | --
726 | -- >>> _ <- run' h $ sample 3 [0,1,2,3,4,5,6,7,8,9]
727 | sample :: (Expr n, Expr seq) => n -> seq -> ReQL
728 | sample n s = op SAMPLE (s, n)
729 |
730 | -- | Prepend an element to an array
731 | --
732 | -- >>> run h $ prepend 1 [2,3]
733 | -- [1,2,3]
734 | prepend :: (Expr datum, Expr array) => datum -> array -> ReQL
735 | prepend d a = op PREPEND (a, d)
736 |
737 | -- | The different of two lists
738 | --
739 | -- >>> run h $ [1,2,3,4,5] # difference [2,5]
740 | -- [1,3,4]
741 | difference :: (Expr a, Expr b) => a -> b -> ReQL
742 | difference a b = op DIFFERENCE (b, a)
743 |
744 | -- | Insert a datum into an array if it is not yet present
745 | --
746 | -- >>> run h $ setInsert 3 [1,2,4,4,5]
747 | -- [1,2,4,5,3]
748 | setInsert :: (Expr datum, Expr array) => datum -> array -> ReQL
749 | setInsert d a = op SET_INSERT (a, d)
750 |
751 | -- | The union of two sets
752 | --
753 | -- >>> run h $ [1,2] `setUnion` [2,3]
754 | -- [2,3,1]
755 | setUnion :: (Expr a, Expr b) => a -> b -> ReQL
756 | setUnion a b = op SET_UNION (b, a)
757 |
758 | -- | The intersection of two sets
759 | --
760 | -- >>> run h $ [1,2] `setIntersection` [2,3]
761 | -- [2]
762 | setIntersection :: (Expr a, Expr b) => a -> b -> ReQL
763 | setIntersection a b = op SET_INTERSECTION (b, a)
764 |
765 | -- | The difference of two sets
766 | --
767 | -- >>> run h $ [2,3] # setDifference [1,2]
768 | -- [3]
769 | setDifference :: (Expr set, Expr remove) => remove -> set -> ReQL
770 | setDifference r s = op SET_DIFFERENCE (s, r)
771 |
772 | -- | Test if an object has the given fields
773 | --
774 | -- >>> run h $ hasFields "a" $ ["a" := 1]
775 | -- true
776 | hasFields :: (Expr obj) => ReQL -> obj -> ReQL
777 | hasFields p o = op HAS_FIELDS (o, expr p)
778 |
779 | -- | Insert a datum at the given position in an array
780 | --
781 | -- >>> run h $ insertAt 1 4 [1,2,3]
782 | -- [1,4,2,3]
783 | insertAt :: (Expr n, Expr datum, Expr array) => n -> datum -> array -> ReQL
784 | insertAt n d a = op INSERT_AT (a, n, d)
785 |
786 | -- | Splice an array at a given position inside another array
787 | --
788 | -- >>> run h $ spliceAt 2 [4,5] [1,2,3]
789 | -- [1,2,4,5,3]
790 | spliceAt :: (Expr n, Expr replace, Expr array) => n -> replace -> array -> ReQL
791 | spliceAt n s a = op SPLICE_AT (a, n, s)
792 |
793 | -- | Delete an element from an array
794 | --
795 | -- >>> run h $ deleteAt 1 [1,2,3]
796 | -- [1,3]
797 | deleteAt :: (Expr n, Expr array) => n -> array -> ReQL
798 | deleteAt n a = op DELETE_AT (a, n)
799 |
800 | -- | Change an element in an array
801 | --
802 | -- >>> run h $ changeAt 1 4 [1,2,3]
803 | -- [1,4,3]
804 | changeAt :: (Expr n, Expr datum, Expr array) => n -> datum -> array -> ReQL
805 | changeAt n d a = op CHANGE_AT (a, n, d)
806 |
807 | -- | The list of keys of the given object
808 | --
809 | -- >>> run h $ keys ["a" := 1, "b" := 2]
810 | -- ["a","b"]
811 | keys :: Expr object => object -> ReQL
812 | keys o = op KEYS [o]
813 |
814 | -- | The list of values of the given object
815 | --
816 | -- >>> run h $ values ["a" := 1, "b" := 2]
817 | -- [1,2]
818 | values :: Expr object => object -> ReQL
819 | values o = op VALUES [o]
820 |
821 | -- | Match a string to a regular expression.
822 | --
823 | -- >>> run' h $ str "foobar" # match "f(.)+[bc](.+)"
824 | -- {"groups":[{"start":2,"end":3,"str":"o"},{"start":4,"end":6,"str":"ar"}],"start":0,"end":6,"str":"foobar"}
825 | match :: (Expr string) => ReQL -> string -> ReQL
826 | match r s = op MATCH (s, r)
827 |
828 | -- | Apply a function to a list of arguments.
829 | --
830 | -- Called /do/ in the official drivers
831 | --
832 | -- >>> run h $ (\x -> x R.* 2) `apply` [4]
833 | -- 8
834 | apply :: (Expr fun, Expr arg) => fun -> [arg] -> ReQL
835 | f `apply` as = op FUNCALL (expr f : P.map expr as)
836 |
837 | -- | Catch some expections inside the query.
838 | --
839 | -- Called /default/ in the official drivers
840 | --
841 | -- >>> run h $ R.handle (const 0) $ ["a" := 1] ! "b"
842 | -- 0
843 | -- >>> run h $ R.handle (expr . id) $ ["a" := 1] ! "b"
844 | -- "No attribute `b` in object:\n{\n\t\"a\":\t1\n}"
845 | handle :: (Expr instead, Expr reql) => (ReQL -> instead) -> reql -> ReQL
846 | handle h r = op DEFAULT (r, expr . h)
847 |
848 | -- | A string representing the type of an expression
849 | --
850 | -- >>> run h $ typeOf 1
851 | -- "NUMBER"
852 | typeOf :: Expr a => a -> ReQL
853 | typeOf a = op TYPE_OF [a]
854 |
855 | -- | Get information on a given expression. Useful for tables and databases.
856 | --
857 | -- >>> run h $ info $ table "users"
858 | -- {"primary_key":"name","doc_count_estimates":...,"name":"users","id":...,"indexes":["friends","location"],"type":"TABLE","db":{"name":"doctests","id":...,"type":"DB"}}
859 | info :: Expr a => a -> ReQL
860 | info a = op INFO [a]
861 |
862 | -- | Parse a json string into an object
863 | --
864 | -- >>> run' h $ json "{\"a\":1}"
865 | -- {"a":1}
866 | json :: ReQL -> ReQL
867 | json s = op Term.JSON [s]
868 |
869 | -- | Flipped function application
870 | infixl 8 #
871 | (#) :: (Expr a, Expr b) => a -> (a -> b) -> ReQL
872 | x # f = expr (f x)
873 |
874 | -- | Convert to upper case
875 | --
876 | -- >>> run h $ upcase (str "Foo")
877 | -- "FOO"
878 | upcase :: Expr str => str -> ReQL
879 | upcase s = op UPCASE [s]
880 |
881 | -- | Convert to lower case
882 | --
883 | -- >>> run h $ downcase (str "Foo")
884 | -- "foo"
885 | downcase :: Expr str => str -> ReQL
886 | downcase s = op DOWNCASE [s]
887 |
888 | -- | Split a string on whitespace characters
889 | --
890 | -- >>> run' h $ split (str "foo bar")
891 | -- ["foo","bar"]
892 | split :: Expr str => str -> ReQL
893 | split s = op SPLIT [s]
894 |
895 | -- | Split a string on a given delimiter
896 | --
897 | -- >>> run' h $ str "foo, bar" # splitOn ","
898 | -- ["foo"," bar"]
899 | --
900 | -- >>> run' h $ str "foo" # splitOn ""
901 | -- ["f","o","o"]
902 | splitOn :: Expr str => ReQL -> str -> ReQL
903 | splitOn sep s = op SPLIT [expr s, sep]
904 |
905 | -- | Split a string up to a given number of times
906 | --
907 | -- >>> run' h $ str "a:b:c:d" # splitMax ":" 2
908 | -- ["a","b","c:d"]
909 | splitMax :: Expr str => ReQL -> ReQL -> str -> ReQL
910 | splitMax sep n s = op SPLIT [expr s, sep, n]
911 |
912 | -- | A random float between 0 and 1
913 | --
914 | -- >>> run' h $ (\x -> x R.< 1 R.&& x R.>= 0) `apply` [random]
915 | -- true
916 | random :: ReQL
917 | random = op RANDOM ()
918 |
919 | -- | A random number between 0 and n
920 | --
921 | -- >>> run' h $ (\x -> x R.< 10 R.&& x R.>= 0) `apply` [randomTo 10]
922 | -- true
923 | randomTo :: ReQL -> ReQL
924 | randomTo n = op RANDOM [n]
925 |
926 | -- | A random number between 0 and n
927 | --
928 | -- >>> run' h $ (\x -> x R.< 10 R.&& x R.>= 5) `apply` [randomFromTo 5 10]
929 | -- true
930 | randomFromTo :: ReQL -> ReQL -> ReQL
931 | randomFromTo n m = op RANDOM [n, m]
932 |
933 | data HttpOptions = HttpOptions {
934 | httpTimeout :: Maybe P.Int,
935 | httpReattempts :: Maybe P.Int,
936 | httpRedirects :: Maybe P.Int,
937 | httpVerify :: Maybe P.Bool,
938 | httpResultFormat :: Maybe HttpResultFormat,
939 | httpMethod :: Maybe HttpMethod,
940 | httpAuth :: Maybe [Attribute Dynamic],
941 | httpParams :: Maybe [Attribute Dynamic],
942 | httpHeader :: Maybe [Attribute Dynamic],
943 | httpData :: Maybe ReQL,
944 | httpPage :: Maybe PaginationStrategy,
945 | httpPageLimit :: Maybe P.Int
946 | }
947 |
948 | data HttpResultFormat =
949 | FormatAuto | FormatJSON | FormatJSONP | FormatBinary
950 |
951 | instance Expr HttpResultFormat where
952 | expr FormatAuto = "auto"
953 | expr FormatJSON = "json"
954 | expr FormatJSONP = "jsonp"
955 | expr FormatBinary = "binary"
956 |
957 | data HttpMethod = GET | POST | PUT | PATCH | DELETE | HEAD
958 | deriving P.Show
959 |
960 | instance Expr HttpMethod where
961 | expr = str P.. P.show
962 |
963 | data PaginationStrategy =
964 | LinkNext |
965 | PaginationFunction (ReQL -> ReQL)
966 |
967 | instance Expr PaginationStrategy where
968 | expr LinkNext = "link-next"
969 | expr (PaginationFunction f) = expr f
970 |
971 | instance Default HttpOptions where
972 | def = HttpOptions {
973 | httpTimeout = Nothing,
974 | httpReattempts = Nothing,
975 | httpRedirects = Nothing,
976 | httpVerify = Nothing,
977 | httpResultFormat = Nothing,
978 | httpMethod = Nothing,
979 | httpAuth = Nothing,
980 | httpParams = Nothing,
981 | httpHeader = Nothing,
982 | httpData = Nothing,
983 | httpPage = Nothing,
984 | httpPageLimit = Nothing
985 | }
986 |
987 | -- | Retrieve data from the specified URL over HTTP
988 | --
989 | -- >>> _ <- run' h $ http "http://httpbin.org/get" def{ httpParams = Just ["foo" := 1] }
990 | -- >>> _ <- run' h $ http "http://httpbin.org/put" def{ httpMethod = Just PUT, httpData = Just $ expr ["foo" := "bar"] }
991 | http :: Expr url => url -> HttpOptions -> ReQL
992 | http url opts = op' HTTP [url] $ render opts
993 | where
994 | render ho =
995 | let
996 | go :: Expr x => (HttpOptions -> Maybe x) -> Text -> [Attribute Static]
997 | go f s = maybe [] (\x -> [s := x]) (f ho)
998 | in mconcat [
999 | go httpTimeout "timeout",
1000 | go httpReattempts "reattempts",
1001 | go httpRedirects "redirects",
1002 | go httpVerify "verify",
1003 | go httpResultFormat "result_format",
1004 | go httpMethod "method",
1005 | go httpAuth "auth",
1006 | go httpParams "params",
1007 | go httpHeader "header",
1008 | go httpData "data",
1009 | go httpPage "page",
1010 | go httpPageLimit "page_limit"
1011 | ]
1012 |
1013 | -- | Splice a list of values into an argument list
1014 | args :: Expr array => array -> ReQL
1015 | args a = op ARGS [a]
1016 |
1017 | -- | Return an infinite stream of objects representing changes to a table
1018 | --
1019 | -- >>> cursor <- run h $ table "posts" # changes :: IO (Cursor Datum)
1020 | -- >>> run h $ table "posts" # insert ["author" := "bill", "message" := "bye", "id" := 4] :: IO WriteResponse
1021 | -- {inserted:1}
1022 | -- >>> next cursor
1023 | -- Just {"new_val":{"author":"bill","id":4,"message":"bye"},"old_val":null}
1024 | changes :: Expr seq => seq -> ReQL
1025 | changes s = op CHANGES [s]
1026 |
1027 | -- | Optional argument for returning an array of objects describing the changes made
1028 | --
1029 | -- >>> run h $ table "users" # ex insert [returnChanges] ["name" := "sabrina"] :: IO WriteResponse
1030 | -- {inserted:1,changes:[{"old_val":null,"new_val":{"name":"sabrina"}}]}
1031 | returnChanges :: Attribute a
1032 | returnChanges = "return_changes" := P.True
1033 |
1034 | -- | Optional argument for changes
1035 | includeStates :: Attribute a
1036 | includeStates = "include_states" := P.True
1037 |
1038 | -- | Optional argument for changes
1039 | includeInitial :: Attribute a
1040 | includeInitial = "include_initial" := P.True
1041 |
1042 | -- | Optional argument for non-atomic writes
1043 | --
1044 | -- >>> run' h $ table "users" # get "sabrina" # update (merge ["lucky_number" := random])
1045 | -- *** Exception: RethinkDB: Runtime error: Could not prove argument deterministic. Maybe you want to use the non_atomic flag?
1046 | -- in
1047 | -- {- HERE -}
1048 | -- update(
1049 | -- get(table(db("doctests"), "users"), "sabrina"),
1050 | -- (\b -> merge(b, {lucky_number: random()})))
1051 | -- >>> run h $ table "users" # get "sabrina" # ex update [nonAtomic] (merge ["lucky_number" := random]) :: IO WriteResponse
1052 | -- {replaced:1}
1053 | nonAtomic :: Attribute a
1054 | nonAtomic = "non_atomic" := P.True
1055 |
1056 | data ConflictResolution = Error | Replace | Update
1057 |
1058 | instance Expr ConflictResolution where
1059 | expr Error = "error"
1060 | expr Replace = "replace"
1061 | expr Update = "update"
1062 |
1063 | conflict :: ConflictResolution -> Attribute a
1064 | conflict cr = "conflict" := cr
1065 |
1066 | -- | Generate a UUID
1067 | --
1068 | -- >>> run h uuid
1069 | -- "...-...-...-..."
1070 | uuid :: ReQL
1071 | uuid = op UUID ()
1072 |
1073 | -- | Generate a Version 5 UUID
1074 | --
1075 | -- >>> run h $ uuid5 "foo"
1076 | -- "aa32a020-8c2d-5ff1-823b-ad3fa5d067eb"
1077 | uuid5 :: Expr name => name -> ReQL
1078 | uuid5 name = op UUID [name]
1079 |
1080 | -- | Generate numbers starting from 0
1081 | --
1082 | -- >>> run h $ range 10
1083 | -- [0,1,2,3,4,5,6,7,8,9]
1084 | range :: ReQL -> ReQL
1085 | range n = op RANGE [n]
1086 |
1087 | -- | Generate numbers within a range
1088 | --
1089 | -- >>> run h $ rangeFromTo 2 4
1090 | -- [2,3]
1091 | rangeFromTo :: ReQL -> ReQL -> ReQL
1092 | rangeFromTo a b = op RANGE (a, b)
1093 |
1094 | -- | Generate numbers starting from 0
1095 | --
1096 | -- >>> run' h $ rangeAll # limit 4
1097 | -- [0,1,2,3]
1098 | rangeAll :: ReQL
1099 | rangeAll = op RANGE ()
1100 |
1101 | -- | Wait for tables to be ready
1102 | --
1103 | -- >>> run h $ table "users" # wait
1104 | -- {"ready":1}
1105 | wait :: Expr table => table -> ReQL
1106 | wait t = op WAIT [t]
1107 |
1108 | -- | Convert an object or value to a JSON string
1109 | --
1110 | -- >>> run h $ toJSON "a"
1111 | -- "\"a\""
1112 | toJSON :: Expr a => a -> ReQL
1113 | toJSON a = op TO_JSON_STRING [a]
1114 |
1115 | -- | Map over two sequences
1116 | --
1117 | -- >>> run h $ zipWith (+) [1,2] [3,4]
1118 | -- [4,6]
1119 | zipWith :: (Expr left, Expr right, Expr b)
1120 | => (ReQL -> ReQL -> b) -> left -> right -> ReQL
1121 | zipWith f a b = op MAP (a, b, \x y -> expr (f x y))
1122 |
1123 | -- | Map over multiple sequences
1124 | --
1125 | -- >>> run' h $ zipWithN (\a b c -> expr $ a + b * c) [[1,2],[3,4],[5,6]]
1126 | -- [16,26]
1127 | zipWithN :: (Arr a, Expr f)
1128 | => f -> a -> ReQL
1129 | zipWithN f s = op MAP $ arr s <> arr [f]
1130 |
1131 | -- | Change a table's configuration
1132 | --
1133 | -- >>> run h $ table "users" # reconfigure 2 1
1134 | -- {"config_changes":[{"new_val":{"primary_key":"name","write_acks":"majority","durability":"hard","name":"users","shards":...
1135 | reconfigure :: (Expr table, Expr replicas)
1136 | => ReQL -> replicas -> table -> ReQL
1137 | reconfigure shards replicas t = op' RECONFIGURE [t] ["shards" := shards, "replicas" := replicas]
1138 |
1139 | -- | Rebalance a table's shards
1140 | --
1141 | -- >>> run h $ table "users" # rebalance
1142 | -- {"rebalanced":1,"status_changes":[{"new_val":{"status":{"all_replicas_ready":...,"ready_for_outdated_reads":...
1143 | rebalance :: Expr table => table -> ReQL
1144 | rebalance t = op REBALANCE [t]
1145 |
1146 | -- | Get the config for a table or database
1147 | --
1148 | -- >>> run h $ table "users" # config
1149 | -- {"primary_key":"name","write_acks":"majority","durability":"hard","name":"users","shards":...,"id":...,"db":"doctests"}
1150 | config :: Expr table => table -> ReQL
1151 | config t = op CONFIG [t]
1152 |
1153 | -- | Get the status of a table
1154 | --
1155 | -- >>> run h $ table "users" # status
1156 | -- {"status":{"all_replicas_ready":true,"ready_for_outdated_reads":true,...
1157 | status :: Expr table => table -> ReQL
1158 | status t = op STATUS [t]
1159 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Functions.hs-boot:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Functions where
2 | import {-# SOURCE #-} Database.RethinkDB.ReQL
3 | js :: ReQL -> ReQL
4 | apply :: (Expr fun, Expr arg) => fun -> [arg] -> ReQL
--------------------------------------------------------------------------------
/Database/RethinkDB/Geospatial.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | module Database.RethinkDB.Geospatial where
4 |
5 | import Database.RethinkDB.ReQL
6 | import Database.RethinkDB.Types
7 | import Database.RethinkDB.Wire.Term
8 |
9 | -- $setup
10 | --
11 | -- Get the doctests ready
12 | --
13 | -- >>> :set -XOverloadedStrings
14 | -- >>> :load Database.RethinkDB.NoClash
15 | -- >>> import qualified Database.RethinkDB as R
16 | -- >>> import Control.Exception
17 | -- >>> let try' x = (try x `asTypeOf` return (Left (undefined :: SomeException))) >> return ()
18 | -- >>> h <- fmap (use "doctests") $ connect "localhost" 28015 def
19 | -- >>> try' $ run' h $ dbCreate "doctests"
20 | -- >>> try' $ run' h $ tableCreate "places"
21 | -- >>> try' $ run' h $ table "places" # insert ["location" := point (-120) 60]
22 | -- >>> try' $ run' h $ table "places" # insert ["location" := point (-122) 43]
23 | -- >>> try' $ run' h $ table "places" # insert ["location" := point (-91) 44, "area" := polygon [[-124,30],[-113,54],[-80,44]]]
24 | -- >>> try' $ run' h $ table "places" # ex indexCreate ["geo":=True] "location" (!"location")
25 | -- >>> try' $ run' h $ table "places" # ex indexCreate ["geo":=True] "geo" (!"area")
26 |
27 | -- | Convert a line object into a polygon
28 | --
29 | -- >>> run' h $ fill $ line [[-122,37], [-120,39], [-121,38]]
30 | -- Polygon<[[-122,37],[-120,39],[-121,38],[-122,37]]>
31 |
32 | fill :: Expr line => line -> ReQL
33 | fill l = op FILL [l]
34 |
35 | -- | Convert a GeoJSON object into a RethinkDB geometry object
36 | --
37 | -- >>> run' h $ geoJSON ["type" := "Point", "coordinates" := [-45,80]]
38 | -- Point<-45,80>
39 |
40 | geoJSON :: Expr geojson => geojson -> ReQL
41 | geoJSON g = op GEOJSON [g]
42 |
43 | -- | Convert a RethinkDB geometry object into a GeoJSON object
44 | --
45 | -- >>> run' h $ toGeoJSON $ point (-122.423246) 37.779388
46 | -- {"coordinates":[-122.423246,37.779388],"type":"Point"}
47 | toGeoJSON :: Expr geo => geo -> ReQL
48 | toGeoJSON g = op TO_GEOJSON [g]
49 |
50 | -- | Search a geospatial index for intersecting objects
51 | --
52 | -- >>> run' h $ table "places" # getIntersecting (point (-122) 37) (Index "geo")
53 | -- []
54 | getIntersecting :: (Expr geo, Expr table) => geo -> Index -> table -> ReQL
55 | getIntersecting g i t = op' GET_INTERSECTING (t, g) $ idx
56 | where idx = case i of
57 | PrimaryKey -> []
58 | Index n -> ["index" := n]
59 |
60 | -- | Query a geospatial index for the nearest matches
61 | --
62 | -- >>> run' h $ table "places" # getNearest (point (-122) 37) (Index "location")
63 | -- []
64 | -- >>> run' h $ table "places" # ex getNearest [maxResults 5, maxDist 10, unit Kilometer] (point (-122) 37) (Index "location")
65 | -- []
66 | getNearest :: (Expr point, Expr table) => point -> Index -> table -> ReQL
67 | getNearest p i t = op' GET_NEAREST (t, p) idx
68 | where idx = case i of
69 | PrimaryKey -> []
70 | Index n -> ["index" := n]
71 |
72 | -- | Test whether a geometry object includes another
73 | --
74 | -- >>> run' h $ circle (point (-122) 37) 5000 # includes (point (-120) 48)
75 | -- false
76 | includes :: (Expr area, Expr geo) => geo -> area -> ReQL
77 | includes g a = op INCLUDES (a, g)
78 |
79 | -- | Test if two geometry objects intersects
80 | --
81 | -- >>> run' h $ intersects (line [[-122,37],[-120,48]]) (line [[-120,49],[-122,48]])
82 | -- false
83 | intersects :: (Expr a, Expr b) => a -> b -> ReQL
84 | intersects a b = op INTERSECTS (b, a)
85 |
86 | -- | Create a line object
87 | --
88 | -- >>> run' h $ line [[-73,45],[-122,37]]
89 | -- Line<[-73,45],[-122,37]>
90 | line :: Expr points => points -> ReQL
91 | line p = op LINE [op ARGS [p]]
92 |
93 | -- | Create a point objects
94 | --
95 | -- >>> run' h $ point (-73) 40
96 | -- Point<-73,40>
97 | point :: (Expr longitude, Expr latitude) => longitude -> latitude -> ReQL
98 | point lon lat = op POINT (lon, lat)
99 |
100 | -- | Create a polygon object
101 | --
102 | -- >>> run' h $ polygon [[-73,45],[-122,37],[-73,40]]
103 | -- Polygon<[[-73,45],[-122,37],[-73,40],[-73,45]]>
104 | polygon :: Expr points => points -> ReQL
105 | polygon p = op POLYGON [op ARGS [p]]
106 |
107 | -- | Punch a hole in a polygon
108 | --
109 | -- >>> run' h $ (polygon [[-73,45],[-122,37],[-73,40]]) # polygonSub (polygon [[-73.2,40.1],[-73.2,40.2],[-73.3,40.1]])
110 | -- Polygon<[[-73,45],[-122,37],[-73,40],[-73,45]],[[-73.2,40.1],[-73.2,40.2],[-73.3,40.1],[-73.2,40.1]]>
111 | polygonSub :: (Expr polygon, Expr hole) => hole -> polygon -> ReQL
112 | polygonSub h p = op POLYGON_SUB (p, h)
113 |
114 | -- | Create a polygon approximating a circle
115 | --
116 | -- >>> run' h $ ex circle [numVertices 6, unit Kilometer] (point (-73) 40) 100
117 | -- Polygon<[[-73,39.099310036015424],[-74.00751390838496,39.54527799206398],[-74.02083610406069,40.445812561599965],[-73,40.900549591978255],[-71.97916389593931,40.445812561599965],[-71.99248609161504,39.54527799206398],[-73,39.099310036015424]]>
118 | circle :: (Expr point, Expr radius) => point -> radius -> ReQL
119 | circle p r = op CIRCLE (p, r)
120 |
121 | -- | Distance between a point and another geometry object
122 | --
123 | -- > run' h $ distance (point (-73) 40) (point (-122) 37)
124 | -- 4233453.467303546
125 | -- > run' h $ ex distance [unit Mile] (point (-73) 40) (point (-122) 37)
126 | -- 2630.5460282596796
127 | distance :: (Expr a, Expr b) => a -> b -> ReQL
128 | distance a b = op DISTANCE (a,b)
129 |
130 | -- | Optional argument for getNearest
131 | maxResults :: ReQL -> Attribute a
132 | maxResults n = "max_results" := n
133 |
134 | -- | Optional argument for getNearest
135 | maxDist :: ReQL -> Attribute a
136 | maxDist d = "max_dist" := d
137 |
138 | -- | Optional argument for getNearest, circle and distance
139 | unit :: Unit -> Attribute a
140 | unit u = "unit" := u
141 |
142 | -- | Optional argument for circle
143 | numVertices :: ReQL -> Attribute a
144 | numVertices n = "num_vertices" := n
145 |
146 | data Unit = Meter | Kilometer | Mile | NauticalMile | Foot
147 |
148 | instance Expr Unit where
149 | expr Meter = "m"
150 | expr Kilometer = "km"
151 | expr Mile = "mi"
152 | expr NauticalMile = "nm"
153 | expr Foot = "ft"
154 |
--------------------------------------------------------------------------------
/Database/RethinkDB/JSON.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.JSON where
2 |
--------------------------------------------------------------------------------
/Database/RethinkDB/MapReduce.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings, PatternGuards #-}
2 |
3 | module Database.RethinkDB.MapReduce where -- (termToMapReduce) where
4 |
5 | import Control.Monad.State
6 | import Control.Monad.Writer
7 | import qualified Data.Text as T
8 | import Data.Maybe
9 | import Data.Foldable (toList)
10 |
11 | import Database.RethinkDB.Wire.Term
12 | import Database.RethinkDB.ReQL
13 | import Database.RethinkDB.Types
14 |
15 | import qualified Database.RethinkDB.Functions as R
16 | import Database.RethinkDB.NoClash hiding (get, collect, args)
17 | import Database.RethinkDB.Datum
18 |
19 | -- | Takes a function that takes a sequence as an argument, and
20 | -- returns a function that only uses that sequence once, by merging
21 | -- the map and reduce operations. This is used by groupBy.
22 | termToMapReduce :: (ReQL -> ReQL) -> State QuerySettings (ReQL -> ReQL)
23 | termToMapReduce f = do
24 |
25 | -- A variable is introduced to represent the sequence that f
26 | -- is being performed on. This variable is no longer present
27 | -- in the return value
28 | v <- newVarId
29 | body <- runReQL $ f (op VAR [v])
30 |
31 | return . applyChain $ toMapReduce v body
32 |
33 | -- | Compares the two representations of a variable
34 | sameVar :: Int -> [Term] -> Bool
35 | sameVar x [Datum d] | Success y <- fromDatum d = x == y
36 | sameVar _ _ = False
37 |
38 | -- | notNone checks that it is a map/reduce and not a constant
39 | notConst :: Chain -> Bool
40 | notConst None{} = False
41 | notConst SingletonArray{} = False
42 | notConst _ = True
43 |
44 | -- | Helper function for casting up from Term into ReQL
45 | wrap :: Term -> ReQL
46 | wrap = ReQL . return
47 |
48 | -- | Build a single argument function from a constant ReQL expression
49 | toFun1 :: Term -> (ReQL -> ReQL)
50 | toFun1 f a = op FUNCALL (wrap f, a)
51 |
52 | -- | Build a two argument function from a constant ReQL expression
53 | toFun2 :: Term -> (ReQL -> ReQL -> ReQL)
54 | toFun2 f a b = op FUNCALL (wrap f, a, b)
55 |
56 | -- | Represents a map/reduce operation split into its map and reduce parts
57 | data MRF = MRF {
58 | _mrfMapFun :: MapFun,
59 | _mrfReduceFun :: ReQL -> ReQL -> ReQL,
60 | _mrfBase :: Maybe ReQL,
61 | _mrfFinally :: ReQL -> ReQL }
62 |
63 | -- | A Chain of ReQL expressions that might be transformed into
64 | -- a map/reduce operation
65 | data Chain =
66 |
67 | -- | A constant, not really a map/reduce operation
68 | None ReQL |
69 |
70 | -- | Just a map
71 | Map [Map] |
72 |
73 | -- | map/reduce operations represented as parts
74 | MapReduceChain [Map] Reduce |
75 |
76 | -- | A rewritten map/reduce
77 | MapReduce MRF |
78 |
79 | -- | Special cases for reduce with base
80 | SingletonArray ReQL |
81 | AddBase ReQL Chain
82 |
83 | -- | A built-in map operation
84 | data Map =
85 | BuiltInMap TermType [ReQL] [OptArg] MapFun
86 |
87 | data MapFun =
88 | MapFun (ReQL -> ReQL) |
89 | ConcatMapFun (ReQL -> ReQL)
90 |
91 | data Reduce =
92 | BuiltInReduce TermType [ReQL] [OptArg] MRF
93 |
94 | -- | Convert a Chain back into a ReQL function
95 | applyChain :: Chain -> (ReQL -> ReQL)
96 | applyChain (None t) x = op FUNCALL (t, x)
97 | applyChain (Map maps) s = applyMaps maps s
98 | applyChain (MapReduceChain maps red) s =
99 | applyReduce red $ applyMaps maps s
100 | applyChain (MapReduce mrf) s = applyMRF mrf s
101 | applyChain (SingletonArray x) s = op FUNCALL (op MAKE_ARRAY [x], s)
102 | applyChain (AddBase b c) s = applyChain c s `union` [b]
103 |
104 | -- | Convert an MRF into a ReQL function
105 | applyMRF :: MRF -> ReQL -> ReQL
106 | applyMRF (MRF m r Nothing f) s = f `apply` [reduce r (applyMapFun m s)]
107 | applyMRF (MRF m r (Just base) f) s =
108 | f $
109 | apply (\x -> branch (isEmpty x) base (x R.! 0)) . return $
110 | reduce (\a b -> [a R.! 0 `r` b R.! 0]) $
111 | R.map (\x -> [x]) $
112 | applyMapFun m s
113 |
114 | applyMaps :: [Map] -> ReQL -> ReQL
115 | applyMaps maps s = foldr applyMap s maps
116 |
117 | applyMap :: Map -> ReQL -> ReQL
118 | applyMap (BuiltInMap tt a oa _) s = op' tt (s : a) oa
119 |
120 | applyMapFun :: MapFun -> ReQL -> ReQL
121 | applyMapFun (MapFun f) = R.map f
122 | applyMapFun (ConcatMapFun f) = R.concatMap f
123 |
124 |
125 | applyReduce :: Reduce -> ReQL -> ReQL
126 | applyReduce (BuiltInReduce tt a oa _) s = op' tt (s : a) oa
127 |
128 | chainToMRF :: Chain -> Either ReQL MRF
129 | chainToMRF (None t) = Left t
130 | chainToMRF (Map maps) = Right $ maps `thenMRF` collect
131 | chainToMRF (MapReduceChain maps red) = Right $ maps `thenReduce` red
132 | chainToMRF (MapReduce mrf) = Right $ mrf
133 | chainToMRF (SingletonArray x) = Left $ op MAKE_ARRAY [x]
134 | chainToMRF (AddBase b c) = fmap (`thenFinally` \x -> op UNION [b, x]) $ chainToMRF c
135 |
136 | thenFinally :: MRF -> (ReQL -> ReQL) -> MRF
137 | thenFinally (MRF m r b f1) f2 = MRF m r b $ f2 . f1
138 |
139 | thenMRF :: [Map] -> MRF -> MRF
140 | thenMRF maps (MRF m r b f) =
141 | MRF (m `composeMapFun` composeMaps maps) r b f
142 |
143 | composeMaps :: [Map] -> MapFun
144 | composeMaps = foldr composeMapFun (MapFun id) . map getMapFun
145 | where getMapFun (BuiltInMap _ _ _ mf) = mf
146 |
147 | composeMapFun :: MapFun -> MapFun -> MapFun
148 | composeMapFun (MapFun f) (MapFun g) = MapFun (f . g)
149 | composeMapFun (ConcatMapFun f) (MapFun g) = ConcatMapFun (f . g)
150 | composeMapFun (MapFun f) (ConcatMapFun g) = ConcatMapFun (R.map f . g)
151 | composeMapFun (ConcatMapFun f) (ConcatMapFun g) = ConcatMapFun (R.concatMap f . g)
152 |
153 | thenReduce :: [Map] -> Reduce -> MRF
154 | thenReduce maps (BuiltInReduce _ _ _ mrf) = maps `thenMRF` mrf
155 |
156 | collect :: MRF
157 | collect = MRF (MapFun $ \x -> expr [x]) union (Just (expr ())) id
158 |
159 | -- | Rewrites the term in the second argument to merge all uses of the
160 | -- variable whose id is given in the first argument.
161 | toMapReduce :: Int -> Term -> Chain
162 |
163 | toMapReduce v (Note _ t) = toMapReduce v t -- TODO: keep notes
164 |
165 | -- Singletons are singled out
166 | toMapReduce _ (Datum (Array a))
167 | | [datum] <- toList a =
168 | SingletonArray . wrap $ Datum datum
169 |
170 | -- A datum stays constant
171 | toMapReduce _ t@(Datum _) = None $ wrap t
172 |
173 | -- The presence of the variable
174 | toMapReduce v (Term VAR w _) | sameVar v w = Map []
175 |
176 | -- An arbitrary term
177 | toMapReduce v t@(Term type' args optargs) = let
178 |
179 | -- Recursively convert all arguments
180 | args' = map (toMapReduce v) args
181 | optargs' = map (\(TermAttribute k vv) -> (k, toMapReduce v vv)) optargs
182 |
183 | -- Count how many of the arguments have been rewritten
184 | nb = length $ filter notConst $ args' ++ map snd optargs'
185 |
186 | -- Rewrite the current term. rewrite1 is optimised for
187 | -- the single count case
188 | rewrite = MapReduce $
189 | (if nb == 1 then rewrite1 else rewritex) type' args' optargs'
190 |
191 | in case nb of
192 | -- Special case for singleton arrays
193 | 0 | Just sing <- singleton type' args' optargs -> SingletonArray sing
194 |
195 | -- Special case for snoc
196 | 1 | UNION <- type', [x, SingletonArray s] <- args', [] <- optargs'
197 | -> AddBase s x
198 |
199 | -- Don't rewrite if there is nothing to rewrite
200 | 0 -> None $ wrap t
201 |
202 | -- Don't rewrite an operation that can be chained
203 | 1 | (arg1 : _) <- args', notConst arg1 ->
204 | fromMaybe rewrite $ mrChain type' arg1 (tail args) optargs
205 |
206 | -- Default to rewriting the term
207 | _ -> rewrite
208 |
209 | singleton :: TermType -> [Chain] -> [TermAttribute] -> Maybe ReQL
210 | singleton MAKE_ARRAY [None el] [] = Just el
211 | singleton _ _ _ = Nothing
212 |
213 | -- | Chain a ReQL command onto a MapReduce operation
214 | mrChain :: TermType -> Chain -> [Term] -> [TermAttribute] -> Maybe Chain
215 |
216 | mrChain REDUCE (AddBase base (Map maps)) [f] [] =
217 | Just $
218 | MapReduceChain maps $
219 | BuiltInReduce REDUCE [wrap f] [] $
220 | MRF (MapFun id) (toFun2 f) (Just base) id
221 |
222 | -- | A built-in map
223 | mrChain tt (Map maps) args optargs
224 | | Just mrf <- mapMRF tt args optargs =
225 | Just . Map . (: maps) $
226 | BuiltInMap tt (map wrap args) (map baseAttrToOptArg optargs) mrf
227 |
228 | -- | A built-in reduction
229 | mrChain tt (Map maps) args optargs
230 | | Just mrf <- reduceMRF tt args optargs =
231 | Just . MapReduceChain maps $
232 | BuiltInReduce tt (map wrap args) (map baseAttrToOptArg optargs) mrf
233 |
234 | mrChain _ _ _ _ = Nothing
235 |
236 | -- | Convert some builtin operations into a map
237 | mapMRF :: TermType -> [Term] -> [TermAttribute]
238 | -> Maybe MapFun
239 | mapMRF MAP [f] [] = Just . MapFun $ toFun1 f
240 | mapMRF PLUCK ks [] =
241 | Just . MapFun $ \s -> op' PLUCK (s : map wrap ks) [noRecurse]
242 | mapMRF WITHOUT ks [] =
243 | Just . MapFun $ \s -> op' WITHOUT (s : map wrap ks) [noRecurse]
244 | mapMRF MERGE [b] [] =
245 | Just . MapFun $ \s -> op' MERGE [s, wrap b] [noRecurse]
246 | mapMRF CONCAT_MAP [f] [] = Just . ConcatMapFun $ toFun1 f
247 | mapMRF FILTER [f] [] =
248 | Just . ConcatMapFun $ \x -> branch (toFun1 f x # handle (const False)) x ()
249 | mapMRF FILTER [f] [TermAttribute "default" defval] =
250 | Just . ConcatMapFun $ \x -> branch (toFun1 f x # handle (const defval)) x ()
251 | mapMRF GET_FIELD [attr] [] =
252 | Just . ConcatMapFun $ \x ->
253 | branch (op' HAS_FIELDS (x, wrap attr) [noRecurse])
254 | [op' GET_FIELD (x, attr) [noRecurse]] ()
255 | mapMRF HAS_FIELDS sel [] =
256 | Just . ConcatMapFun $ \x ->
257 | branch (op' HAS_FIELDS (x : map wrap sel) [noRecurse]) [x] ()
258 | mapMRF WITH_FIELDS sel [] =
259 | Just . ConcatMapFun $ \x ->
260 | branch (op' HAS_FIELDS (x : map wrap sel) [noRecurse])
261 | [op' PLUCK (x : map wrap sel) [noRecurse]] ()
262 | mapMRF BRACKET [k] [] =
263 | Just . MapFun $ \s -> op' BRACKET (s, k) [noRecurse]
264 | mapMRF _ _ _ = Nothing
265 |
266 | -- | Convert some of the built-in operations into a map/reduce
267 | --
268 | -- TODO: these have not been tested
269 | reduceMRF :: TermType -> [Term] -> [TermAttribute]
270 | -> Maybe MRF
271 | reduceMRF REDUCE [f] [] = Just $ MRF (MapFun id) (toFun2 f) Nothing id
272 | reduceMRF COUNT [] [] = Just $ MRF (MapFun $ const (num 1)) (\a b -> op ADD (a, b)) (Just 0) id
273 | reduceMRF AVG [] [] =
274 | Just $ MRF (MapFun $ \x -> expr [x, 1])
275 | (\a b -> expr [a R.! 0 R.+ b R.! 0, a R.! 1 R.+ b R.! 1])
276 | Nothing
277 | (\x -> x R.! 0 R./ x R.! 1)
278 | reduceMRF SUM [] [] = Just $ MRF (MapFun id) (R.+) (Just 0) id
279 | reduceMRF SUM [sel] [] = Just $ MRF (MapFun $ toFun1 sel) (R.+) (Just 0) id
280 | reduceMRF MIN [] [] = Just $ MRF (MapFun id) (\a b -> branch (a R.< b) a b) Nothing id
281 | reduceMRF MIN [sel] [] =
282 | Just $ MRF (MapFun $ \x -> expr [x, toFun1 sel x])
283 | (\a b -> branch (a R.! 1 R.< b R.! 1) a b)
284 | Nothing
285 | (R.! 0)
286 | reduceMRF MAX [] [] = Just $ MRF (MapFun id) (\a b -> branch (a R.> b) a b) Nothing id
287 | reduceMRF MAX [sel] [] =
288 | Just $ MRF (MapFun $ \x -> expr [x, toFun1 sel x])
289 | (\a b -> branch (a R.! 1 R.> b R.! 1) a b)
290 | Nothing
291 | (R.! 0)
292 | reduceMRF DISTINCT [] [] = Just $ MRF (MapFun $ \a -> expr [a]) (\a b -> distinct (a `union` b)) (Just (expr ())) id
293 | reduceMRF _ _ _ = Nothing
294 |
295 | -- | Convert from one representation to the other
296 | baseAttrToOptArg :: TermAttribute -> OptArg
297 | baseAttrToOptArg (TermAttribute k v) = k := v
298 |
299 | -- | This undocumented optional argument circumvents stream
300 | -- polymorphism on some operations
301 | noRecurse :: OptArg
302 | noRecurse = "_NO_RECURSE_" := True
303 |
304 | -- | Rewrite a command into a map/reduce.
305 | --
306 | -- This is a special case for when only one of the arguments
307 | -- is itself a map/reduce
308 | rewrite1 :: TermType -> [Chain] -> [(T.Text, Chain)] -> MRF
309 | rewrite1 ttype args optargs = MRF maps red mbase finals where
310 | (finally2, [mr]) = extract Nothing ttype args optargs
311 | MRF maps red mbase fin1 = mr
312 | finals = finally2 . return . fin1
313 |
314 | -- | Rewrite a command that combines the result of multiple map/reduce
315 | -- operations into a single map/reduce operation
316 | rewritex :: TermType -> [Chain] -> [(Key, Chain)] -> MRF
317 | rewritex ttype args optargs = MRF maps reduces Nothing finallys where
318 | (finally, mrs) = extract (Just 0) ttype args optargs
319 | index = zip $ map expr ([0..] :: [Int])
320 | maps = MapFun $ \x -> expr $ map (($ x) . getMapFun) mrs
321 | reduces a b = expr $ map (uncurry $ mkReduce a b) . index $ map getReduceFun mrs
322 | finallys = let fs = map getFinallyFun mrs in
323 | \x -> finally . map (uncurry $ mkFinally x) $ index fs
324 | mkReduce a b i f = f (a!i) (b!i)
325 | mkFinally x i f = f (x!i)
326 | getMapFun (MRF (MapFun f) _ _ _) = f
327 | getMapFun (MRF (ConcatMapFun f) _ _ _) = f
328 | getReduceFun (MRF (MapFun _) f _ _) = f
329 | getReduceFun (MRF (ConcatMapFun _) f _ _) =
330 | \a b -> flip apply [a `union` b] $ \l ->
331 | branch (isEmpty l) () [reduce f l]
332 | getFinallyFun (MRF (MapFun _) _ _ f) = f
333 | getFinallyFun (MRF (ConcatMapFun _) _ mbase f) =
334 | f . maybe (R.! 0) (\base s ->
335 | flip apply [s] $ handle (const base) $ s R.! 0) mbase
336 |
337 | -- | Extract the inner map/reduce objects, also returning a function
338 | -- which, given the result of all the map/reduce operations, returns
339 | -- the result of the given command
340 | extract ::
341 | Maybe Int -> TermType -> [Chain] -> [(Key, Chain)]
342 | -> ([ReQL] -> ReQL, [MRF])
343 | extract st tt args optargs = fst $ flip runState st $ runWriterT $ do
344 | args' <- sequence $ map extractOne args
345 | optargvs' <- sequence $ map extractOne (map snd optargs)
346 | let optargks = map fst optargs
347 | return $ \v -> op' tt (map ($ v) args') (Prelude.zipWith (:=) optargks $ map ($ v) optargvs')
348 | where
349 | extractOne chain = either (return . const) go $ chainToMRF chain
350 |
351 | go :: MRF -> WriterT [MRF] (State (Maybe Int)) ([ReQL] -> ReQL)
352 | go mrf = do
353 | tell [mrf]
354 | st' <- get
355 | case st' of
356 | Nothing -> return head
357 | Just n -> do
358 | put $ Just $ n + 1
359 | return $ \v -> v !! n
--------------------------------------------------------------------------------
/Database/RethinkDB/MapReduce.hs-boot:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.MapReduce (termToMapReduce) where
2 | import Control.Monad.State
3 | import Database.RethinkDB.ReQL
4 | termToMapReduce :: (ReQL -> ReQL) -> State QuerySettings (ReQL -> ReQL)
--------------------------------------------------------------------------------
/Database/RethinkDB/Network.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE RecordWildCards, OverloadedStrings, DeriveDataTypeable, NamedFieldPuns, PatternGuards #-}
2 |
3 | -- TODO: the code sends an extra query after getting SUCCESS_ATOM when doing e.g. (expr 1)
4 |
5 | module Database.RethinkDB.Network (
6 | RethinkDBHandle(..),
7 | connect,
8 | close,
9 | use,
10 | runQLQuery,
11 | Cursor(..),
12 | makeCursor,
13 | next,
14 | nextBatch,
15 | collect,
16 | collect',
17 | nextResponse,
18 | Response(..),
19 | ErrorCode(..),
20 | RethinkDBError(..),
21 | RethinkDBConnectionError(..),
22 | More,
23 | noReplyWait,
24 | each,
25 | serverInfo
26 | ) where
27 |
28 | import Control.Monad (when, forever, forM_)
29 | import Data.Typeable (Typeable)
30 | import Network (HostName)
31 | import Network.Socket (
32 | socket, Family(AF_INET, AF_INET6), SocketType(Stream), setSocketOption,
33 | SocketOption(NoDelay, KeepAlive), Socket, AddrInfo(AddrInfo, addrAddress, addrFamily))
34 | import qualified Network.Socket as Socket
35 | import Network.BSD (getProtocolNumber)
36 | import Network.Socket.ByteString.Lazy (sendAll)
37 | import Network.Socket.ByteString (recv)
38 | import Data.ByteString.Lazy (ByteString)
39 | import qualified Data.ByteString.Lazy as B
40 | import qualified Data.ByteString.UTF8 as BS (fromString)
41 | import qualified Data.ByteString as BS
42 | import Control.Concurrent (
43 | writeChan, MVar, Chan, modifyMVar, takeMVar, forkIO, readChan,
44 | myThreadId, newMVar, ThreadId, newChan, killThread,
45 | newEmptyMVar, putMVar, mkWeakMVar)
46 | import Control.Exception (catch, Exception, throwIO, SomeException(..), bracketOnError)
47 | import Data.IORef (IORef, newIORef, atomicModifyIORef', readIORef, writeIORef)
48 | import Data.Map (Map)
49 | import qualified Data.Map as M
50 | import Data.Maybe (fromMaybe, listToMaybe, isNothing)
51 | import Control.Monad.Fix (fix)
52 | import System.IO.Unsafe (unsafeInterleaveIO)
53 | import System.Mem.Weak (finalize)
54 | import Data.Binary.Get (runGet, getWord32le, getWord64le)
55 | import Data.Binary.Put (runPut, putWord32le, putWord64le, putLazyByteString)
56 | import Data.Word (Word64, Word32)
57 | import qualified Data.HashMap.Strict as HM
58 |
59 | import Database.RethinkDB.Wire
60 | import Database.RethinkDB.Wire.Response as Response
61 | import Database.RethinkDB.Wire.Query as Query
62 | import Database.RethinkDB.Wire.VersionDummy as Protocol
63 | import Database.RethinkDB.Types
64 | import Database.RethinkDB.Datum
65 | import Database.RethinkDB.ReQL (
66 | Term, Backtrace, convertBacktrace, WireQuery(..),
67 | WireBacktrace(..), Term(..), Frame(..),
68 | TermAttribute(..))
69 | import Data.Foldable (toList)
70 |
71 | -- $setup
72 | --
73 | -- Get the doctests ready
74 | --
75 | -- >>> import qualified Database.RethinkDB as R
76 | -- >>> import Database.RethinkDB.NoClash
77 | -- >>> h' <- unsafeInterleaveIO $ connect "localhost" 28015 def
78 | -- >>> let h = use "doctests" h'
79 |
80 | type Token = Word64
81 |
82 | -- | A connection to the database server
83 | data RethinkDBHandle = RethinkDBHandle {
84 | rdbSocket :: Socket,
85 | rdbWriteLock :: MVar (Maybe SomeException),
86 | rdbToken :: IORef Token, -- ^ The next token to use
87 | rdbDatabase :: Database, -- ^ The default database
88 | rdbWait :: IORef (Map Token (Chan Response, Term, IO ())),
89 | rdbThread :: ThreadId
90 | }
91 |
92 | data Cursor a = Cursor {
93 | cursorMBox :: MVar Response,
94 | cursorBuffer :: MVar (Either RethinkDBError ([Datum], Bool)),
95 | cursorMap :: Datum -> IO a }
96 |
97 | instance Functor Cursor where
98 | fmap f Cursor{ .. } = Cursor { cursorMap = fmap f . cursorMap, .. }
99 |
100 | instance Show RethinkDBHandle where
101 | show RethinkDBHandle{ rdbSocket } = "RethinkDB Connection " ++ show rdbSocket
102 |
103 | newToken :: RethinkDBHandle -> IO Token
104 | newToken RethinkDBHandle{rdbToken} =
105 | atomicModifyIORef' rdbToken $ \x -> (x+1, x)
106 |
107 | data RethinkDBConnectionError =
108 | RethinkDBConnectionError String
109 | deriving (Show, Typeable)
110 | instance Exception RethinkDBConnectionError
111 |
112 | getAddrFamily :: AddrInfo -> Family
113 | getAddrFamily addrInfo = case addrInfo of
114 | AddrInfo { addrFamily = AF_INET6 } -> AF_INET6
115 | _ -> AF_INET
116 |
117 | connectTo :: HostName -> Integer -> IO Socket
118 | connectTo host port = do
119 | h <- Socket.getAddrInfo Nothing (Just host) (Just $ show port)
120 | let addrI = head h
121 | let addrF = getAddrFamily addrI
122 | proto <- getProtocolNumber "tcp"
123 | bracketOnError (socket addrF Stream proto) Socket.close $ \sock -> do
124 | Socket.connect sock (addrAddress addrI)
125 | setSocketOption sock NoDelay 1
126 | setSocketOption sock KeepAlive 1
127 | return sock
128 |
129 | -- | Create a new connection to the database server
130 | --
131 | -- /Example:/ connect using the default port with no passphrase (/note:/ IPv4 and IPv6 supported)
132 | --
133 | -- >>> h <- connect "localhost" 28015 Nothing
134 | --
135 | -- > >>> h <- connect "::1" 28015 Nothing
136 |
137 | connect :: HostName -> Integer -> Maybe String -> IO RethinkDBHandle
138 | connect host port mauth = do
139 | let auth = B.fromChunks . return . BS.fromString $ fromMaybe "" mauth
140 | s <- connectTo host port
141 | sendAll s $ runPut $ do
142 | putWord32le magicNumber
143 | putWord32le (fromIntegral $ B.length auth)
144 | putLazyByteString auth
145 | putWord32le $ fromIntegral $ toWire Protocol.JSON
146 | res <- sGetNullTerminatedString s
147 | when (res /= "SUCCESS") $ throwIO (RethinkDBConnectionError $ show res)
148 | r <- newIORef 1
149 | let db' = Database "test"
150 | wlock <- newMVar Nothing
151 | waits <- newIORef M.empty
152 | let rdb = RethinkDBHandle s wlock r db' waits
153 | tid <- forkIO $ readResponses rdb
154 | return $ rdb tid
155 |
156 | recvAll :: Socket -> Int -> IO ByteString
157 | recvAll s n_ = go [] n_ where
158 | go acc 0 = return $ B.fromChunks $ reverse acc
159 | go acc n = do
160 | d <- recv s n
161 | if BS.null d
162 | then throwIO $ RethinkDBConnectionError "Connection closed unexpectedly"
163 | else go (d : acc) (n - BS.length d)
164 |
165 | sGetNullTerminatedString :: Socket -> IO ByteString
166 | sGetNullTerminatedString s = go [] where
167 | go acc = do
168 | c <- recv s 1
169 | if BS.null c || c == BS.pack [0]
170 | then return (B.fromChunks (reverse acc))
171 | else go (c : acc)
172 |
173 | magicNumber :: Word32
174 | magicNumber = fromIntegral $ toWire V0_4
175 |
176 | withSocket :: RethinkDBHandle -> (Socket -> IO a) -> IO a
177 | withSocket RethinkDBHandle{ rdbSocket, rdbWriteLock } f =
178 | modifyMVar rdbWriteLock $ \mex ->
179 | case mex of
180 | Nothing -> do
181 | a <- f rdbSocket
182 | return (Nothing, a)
183 | Just ex -> throwIO ex
184 |
185 | data RethinkDBError = RethinkDBError {
186 | errorCode :: ErrorCode,
187 | errorTerm :: Term,
188 | errorMessage :: String,
189 | errorBacktrace :: Backtrace
190 | } deriving (Typeable)
191 |
192 | instance Exception RethinkDBError
193 |
194 | instance Show RethinkDBError where
195 | show (RethinkDBError code term message backtrace) =
196 | show code ++ ": " ++ message ++
197 | if term == Datum Null
198 | then ""
199 | else "\n" ++ indent ("in " ++ show (annotate backtrace term))
200 | where
201 | indent = (\x -> case x of [] -> []; _ -> init x) . unlines . map (" "++) . lines
202 | annotate :: Backtrace -> Term -> Term
203 | annotate (x : xs) t | Just new <- inside x t (annotate xs) = new
204 | annotate _ t = Note "HERE" t
205 | inside (FramePos n) (Term tt a oa) f
206 | | n < length a = Just $ Term tt (take n a ++ [f (a!!n)] ++ drop (n+1) a) oa
207 | inside (FrameOpt k) (Term tt a oa) f
208 | | Just (before, v, after) <- extract k oa =
209 | Just $ Term tt a $ before ++ [TermAttribute k (f v)] ++ after
210 | inside _ _ _ = Nothing
211 | extract _ [] = Nothing
212 | extract k (TermAttribute kk v : xs) | k == kk = Just ([], v, xs)
213 | extract k (x:xs) =
214 | case extract k xs of
215 | Nothing -> Nothing
216 | Just (a,b,c) -> Just (x:a,b,c)
217 |
218 | -- | The response to a query
219 | data Response =
220 | ResponseError RethinkDBError |
221 | ResponseSingle Datum |
222 | ResponseBatch (Maybe More) [Datum]
223 |
224 | data More = More {
225 | _moreFeed :: Bool,
226 | _moreHandle :: RethinkDBHandle,
227 | _moreToken :: Token
228 | }
229 |
230 | data ErrorCode =
231 | ErrorBrokenClient |
232 | ErrorBadQuery |
233 | ErrorRuntime |
234 | ErrorUnexpectedResponse
235 |
236 | instance Show ErrorCode where
237 | show ErrorBrokenClient = "RethinkDB: Broken client error"
238 | show ErrorBadQuery = "RethinkDB: Malformed query error"
239 | show ErrorRuntime = "RethinkDB: Runtime error"
240 | show ErrorUnexpectedResponse = "RethinkDB: Unexpected response"
241 |
242 | instance Show Response where
243 | show (ResponseError RethinkDBError {..}) =
244 | show errorCode ++ ": " ++
245 | show errorMessage ++ " (" ++
246 | show errorBacktrace ++ ")"
247 | show (ResponseSingle datum) = show datum
248 | show (ResponseBatch _more batch) = show batch
249 |
250 | newtype WireResponse = WireResponse { _responseDatum :: Datum }
251 |
252 | convertResponse :: RethinkDBHandle -> Term -> Token -> WireResponse -> Response
253 | convertResponse h q t (WireResponse (Object o)) = let
254 | type_ = o .? "t" >>= fromWire
255 | results :: Maybe [Datum]
256 | results = o .? "r"
257 | bt = o .? "b" --> maybe [] (convertBacktrace . WireBacktrace)
258 | -- _profile = o .? "p" -- TODO
259 | atom :: Maybe Datum
260 | atom = case results of Just [single] -> Just single; _ -> Nothing
261 | m .? k = HM.lookup k m >>= resultToMaybe . fromDatum
262 | (-->) = flip ($)
263 | e = fromMaybe "" $ resultToMaybe . fromDatum =<< listToMaybe =<< results
264 | _ ResponseSingle ResponseSingle ResponseBatch (Just $ More False h t) ResponseBatch Nothing ResponseError $ RethinkDBError ErrorBrokenClient q e bt
272 | Just COMPILE_ERROR -> ResponseError $ RethinkDBError ErrorBadQuery q e bt
273 | Just RUNTIME_ERROR -> ResponseError $ RethinkDBError ErrorRuntime q e bt
274 | Just WAIT_COMPLETE -> ResponseSingle (toDatum True)
275 | Nothing -> ResponseError $ RethinkDBError ErrorUnexpectedResponse q e bt
276 |
277 | convertResponse _ q _ (WireResponse json) =
278 | ResponseError $
279 | RethinkDBError ErrorUnexpectedResponse q ("Response is not a JSON object: " ++ show json) []
280 |
281 | runQLQuery :: RethinkDBHandle -> WireQuery -> Term -> IO (MVar Response)
282 | runQLQuery h query term = do
283 | tok <- newToken h
284 | let noReply = isNoReplyQuery query
285 | mbox <- if noReply
286 | then newEmptyMVar
287 | else addMBox h tok term
288 | sendQLQuery h tok query
289 | when noReply $ putMVar mbox $ ResponseSingle $ Null
290 | return mbox
291 |
292 | isNoReplyQuery :: WireQuery -> Bool
293 | isNoReplyQuery (WireQuery (Array v)) |
294 | [_type, _term, (Object optargs)] <- toList v,
295 | Just (Bool True) <- HM.lookup "noreply" optargs =
296 | True
297 | isNoReplyQuery _ = False
298 |
299 | addMBox :: RethinkDBHandle -> Token -> Term -> IO (MVar Response)
300 | addMBox h tok term = do
301 | chan <- newChan
302 | mbox <- newEmptyMVar
303 | weak <- mkWeakMVar mbox $ do
304 | closeToken h tok -- TODO: don't close if already closed
305 | atomicModifyIORef' (rdbWait h) $ \mboxes ->
306 | (M.delete tok mboxes, ())
307 | atomicModifyIORef' (rdbWait h) $ \mboxes ->
308 | (M.insert tok (chan, term, finalize weak) mboxes, ())
309 | _ <- forkIO $ fix $ \loop -> do
310 | response <- readChan chan
311 | putMVar mbox response
312 | when (not $ isLastResponse response) $ do
313 | nextResponse response
314 | loop
315 | return mbox
316 |
317 | sendQLQuery :: RethinkDBHandle -> Token -> WireQuery -> IO ()
318 | sendQLQuery h tok query = do
319 | let queryS = encode $ queryJSON query
320 | withSocket h $ \s -> do
321 | sendAll s $ runPut $ do
322 | putWord64le tok
323 | putWord32le (fromIntegral $ B.length queryS)
324 | putLazyByteString queryS
325 |
326 | data RethinkDBReadError =
327 | RethinkDBReadError SomeException
328 | deriving (Show, Typeable)
329 | instance Exception RethinkDBReadError
330 |
331 | readResponses :: (ThreadId -> RethinkDBHandle) -> IO ()
332 | readResponses h' = do
333 | tid <- myThreadId
334 | let h = h' tid
335 | let handler e@SomeException{} = do
336 | Socket.close $ rdbSocket h
337 | modifyMVar (rdbWriteLock h) $ \_ -> return (Just e, ())
338 | writeIORef (rdbWait h) M.empty
339 | flip catch handler $ forever $ readSingleResponse h
340 |
341 | readSingleResponse :: RethinkDBHandle -> IO ()
342 | readSingleResponse h = do
343 | tokenString <- recvAll (rdbSocket h) 8
344 | when (B.length tokenString /= 8) $
345 | throwIO $ RethinkDBConnectionError "RethinkDB connection closed unexpectedly"
346 | let token = runGet getWord64le tokenString
347 | header <- recvAll (rdbSocket h) 4
348 | when (B.length header /= 4) $
349 | throwIO $ RethinkDBConnectionError "RethinkDB connection closed unexpectedly"
350 | let replyLength = runGet getWord32le header
351 | rawResponse <- recvAll (rdbSocket h) (fromIntegral replyLength)
352 | let parsedResponse = eitherDecode rawResponse
353 | case parsedResponse of
354 | Left errMsg -> do
355 | -- TODO: don't give up on the connection, only share the error message with the MVar
356 | fail errMsg
357 | Right response -> dispatch token $ WireResponse response
358 |
359 | where
360 | dispatch tok response = do
361 | mboxes <- readIORef $ rdbWait h
362 | case M.lookup tok mboxes of
363 | Nothing -> return ()
364 | Just (mbox, term, closetok) -> do
365 | let convertedResponse = convertResponse h term tok response
366 | writeChan mbox convertedResponse
367 | when (isLastResponse convertedResponse) $ closetok
368 |
369 | isLastResponse :: Response -> Bool
370 | isLastResponse ResponseError{} = True
371 | isLastResponse ResponseSingle{} = True
372 | isLastResponse (ResponseBatch (Just _) _) = False
373 | isLastResponse (ResponseBatch Nothing _) = True
374 |
375 | -- | Set the default database
376 | --
377 | -- The new handle is an alias for the old one. Calling close on either one
378 | -- will close both.
379 | use :: Database -> RethinkDBHandle -> RethinkDBHandle
380 | use db' h = h { rdbDatabase = db' }
381 |
382 | -- | Close an open connection
383 | close :: RethinkDBHandle -> IO ()
384 | close h@RethinkDBHandle{ rdbSocket, rdbThread } = do
385 | noReplyWait h
386 | killThread rdbThread
387 | Socket.close rdbSocket
388 |
389 | closeToken :: RethinkDBHandle -> Token -> IO ()
390 | closeToken h tok = do
391 | let query = WireQuery $ toDatum [toWire STOP]
392 | sendQLQuery h tok query
393 |
394 | nextResponse :: Response -> IO ()
395 | nextResponse (ResponseBatch (Just (More _ h tok)) _) = do
396 | let query = WireQuery $ toDatum [toWire CONTINUE]
397 | sendQLQuery h tok query
398 | nextResponse _ = return ()
399 |
400 | makeCursor :: MVar Response -> IO (Cursor Datum)
401 | makeCursor cursorMBox = do
402 | cursorBuffer <- newMVar (Right ([], False))
403 | return Cursor{..}
404 | where cursorMap = return . id
405 |
406 | -- | Get the next value from a cursor
407 | next :: Cursor a -> IO (Maybe a)
408 | next c@Cursor{ .. } = modifyMVar cursorBuffer $ fix $ \loop mbuffer ->
409 | case mbuffer of
410 | Left err -> throwIO err
411 | Right ([], True) -> return (Right ([], True), Nothing)
412 | Right (x:xs, end) -> do x' <- cursorMap x; return $ (Right (xs, end), Just x')
413 | Right ([], False) -> cursorFetchBatch c >>= loop
414 |
415 | -- | Get the next batch from a cursor
416 | nextBatch :: Cursor a -> IO [a]
417 | nextBatch c@Cursor{ .. } = modifyMVar cursorBuffer $ fix $ \loop mbuffer ->
418 | case mbuffer of
419 | Left err -> throwIO err
420 | Right ([], True) -> return (Right ([], True), [])
421 | Right (xs@(_:_), end) -> do
422 | xs' <- mapM cursorMap xs
423 | return $ (Right ([], end), xs')
424 | Right ([], False) -> cursorFetchBatch c >>= loop
425 |
426 | cursorFetchBatch :: Cursor a -> IO (Either RethinkDBError ([Datum], Bool))
427 | cursorFetchBatch c = do
428 | response <- takeMVar (cursorMBox c)
429 | case response of
430 | ResponseError e -> return $ Left e
431 | ResponseBatch more datums -> return $ Right (datums, isNothing more)
432 | ResponseSingle (Array a) -> return $ Right (toList a, True)
433 | ResponseSingle _ ->
434 | return $ Left $ RethinkDBError ErrorUnexpectedResponse (Datum Null)
435 | "Expected a stream or an array but got a datum" []
436 |
437 | -- | A lazy stream of all the elements in the cursor
438 | collect :: Cursor a -> IO [a]
439 | collect c = fix $ \loop -> do
440 | b <- nextBatch c
441 | case b of
442 | [] -> return []
443 | xs -> do
444 | ys <- unsafeInterleaveIO $ loop
445 | return $ xs ++ ys
446 |
447 | -- | A strict version of collect
448 | collect' :: Cursor a -> IO [a]
449 | collect' c = fix $ \loop -> do
450 | b <- nextBatch c
451 | case b of
452 | [] -> return []
453 | xs -> do
454 | ys <- loop
455 | return $ xs ++ ys
456 |
457 | -- | Wait for NoReply queries to complete on the server
458 | --
459 | -- >>> () <- runOpts h [NoReply] $ table "users" # get "bob" # update (\row -> merge row ["occupation" := "teacher"])
460 | -- >>> noReplyWait h
461 | noReplyWait :: RethinkDBHandle -> IO ()
462 | noReplyWait h = do
463 | m <- runQLQuery h (WireQuery $ toDatum [toWire NOREPLY_WAIT]) (Datum Null)
464 | _ <- takeMVar m
465 | return ()
466 |
467 | each :: Cursor a -> (a -> IO b) -> IO ()
468 | each cursor f = do
469 | batch <- nextBatch cursor
470 | if null batch
471 | then return ()
472 | else do
473 | forM_ batch f
474 | each cursor f
475 |
476 | -- | Get information about the server
477 | serverInfo :: RethinkDBHandle -> IO Datum
478 | serverInfo h = do
479 | m <- runQLQuery h (WireQuery $ toDatum [toWire Query.SERVER_INFO]) (Datum Null)
480 | response <- takeMVar m
481 | case response of
482 | ResponseError e -> throwIO e
483 | ResponseBatch _ _ -> throwIO (RethinkDBError ErrorUnexpectedResponse (Datum Null) "" [])
484 | ResponseSingle d -> return d
485 |
--------------------------------------------------------------------------------
/Database/RethinkDB/NoClash.hs:
--------------------------------------------------------------------------------
1 | -- | This module exports all of Database.RethinkDB except for the
2 | -- names that clash with Prelude or Data.Time
3 |
4 | module Database.RethinkDB.NoClash (
5 | module Database.RethinkDB,
6 | -- module Prelude -- Uncomment to let GHC detect clashes
7 | ) where
8 |
9 | import Database.RethinkDB hiding (
10 | (*), (+), (-), (/),
11 | sum, map, mod, concatMap, (&&),
12 | not, (||), (/=), (<), (<=), (>), (>=), error, (==), filter,
13 | max, min,
14 | zip, zipWith,
15 | floor, ceil, round)
16 |
--------------------------------------------------------------------------------
/Database/RethinkDB/ReQL.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE ExistentialQuantification, RecordWildCards,
2 | ScopedTypeVariables, FlexibleInstances,
3 | OverloadedStrings, PatternGuards, GADTs,
4 | EmptyDataDecls, DefaultSignatures, CPP #-}
5 |
6 | #if __GLASGOW_HASKELL__ < 710
7 | {-# LANGUAGE OverlappingInstances #-}
8 | #define PRAGMA_OVERLAPPING
9 | #else
10 | #define PRAGMA_OVERLAPPING {-# OVERLAPPING #-}
11 | #endif
12 |
13 | -- | Building RQL queries in Haskell
14 | module Database.RethinkDB.ReQL (
15 | ReQL(..),
16 | op, op',
17 | Term(..),
18 | TermAttribute(..),
19 | buildQuery,
20 | Backtrace, convertBacktrace, Frame(..),
21 | Expr(..),
22 | QuerySettings(..),
23 | newVarId,
24 | str,
25 | num,
26 | Attribute(..),
27 | Static, Dynamic, OptArg,
28 | OptArgs(..),
29 | cons,
30 | baseArray,
31 | withQuerySettings,
32 | reqlToDatum,
33 | Bound(..),
34 | closedOrOpen,
35 | datumTerm,
36 | empty,
37 | WireQuery(..),
38 | WireBacktrace(..),
39 | note,
40 | (?:=),
41 | Arr(arr),
42 | minval,
43 | maxval
44 | ) where
45 |
46 | import qualified Data.Aeson as J
47 | #if MIN_VERSION_aeson(1,0,0)
48 | import qualified Data.Aeson.Text as J
49 | #else
50 | import qualified Data.Aeson.Encode as J
51 | #endif
52 | import qualified Data.Text.Lazy as LT
53 | import qualified Data.Text.Lazy.Builder as LT
54 | import Data.Aeson (Value)
55 | import qualified Data.Vector as V
56 | import qualified Data.HashMap.Lazy as M
57 | import Data.Maybe (fromMaybe, catMaybes)
58 | import Data.String (IsString(..))
59 | import Data.List (intercalate)
60 | import Control.Monad.State (State, get, put, runState)
61 | #if __GLASGOW_HASKELL__ < 710
62 | import Control.Applicative ((<$>), (<*>))
63 | #endif
64 | import Data.Default (Default, def)
65 | import qualified Data.Text as T
66 | import qualified Data.ByteString as SB
67 | import qualified Data.ByteString.Lazy as LB
68 | import Data.Foldable (toList)
69 | import Data.Time
70 | import Control.Monad.Fix
71 | import Data.Int
72 | #if __GLASGOW_HASKELL__ < 710
73 | import Data.Monoid
74 | #endif
75 | import Data.Char
76 | import Data.Ratio
77 | import Data.Word
78 | import qualified Data.HashMap.Strict as HM
79 | import qualified Data.Map as Map
80 | import qualified Data.Set as Set
81 |
82 | import {-# SOURCE #-} Database.RethinkDB.Functions as R
83 | import Database.RethinkDB.Wire
84 | import Database.RethinkDB.Wire.Query
85 | import qualified Database.RethinkDB.Wire.Term as Term
86 | import Database.RethinkDB.Wire.Term hiding (JSON)
87 | import Database.RethinkDB.Types
88 | import Database.RethinkDB.Datum
89 |
90 | -- $setup
91 | --
92 | -- Get the doctests ready
93 | --
94 | -- >>> import qualified Database.RethinkDB as R
95 | -- >>> import Database.RethinkDB.NoClash
96 | -- >>> h' <- connect "localhost" 28015 def
97 | -- >>> let h = use "doctests" h'
98 |
99 | -- | A ReQL Term
100 | data ReQL = ReQL { runReQL :: State QuerySettings Term }
101 |
102 | -- | Internal representation of a ReQL Term
103 | data Term = Term {
104 | termType :: TermType,
105 | termArgs :: [Term],
106 | termOptArgs :: [TermAttribute]
107 | } | Datum {
108 | termDatum :: Datum
109 | } | Note {
110 | termNote :: String,
111 | termTerm :: Term
112 | } deriving Eq
113 |
114 | -- | A term ready to be sent over the network
115 | newtype WireTerm = WireTerm { termJSON :: Datum }
116 |
117 | -- | State used to build a Term
118 | data QuerySettings = QuerySettings {
119 | queryToken :: Int64,
120 | queryDefaultDatabase :: Database,
121 | queryVarIndex :: Int,
122 | queryReadMode :: Maybe String
123 | }
124 |
125 | instance Default QuerySettings where
126 | def = QuerySettings 0 (Database "") 0 Nothing
127 |
128 | withQuerySettings :: (QuerySettings -> ReQL) -> ReQL
129 | withQuerySettings f = ReQL $ (runReQL . f) =<< get
130 |
131 | -- | An operation that accepts optional arguments
132 | class OptArgs a where
133 | -- | Extend an operation with optional arguments
134 | ex :: a -> [Attribute Static] -> a
135 |
136 | instance OptArgs ReQL where
137 | ex (ReQL m) attrs = ReQL $ do
138 | e <- m
139 | case e of
140 | Datum _ -> return e
141 | Term t a oa -> Term t a . (oa ++) <$> baseAttributes attrs
142 | Note n t -> Note n <$> runReQL (ex (ReQL $ return t) attrs)
143 |
144 | instance OptArgs b => OptArgs (a -> b) where
145 | ex f a = flip ex a . f
146 |
147 | newVarId :: State QuerySettings Int
148 | newVarId = do
149 | QuerySettings {..} <- get
150 | let n = queryVarIndex + 1
151 | put QuerySettings {queryVarIndex = n, ..}
152 | return $ n
153 |
154 | instance Show Term where
155 | show (Datum dat) = show dat
156 | show (Note n term) = shortLines "" ["{- " ++ n ++ " -}", show term]
157 | show (Term MAKE_ARRAY x []) = "[" ++ (shortLines "," $ map show x) ++ "]"
158 | show (Term MAKE_OBJ [] x) = "{" ++ (shortLines "," $ map show x) ++ "}"
159 | show (Term MAKE_OBJ args []) = "{" ++ (shortLines "," $ map (\(a,b) -> show a ++ ":" ++ show b) $ pairs args) ++ "}"
160 | where pairs (a:b:xs) = (a,b) : pairs xs
161 | pairs _ = []
162 | show (Term VAR [Datum d] []) | Just x <- toInt d = varName x
163 | show (Term FUNC [args, body] []) | Just vars <- argList args =
164 | "(\\" ++ (shortLines " " $ map varName vars)
165 | ++ " -> " ++ show body ++ ")"
166 | show (Term BRACKET [o, k] []) = show o ++ "[" ++ show k ++ "]"
167 | show (Term FUNCALL (f : as) []) = "(" ++ show f ++ ")(" ++ shortLines "," (map show as) ++ ")"
168 | show (Term fun args oargs) =
169 | map toLower (show fun) ++ "(" ++
170 | shortLines "," (map show args ++ map show oargs) ++ ")"
171 |
172 | shortLines :: String -> [String] -> String
173 | shortLines sep args =
174 | if tooLong
175 | then "\n" ++ intercalate (sep ++ "\n") (map indent args)
176 | else intercalate (sep ++ " ") args
177 | where
178 | tooLong = any ('\n' `elem`) args || 80 < (length $ concat args)
179 | indent = (\x -> case x of [] -> []; _ -> init x) . unlines . map (" "++) . lines
180 |
181 | varName :: Int -> String
182 | varName n = replicate (q+1) (chr $ ord 'a' + r)
183 | where (q, r) = quotRem n 26
184 |
185 | -- | A list of terms
186 | data ArgList = ArgList { baseArray :: State QuerySettings [Term] }
187 |
188 | instance Monoid ArgList where
189 | mempty = ArgList $ return []
190 | mappend (ArgList a) (ArgList b) = ArgList $ (++) <$> a <*> b
191 |
192 | -- | Build arrays of exprs
193 | class Arr a where
194 | arr :: a -> ArgList
195 |
196 | cons :: Expr e => e -> ArgList -> ArgList
197 | cons x xs = ArgList $ do
198 | bt <- runReQL (expr x)
199 | xs' <- baseArray xs
200 | return $ bt : xs'
201 |
202 | instance Arr () where
203 | arr () = ArgList $ return []
204 |
205 | instance Expr a => Arr [a] where
206 | arr [] = ArgList $ return []
207 | arr (x:xs) = cons x (arr xs)
208 |
209 | instance (Expr a, Expr b) => Arr (a, b) where
210 | arr (a,b) = cons a $ cons b $ arr ()
211 |
212 | instance (Expr a, Expr b, Expr c) => Arr (a, b, c) where
213 | arr (a,b,c) = cons a $ cons b $ cons c $ arr ()
214 |
215 | instance (Expr a, Expr b, Expr c, Expr d) => Arr (a, b, c, d) where
216 | arr (a,b,c,d) = cons a $ cons b $ cons c $ cons d $ arr ()
217 |
218 | instance Arr ArgList where
219 | arr = id
220 |
221 | infix 0 :=
222 |
223 | -- | A key/value pair used for building objects
224 | data Attribute a where
225 | (:=) :: Expr e => T.Text -> e -> Attribute a
226 | (::=) :: (Expr k, Expr v) => k -> v -> Attribute Dynamic
227 | NoAttribute :: Attribute a
228 |
229 | (?:=) :: Expr e => T.Text -> Maybe e -> Attribute a
230 | _ ?:= Nothing = NoAttribute
231 | k ?:= (Just v) = k := v
232 |
233 | type OptArg = Attribute Static
234 |
235 | data Static
236 | data Dynamic
237 |
238 | instance Expr (Attribute a) where
239 | expr (k := v) = expr (k, v)
240 | expr (k ::= v) = expr (k, v)
241 | expr NoAttribute = expr Null
242 | exprList kvs = maybe (obj kvs) (op' MAKE_OBJ () . concat) $ mapM staticPair kvs
243 | where staticPair :: Attribute a -> Maybe [Attribute Static]
244 | staticPair (k := v) = Just [k := v]
245 | staticPair NoAttribute = Just []
246 | staticPair _ = Nothing
247 | obj :: [Attribute a] -> ReQL
248 | obj = op OBJECT . concatMap unpair
249 | unpair :: Attribute a -> [ReQL]
250 | unpair (k := v) = [expr k, expr v]
251 | unpair (k ::= v) = [expr k, expr v]
252 | unpair NoAttribute = []
253 |
254 | data TermAttribute = TermAttribute T.Text Term deriving Eq
255 |
256 | mapTermAttribute :: (Term -> Term) -> TermAttribute -> TermAttribute
257 | mapTermAttribute f (TermAttribute k v) = TermAttribute k (f v)
258 |
259 | instance Show TermAttribute where
260 | show (TermAttribute a b) = T.unpack a ++ ": " ++ show b
261 |
262 | baseAttributes :: [Attribute Static] -> State QuerySettings [TermAttribute]
263 | baseAttributes = sequence . concat . map toBase
264 | where
265 | toBase :: Attribute Static -> [State QuerySettings TermAttribute]
266 | toBase (k := v) = [TermAttribute k <$> runReQL (expr v)]
267 | toBase NoAttribute = []
268 |
269 | -- | Build a term
270 | op' :: Arr a => TermType -> a -> [Attribute Static] -> ReQL
271 | op' t a b = ReQL $ do
272 | a' <- baseArray (arr a)
273 | b' <- baseAttributes b
274 | case (t, a', b') of
275 | -- Inline function calls if all arguments are variables
276 | (FUNCALL, (Term FUNC [argsFunTerm, fun] [] : argsCall), []) |
277 | Just varsFun <- argList argsFunTerm,
278 | length varsFun == length argsCall,
279 | Just varsCall <- varsOf argsCall ->
280 | return $ alphaRename (zip varsFun varsCall) fun
281 | _ -> return $ Term t a' b'
282 |
283 | -- | Build a term with no optargs
284 | op :: Arr a => TermType -> a -> ReQL
285 | op t a = op' t a []
286 |
287 | argList :: Term -> Maybe [Int]
288 | argList (Datum d) | Just a <- toInts d = Just a
289 | argList (Term MAKE_ARRAY a []) = mapM toInt =<< datums a
290 | where datums (Datum d:xs) = fmap (d:) $ datums xs; datums [] = Just []; datums _ = Nothing
291 | argList _ = Nothing
292 |
293 | toInts :: Datum -> Maybe [Int]
294 | toInts (Array xs) = mapM toInt $ toList xs
295 | toInts _ = Nothing
296 |
297 | toInt :: Datum -> Maybe Int
298 | toInt (Number n) = if denominator (toRational n) == 1 then Just (truncate n) else Nothing
299 | toInt _ = Nothing
300 |
301 | varsOf :: [Term] -> Maybe [Int]
302 | varsOf = sequence . map varOf
303 |
304 | varOf :: Term -> Maybe Int
305 | varOf (Term VAR [Datum d] []) = toInt d
306 | varOf _ = Nothing
307 |
308 | alphaRename :: [(Int, Int)] -> Term -> Term
309 | alphaRename assoc = fix $ \f x ->
310 | case varOf x of
311 | Just n
312 | | Just n' <- lookup n assoc ->
313 | Term VAR [Datum $ toDatum n'] []
314 | | otherwise -> x
315 | _ -> updateChildren x f
316 |
317 | updateChildren :: Term -> (Term -> Term) -> Term
318 | updateChildren (Note _ t) f = updateChildren t f
319 | updateChildren d@Datum{} _ = d
320 | updateChildren (Term t a o) f = Term t (map f a) (map (mapTermAttribute f) o)
321 |
322 | datumTerm :: ToDatum a => a -> ReQL
323 | datumTerm = ReQL . return . Datum . toDatum
324 |
325 | -- | A shortcut for inserting strings into ReQL expressions
326 | -- Useful when OverloadedStrings makes the type ambiguous
327 | str :: String -> ReQL
328 | str = datumTerm
329 |
330 | -- | A shortcut for inserting numbers into ReQL expressions
331 | num :: Double -> ReQL
332 | num = expr
333 |
334 | instance Num ReQL where
335 | fromInteger = datumTerm
336 | a + b = op ADD (a, b)
337 | a * b = op MUL (a, b)
338 | a - b = op SUB (a, b)
339 | negate a = op SUB (0 :: Double, a)
340 | abs n = op BRANCH (op Term.LT (n, 0 :: Double), negate n, n)
341 | signum n = op BRANCH (op Term.LT (n, 0 :: Double),
342 | -1 :: Double,
343 | op BRANCH (op Term.EQ (n, 0 :: Double), 0 :: Double, 1 :: Double))
344 |
345 | instance IsString ReQL where
346 | fromString = datumTerm
347 |
348 | -- | Convert other types into ReQL expressions
349 | class Expr e where
350 | expr :: e -> ReQL
351 | default expr :: ToDatum e => e -> ReQL
352 | expr = datumTerm
353 | exprList :: [e] -> ReQL
354 | exprList = expr . arr
355 |
356 | instance Expr ReQL where
357 | expr t = t
358 |
359 | instance Expr Char where
360 | exprList = datumTerm
361 |
362 | instance (Expr a, Expr b) => Expr (Either a b) where
363 | expr (Left a) = expr ["Left" := a]
364 | expr (Right b) = expr ["Right" := b]
365 |
366 | instance PRAGMA_OVERLAPPING Expr a => Expr (HM.HashMap [Char] a) where
367 | expr = expr . map (\(k,v) -> T.pack k := v) . HM.toList
368 |
369 | instance PRAGMA_OVERLAPPING Expr a => Expr (HM.HashMap T.Text a) where
370 | expr = expr . map (uncurry (:=)) . HM.toList
371 |
372 | instance Expr a => Expr (Map.Map [Char] a) where
373 | expr = expr . map (\(k,v) -> T.pack k := v) . Map.toList
374 |
375 | instance Expr a => Expr (Map.Map T.Text a) where
376 | expr = expr . map (uncurry (:=)) . Map.toList
377 |
378 | instance Expr a => Expr (Maybe a) where
379 | expr Nothing = expr Null
380 | expr (Just a) = expr a
381 |
382 | instance Expr a => Expr (Set.Set a) where
383 | expr = expr . Set.toList
384 |
385 | instance Expr a => Expr (V.Vector a) where
386 | expr = expr . V.toList
387 |
388 | instance Expr Value where
389 | expr v = op Term.JSON [encodeTextJSON v]
390 |
391 | instance Expr Int
392 | instance Expr Integer
393 | instance Expr Bool
394 | instance Expr Datum
395 | instance Expr Double
396 | instance Expr ()
397 | instance Expr Float
398 | instance Expr Int8
399 | instance Expr Int16
400 | instance Expr Int32
401 | instance Expr Int64
402 | instance Expr LT.Text
403 | instance Expr T.Text
404 | instance Expr LB.ByteString
405 | instance Expr SB.ByteString
406 | instance Expr Word
407 | instance Expr Word8
408 | instance Expr Word16
409 | instance Expr Word32
410 | instance Expr Word64
411 | instance Expr (Ratio Integer)
412 | instance Expr LonLat
413 |
414 | instance (a ~ ReQL) => Expr (a -> ReQL) where
415 | expr f = ReQL $ do
416 | v <- newVarId
417 | runReQL $ op FUNC ([v], expr $ f (op VAR [v]))
418 |
419 | instance (a ~ ReQL, b ~ ReQL) => Expr (a -> b -> ReQL) where
420 | expr f = ReQL $ do
421 | a <- newVarId
422 | b <- newVarId
423 | runReQL $ op FUNC ([a, b], expr $ f (op VAR [a]) (op VAR [b]))
424 |
425 | instance (a ~ ReQL, b ~ ReQL, c ~ ReQL) => Expr (a -> b -> c -> ReQL) where
426 | expr f = ReQL $ do
427 | a <- newVarId
428 | b <- newVarId
429 | c <- newVarId
430 | runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]))
431 |
432 | instance (a ~ ReQL, b ~ ReQL, c ~ ReQL, d ~ ReQL) => Expr (a -> b -> c -> d -> ReQL) where
433 | expr f = ReQL $ do
434 | a <- newVarId
435 | b <- newVarId
436 | c <- newVarId
437 | d <- newVarId
438 | runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]) (op VAR [d]))
439 |
440 | instance (a ~ ReQL, b ~ ReQL, c ~ ReQL, d ~ ReQL, e ~ ReQL) => Expr (a -> b -> c -> d -> e -> ReQL) where
441 | expr f = ReQL $ do
442 | a <- newVarId
443 | b <- newVarId
444 | c <- newVarId
445 | d <- newVarId
446 | e <- newVarId
447 | runReQL $ op FUNC ([a, b, c], expr $ f (op VAR [a]) (op VAR [b]) (op VAR [c]) (op VAR [d]) (op VAR [e]))
448 |
449 | instance Expr Table where
450 | expr (Table mdb name _) = withQuerySettings $ \QuerySettings {..} ->
451 | op' TABLE (fromMaybe queryDefaultDatabase mdb, name) $ catMaybes [
452 | fmap ("read_mode" :=) queryReadMode ]
453 |
454 | instance Expr Database where
455 | expr (Database name) = op DB [name]
456 |
457 | instance Expr a => Expr [a] where
458 | expr = exprList
459 |
460 | instance Expr ArgList where
461 | expr a = op MAKE_ARRAY a
462 |
463 | instance PRAGMA_OVERLAPPING (Expr k, Expr v) => Expr (M.HashMap k v) where
464 | expr m = expr $ map (uncurry (::=)) $ M.toList m
465 |
466 |
467 | buildTerm :: Term -> WireTerm
468 | buildTerm (Note _ t) = buildTerm t
469 | buildTerm (Datum d)
470 | | complexDatum d = buildTerm $ Term Term.JSON [Datum $ toDatum $ encodeTextJSON $ J.toJSON d] []
471 | | otherwise = WireTerm $ d
472 | buildTerm (Term type_ args oargs) =
473 | WireTerm $ toDatum (
474 | toWire type_,
475 | map (termJSON . buildTerm) args,
476 | buildAttributes oargs)
477 |
478 | complexDatum :: Datum -> Bool
479 | complexDatum Null = False
480 | complexDatum Bool{} = False
481 | complexDatum Number{} = False
482 | complexDatum String{} = False
483 | complexDatum _ = True
484 |
485 | encodeTextJSON :: Value -> T.Text
486 | encodeTextJSON = LT.toStrict . LT.toLazyText . J.encodeToTextBuilder
487 |
488 | buildAttributes :: [TermAttribute] -> Datum
489 | buildAttributes ts = toDatum $ M.fromList $ map toPair ts
490 | where toPair (TermAttribute a b) = (a, termJSON $ buildTerm b)
491 |
492 | newtype WireQuery = WireQuery { queryJSON :: Datum }
493 | deriving Show
494 |
495 | buildQuery :: ReQL -> Int64 -> Database -> [(T.Text, Datum)] -> (WireQuery, Term)
496 | buildQuery reql token db opts =
497 | (WireQuery $ toDatum (toWire START, termJSON pterm, object opts), bterm)
498 | where
499 | bterm = fst $ runState (runReQL reql) (def {queryToken = token,
500 | queryDefaultDatabase = db })
501 | pterm = buildTerm bterm
502 |
503 | instance Show ReQL where
504 | show t = show . snd $ buildQuery t 0 (Database "") []
505 |
506 | reqlToDatum :: ReQL -> Datum
507 | reqlToDatum t = queryJSON $ fst $ buildQuery t 0 (Database "") []
508 |
509 | type Backtrace = [Frame]
510 |
511 | data Frame = FramePos Int | FrameOpt T.Text
512 |
513 | instance Show Frame where
514 | show (FramePos n) = show n
515 | show (FrameOpt k) = show k
516 |
517 | instance FromDatum Frame where
518 | parseDatum d@Number{} | Success i <- fromDatum d = return $ FramePos i
519 | parseDatum (String s) = return $ FrameOpt s
520 | parseDatum _ = mempty
521 |
522 | newtype WireBacktrace = WireBacktrace { backtraceJSON :: Datum }
523 |
524 | convertBacktrace :: WireBacktrace -> Backtrace
525 | convertBacktrace (WireBacktrace b) =
526 | case fromDatum b of
527 | Success a -> a
528 | Error _ -> []
529 |
530 | instance Expr UTCTime
531 | instance Expr ZonedTime
532 |
533 | instance Expr Term where
534 | expr = ReQL . return
535 |
536 | -- | An upper or lower bound for between and during
537 | data Bound a =
538 | Open { getBound :: a } -- ^ An inclusive bound
539 | | Closed { getBound :: a } -- ^ An exclusive bound
540 | | DefaultBound { getBound :: a }
541 | | MinVal
542 | | MaxVal
543 |
544 | instance Expr a => Expr (Bound a) where
545 | expr (Open a) = expr a
546 | expr (Closed a) = expr a
547 | expr (DefaultBound a) = expr a
548 | expr MinVal = op MINVAL ()
549 | expr MaxVal = op MAXVAL ()
550 |
551 | minval :: Bound a
552 | minval = MinVal
553 |
554 | maxval :: Bound a
555 | maxval = MaxVal
556 |
557 | instance Functor Bound where
558 | fmap f (Open a) = Open (f a)
559 | fmap f (Closed a) = Closed (f a)
560 | fmap f (DefaultBound a) = DefaultBound (f a)
561 | fmap _ MinVal = MinVal
562 | fmap _ MaxVal = MaxVal
563 |
564 | closedOrOpen :: Bound a -> Maybe T.Text
565 | closedOrOpen Open{} = Just "open"
566 | closedOrOpen Closed{} = Just "closed"
567 | closedOrOpen DefaultBound{} = Nothing
568 | closedOrOpen MinVal = Nothing
569 | closedOrOpen MaxVal = Nothing
570 |
571 | boundOp :: (a -> a -> a) -> Bound a -> Bound a -> Bound a
572 | boundOp f (Closed a) (Closed b) = Closed $ f a b
573 | boundOp f (Closed a) (Open b) = Open $ f a b
574 | boundOp f (Open a) (Closed b) = Open $ f a b
575 | boundOp f (Open a) (Open b) = Open $ f a b
576 | boundOp f (DefaultBound a) b = fmap (f a) b
577 | boundOp f a (DefaultBound b) = fmap (flip f b) a
578 | boundOp _ MaxVal a = a
579 | boundOp _ MinVal a = a
580 | boundOp _ a MaxVal = a
581 | boundOp _ a MinVal = a
582 |
583 | instance Num a => Num (Bound a) where
584 | (+) = boundOp (+)
585 | (-) = boundOp (-)
586 | (*) = boundOp (*)
587 | negate MinVal = MaxVal
588 | negate MaxVal = MaxVal
589 | negate a = fmap negate a
590 | abs MinVal = MaxVal
591 | abs a = fmap abs a
592 | signum MinVal = Open (-1)
593 | signum MaxVal = Open 1
594 | signum a = fmap signum a
595 | fromInteger = DefaultBound . fromInteger
596 |
597 | -- | An empty object
598 | empty :: ReQL
599 | empty = op MAKE_OBJ ()
600 |
601 | instance (Expr a, Expr b) => Expr (a, b) where
602 | expr (a, b) = expr [expr a, expr b]
603 |
604 | instance (Expr a, Expr b, Expr c) => Expr (a, b, c) where
605 | expr (a, b, c) = expr [expr a, expr b, expr c]
606 |
607 | instance (Expr a, Expr b, Expr c, Expr d) => Expr (a, b, c, d) where
608 | expr (a, b, c, d) = expr [expr a, expr b, expr c, expr d]
609 |
610 | instance (Expr a, Expr b, Expr c, Expr d, Expr e) => Expr (a, b, c, d, e) where
611 | expr (a, b, c, d, e) = expr [expr a, expr b, expr c, expr d, expr e]
612 |
613 | -- | Add a note a a ReQL Term
614 | --
615 | -- This note does not get sent to the server. It is used to annotate
616 | -- backtraces and help debugging.
617 | note :: String -> ReQL -> ReQL
618 | note n (ReQL t) = ReQL $ return . Note n =<< t
619 |
620 | instance Fractional ReQL where
621 | a / b = op DIV [a, b]
622 | recip a = op DIV [num 1, a]
623 | fromRational = expr
624 |
625 | instance Floating ReQL where
626 | pi = js "Math.PI"
627 | exp x = js "(function(x){return Math.pow(Math.E,x)})" `apply` [x]
628 | sqrt x = js "Math.sqrt" `apply` [x]
629 | log x = js "Math.log" `apply` [x]
630 | (**) x y = js "Math.pow" `apply` [x, y]
631 | logBase x y = js "(function(x, y){return Math.log(x)/Math.log(y)})" `apply` [x, y]
632 | sin x = js "Math.sin" `apply` [x]
633 | tan x = js "Math.tan" `apply` [x]
634 | cos x = js "Math.cos" `apply` [x]
635 | asin x = js "Math.asin" `apply` [x]
636 | atan x = js "Math.atan" `apply` [x]
637 | acos x = js "Math.acos" `apply` [x]
638 | sinh = error "hyberbolic math is not supported"
639 | tanh = error "hyberbolic math is not supported"
640 | cosh = error "hyberbolic math is not supported"
641 | asinh = error "hyberbolic math is not supported"
642 | atanh = error "hyberbolic math is not supported"
643 | acosh = error "hyberbolic math is not supported"
644 |
--------------------------------------------------------------------------------
/Database/RethinkDB/ReQL.hs-boot:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.ReQL where
2 | data ReQL
3 | class Expr e
--------------------------------------------------------------------------------
/Database/RethinkDB/Time.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | module Database.RethinkDB.Time where
4 |
5 | import Database.RethinkDB.Wire.Term
6 | import Database.RethinkDB.ReQL
7 |
8 | -- $setup
9 | -- >>> :set -XOverloadedStrings
10 | -- >>> :load Database.RethinkDB.NoClash
11 | -- >>> import qualified Database.RethinkDB as R
12 | -- >>> import Database.RethinkDB.NoClash
13 | -- >>> import Prelude
14 | -- >>> h <- connect "localhost" 28015 def
15 |
16 | -- | The time and date when the query is executed
17 | --
18 | -- > >>> run' h $ now
19 | now :: ReQL
20 | now = op NOW ()
21 |
22 | -- | Build a time object from the year, month, day, hour, minute, second and timezone fields
23 | --
24 | -- >>> run' h $ time 2011 12 24 23 59 59 "Z"
25 | -- Time<2011-12-24 23:59:59 +0000>
26 | time :: ReQL -> ReQL -> ReQL -> ReQL -> ReQL -> ReQL -> ReQL -> ReQL
27 | time y m d hh mm ss tz = op TIME [y, m, d, hh, mm, ss, tz]
28 |
29 | -- | Build a time object given the number of seconds since the unix epoch
30 | --
31 | -- >>> run' h $ epochTime 1147162826
32 | -- Time<2006-05-09 08:20:26 +0000>
33 | epochTime :: ReQL -> ReQL
34 | epochTime t = op EPOCH_TIME [t]
35 |
36 | -- | Build a time object given an iso8601 string
37 | --
38 | -- >>> run' h $ iso8601 "2012-01-07T08:34:00-0700"
39 | -- Time<2012-01-07 08:34:00 -0700>
40 | iso8601 :: ReQL -> ReQL
41 | iso8601 t = op ISO8601 [t]
42 |
43 | -- | The same time in a different timezone
44 | --
45 | -- >>> _ <- run' h $ inTimezone "+0800" now
46 | inTimezone :: Expr time => ReQL -> time -> ReQL
47 | inTimezone tz t = op IN_TIMEZONE (t, tz)
48 |
49 | -- | Test if a time is between two other times
50 | --
51 | -- >>> run' h $ during (Open $ now R.- (60*60)) (Closed now) $ epochTime 1382919271
52 | -- false
53 | during :: (Expr left, Expr right, Expr time) => Bound left -> Bound right -> time -> ReQL
54 | during l r t = op' DURING (t, getBound l, getBound r) [
55 | "left_bound" ?:= closedOrOpen l, "right_bound" ?:= closedOrOpen r]
56 |
57 | -- | Extract part of a time value
58 | timezone, date, timeOfDay, year, month, day, dayOfWeek, dayOfYear, hours, minutes, seconds ::
59 | Expr time => time -> ReQL
60 | timezone t = op TIMEZONE [t]
61 | date t = op DATE [t]
62 | timeOfDay t = op TIME_OF_DAY [t]
63 | year t = op YEAR [t]
64 | month t = op MONTH [t]
65 | day t = op DAY [t]
66 | dayOfWeek t = op DAY_OF_WEEK [t]
67 | dayOfYear t = op DAY_OF_YEAR [t]
68 | hours t = op HOURS [t]
69 | minutes t = op MINUTES [t]
70 | seconds t = op SECONDS [t]
71 |
72 | -- | Convert a time to another representation
73 | toIso8601, toEpochTime :: Expr t => t -> ReQL
74 | toIso8601 t = op TO_ISO8601 [t]
75 | toEpochTime t = op TO_EPOCH_TIME [t]
76 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Types.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Types (
2 | Database(..),
3 | Table(..),
4 | Key,
5 | Index(..)
6 | ) where
7 |
8 | import qualified Data.Text as Text
9 | import Data.Text (Text, pack)
10 | import Data.String
11 |
12 | type Key = Text
13 |
14 | -- | A database, referenced by name
15 | data Database = Database {
16 | databaseName :: Text
17 | } deriving (Eq, Ord)
18 |
19 | instance Show Database where
20 | show (Database d) = show d
21 |
22 | instance IsString Database where
23 | fromString name = Database $ fromString name
24 |
25 | -- | A table description
26 | data Table = Table {
27 | tableDatabase :: Maybe Database, -- ^ when Nothing, use the connection's database
28 | tableName :: Text,
29 | tablePrimaryKey :: Maybe Key
30 | } deriving (Eq, Ord)
31 |
32 | instance Show Table where
33 | show (Table db' nam mkey) =
34 | maybe "" (\(Database d) -> Text.unpack d++".") db' ++ Text.unpack nam ++
35 | maybe "" (\k -> "[" ++ show k ++ "]") mkey
36 |
37 | instance IsString Table where
38 | fromString name = Table Nothing (fromString name) Nothing
39 |
40 | data Index =
41 | PrimaryKey |
42 | Index Key
43 |
44 | instance IsString Index where
45 | fromString = Index . pack
46 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire where
2 | class WireValue a where
3 | toWire :: a -> Int
4 | fromWire :: Int -> Maybe a
5 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire/Datum.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire.Datum where
2 | import Prelude (Maybe(..), Eq, Show)
3 | import Database.RethinkDB.Wire
4 | data DatumType = R_NULL | R_BOOL | R_NUM | R_STR | R_ARRAY | R_OBJECT | R_JSON
5 | deriving (Eq, Show)
6 | instance WireValue DatumType where
7 | toWire R_NULL = 1
8 | toWire R_BOOL = 2
9 | toWire R_NUM = 3
10 | toWire R_STR = 4
11 | toWire R_ARRAY = 5
12 | toWire R_OBJECT = 6
13 | toWire R_JSON = 7
14 | fromWire 1 = Just R_NULL
15 | fromWire 2 = Just R_BOOL
16 | fromWire 3 = Just R_NUM
17 | fromWire 4 = Just R_STR
18 | fromWire 5 = Just R_ARRAY
19 | fromWire 6 = Just R_OBJECT
20 | fromWire 7 = Just R_JSON
21 | fromWire _ = Nothing
22 |
23 |
24 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire/Frame.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire.Frame where
2 | import Prelude (Maybe(..), Eq, Show)
3 | import Database.RethinkDB.Wire
4 | data FrameType = POS | OPT
5 | deriving (Eq, Show)
6 | instance WireValue FrameType where
7 | toWire POS = 1
8 | toWire OPT = 2
9 | fromWire 1 = Just POS
10 | fromWire 2 = Just OPT
11 | fromWire _ = Nothing
12 |
13 |
14 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire/Query.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire.Query where
2 | import Prelude (Maybe(..), Eq, Show)
3 | import Database.RethinkDB.Wire
4 | data QueryType = START | CONTINUE | STOP | NOREPLY_WAIT | SERVER_INFO
5 | deriving (Eq, Show)
6 | instance WireValue QueryType where
7 | toWire START = 1
8 | toWire CONTINUE = 2
9 | toWire STOP = 3
10 | toWire NOREPLY_WAIT = 4
11 | toWire SERVER_INFO = 5
12 | fromWire 1 = Just START
13 | fromWire 2 = Just CONTINUE
14 | fromWire 3 = Just STOP
15 | fromWire 4 = Just NOREPLY_WAIT
16 | fromWire 5 = Just SERVER_INFO
17 | fromWire _ = Nothing
18 |
19 |
20 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire/Response.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire.Response where
2 | import Prelude (Maybe(..), Eq, Show)
3 | import Database.RethinkDB.Wire
4 | data ResponseType = SUCCESS_ATOM | SUCCESS_SEQUENCE | SUCCESS_PARTIAL | WAIT_COMPLETE | SERVER_INFO | CLIENT_ERROR | COMPILE_ERROR | RUNTIME_ERROR
5 | deriving (Eq, Show)
6 | instance WireValue ResponseType where
7 | toWire SUCCESS_ATOM = 1
8 | toWire SUCCESS_SEQUENCE = 2
9 | toWire SUCCESS_PARTIAL = 3
10 | toWire WAIT_COMPLETE = 4
11 | toWire SERVER_INFO = 5
12 | toWire CLIENT_ERROR = 16
13 | toWire COMPILE_ERROR = 17
14 | toWire RUNTIME_ERROR = 18
15 | fromWire 1 = Just SUCCESS_ATOM
16 | fromWire 2 = Just SUCCESS_SEQUENCE
17 | fromWire 3 = Just SUCCESS_PARTIAL
18 | fromWire 4 = Just WAIT_COMPLETE
19 | fromWire 5 = Just SERVER_INFO
20 | fromWire 16 = Just CLIENT_ERROR
21 | fromWire 17 = Just COMPILE_ERROR
22 | fromWire 18 = Just RUNTIME_ERROR
23 | fromWire _ = Nothing
24 |
25 |
26 | data ErrorType = INTERNAL | RESOURCE_LIMIT | QUERY_LOGIC | NON_EXISTENCE | OP_FAILED | OP_INDETERMINATE | USER
27 | deriving (Eq, Show)
28 | instance WireValue ErrorType where
29 | toWire INTERNAL = 1000000
30 | toWire RESOURCE_LIMIT = 2000000
31 | toWire QUERY_LOGIC = 3000000
32 | toWire NON_EXISTENCE = 3100000
33 | toWire OP_FAILED = 4100000
34 | toWire OP_INDETERMINATE = 4200000
35 | toWire USER = 5000000
36 | fromWire 1000000 = Just INTERNAL
37 | fromWire 2000000 = Just RESOURCE_LIMIT
38 | fromWire 3000000 = Just QUERY_LOGIC
39 | fromWire 3100000 = Just NON_EXISTENCE
40 | fromWire 4100000 = Just OP_FAILED
41 | fromWire 4200000 = Just OP_INDETERMINATE
42 | fromWire 5000000 = Just USER
43 | fromWire _ = Nothing
44 |
45 |
46 | data ResponseNote = SEQUENCE_FEED | ATOM_FEED | ORDER_BY_LIMIT_FEED | UNIONED_FEED | INCLUDES_STATES
47 | deriving (Eq, Show)
48 | instance WireValue ResponseNote where
49 | toWire SEQUENCE_FEED = 1
50 | toWire ATOM_FEED = 2
51 | toWire ORDER_BY_LIMIT_FEED = 3
52 | toWire UNIONED_FEED = 4
53 | toWire INCLUDES_STATES = 5
54 | fromWire 1 = Just SEQUENCE_FEED
55 | fromWire 2 = Just ATOM_FEED
56 | fromWire 3 = Just ORDER_BY_LIMIT_FEED
57 | fromWire 4 = Just UNIONED_FEED
58 | fromWire 5 = Just INCLUDES_STATES
59 | fromWire _ = Nothing
60 |
61 |
62 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire/Term.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire.Term where
2 | import Prelude (Maybe(..), Eq, Show)
3 | import Database.RethinkDB.Wire
4 | data TermType = DATUM | MAKE_ARRAY | MAKE_OBJ | VAR | JAVASCRIPT | UUID | HTTP | ERROR | IMPLICIT_VAR | DB | TABLE | GET | GET_ALL | EQ | NE | LT | LE | GT | GE | NOT | ADD | SUB | MUL | DIV | MOD | FLOOR | CEIL | ROUND | APPEND | PREPEND | DIFFERENCE | SET_INSERT | SET_INTERSECTION | SET_UNION | SET_DIFFERENCE | SLICE | SKIP | LIMIT | OFFSETS_OF | CONTAINS | GET_FIELD | KEYS | VALUES | OBJECT | HAS_FIELDS | WITH_FIELDS | PLUCK | WITHOUT | MERGE | BETWEEN_DEPRECATED | BETWEEN | REDUCE | MAP | FILTER | CONCAT_MAP | ORDER_BY | DISTINCT | COUNT | IS_EMPTY | UNION | NTH | BRACKET | INNER_JOIN | OUTER_JOIN | EQ_JOIN | ZIP | RANGE | INSERT_AT | DELETE_AT | CHANGE_AT | SPLICE_AT | COERCE_TO | TYPE_OF | UPDATE | DELETE | REPLACE | INSERT | DB_CREATE | DB_DROP | DB_LIST | TABLE_CREATE | TABLE_DROP | TABLE_LIST | CONFIG | STATUS | WAIT | RECONFIGURE | REBALANCE | SYNC | INDEX_CREATE | INDEX_DROP | INDEX_LIST | INDEX_STATUS | INDEX_WAIT | INDEX_RENAME | FUNCALL | BRANCH | OR | AND | FOR_EACH | FUNC | ASC | DESC | INFO | MATCH | UPCASE | DOWNCASE | SAMPLE | DEFAULT | JSON | TO_JSON_STRING | ISO8601 | TO_ISO8601 | EPOCH_TIME | TO_EPOCH_TIME | NOW | IN_TIMEZONE | DURING | DATE | TIME_OF_DAY | TIMEZONE | YEAR | MONTH | DAY | DAY_OF_WEEK | DAY_OF_YEAR | HOURS | MINUTES | SECONDS | TIME | MONDAY | TUESDAY | WEDNESDAY | THURSDAY | FRIDAY | SATURDAY | SUNDAY | JANUARY | FEBRUARY | MARCH | APRIL | MAY | JUNE | JULY | AUGUST | SEPTEMBER | OCTOBER | NOVEMBER | DECEMBER | LITERAL | GROUP | SUM | AVG | MIN | MAX | SPLIT | UNGROUP | RANDOM | CHANGES | ARGS | BINARY | GEOJSON | TO_GEOJSON | POINT | LINE | POLYGON | DISTANCE | INTERSECTS | INCLUDES | CIRCLE | GET_INTERSECTING | FILL | GET_NEAREST | POLYGON_SUB | MINVAL | MAXVAL
5 | deriving (Eq, Show)
6 | instance WireValue TermType where
7 | toWire DATUM = 1
8 | toWire MAKE_ARRAY = 2
9 | toWire MAKE_OBJ = 3
10 | toWire VAR = 10
11 | toWire JAVASCRIPT = 11
12 | toWire UUID = 169
13 | toWire HTTP = 153
14 | toWire ERROR = 12
15 | toWire IMPLICIT_VAR = 13
16 | toWire DB = 14
17 | toWire TABLE = 15
18 | toWire GET = 16
19 | toWire GET_ALL = 78
20 | toWire EQ = 17
21 | toWire NE = 18
22 | toWire LT = 19
23 | toWire LE = 20
24 | toWire GT = 21
25 | toWire GE = 22
26 | toWire NOT = 23
27 | toWire ADD = 24
28 | toWire SUB = 25
29 | toWire MUL = 26
30 | toWire DIV = 27
31 | toWire MOD = 28
32 | toWire FLOOR = 183
33 | toWire CEIL = 184
34 | toWire ROUND = 185
35 | toWire APPEND = 29
36 | toWire PREPEND = 80
37 | toWire DIFFERENCE = 95
38 | toWire SET_INSERT = 88
39 | toWire SET_INTERSECTION = 89
40 | toWire SET_UNION = 90
41 | toWire SET_DIFFERENCE = 91
42 | toWire SLICE = 30
43 | toWire SKIP = 70
44 | toWire LIMIT = 71
45 | toWire OFFSETS_OF = 87
46 | toWire CONTAINS = 93
47 | toWire GET_FIELD = 31
48 | toWire KEYS = 94
49 | toWire VALUES = 186
50 | toWire OBJECT = 143
51 | toWire HAS_FIELDS = 32
52 | toWire WITH_FIELDS = 96
53 | toWire PLUCK = 33
54 | toWire WITHOUT = 34
55 | toWire MERGE = 35
56 | toWire BETWEEN_DEPRECATED = 36
57 | toWire BETWEEN = 182
58 | toWire REDUCE = 37
59 | toWire MAP = 38
60 | toWire FILTER = 39
61 | toWire CONCAT_MAP = 40
62 | toWire ORDER_BY = 41
63 | toWire DISTINCT = 42
64 | toWire COUNT = 43
65 | toWire IS_EMPTY = 86
66 | toWire UNION = 44
67 | toWire NTH = 45
68 | toWire BRACKET = 170
69 | toWire INNER_JOIN = 48
70 | toWire OUTER_JOIN = 49
71 | toWire EQ_JOIN = 50
72 | toWire ZIP = 72
73 | toWire RANGE = 173
74 | toWire INSERT_AT = 82
75 | toWire DELETE_AT = 83
76 | toWire CHANGE_AT = 84
77 | toWire SPLICE_AT = 85
78 | toWire COERCE_TO = 51
79 | toWire TYPE_OF = 52
80 | toWire UPDATE = 53
81 | toWire DELETE = 54
82 | toWire REPLACE = 55
83 | toWire INSERT = 56
84 | toWire DB_CREATE = 57
85 | toWire DB_DROP = 58
86 | toWire DB_LIST = 59
87 | toWire TABLE_CREATE = 60
88 | toWire TABLE_DROP = 61
89 | toWire TABLE_LIST = 62
90 | toWire CONFIG = 174
91 | toWire STATUS = 175
92 | toWire WAIT = 177
93 | toWire RECONFIGURE = 176
94 | toWire REBALANCE = 179
95 | toWire SYNC = 138
96 | toWire INDEX_CREATE = 75
97 | toWire INDEX_DROP = 76
98 | toWire INDEX_LIST = 77
99 | toWire INDEX_STATUS = 139
100 | toWire INDEX_WAIT = 140
101 | toWire INDEX_RENAME = 156
102 | toWire FUNCALL = 64
103 | toWire BRANCH = 65
104 | toWire OR = 66
105 | toWire AND = 67
106 | toWire FOR_EACH = 68
107 | toWire FUNC = 69
108 | toWire ASC = 73
109 | toWire DESC = 74
110 | toWire INFO = 79
111 | toWire MATCH = 97
112 | toWire UPCASE = 141
113 | toWire DOWNCASE = 142
114 | toWire SAMPLE = 81
115 | toWire DEFAULT = 92
116 | toWire JSON = 98
117 | toWire TO_JSON_STRING = 172
118 | toWire ISO8601 = 99
119 | toWire TO_ISO8601 = 100
120 | toWire EPOCH_TIME = 101
121 | toWire TO_EPOCH_TIME = 102
122 | toWire NOW = 103
123 | toWire IN_TIMEZONE = 104
124 | toWire DURING = 105
125 | toWire DATE = 106
126 | toWire TIME_OF_DAY = 126
127 | toWire TIMEZONE = 127
128 | toWire YEAR = 128
129 | toWire MONTH = 129
130 | toWire DAY = 130
131 | toWire DAY_OF_WEEK = 131
132 | toWire DAY_OF_YEAR = 132
133 | toWire HOURS = 133
134 | toWire MINUTES = 134
135 | toWire SECONDS = 135
136 | toWire TIME = 136
137 | toWire MONDAY = 107
138 | toWire TUESDAY = 108
139 | toWire WEDNESDAY = 109
140 | toWire THURSDAY = 110
141 | toWire FRIDAY = 111
142 | toWire SATURDAY = 112
143 | toWire SUNDAY = 113
144 | toWire JANUARY = 114
145 | toWire FEBRUARY = 115
146 | toWire MARCH = 116
147 | toWire APRIL = 117
148 | toWire MAY = 118
149 | toWire JUNE = 119
150 | toWire JULY = 120
151 | toWire AUGUST = 121
152 | toWire SEPTEMBER = 122
153 | toWire OCTOBER = 123
154 | toWire NOVEMBER = 124
155 | toWire DECEMBER = 125
156 | toWire LITERAL = 137
157 | toWire GROUP = 144
158 | toWire SUM = 145
159 | toWire AVG = 146
160 | toWire MIN = 147
161 | toWire MAX = 148
162 | toWire SPLIT = 149
163 | toWire UNGROUP = 150
164 | toWire RANDOM = 151
165 | toWire CHANGES = 152
166 | toWire ARGS = 154
167 | toWire BINARY = 155
168 | toWire GEOJSON = 157
169 | toWire TO_GEOJSON = 158
170 | toWire POINT = 159
171 | toWire LINE = 160
172 | toWire POLYGON = 161
173 | toWire DISTANCE = 162
174 | toWire INTERSECTS = 163
175 | toWire INCLUDES = 164
176 | toWire CIRCLE = 165
177 | toWire GET_INTERSECTING = 166
178 | toWire FILL = 167
179 | toWire GET_NEAREST = 168
180 | toWire POLYGON_SUB = 171
181 | toWire MINVAL = 180
182 | toWire MAXVAL = 181
183 | fromWire 1 = Just DATUM
184 | fromWire 2 = Just MAKE_ARRAY
185 | fromWire 3 = Just MAKE_OBJ
186 | fromWire 10 = Just VAR
187 | fromWire 11 = Just JAVASCRIPT
188 | fromWire 169 = Just UUID
189 | fromWire 153 = Just HTTP
190 | fromWire 12 = Just ERROR
191 | fromWire 13 = Just IMPLICIT_VAR
192 | fromWire 14 = Just DB
193 | fromWire 15 = Just TABLE
194 | fromWire 16 = Just GET
195 | fromWire 78 = Just GET_ALL
196 | fromWire 17 = Just EQ
197 | fromWire 18 = Just NE
198 | fromWire 19 = Just LT
199 | fromWire 20 = Just LE
200 | fromWire 21 = Just GT
201 | fromWire 22 = Just GE
202 | fromWire 23 = Just NOT
203 | fromWire 24 = Just ADD
204 | fromWire 25 = Just SUB
205 | fromWire 26 = Just MUL
206 | fromWire 27 = Just DIV
207 | fromWire 28 = Just MOD
208 | fromWire 183 = Just FLOOR
209 | fromWire 184 = Just CEIL
210 | fromWire 185 = Just ROUND
211 | fromWire 29 = Just APPEND
212 | fromWire 80 = Just PREPEND
213 | fromWire 95 = Just DIFFERENCE
214 | fromWire 88 = Just SET_INSERT
215 | fromWire 89 = Just SET_INTERSECTION
216 | fromWire 90 = Just SET_UNION
217 | fromWire 91 = Just SET_DIFFERENCE
218 | fromWire 30 = Just SLICE
219 | fromWire 70 = Just SKIP
220 | fromWire 71 = Just LIMIT
221 | fromWire 87 = Just OFFSETS_OF
222 | fromWire 93 = Just CONTAINS
223 | fromWire 31 = Just GET_FIELD
224 | fromWire 94 = Just KEYS
225 | fromWire 186 = Just VALUES
226 | fromWire 143 = Just OBJECT
227 | fromWire 32 = Just HAS_FIELDS
228 | fromWire 96 = Just WITH_FIELDS
229 | fromWire 33 = Just PLUCK
230 | fromWire 34 = Just WITHOUT
231 | fromWire 35 = Just MERGE
232 | fromWire 36 = Just BETWEEN_DEPRECATED
233 | fromWire 182 = Just BETWEEN
234 | fromWire 37 = Just REDUCE
235 | fromWire 38 = Just MAP
236 | fromWire 39 = Just FILTER
237 | fromWire 40 = Just CONCAT_MAP
238 | fromWire 41 = Just ORDER_BY
239 | fromWire 42 = Just DISTINCT
240 | fromWire 43 = Just COUNT
241 | fromWire 86 = Just IS_EMPTY
242 | fromWire 44 = Just UNION
243 | fromWire 45 = Just NTH
244 | fromWire 170 = Just BRACKET
245 | fromWire 48 = Just INNER_JOIN
246 | fromWire 49 = Just OUTER_JOIN
247 | fromWire 50 = Just EQ_JOIN
248 | fromWire 72 = Just ZIP
249 | fromWire 173 = Just RANGE
250 | fromWire 82 = Just INSERT_AT
251 | fromWire 83 = Just DELETE_AT
252 | fromWire 84 = Just CHANGE_AT
253 | fromWire 85 = Just SPLICE_AT
254 | fromWire 51 = Just COERCE_TO
255 | fromWire 52 = Just TYPE_OF
256 | fromWire 53 = Just UPDATE
257 | fromWire 54 = Just DELETE
258 | fromWire 55 = Just REPLACE
259 | fromWire 56 = Just INSERT
260 | fromWire 57 = Just DB_CREATE
261 | fromWire 58 = Just DB_DROP
262 | fromWire 59 = Just DB_LIST
263 | fromWire 60 = Just TABLE_CREATE
264 | fromWire 61 = Just TABLE_DROP
265 | fromWire 62 = Just TABLE_LIST
266 | fromWire 174 = Just CONFIG
267 | fromWire 175 = Just STATUS
268 | fromWire 177 = Just WAIT
269 | fromWire 176 = Just RECONFIGURE
270 | fromWire 179 = Just REBALANCE
271 | fromWire 138 = Just SYNC
272 | fromWire 75 = Just INDEX_CREATE
273 | fromWire 76 = Just INDEX_DROP
274 | fromWire 77 = Just INDEX_LIST
275 | fromWire 139 = Just INDEX_STATUS
276 | fromWire 140 = Just INDEX_WAIT
277 | fromWire 156 = Just INDEX_RENAME
278 | fromWire 64 = Just FUNCALL
279 | fromWire 65 = Just BRANCH
280 | fromWire 66 = Just OR
281 | fromWire 67 = Just AND
282 | fromWire 68 = Just FOR_EACH
283 | fromWire 69 = Just FUNC
284 | fromWire 73 = Just ASC
285 | fromWire 74 = Just DESC
286 | fromWire 79 = Just INFO
287 | fromWire 97 = Just MATCH
288 | fromWire 141 = Just UPCASE
289 | fromWire 142 = Just DOWNCASE
290 | fromWire 81 = Just SAMPLE
291 | fromWire 92 = Just DEFAULT
292 | fromWire 98 = Just JSON
293 | fromWire 172 = Just TO_JSON_STRING
294 | fromWire 99 = Just ISO8601
295 | fromWire 100 = Just TO_ISO8601
296 | fromWire 101 = Just EPOCH_TIME
297 | fromWire 102 = Just TO_EPOCH_TIME
298 | fromWire 103 = Just NOW
299 | fromWire 104 = Just IN_TIMEZONE
300 | fromWire 105 = Just DURING
301 | fromWire 106 = Just DATE
302 | fromWire 126 = Just TIME_OF_DAY
303 | fromWire 127 = Just TIMEZONE
304 | fromWire 128 = Just YEAR
305 | fromWire 129 = Just MONTH
306 | fromWire 130 = Just DAY
307 | fromWire 131 = Just DAY_OF_WEEK
308 | fromWire 132 = Just DAY_OF_YEAR
309 | fromWire 133 = Just HOURS
310 | fromWire 134 = Just MINUTES
311 | fromWire 135 = Just SECONDS
312 | fromWire 136 = Just TIME
313 | fromWire 107 = Just MONDAY
314 | fromWire 108 = Just TUESDAY
315 | fromWire 109 = Just WEDNESDAY
316 | fromWire 110 = Just THURSDAY
317 | fromWire 111 = Just FRIDAY
318 | fromWire 112 = Just SATURDAY
319 | fromWire 113 = Just SUNDAY
320 | fromWire 114 = Just JANUARY
321 | fromWire 115 = Just FEBRUARY
322 | fromWire 116 = Just MARCH
323 | fromWire 117 = Just APRIL
324 | fromWire 118 = Just MAY
325 | fromWire 119 = Just JUNE
326 | fromWire 120 = Just JULY
327 | fromWire 121 = Just AUGUST
328 | fromWire 122 = Just SEPTEMBER
329 | fromWire 123 = Just OCTOBER
330 | fromWire 124 = Just NOVEMBER
331 | fromWire 125 = Just DECEMBER
332 | fromWire 137 = Just LITERAL
333 | fromWire 144 = Just GROUP
334 | fromWire 145 = Just SUM
335 | fromWire 146 = Just AVG
336 | fromWire 147 = Just MIN
337 | fromWire 148 = Just MAX
338 | fromWire 149 = Just SPLIT
339 | fromWire 150 = Just UNGROUP
340 | fromWire 151 = Just RANDOM
341 | fromWire 152 = Just CHANGES
342 | fromWire 154 = Just ARGS
343 | fromWire 155 = Just BINARY
344 | fromWire 157 = Just GEOJSON
345 | fromWire 158 = Just TO_GEOJSON
346 | fromWire 159 = Just POINT
347 | fromWire 160 = Just LINE
348 | fromWire 161 = Just POLYGON
349 | fromWire 162 = Just DISTANCE
350 | fromWire 163 = Just INTERSECTS
351 | fromWire 164 = Just INCLUDES
352 | fromWire 165 = Just CIRCLE
353 | fromWire 166 = Just GET_INTERSECTING
354 | fromWire 167 = Just FILL
355 | fromWire 168 = Just GET_NEAREST
356 | fromWire 171 = Just POLYGON_SUB
357 | fromWire 180 = Just MINVAL
358 | fromWire 181 = Just MAXVAL
359 | fromWire _ = Nothing
360 |
361 |
362 |
--------------------------------------------------------------------------------
/Database/RethinkDB/Wire/VersionDummy.hs:
--------------------------------------------------------------------------------
1 | module Database.RethinkDB.Wire.VersionDummy where
2 | import Prelude (Maybe(..), Eq, Show)
3 | import Database.RethinkDB.Wire
4 | data Version = V0_1 | V0_2 | V0_3 | V0_4
5 | deriving (Eq, Show)
6 | instance WireValue Version where
7 | toWire V0_1 = 0x3f61ba36
8 | toWire V0_2 = 0x723081e1
9 | toWire V0_3 = 0x5f75e83e
10 | toWire V0_4 = 0x400c2d20
11 | fromWire 0x3f61ba36 = Just V0_1
12 | fromWire 0x723081e1 = Just V0_2
13 | fromWire 0x5f75e83e = Just V0_3
14 | fromWire 0x400c2d20 = Just V0_4
15 | fromWire _ = Nothing
16 |
17 |
18 | data Protocol = PROTOBUF | JSON
19 | deriving (Eq, Show)
20 | instance WireValue Protocol where
21 | toWire PROTOBUF = 0x271ffc41
22 | toWire JSON = 0x7e6970c7
23 | fromWire 0x271ffc41 = Just PROTOBUF
24 | fromWire 0x7e6970c7 = Just JSON
25 | fromWire _ = Nothing
26 |
27 |
28 |
--------------------------------------------------------------------------------
/Debug.hs:
--------------------------------------------------------------------------------
1 | module Debug (
2 | module Debug.Trace,
3 | tr, tracePrint
4 | ) where
5 |
6 | import Debug.Trace
7 |
8 | tr :: Show a => String -> a -> a
9 | tr s a = trace (s ++ " " ++ show a) a
10 |
11 | tracePrint :: Show a => a -> IO ()
12 | tracePrint = traceIO . show
--------------------------------------------------------------------------------
/LICENSE:
--------------------------------------------------------------------------------
1 | RethinkDB Language Drivers for Haskell
2 |
3 | Copyright 2012 Etienne Laurin
4 |
5 | Licensed under the Apache License, Version 2.0 (the "License");
6 | you may not use this product except in compliance with the License.
7 | You may obtain a copy of the License at
8 |
9 | http://www.apache.org/licenses/LICENSE-2.0
10 |
11 | Unless required by applicable law or agreed to in writing, software
12 | distributed under the License is distributed on an "AS IS" BASIS,
13 | WITHOUT WARRANTIES OR CONDITIONS OF ANY KIND, either express or implied.
14 | See the License for the specific language governing permissions and
15 | limitations under the License.
16 |
--------------------------------------------------------------------------------
/README.md:
--------------------------------------------------------------------------------
1 | # RethinkDB Haskell Driver #
2 |
3 | [](https://travis-ci.org/AtnNn/haskell-rethinkdb)
4 |
5 | This driver targets versions 2.2 of [RethinkDB](http://rethinkdb.com).
6 |
7 | API Documentation:
8 |
9 | * [Generated API documentation for Database.RethinkDB](http://hackage.haskell.org/package/rethinkdb/docs/Database-RethinkDB.html)
10 | * [Official API documentation on rethinkdb.com](http://rethinkdb.com/api)
11 | * [Release Announcements](https://github.com/atnnn/haskell-rethinkdb/releases)
12 |
13 | RethinkDB Driver Development:
14 |
15 | * [driver specs](http://rethinkdb.com/docs/driver-spec/)
16 | * [rethinkdb-dev mailing list](https://groups.google.com/forum/#!forum/rethinkdb-dev)
17 | * [@neumino's tracing driver](https://github.com/neumino/rethinkdb-driver-development)
18 | * [release notes](https://github.com/rethinkdb/rethinkdb/blob/next/NOTES.md)
19 |
--------------------------------------------------------------------------------
/Setup.hs:
--------------------------------------------------------------------------------
1 | import Distribution.Simple
2 | main = defaultMain
3 |
--------------------------------------------------------------------------------
/bench/Bench.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | module Main where
4 |
5 | import Control.Exception
6 | import Database.RethinkDB.NoClash hiding (wait)
7 | import qualified Database.RethinkDB as R
8 | import Criterion.Main
9 | import Control.Monad
10 | import Control.Concurrent.Async
11 |
12 | main :: IO ()
13 | main = do
14 | h <- prepare
15 | let test name = bench name . nfIO . void . run' h
16 | let testn n name q = bench (name ++ "-" ++ show n) $ nfIO $ mapM_ wait =<< replicateM n (async $ run' h q)
17 | defaultMain [
18 | test "nil" $ expr Null,
19 | testn 10 "nil" $ expr [Null],
20 | testn 100 "nil" $ expr [Null],
21 | testn 1000 "nil" $ expr [Null],
22 | test "point-get" $ table "bench" # get (num 0)
23 | ]
24 |
25 | prepare :: IO RethinkDBHandle
26 | prepare = do
27 | h <- fmap (use "bench") $ connect "localhost" 28015 Nothing
28 | try_ $ run' h $ dbCreate "bench"
29 | try_ $ run' h $ tableCreate "bench"
30 | try_ $ run' h $ table "bench" # ex insert ["conflict" := str "replace"] ["id" := num 0]
31 | return h
32 |
33 | try_ :: IO a -> IO (Either SomeException a)
34 | try_ = try
35 |
--------------------------------------------------------------------------------
/check-instances.sh:
--------------------------------------------------------------------------------
1 | #!/usr/bin/env bash
2 |
3 | required_instances () {
4 | cat < *//; s/ *--.*//' \
71 | | sed "s/$1 *//" \
72 | | sort
73 | }
74 |
75 | for class in Expr R.Result ToDatum FromDatum; do
76 | echo Missing $class instances:
77 | diff -u <(instances $class) <(required_instances) | grep '^\+[^+]' | sed 's/^+//'
78 | done
79 |
--------------------------------------------------------------------------------
/doctests.hs:
--------------------------------------------------------------------------------
1 | module Main where
2 |
3 | import Test.DocTest
4 |
5 | main = doctest ["Database.RethinkDB"]
--------------------------------------------------------------------------------
/doctests.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | set -o pipefail
4 |
5 | cabal test 2>&1 | sed -r 's/^### Failure in //; s/:[0-9]+:[0-9]+://'
6 |
--------------------------------------------------------------------------------
/proto2hs.hs:
--------------------------------------------------------------------------------
1 | {-# LANGUAGE OverloadedStrings #-}
2 |
3 | module Main where
4 |
5 | import Prelude hiding (
6 | readFile, putStr, putStrLn, takeWhile, hPutStrLn, writeFile,
7 | unlines, unwords)
8 | import Data.Attoparsec.Text
9 | import Data.Text.IO
10 | import Data.Text (unwords, unlines, pack, unpack)
11 | import System.Exit
12 | import System.IO (stderr)
13 | import Data.Maybe
14 | import Control.Applicative
15 | import Data.Monoid
16 | import Data.List (intersperse)
17 | import Data.Char
18 | import Control.Monad
19 |
20 | import Debug.Trace
21 |
22 | main = do
23 | proto <- readFile "ql2.proto"
24 | case parseOnly protoFile proto of
25 | Left err -> hPutStrLn stderr ("Error: " <> pack err) >> exitWith ExitSuccess
26 | Right mod -> do
27 | writeFile "Database/RethinkDB/Wire.hs" genRaw
28 | forM_ mod $ \(name, enums) ->
29 | maybe (return ()) (writeFile (unpack $ "Database/RethinkDB/Wire/" <> name <> ".hs"))
30 | (renderMessage (name, enums))
31 |
32 | protoFile = tr "protoFile" $ do
33 | many message
34 |
35 | message = tr "message" $ do
36 | token "message"
37 | n <- name
38 | token "{"
39 | body <- catMaybes <$> many justEnums
40 | token "}"
41 | return (n, body)
42 |
43 | justEnums = tr "justEnums" $ choice [
44 | Just <$> enum,
45 | const Nothing <$> field,
46 | const Nothing <$> message
47 | ]
48 |
49 | field = tr "field" $ do
50 | choice [token "repeated", token "optional", token "extensions"]
51 | skipWhile (/=';')
52 | string ";"
53 |
54 | enum = tr "enum" $ do
55 | token "enum"
56 | n <- name
57 | token "{"
58 | d <- many decl
59 | token "}"
60 | return (n,d)
61 |
62 | decl = tr "decl" $ do
63 | n <- name
64 | token "="
65 | v <- value
66 | choice [token ";", string ";"]
67 | return (n,v)
68 |
69 | value = tr "value" $ whitespace >> takeWhile (\c -> not (isSpace c) && c /= ';')
70 |
71 | name = tr "name" $ whitespace >> takeWhile1 (`elem` alphanum)
72 |
73 | alphanum = "_" <> ['a'..'z'] <> ['A'..'Z'] <> ['0'..'9']
74 |
75 | token s = tr ("token " ++ show s) $ whitespace >> string s
76 |
77 | whitespace = do
78 | many1 $ choice [
79 | satisfy isSpace >> skipWhile isSpace,
80 | string "//" >> skipWhile (not . isEndOfLine) ]
81 | return ()
82 |
83 | genRaw = unlines $ [
84 | "module Database.RethinkDB.Wire where",
85 | "class WireValue a where",
86 | " toWire :: a -> Int",
87 | " fromWire :: Int -> Maybe a"
88 | ]
89 |
90 | renderMessage (name, []) = Nothing
91 | renderMessage (name, enums) = Just $ unlines $ [
92 | unwords ["module", "Database.RethinkDB.Wire." <> name, "where"],
93 | "import Prelude (Maybe(..), Eq, Show)",
94 | "import Database.RethinkDB.Wire"
95 | ] ++ map renderEnum enums
96 |
97 | renderEnum (name, decls) = unlines $ [
98 | unwords $ ["data", name, "="] <> intersperse "|" (map fst decls),
99 | " deriving (Eq, Show)",
100 | unwords ["instance WireValue", name, "where"],
101 | indent $
102 | (for decls $ \(var, val) -> "toWire " <> var <> " = " <> val) <>
103 | (for decls $ \(var, val) -> "fromWire " <> val <> " = Just " <> var) <>
104 | ["fromWire _ = Nothing"]
105 | ]
106 |
107 |
108 | indent = unlines . map (" " <>)
109 |
110 | for = flip map
111 |
112 | tr s p = p > s
113 |
--------------------------------------------------------------------------------
/ql2.proto:
--------------------------------------------------------------------------------
1 | ////////////////////////////////////////////////////////////////////////////////
2 | // THE HIGH-LEVEL VIEW //
3 | ////////////////////////////////////////////////////////////////////////////////
4 |
5 | // Process: When you first open a connection, send the magic number
6 | // for the version of the protobuf you're targeting (in the [Version]
7 | // enum). This should **NOT** be sent as a protobuf; just send the
8 | // little-endian 32-bit integer over the wire raw. This number should
9 | // only be sent once per connection.
10 |
11 | // The magic number shall be followed by an authorization key. The
12 | // first 4 bytes are the length of the key to be sent as a little-endian
13 | // 32-bit integer, followed by the key string. Even if there is no key,
14 | // an empty string should be sent (length 0 and no data).
15 |
16 | // Following the authorization key, the client shall send a magic number
17 | // for the communication protocol they want to use (in the [Protocol]
18 | // enum). This shall be a little-endian 32-bit integer.
19 |
20 | // The server will then respond with a NULL-terminated string response.
21 | // "SUCCESS" indicates that the connection has been accepted. Any other
22 | // response indicates an error, and the response string should describe
23 | // the error.
24 |
25 | // Next, for each query you want to send, construct a [Query] protobuf
26 | // and serialize it to a binary blob. Send the blob's size to the
27 | // server encoded as a little-endian 32-bit integer, followed by the
28 | // blob itself. You will recieve a [Response] protobuf back preceded
29 | // by its own size, once again encoded as a little-endian 32-bit
30 | // integer. You can see an example exchange below in **EXAMPLE**.
31 |
32 | // A query consists of a [Term] to evaluate and a unique-per-connection
33 | // [token].
34 |
35 | // Tokens are used for two things:
36 | // * Keeping track of which responses correspond to which queries.
37 | // * Batched queries. Some queries return lots of results, so we send back
38 | // batches of <1000, and you need to send a [CONTINUE] query with the same
39 | // token to get more results from the original query.
40 | ////////////////////////////////////////////////////////////////////////////////
41 |
42 | message VersionDummy { // We need to wrap it like this for some
43 | // non-conforming protobuf libraries
44 | // This enum contains the magic numbers for your version. See **THE HIGH-LEVEL
45 | // VIEW** for what to do with it.
46 | enum Version {
47 | V0_1 = 0x3f61ba36;
48 | V0_2 = 0x723081e1; // Authorization key during handshake
49 | V0_3 = 0x5f75e83e; // Authorization key and protocol during handshake
50 | V0_4 = 0x400c2d20; // Queries execute in parallel
51 | }
52 |
53 | // The protocol to use after the handshake, specified in V0_3
54 | enum Protocol {
55 | PROTOBUF = 0x271ffc41;
56 | JSON = 0x7e6970c7;
57 | }
58 | }
59 |
60 | // You send one of:
61 | // * A [START] query with a [Term] to evaluate and a unique-per-connection token.
62 | // * A [CONTINUE] query with the same token as a [START] query that returned
63 | // [SUCCESS_PARTIAL] in its [Response].
64 | // * A [STOP] query with the same token as a [START] query that you want to stop.
65 | // * A [NOREPLY_WAIT] query with a unique per-connection token. The server answers
66 | // with a [WAIT_COMPLETE] [Response].
67 | // * A [SERVER_INFO] query. The server answers with a [SERVER_INFO] [Response].
68 | message Query {
69 | enum QueryType {
70 | START = 1; // Start a new query.
71 | CONTINUE = 2; // Continue a query that returned [SUCCESS_PARTIAL]
72 | // (see [Response]).
73 | STOP = 3; // Stop a query partway through executing.
74 | NOREPLY_WAIT = 4;
75 | // Wait for noreply operations to finish.
76 | SERVER_INFO = 5;
77 | // Get server information.
78 | }
79 | optional QueryType type = 1;
80 | // A [Term] is how we represent the operations we want a query to perform.
81 | optional Term query = 2; // only present when [type] = [START]
82 | optional int64 token = 3;
83 | // This flag is ignored on the server. `noreply` should be added
84 | // to `global_optargs` instead (the key "noreply" should map to
85 | // either true or false).
86 | optional bool OBSOLETE_noreply = 4 [default = false];
87 |
88 | // If this is set to [true], then [Datum] values will sometimes be
89 | // of [DatumType] [R_JSON] (see below). This can provide enormous
90 | // speedups in languages with poor protobuf libraries.
91 | optional bool accepts_r_json = 5 [default = false];
92 |
93 | message AssocPair {
94 | optional string key = 1;
95 | optional Term val = 2;
96 | }
97 | repeated AssocPair global_optargs = 6;
98 | }
99 |
100 | // A backtrace frame (see `backtrace` in Response below)
101 | message Frame {
102 | enum FrameType {
103 | POS = 1; // Error occured in a positional argument.
104 | OPT = 2; // Error occured in an optional argument.
105 | }
106 | optional FrameType type = 1;
107 | optional int64 pos = 2; // The index of the positional argument.
108 | optional string opt = 3; // The name of the optional argument.
109 | }
110 | message Backtrace {
111 | repeated Frame frames = 1;
112 | }
113 |
114 | // You get back a response with the same [token] as your query.
115 | message Response {
116 | enum ResponseType {
117 | // These response types indicate success.
118 | SUCCESS_ATOM = 1; // Query returned a single RQL datatype.
119 | SUCCESS_SEQUENCE = 2; // Query returned a sequence of RQL datatypes.
120 | SUCCESS_PARTIAL = 3; // Query returned a partial sequence of RQL
121 | // datatypes. If you send a [CONTINUE] query with
122 | // the same token as this response, you will get
123 | // more of the sequence. Keep sending [CONTINUE]
124 | // queries until you get back [SUCCESS_SEQUENCE].
125 | WAIT_COMPLETE = 4; // A [NOREPLY_WAIT] query completed.
126 | SERVER_INFO = 5; // The data for a [SERVER_INFO] request.
127 |
128 | // These response types indicate failure.
129 | CLIENT_ERROR = 16; // Means the client is buggy. An example is if the
130 | // client sends a malformed protobuf, or tries to
131 | // send [CONTINUE] for an unknown token.
132 | COMPILE_ERROR = 17; // Means the query failed during parsing or type
133 | // checking. For example, if you pass too many
134 | // arguments to a function.
135 | RUNTIME_ERROR = 18; // Means the query failed at runtime. An example is
136 | // if you add together two values from a table, but
137 | // they turn out at runtime to be booleans rather
138 | // than numbers.
139 | }
140 | optional ResponseType type = 1;
141 |
142 | // If `ResponseType` is `RUNTIME_ERROR`, this may be filled in with more
143 | // information about the error.
144 | enum ErrorType {
145 | INTERNAL = 1000000;
146 | RESOURCE_LIMIT = 2000000;
147 | QUERY_LOGIC = 3000000;
148 | NON_EXISTENCE = 3100000;
149 | OP_FAILED = 4100000;
150 | OP_INDETERMINATE = 4200000;
151 | USER = 5000000;
152 | }
153 | optional ErrorType error_type = 7;
154 |
155 | // ResponseNotes are used to provide information about the query
156 | // response that may be useful for people writing drivers or ORMs.
157 | // Currently all the notes we send indicate that a stream has certain
158 | // special properties.
159 | enum ResponseNote {
160 | // The stream is a changefeed stream (e.g. `r.table('test').changes()`).
161 | SEQUENCE_FEED = 1;
162 | // The stream is a point changefeed stream
163 | // (e.g. `r.table('test').get(0).changes()`).
164 | ATOM_FEED = 2;
165 | // The stream is an order_by_limit changefeed stream
166 | // (e.g. `r.table('test').order_by(index: 'id').limit(5).changes()`).
167 | ORDER_BY_LIMIT_FEED = 3;
168 | // The stream is a union of multiple changefeed types that can't be
169 | // collapsed to a single type
170 | // (e.g. `r.table('test').changes().union(r.table('test').get(0).changes())`).
171 | UNIONED_FEED = 4;
172 | // The stream is a changefeed stream and includes notes on what state
173 | // the changefeed stream is in (e.g. objects of the form `{state:
174 | // 'initializing'}`).
175 | INCLUDES_STATES = 5;
176 | }
177 | repeated ResponseNote notes = 6;
178 |
179 | optional int64 token = 2; // Indicates what [Query] this response corresponds to.
180 |
181 | // [response] contains 1 RQL datum if [type] is [SUCCESS_ATOM], or many RQL
182 | // data if [type] is [SUCCESS_SEQUENCE] or [SUCCESS_PARTIAL]. It contains 1
183 | // error message (of type [R_STR]) in all other cases.
184 | repeated Datum response = 3;
185 |
186 | // If [type] is [CLIENT_ERROR], [TYPE_ERROR], or [RUNTIME_ERROR], then a
187 | // backtrace will be provided. The backtrace says where in the query the
188 | // error occured. Ideally this information will be presented to the user as
189 | // a pretty-printed version of their query with the erroneous section
190 | // underlined. A backtrace is a series of 0 or more [Frame]s, each of which
191 | // specifies either the index of a positional argument or the name of an
192 | // optional argument. (Those words will make more sense if you look at the
193 | // [Term] message below.)
194 | optional Backtrace backtrace = 4; // Contains n [Frame]s when you get back an error.
195 |
196 | // If the [global_optargs] in the [Query] that this [Response] is a
197 | // response to contains a key "profile" which maps to a static value of
198 | // true then [profile] will contain a [Datum] which provides profiling
199 | // information about the execution of the query. This field should be
200 | // returned to the user along with the result that would normally be
201 | // returned (a datum or a cursor). In official drivers this is accomplished
202 | // by putting them inside of an object with "value" mapping to the return
203 | // value and "profile" mapping to the profile object.
204 | optional Datum profile = 5;
205 | }
206 |
207 | // A [Datum] is a chunk of data that can be serialized to disk or returned to
208 | // the user in a Response. Currently we only support JSON types, but we may
209 | // support other types in the future (e.g., a date type or an integer type).
210 | message Datum {
211 | enum DatumType {
212 | R_NULL = 1;
213 | R_BOOL = 2;
214 | R_NUM = 3; // a double
215 | R_STR = 4;
216 | R_ARRAY = 5;
217 | R_OBJECT = 6;
218 | // This [DatumType] will only be used if [accepts_r_json] is
219 | // set to [true] in [Query]. [r_str] will be filled with a
220 | // JSON encoding of the [Datum].
221 | R_JSON = 7; // uses r_str
222 | }
223 | optional DatumType type = 1;
224 | optional bool r_bool = 2;
225 | optional double r_num = 3;
226 | optional string r_str = 4;
227 |
228 | repeated Datum r_array = 5;
229 | message AssocPair {
230 | optional string key = 1;
231 | optional Datum val = 2;
232 | }
233 | repeated AssocPair r_object = 6;
234 | }
235 |
236 | // A [Term] is either a piece of data (see **Datum** above), or an operator and
237 | // its operands. If you have a [Datum], it's stored in the member [datum]. If
238 | // you have an operator, its positional arguments are stored in [args] and its
239 | // optional arguments are stored in [optargs].
240 | //
241 | // A note about type signatures:
242 | // We use the following notation to denote types:
243 | // arg1_type, arg2_type, argrest_type... -> result_type
244 | // So, for example, if we have a function `avg` that takes any number of
245 | // arguments and averages them, we might write:
246 | // NUMBER... -> NUMBER
247 | // Or if we had a function that took one number modulo another:
248 | // NUMBER, NUMBER -> NUMBER
249 | // Or a function that takes a table and a primary key of any Datum type, then
250 | // retrieves the entry with that primary key:
251 | // Table, DATUM -> OBJECT
252 | // Some arguments must be provided as literal values (and not the results of sub
253 | // terms). These are marked with a `!`.
254 | // Optional arguments are specified within curly braces as argname `:` value
255 | // type (e.x `{noreply:BOOL}`)
256 | // Many RQL operations are polymorphic. For these, alterantive type signatures
257 | // are separated by `|`.
258 | //
259 | // The RQL type hierarchy is as follows:
260 | // Top
261 | // DATUM
262 | // NULL
263 | // BOOL
264 | // NUMBER
265 | // STRING
266 | // OBJECT
267 | // SingleSelection
268 | // ARRAY
269 | // Sequence
270 | // ARRAY
271 | // Stream
272 | // StreamSelection
273 | // Table
274 | // Database
275 | // Function
276 | // Ordering - used only by ORDER_BY
277 | // Pathspec -- an object, string, or array that specifies a path
278 | // Error
279 | message Term {
280 | enum TermType {
281 | // A RQL datum, stored in `datum` below.
282 | DATUM = 1;
283 |
284 | MAKE_ARRAY = 2; // DATUM... -> ARRAY
285 | // Evaluate the terms in [optargs] and make an object
286 | MAKE_OBJ = 3; // {...} -> OBJECT
287 |
288 | // * Compound types
289 |
290 | // Takes an integer representing a variable and returns the value stored
291 | // in that variable. It's the responsibility of the client to translate
292 | // from their local representation of a variable to a unique _non-negative_
293 | // integer for that variable. (We do it this way instead of letting
294 | // clients provide variable names as strings to discourage
295 | // variable-capturing client libraries, and because it's more efficient
296 | // on the wire.)
297 | VAR = 10; // !NUMBER -> DATUM
298 | // Takes some javascript code and executes it.
299 | JAVASCRIPT = 11; // STRING {timeout: !NUMBER} -> DATUM |
300 | // STRING {timeout: !NUMBER} -> Function(*)
301 | UUID = 169; // () -> DATUM
302 |
303 | // Takes an HTTP URL and gets it. If the get succeeds and
304 | // returns valid JSON, it is converted into a DATUM
305 | HTTP = 153; // STRING {data: OBJECT | STRING,
306 | // timeout: !NUMBER,
307 | // method: STRING,
308 | // params: OBJECT,
309 | // header: OBJECT | ARRAY,
310 | // attempts: NUMBER,
311 | // redirects: NUMBER,
312 | // verify: BOOL,
313 | // page: FUNC | STRING,
314 | // page_limit: NUMBER,
315 | // auth: OBJECT,
316 | // result_format: STRING,
317 | // } -> STRING | STREAM
318 |
319 | // Takes a string and throws an error with that message.
320 | // Inside of a `default` block, you can omit the first
321 | // argument to rethrow whatever error you catch (this is most
322 | // useful as an argument to the `default` filter optarg).
323 | ERROR = 12; // STRING -> Error | -> Error
324 | // Takes nothing and returns a reference to the implicit variable.
325 | IMPLICIT_VAR = 13; // -> DATUM
326 |
327 | // * Data Operators
328 | // Returns a reference to a database.
329 | DB = 14; // STRING -> Database
330 | // Returns a reference to a table.
331 | TABLE = 15; // Database, STRING, {read_mode:STRING, identifier_format:STRING} -> Table
332 | // STRING, {read_mode:STRING, identifier_format:STRING} -> Table
333 | // Gets a single element from a table by its primary or a secondary key.
334 | GET = 16; // Table, STRING -> SingleSelection | Table, NUMBER -> SingleSelection |
335 | // Table, STRING -> NULL | Table, NUMBER -> NULL |
336 | GET_ALL = 78; // Table, DATUM..., {index:!STRING} => ARRAY
337 |
338 | // Simple DATUM Ops
339 | EQ = 17; // DATUM... -> BOOL
340 | NE = 18; // DATUM... -> BOOL
341 | LT = 19; // DATUM... -> BOOL
342 | LE = 20; // DATUM... -> BOOL
343 | GT = 21; // DATUM... -> BOOL
344 | GE = 22; // DATUM... -> BOOL
345 | NOT = 23; // BOOL -> BOOL
346 | // ADD can either add two numbers or concatenate two arrays.
347 | ADD = 24; // NUMBER... -> NUMBER | STRING... -> STRING
348 | SUB = 25; // NUMBER... -> NUMBER
349 | MUL = 26; // NUMBER... -> NUMBER
350 | DIV = 27; // NUMBER... -> NUMBER
351 | MOD = 28; // NUMBER, NUMBER -> NUMBER
352 |
353 | FLOOR = 183; // NUMBER -> NUMBER
354 | CEIL = 184; // NUMBER -> NUMBER
355 | ROUND = 185; // NUMBER -> NUMBER
356 |
357 | // DATUM Array Ops
358 | // Append a single element to the end of an array (like `snoc`).
359 | APPEND = 29; // ARRAY, DATUM -> ARRAY
360 | // Prepend a single element to the end of an array (like `cons`).
361 | PREPEND = 80; // ARRAY, DATUM -> ARRAY
362 | //Remove the elements of one array from another array.
363 | DIFFERENCE = 95; // ARRAY, ARRAY -> ARRAY
364 |
365 | // DATUM Set Ops
366 | // Set ops work on arrays. They don't use actual sets and thus have
367 | // performance characteristics you would expect from arrays rather than
368 | // from sets. All set operations have the post condition that they
369 | // array they return contains no duplicate values.
370 | SET_INSERT = 88; // ARRAY, DATUM -> ARRAY
371 | SET_INTERSECTION = 89; // ARRAY, ARRAY -> ARRAY
372 | SET_UNION = 90; // ARRAY, ARRAY -> ARRAY
373 | SET_DIFFERENCE = 91; // ARRAY, ARRAY -> ARRAY
374 |
375 | SLICE = 30; // Sequence, NUMBER, NUMBER -> Sequence
376 | SKIP = 70; // Sequence, NUMBER -> Sequence
377 | LIMIT = 71; // Sequence, NUMBER -> Sequence
378 | OFFSETS_OF = 87; // Sequence, DATUM -> Sequence | Sequence, Function(1) -> Sequence
379 | CONTAINS = 93; // Sequence, (DATUM | Function(1))... -> BOOL
380 |
381 | // Stream/Object Ops
382 | // Get a particular field from an object, or map that over a
383 | // sequence.
384 | GET_FIELD = 31; // OBJECT, STRING -> DATUM
385 | // | Sequence, STRING -> Sequence
386 | // Return an array containing the keys of the object.
387 | KEYS = 94; // OBJECT -> ARRAY
388 | // Return an array containing the values of the object.
389 | VALUES = 186; // OBJECT -> ARRAY
390 | // Creates an object
391 | OBJECT = 143; // STRING, DATUM, ... -> OBJECT
392 | // Check whether an object contains all the specified fields,
393 | // or filters a sequence so that all objects inside of it
394 | // contain all the specified fields.
395 | HAS_FIELDS = 32; // OBJECT, Pathspec... -> BOOL
396 | // x.with_fields(...) <=> x.has_fields(...).pluck(...)
397 | WITH_FIELDS = 96; // Sequence, Pathspec... -> Sequence
398 | // Get a subset of an object by selecting some attributes to preserve,
399 | // or map that over a sequence. (Both pick and pluck, polymorphic.)
400 | PLUCK = 33; // Sequence, Pathspec... -> Sequence | OBJECT, Pathspec... -> OBJECT
401 | // Get a subset of an object by selecting some attributes to discard, or
402 | // map that over a sequence. (Both unpick and without, polymorphic.)
403 | WITHOUT = 34; // Sequence, Pathspec... -> Sequence | OBJECT, Pathspec... -> OBJECT
404 | // Merge objects (right-preferential)
405 | MERGE = 35; // OBJECT... -> OBJECT | Sequence -> Sequence
406 |
407 | // Sequence Ops
408 | // Get all elements of a sequence between two values.
409 | // Half-open by default, but the openness of either side can be
410 | // changed by passing 'closed' or 'open for `right_bound` or
411 | // `left_bound`.
412 | BETWEEN_DEPRECATED = 36; // Deprecated version of between, which allows `null` to specify unboundedness
413 | // With the newer version, clients should use `r.minval` and `r.maxval` for unboundedness
414 | BETWEEN = 182; // StreamSelection, DATUM, DATUM, {index:!STRING, right_bound:STRING, left_bound:STRING} -> StreamSelection
415 | REDUCE = 37; // Sequence, Function(2) -> DATUM
416 | MAP = 38; // Sequence, Function(1) -> Sequence
417 | // The arity of the function should be
418 | // Sequence..., Function(sizeof...(Sequence)) -> Sequence
419 |
420 | // Filter a sequence with either a function or a shortcut
421 | // object (see API docs for details). The body of FILTER is
422 | // wrapped in an implicit `.default(false)`, and you can
423 | // change the default value by specifying the `default`
424 | // optarg. If you make the default `r.error`, all errors
425 | // caught by `default` will be rethrown as if the `default`
426 | // did not exist.
427 | FILTER = 39; // Sequence, Function(1), {default:DATUM} -> Sequence |
428 | // Sequence, OBJECT, {default:DATUM} -> Sequence
429 | // Map a function over a sequence and then concatenate the results together.
430 | CONCAT_MAP = 40; // Sequence, Function(1) -> Sequence
431 | // Order a sequence based on one or more attributes.
432 | ORDER_BY = 41; // Sequence, (!STRING | Ordering)..., {index: (!STRING | Ordering)} -> Sequence
433 | // Get all distinct elements of a sequence (like `uniq`).
434 | DISTINCT = 42; // Sequence -> Sequence
435 | // Count the number of elements in a sequence, or only the elements that match
436 | // a given filter.
437 | COUNT = 43; // Sequence -> NUMBER | Sequence, DATUM -> NUMBER | Sequence, Function(1) -> NUMBER
438 | IS_EMPTY = 86; // Sequence -> BOOL
439 | // Take the union of multiple sequences (preserves duplicate elements! (use distinct)).
440 | UNION = 44; // Sequence... -> Sequence
441 | // Get the Nth element of a sequence.
442 | NTH = 45; // Sequence, NUMBER -> DATUM
443 | // do NTH or GET_FIELD depending on target object
444 | BRACKET = 170; // Sequence | OBJECT, NUMBER | STRING -> DATUM
445 | // OBSOLETE_GROUPED_MAPREDUCE = 46;
446 | // OBSOLETE_GROUPBY = 47;
447 |
448 | INNER_JOIN = 48; // Sequence, Sequence, Function(2) -> Sequence
449 | OUTER_JOIN = 49; // Sequence, Sequence, Function(2) -> Sequence
450 | // An inner-join that does an equality comparison on two attributes.
451 | EQ_JOIN = 50; // Sequence, !STRING, Sequence, {index:!STRING} -> Sequence
452 | ZIP = 72; // Sequence -> Sequence
453 | RANGE = 173; // -> Sequence [0, +inf)
454 | // NUMBER -> Sequence [0, a)
455 | // NUMBER, NUMBER -> Sequence [a, b)
456 |
457 | // Array Ops
458 | // Insert an element in to an array at a given index.
459 | INSERT_AT = 82; // ARRAY, NUMBER, DATUM -> ARRAY
460 | // Remove an element at a given index from an array.
461 | DELETE_AT = 83; // ARRAY, NUMBER -> ARRAY |
462 | // ARRAY, NUMBER, NUMBER -> ARRAY
463 | // Change the element at a given index of an array.
464 | CHANGE_AT = 84; // ARRAY, NUMBER, DATUM -> ARRAY
465 | // Splice one array in to another array.
466 | SPLICE_AT = 85; // ARRAY, NUMBER, ARRAY -> ARRAY
467 |
468 | // * Type Ops
469 | // Coerces a datum to a named type (e.g. "bool").
470 | // If you previously used `stream_to_array`, you should use this instead
471 | // with the type "array".
472 | COERCE_TO = 51; // Top, STRING -> Top
473 | // Returns the named type of a datum (e.g. TYPE_OF(true) = "BOOL")
474 | TYPE_OF = 52; // Top -> STRING
475 |
476 | // * Write Ops (the OBJECTs contain data about number of errors etc.)
477 | // Updates all the rows in a selection. Calls its Function with the row
478 | // to be updated, and then merges the result of that call.
479 | UPDATE = 53; // StreamSelection, Function(1), {non_atomic:BOOL, durability:STRING, return_changes:BOOL} -> OBJECT |
480 | // SingleSelection, Function(1), {non_atomic:BOOL, durability:STRING, return_changes:BOOL} -> OBJECT |
481 | // StreamSelection, OBJECT, {non_atomic:BOOL, durability:STRING, return_changes:BOOL} -> OBJECT |
482 | // SingleSelection, OBJECT, {non_atomic:BOOL, durability:STRING, return_changes:BOOL} -> OBJECT
483 | // Deletes all the rows in a selection.
484 | DELETE = 54; // StreamSelection, {durability:STRING, return_changes:BOOL} -> OBJECT | SingleSelection -> OBJECT
485 | // Replaces all the rows in a selection. Calls its Function with the row
486 | // to be replaced, and then discards it and stores the result of that
487 | // call.
488 | REPLACE = 55; // StreamSelection, Function(1), {non_atomic:BOOL, durability:STRING, return_changes:BOOL} -> OBJECT | SingleSelection, Function(1), {non_atomic:BOOL, durability:STRING, return_changes:BOOL} -> OBJECT
489 | // Inserts into a table. If `conflict` is replace, overwrites
490 | // entries with the same primary key. If `conflict` is
491 | // update, does an update on the entry. If `conflict` is
492 | // error, or is omitted, conflicts will trigger an error.
493 | INSERT = 56; // Table, OBJECT, {conflict:STRING, durability:STRING, return_changes:BOOL} -> OBJECT | Table, Sequence, {conflict:STRING, durability:STRING, return_changes:BOOL} -> OBJECT
494 |
495 | // * Administrative OPs
496 | // Creates a database with a particular name.
497 | DB_CREATE = 57; // STRING -> OBJECT
498 | // Drops a database with a particular name.
499 | DB_DROP = 58; // STRING -> OBJECT
500 | // Lists all the databases by name. (Takes no arguments)
501 | DB_LIST = 59; // -> ARRAY
502 | // Creates a table with a particular name in a particular
503 | // database. (You may omit the first argument to use the
504 | // default database.)
505 | TABLE_CREATE = 60; // Database, STRING, {primary_key:STRING, shards:NUMBER, replicas:NUMBER, primary_replica_tag:STRING} -> OBJECT
506 | // Database, STRING, {primary_key:STRING, shards:NUMBER, replicas:OBJECT, primary_replica_tag:STRING} -> OBJECT
507 | // STRING, {primary_key:STRING, shards:NUMBER, replicas:NUMBER, primary_replica_tag:STRING} -> OBJECT
508 | // STRING, {primary_key:STRING, shards:NUMBER, replicas:OBJECT, primary_replica_tag:STRING} -> OBJECT
509 | // Drops a table with a particular name from a particular
510 | // database. (You may omit the first argument to use the
511 | // default database.)
512 | TABLE_DROP = 61; // Database, STRING -> OBJECT
513 | // STRING -> OBJECT
514 | // Lists all the tables in a particular database. (You may
515 | // omit the first argument to use the default database.)
516 | TABLE_LIST = 62; // Database -> ARRAY
517 | // -> ARRAY
518 | // Returns the row in the `rethinkdb.table_config` or `rethinkdb.db_config` table
519 | // that corresponds to the given database or table.
520 | CONFIG = 174; // Database -> SingleSelection
521 | // Table -> SingleSelection
522 | // Returns the row in the `rethinkdb.table_status` table that corresponds to the
523 | // given table.
524 | STATUS = 175; // Table -> SingleSelection
525 | // Called on a table, waits for that table to be ready for read/write operations.
526 | // Called on a database, waits for all of the tables in the database to be ready.
527 | // Returns the corresponding row or rows from the `rethinkdb.table_status` table.
528 | WAIT = 177; // Table -> OBJECT
529 | // Database -> OBJECT
530 | // Generates a new config for the given table, or all tables in the given database
531 | // The `shards` and `replicas` arguments are required. If `emergency_repair` is
532 | // specified, it will enter a completely different mode of repairing a table
533 | // which has lost half or more of its replicas.
534 | RECONFIGURE = 176; // Database|Table, {shards:NUMBER, replicas:NUMBER [,
535 | // dry_run:BOOLEAN]
536 | // } -> OBJECT
537 | // Database|Table, {shards:NUMBER, replicas:OBJECT [,
538 | // primary_replica_tag:STRING,
539 | // nonvoting_replica_tags:ARRAY,
540 | // dry_run:BOOLEAN]
541 | // } -> OBJECT
542 | // Table, {emergency_repair:STRING, dry_run:BOOLEAN} -> OBJECT
543 | // Balances the table's shards but leaves everything else the same. Can also be
544 | // applied to an entire database at once.
545 | REBALANCE = 179; // Table -> OBJECT
546 | // Database -> OBJECT
547 |
548 | // Ensures that previously issued soft-durability writes are complete and
549 | // written to disk.
550 | SYNC = 138; // Table -> OBJECT
551 |
552 | // * Secondary indexes OPs
553 | // Creates a new secondary index with a particular name and definition.
554 | INDEX_CREATE = 75; // Table, STRING, Function(1), {multi:BOOL} -> OBJECT
555 | // Drops a secondary index with a particular name from the specified table.
556 | INDEX_DROP = 76; // Table, STRING -> OBJECT
557 | // Lists all secondary indexes on a particular table.
558 | INDEX_LIST = 77; // Table -> ARRAY
559 | // Gets information about whether or not a set of indexes are ready to
560 | // be accessed. Returns a list of objects that look like this:
561 | // {index:STRING, ready:BOOL[, progress:NUMBER]}
562 | INDEX_STATUS = 139; // Table, STRING... -> ARRAY
563 | // Blocks until a set of indexes are ready to be accessed. Returns the
564 | // same values INDEX_STATUS.
565 | INDEX_WAIT = 140; // Table, STRING... -> ARRAY
566 | // Renames the given index to a new name
567 | INDEX_RENAME = 156; // Table, STRING, STRING, {overwrite:BOOL} -> OBJECT
568 |
569 | // * Control Operators
570 | // Calls a function on data
571 | FUNCALL = 64; // Function(*), DATUM... -> DATUM
572 | // Executes its first argument, and returns its second argument if it
573 | // got [true] or its third argument if it got [false] (like an `if`
574 | // statement).
575 | BRANCH = 65; // BOOL, Top, Top -> Top
576 | // Returns true if any of its arguments returns true (short-circuits).
577 | OR = 66; // BOOL... -> BOOL
578 | // Returns true if all of its arguments return true (short-circuits).
579 | AND = 67; // BOOL... -> BOOL
580 | // Calls its Function with each entry in the sequence
581 | // and executes the array of terms that Function returns.
582 | FOR_EACH = 68; // Sequence, Function(1) -> OBJECT
583 |
584 | ////////////////////////////////////////////////////////////////////////////////
585 | ////////// Special Terms
586 | ////////////////////////////////////////////////////////////////////////////////
587 |
588 | // An anonymous function. Takes an array of numbers representing
589 | // variables (see [VAR] above), and a [Term] to execute with those in
590 | // scope. Returns a function that may be passed an array of arguments,
591 | // then executes the Term with those bound to the variable names. The
592 | // user will never construct this directly. We use it internally for
593 | // things like `map` which take a function. The "arity" of a [Function] is
594 | // the number of arguments it takes.
595 | // For example, here's what `_X_.map{|x| x+2}` turns into:
596 | // Term {
597 | // type = MAP;
598 | // args = [_X_,
599 | // Term {
600 | // type = Function;
601 | // args = [Term {
602 | // type = DATUM;
603 | // datum = Datum {
604 | // type = R_ARRAY;
605 | // r_array = [Datum { type = R_NUM; r_num = 1; }];
606 | // };
607 | // },
608 | // Term {
609 | // type = ADD;
610 | // args = [Term {
611 | // type = VAR;
612 | // args = [Term {
613 | // type = DATUM;
614 | // datum = Datum { type = R_NUM;
615 | // r_num = 1};
616 | // }];
617 | // },
618 | // Term {
619 | // type = DATUM;
620 | // datum = Datum { type = R_NUM; r_num = 2; };
621 | // }];
622 | // }];
623 | // }];
624 | FUNC = 69; // ARRAY, Top -> ARRAY -> Top
625 |
626 | // Indicates to ORDER_BY that this attribute is to be sorted in ascending order.
627 | ASC = 73; // !STRING -> Ordering
628 | // Indicates to ORDER_BY that this attribute is to be sorted in descending order.
629 | DESC = 74; // !STRING -> Ordering
630 |
631 | // Gets info about anything. INFO is most commonly called on tables.
632 | INFO = 79; // Top -> OBJECT
633 |
634 | // `a.match(b)` returns a match object if the string `a`
635 | // matches the regular expression `b`.
636 | MATCH = 97; // STRING, STRING -> DATUM
637 |
638 | // Change the case of a string.
639 | UPCASE = 141; // STRING -> STRING
640 | DOWNCASE = 142; // STRING -> STRING
641 |
642 | // Select a number of elements from sequence with uniform distribution.
643 | SAMPLE = 81; // Sequence, NUMBER -> Sequence
644 |
645 | // Evaluates its first argument. If that argument returns
646 | // NULL or throws an error related to the absence of an
647 | // expected value (for instance, accessing a non-existent
648 | // field or adding NULL to an integer), DEFAULT will either
649 | // return its second argument or execute it if it's a
650 | // function. If the second argument is a function, it will be
651 | // passed either the text of the error or NULL as its
652 | // argument.
653 | DEFAULT = 92; // Top, Top -> Top
654 |
655 | // Parses its first argument as a json string and returns it as a
656 | // datum.
657 | JSON = 98; // STRING -> DATUM
658 | // Returns the datum as a JSON string.
659 | // N.B.: we would really prefer this be named TO_JSON and that exists as
660 | // an alias in Python and JavaScript drivers; however it conflicts with the
661 | // standard `to_json` method defined by Ruby's standard json library.
662 | TO_JSON_STRING = 172; // DATUM -> STRING
663 |
664 | // Parses its first arguments as an ISO 8601 time and returns it as a
665 | // datum.
666 | ISO8601 = 99; // STRING -> PSEUDOTYPE(TIME)
667 | // Prints a time as an ISO 8601 time.
668 | TO_ISO8601 = 100; // PSEUDOTYPE(TIME) -> STRING
669 |
670 | // Returns a time given seconds since epoch in UTC.
671 | EPOCH_TIME = 101; // NUMBER -> PSEUDOTYPE(TIME)
672 | // Returns seconds since epoch in UTC given a time.
673 | TO_EPOCH_TIME = 102; // PSEUDOTYPE(TIME) -> NUMBER
674 |
675 | // The time the query was received by the server.
676 | NOW = 103; // -> PSEUDOTYPE(TIME)
677 | // Puts a time into an ISO 8601 timezone.
678 | IN_TIMEZONE = 104; // PSEUDOTYPE(TIME), STRING -> PSEUDOTYPE(TIME)
679 | // a.during(b, c) returns whether a is in the range [b, c)
680 | DURING = 105; // PSEUDOTYPE(TIME), PSEUDOTYPE(TIME), PSEUDOTYPE(TIME) -> BOOL
681 | // Retrieves the date portion of a time.
682 | DATE = 106; // PSEUDOTYPE(TIME) -> PSEUDOTYPE(TIME)
683 | // x.time_of_day == x.date - x
684 | TIME_OF_DAY = 126; // PSEUDOTYPE(TIME) -> NUMBER
685 | // Returns the timezone of a time.
686 | TIMEZONE = 127; // PSEUDOTYPE(TIME) -> STRING
687 |
688 | // These access the various components of a time.
689 | YEAR = 128; // PSEUDOTYPE(TIME) -> NUMBER
690 | MONTH = 129; // PSEUDOTYPE(TIME) -> NUMBER
691 | DAY = 130; // PSEUDOTYPE(TIME) -> NUMBER
692 | DAY_OF_WEEK = 131; // PSEUDOTYPE(TIME) -> NUMBER
693 | DAY_OF_YEAR = 132; // PSEUDOTYPE(TIME) -> NUMBER
694 | HOURS = 133; // PSEUDOTYPE(TIME) -> NUMBER
695 | MINUTES = 134; // PSEUDOTYPE(TIME) -> NUMBER
696 | SECONDS = 135; // PSEUDOTYPE(TIME) -> NUMBER
697 |
698 | // Construct a time from a date and optional timezone or a
699 | // date+time and optional timezone.
700 | TIME = 136; // NUMBER, NUMBER, NUMBER, STRING -> PSEUDOTYPE(TIME) |
701 | // NUMBER, NUMBER, NUMBER, NUMBER, NUMBER, NUMBER, STRING -> PSEUDOTYPE(TIME) |
702 |
703 | // Constants for ISO 8601 days of the week.
704 | MONDAY = 107; // -> 1
705 | TUESDAY = 108; // -> 2
706 | WEDNESDAY = 109; // -> 3
707 | THURSDAY = 110; // -> 4
708 | FRIDAY = 111; // -> 5
709 | SATURDAY = 112; // -> 6
710 | SUNDAY = 113; // -> 7
711 |
712 | // Constants for ISO 8601 months.
713 | JANUARY = 114; // -> 1
714 | FEBRUARY = 115; // -> 2
715 | MARCH = 116; // -> 3
716 | APRIL = 117; // -> 4
717 | MAY = 118; // -> 5
718 | JUNE = 119; // -> 6
719 | JULY = 120; // -> 7
720 | AUGUST = 121; // -> 8
721 | SEPTEMBER = 122; // -> 9
722 | OCTOBER = 123; // -> 10
723 | NOVEMBER = 124; // -> 11
724 | DECEMBER = 125; // -> 12
725 |
726 | // Indicates to MERGE to replace, or remove in case of an empty literal, the
727 | // other object rather than merge it.
728 | LITERAL = 137; // -> Merging
729 | // JSON -> Merging
730 |
731 | // SEQUENCE, STRING -> GROUPED_SEQUENCE | SEQUENCE, FUNCTION -> GROUPED_SEQUENCE
732 | GROUP = 144;
733 | SUM = 145;
734 | AVG = 146;
735 | MIN = 147;
736 | MAX = 148;
737 |
738 | // `str.split()` splits on whitespace
739 | // `str.split(" ")` splits on spaces only
740 | // `str.split(" ", 5)` splits on spaces with at most 5 results
741 | // `str.split(nil, 5)` splits on whitespace with at most 5 results
742 | SPLIT = 149; // STRING -> ARRAY | STRING, STRING -> ARRAY | STRING, STRING, NUMBER -> ARRAY | STRING, NULL, NUMBER -> ARRAY
743 |
744 | UNGROUP = 150; // GROUPED_DATA -> ARRAY
745 |
746 | // Takes a range of numbers and returns a random number within the range
747 | RANDOM = 151; // NUMBER, NUMBER {float:BOOL} -> DATUM
748 |
749 | CHANGES = 152; // TABLE -> STREAM
750 | ARGS = 154; // ARRAY -> SPECIAL (used to splice arguments)
751 |
752 | // BINARY is client-only at the moment, it is not supported on the server
753 | BINARY = 155; // STRING -> PSEUDOTYPE(BINARY)
754 |
755 | GEOJSON = 157; // OBJECT -> PSEUDOTYPE(GEOMETRY)
756 | TO_GEOJSON = 158; // PSEUDOTYPE(GEOMETRY) -> OBJECT
757 | POINT = 159; // NUMBER, NUMBER -> PSEUDOTYPE(GEOMETRY)
758 | LINE = 160; // (ARRAY | PSEUDOTYPE(GEOMETRY))... -> PSEUDOTYPE(GEOMETRY)
759 | POLYGON = 161; // (ARRAY | PSEUDOTYPE(GEOMETRY))... -> PSEUDOTYPE(GEOMETRY)
760 | DISTANCE = 162; // PSEUDOTYPE(GEOMETRY), PSEUDOTYPE(GEOMETRY) {geo_system:STRING, unit:STRING} -> NUMBER
761 | INTERSECTS = 163; // PSEUDOTYPE(GEOMETRY), PSEUDOTYPE(GEOMETRY) -> BOOL
762 | INCLUDES = 164; // PSEUDOTYPE(GEOMETRY), PSEUDOTYPE(GEOMETRY) -> BOOL
763 | CIRCLE = 165; // PSEUDOTYPE(GEOMETRY), NUMBER {num_vertices:NUMBER, geo_system:STRING, unit:STRING, fill:BOOL} -> PSEUDOTYPE(GEOMETRY)
764 | GET_INTERSECTING = 166; // TABLE, PSEUDOTYPE(GEOMETRY) {index:!STRING} -> StreamSelection
765 | FILL = 167; // PSEUDOTYPE(GEOMETRY) -> PSEUDOTYPE(GEOMETRY)
766 | GET_NEAREST = 168; // TABLE, PSEUDOTYPE(GEOMETRY) {index:!STRING, max_results:NUM, max_dist:NUM, geo_system:STRING, unit:STRING} -> ARRAY
767 | POLYGON_SUB = 171; // PSEUDOTYPE(GEOMETRY), PSEUDOTYPE(GEOMETRY) -> PSEUDOTYPE(GEOMETRY)
768 |
769 | // Constants for specifying key ranges
770 | MINVAL = 180;
771 | MAXVAL = 181;
772 | }
773 | optional TermType type = 1;
774 |
775 | // This is only used when type is DATUM.
776 | optional Datum datum = 2;
777 |
778 | repeated Term args = 3; // Holds the positional arguments of the query.
779 | message AssocPair {
780 | optional string key = 1;
781 | optional Term val = 2;
782 | }
783 | repeated AssocPair optargs = 4; // Holds the optional arguments of the query.
784 | // (Note that the order of the optional arguments doesn't matter; think of a
785 | // Hash.)
786 | }
787 |
788 | ////////////////////////////////////////////////////////////////////////////////
789 | // EXAMPLE //
790 | ////////////////////////////////////////////////////////////////////////////////
791 | // ```ruby
792 | // r.table('tbl', {:read_mode => 'outdated'}).insert([{:id => 0}, {:id => 1}])
793 | // ```
794 | // Would turn into:
795 | // Term {
796 | // type = INSERT;
797 | // args = [Term {
798 | // type = TABLE;
799 | // args = [Term {
800 | // type = DATUM;
801 | // datum = Datum { type = R_STR; r_str = "tbl"; };
802 | // }];
803 | // optargs = [["read_mode",
804 | // Term {
805 | // type = DATUM;
806 | // datum = Datum { type = R_STR; r_bool = "outdated"; };
807 | // }]];
808 | // },
809 | // Term {
810 | // type = MAKE_ARRAY;
811 | // args = [Term {
812 | // type = DATUM;
813 | // datum = Datum { type = R_OBJECT; r_object = [["id", 0]]; };
814 | // },
815 | // Term {
816 | // type = DATUM;
817 | // datum = Datum { type = R_OBJECT; r_object = [["id", 1]]; };
818 | // }];
819 | // }]
820 | // }
821 | // And the server would reply:
822 | // Response {
823 | // type = SUCCESS_ATOM;
824 | // token = 1;
825 | // response = [Datum { type = R_OBJECT; r_object = [["inserted", 2]]; }];
826 | // }
827 | // Or, if there were an error:
828 | // Response {
829 | // type = RUNTIME_ERROR;
830 | // token = 1;
831 | // response = [Datum { type = R_STR; r_str = "The table `tbl` doesn't exist!"; }];
832 | // backtrace = [Frame { type = POS; pos = 0; }, Frame { type = POS; pos = 0; }];
833 | // }
834 |
--------------------------------------------------------------------------------
/rethinkdb.cabal:
--------------------------------------------------------------------------------
1 | name: rethinkdb
2 | version: 2.2.0.10
3 | cabal-version: >=1.8
4 | build-type: Simple
5 | license: Apache
6 | license-file: LICENSE
7 | maintainer: Etienne Laurin
8 | homepage: http://github.com/atnnn/haskell-rethinkdb
9 | synopsis: A driver for RethinkDB 2.2
10 | description:
11 | A driver for the RethinkDB database server
12 | category: Database
13 | author: Etienne Laurin, Brandon Martin
14 |
15 | tested-with:
16 | GHC==7.6.3,
17 | GHC==7.8.4,
18 | GHC==7.10.3,
19 | GHC==8.0.2
20 |
21 | source-repository head
22 | type: git
23 | location: https://github.com/atnnn/haskell-rethinkdb
24 |
25 | flag dev
26 | default: False
27 | manual: True
28 |
29 | library
30 | build-depends:
31 | base >=4 && <4.10,
32 | unordered-containers ==0.2.*,
33 | text >=0.11 && <1.3,
34 | aeson >=0.7 && <1.3,
35 | bytestring ==0.10.*,
36 | containers ==0.5.*,
37 | data-default >=0.5 && <0.8,
38 | network >=2.4 && <2.7,
39 | mtl >=2.1 && <2.3,
40 | vector >=0.10 && <0.13,
41 | time >=1.4 && <1.7,
42 | utf8-string >=0.3 && <1.1,
43 | binary >=0.5 && <0.9,
44 | scientific ==0.3.*,
45 | base64-bytestring ==1.0.*
46 |
47 | if flag(dev)
48 | other-modules:
49 | Debug
50 | exposed: True
51 | buildable: True
52 | -- ghc-prof-options: -fprof-auto
53 | exposed-modules:
54 | Database.RethinkDB
55 | Database.RethinkDB.NoClash
56 | Database.RethinkDB.Driver
57 | Database.RethinkDB.Functions
58 | Database.RethinkDB.Time
59 | Database.RethinkDB.Types
60 | Database.RethinkDB.Datum
61 | Database.RethinkDB.Geospatial
62 | Database.RethinkDB.ReQL
63 | Database.RethinkDB.Network
64 | Database.RethinkDB.MapReduce
65 | Database.RethinkDB.Wire
66 | Database.RethinkDB.Wire.Datum
67 | Database.RethinkDB.Wire.Frame
68 | Database.RethinkDB.Wire.Query
69 | Database.RethinkDB.Wire.Response
70 | Database.RethinkDB.Wire.Term
71 | Database.RethinkDB.Wire.VersionDummy
72 | Database.RethinkDB.Doctest
73 | exposed: True
74 | buildable: True
75 |
76 | if impl(ghc > 8)
77 | ghc-options: -Wall -Wno-redundant-constraints
78 | else
79 | ghc-options: -Wall
80 |
81 | test-suite doctests
82 | build-depends:
83 | base,
84 | doctest >=0.9
85 | type: exitcode-stdio-1.0
86 | main-is: doctests.hs
87 | buildable: True
88 | ghc-options: -threaded
89 |
90 | benchmark bench
91 | build-depends:
92 | base,
93 | criterion,
94 | rethinkdb,
95 | text,
96 | aeson,
97 | async
98 | hs-source-dirs: bench
99 | type: exitcode-stdio-1.0
100 | main-is: Bench.hs
101 | ghc-options: -O2 -threaded -rtsopts -with-rtsopts=-N
102 | ghc-prof-options: "-with-rtsopts=-p -s -h -i0.1 -N"
103 |
104 | executable proto2hs
105 | if !flag(dev)
106 | buildable: False
107 | main-is: proto2hs.hs
108 | build-depends: base, text, attoparsec
109 |
--------------------------------------------------------------------------------
/stack-7.10.yaml:
--------------------------------------------------------------------------------
1 | resolver: lts-5.13
2 | packages:
3 | - '.'
4 |
--------------------------------------------------------------------------------
/stack.yaml:
--------------------------------------------------------------------------------
1 | resolver: nightly-2017-05-07
2 | packages:
3 | - '.'
4 | extra-deps:
5 | - aeson-1.2.0.0
6 |
--------------------------------------------------------------------------------
/update-bounds.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | cabal update
4 | cabal sandbox init
5 | cabal configure
6 | cabal-bounds drop --upper --library rethinkdb.cabal
7 | cabal install --only-dependencies
8 | cabal-bounds update --upper --library rethinkdb.cabal dist/setup-config
9 |
--------------------------------------------------------------------------------
/upload-haddocks.sh:
--------------------------------------------------------------------------------
1 | #!/bin/bash
2 |
3 | set -xeu
4 |
5 | package=rethinkdb
6 | version=`grep '^version: ' $package.cabal | cut -f 2 -d ' '`
7 |
8 | echo -n 'Hackage user name: '
9 | read -r user
10 |
11 | cabal haddock --hoogle --hyperlink-source --html-location='/package/$pkg/docs' --contents-location='/package/$pkg'
12 |
13 | cd dist/doc/html
14 |
15 | cp -R $package $package-$version-docs
16 |
17 | tar cz --format=ustar -f $package-$version-docs.tar.gz $package-$version-docs
18 |
19 | curl -X PUT -H 'Content-Type: application/x-tar' -H 'Content-Encoding: gzip' -u $user --data-binary @$package-$version-docs.tar.gz https://hackage.haskell.org/package/$package-$version/docs
20 |
--------------------------------------------------------------------------------