├── .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 | [![Build Status](https://travis-ci.org/AtnNn/haskell-rethinkdb.svg?branch=master)](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 | --------------------------------------------------------------------------------