├── .github └── workflows │ └── validate.yaml ├── .gitignore ├── LICENSE ├── README.md ├── Setup.hs ├── benchmark └── Benchmark.hs ├── rethinkdb-client-driver.cabal ├── script ├── bootstrap └── cibuild ├── shell.nix ├── src └── Database │ ├── RethinkDB.hs │ └── RethinkDB │ ├── Messages.hs │ ├── TH.hs │ ├── Types.hs │ └── Types │ └── Datum.hs └── test └── Test.hs /.github/workflows/validate.yaml: -------------------------------------------------------------------------------- 1 | on: [push] 2 | name: Validate 3 | jobs: 4 | build: 5 | strategy: 6 | matrix: 7 | ghc: ['8.0.2', '8.2.2', '8.4.4', '8.6.5', '8.8.3', '8.10.1'] 8 | 9 | runs-on: ubuntu-latest 10 | name: Haskell GHC ${{ matrix.ghc }} 11 | steps: 12 | - uses: actions/checkout@v2 13 | 14 | - name: Setup Haskell 15 | uses: actions/setup-haskell@v1 16 | with: 17 | ghc-version: ${{ matrix.ghc }} 18 | 19 | - name: Cache .cabal 20 | uses: actions/cache@v1 21 | with: 22 | path: ~/.cabal 23 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal 24 | 25 | - run: cabal update 26 | - run: cabal configure 27 | - run: cabal build 28 | 29 | test: 30 | strategy: 31 | matrix: 32 | ghc: ['8.10.1'] 33 | 34 | runs-on: ubuntu-latest 35 | name: Test 36 | steps: 37 | - uses: actions/checkout@v2 38 | 39 | - name: Setup Haskell 40 | uses: actions/setup-haskell@v1 41 | with: 42 | ghc-version: ${{ matrix.ghc }} 43 | 44 | - name: Cache .cabal 45 | uses: actions/cache@v1 46 | with: 47 | path: ~/.cabal 48 | key: ${{ runner.os }}-${{ matrix.ghc }}-cabal 49 | 50 | - name: Install rethinkdb 51 | run: | 52 | source /etc/lsb-release && echo "deb https://download.rethinkdb.com/apt $DISTRIB_CODENAME main" | sudo tee /etc/apt/sources.list.d/rethinkdb.list 53 | wget -qO- https://download.rethinkdb.com/apt/pubkey.gpg | sudo apt-key add - 54 | sudo apt-get update 55 | sudo apt-get install rethinkdb 56 | 57 | sudo cp /etc/rethinkdb/default.conf.sample /etc/rethinkdb/instances.d/default.conf 58 | sudo /etc/init.d/rethinkdb restart 59 | 60 | - run: cabal update 61 | - run: cabal test 62 | -------------------------------------------------------------------------------- /.gitignore: -------------------------------------------------------------------------------- 1 | /.stack-work/ 2 | /stack.yaml 3 | /stack.yaml.lock 4 | 5 | /dist-newstyle/ 6 | -------------------------------------------------------------------------------- /LICENSE: -------------------------------------------------------------------------------- 1 | Copyright (c) 2014 Tomas Carnecky 2 | 3 | Permission is hereby granted, free of charge, to any person obtaining 4 | a copy of this software and associated documentation files (the 5 | "Software"), to deal in the Software without restriction, including 6 | without limitation the rights to use, copy, modify, merge, publish, 7 | distribute, sublicense, and/or sell copies of the Software, and to 8 | permit persons to whom the Software is furnished to do so, subject to 9 | the following conditions: 10 | 11 | The above copyright notice and this permission notice shall be included 12 | in all copies or substantial portions of the Software. 13 | 14 | THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, 15 | EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF 16 | MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. 17 | IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY 18 | CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION OF CONTRACT, 19 | TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION WITH THE 20 | SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE. 21 | -------------------------------------------------------------------------------- /README.md: -------------------------------------------------------------------------------- 1 | # Haskell client driver for RethinkDB 2 | 3 | It differs from the other driver ([rethinkdb][rethinkdb-haskell]) in that it 4 | uses advanced Haskell magic to properly type the terms, queries and responses. 5 | 6 | 7 | # Structure and usage 8 | 9 | The library exposes a single module, `Database.RethinkDB`. There should be 10 | very little which can conflict with other code, so you should be able to 11 | import it unqualified. 12 | 13 | To be able to run expressions on the server, you first have to create 14 | a handle, this you can do with `newHandle`. Currently it always connects to 15 | "localhost" and the default RethinkDB client driver port. 16 | 17 | Expressions have the type `Exp a`, where the `a` denotes the result you would 18 | get when you run the expression. You can use `lift` to lift many basic Haskell 19 | types (Double, Text, Bool) and certain functions (unary and binary) into 20 | RethinkDB expressions. 21 | 22 | RethinkDB uses JSON for encoding on the protocol level, but certain types (eg. 23 | time) have non-standard encoding. This is why the driver uses a separate type 24 | class (`FromRSON` / `ToRSON`) to describe types which can be sent over the 25 | wire. 26 | 27 | 28 | # Examples 29 | 30 | Add two numbers, one and two. Here we lift the addition function and its 31 | arguments into `Exp`, and then use `call2` to call it. 32 | 33 | ```haskell 34 | h <- newHandle 35 | res <- run h $ call2 (lift (+)) (lift 1) (lift 2) 36 | print res 37 | -- Should print 'Right 3.0' 38 | ``` 39 | 40 | Get all objects in a table. 41 | 42 | ```haskell 43 | h <- newHandle 44 | Right sequence <- run h $ Table "test" 45 | objs <- collect h sequence 46 | -- objs is now a 'Vector' of all objects in the test table. 47 | ``` 48 | 49 | 50 | [rethinkdb-haskell]: https://hackage.haskell.org/package/rethinkdb 51 | -------------------------------------------------------------------------------- /Setup.hs: -------------------------------------------------------------------------------- 1 | import Distribution.Simple 2 | main = defaultMain 3 | -------------------------------------------------------------------------------- /benchmark/Benchmark.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | 9 | module Main where 10 | 11 | import Control.Monad 12 | import Criterion.Main 13 | import Database.RethinkDB 14 | import qualified Data.HashMap.Strict as HMS 15 | 16 | 17 | db :: Exp Database 18 | db = Database "test" 19 | 20 | table :: Exp Table 21 | table = Table Nothing "benchmark" 22 | 23 | 24 | main :: IO () 25 | main = do 26 | h <- prepare 27 | 28 | let test name = bench name . nfIO . void . run h 29 | 30 | defaultMain 31 | [ test "roundtrip" $ lift (0 :: Double) 32 | , test "point-get" $ Get table "id" 33 | ] 34 | 35 | 36 | prepare :: IO Handle 37 | prepare = do 38 | h <- newHandle "localhost" defaultPort Nothing (Database "test") 39 | 40 | void $ run h (CreateTable db "benchmark") 41 | void $ run h (InsertObject CRError table (HMS.singleton "id" (String "id"))) 42 | 43 | return h 44 | -------------------------------------------------------------------------------- /rethinkdb-client-driver.cabal: -------------------------------------------------------------------------------- 1 | name: rethinkdb-client-driver 2 | version: 0.0.25 3 | license: MIT 4 | license-file: LICENSE 5 | author: Tomas Carnecky 6 | maintainer: tomas.carnecky@gmail.com 7 | category: Database 8 | build-type: Simple 9 | cabal-version: >= 1.10 10 | 11 | homepage: https://github.com/wereHamster/rethinkdb-client-driver 12 | bug-reports: https://github.com/wereHamster/rethinkdb-client-driver/issues 13 | 14 | synopsis: Client driver for RethinkDB 15 | description: 16 | This is an alternative client driver for RethinkDB. It is not complete 17 | yet, but the basic structure is in place and the driver can make 18 | simple queries. 19 | . 20 | Its main focus is on type safety, which it achieves quite well. It also 21 | uses the new JSON protocol which should give it a speed boost (and make 22 | the driver compatible with GHC 7.8). 23 | . 24 | Note that the driver is neither thread-safe nor reentrant. If you have 25 | a multi-threaded application, I recommend using 'resource-pool'. 26 | 27 | source-repository head 28 | type: git 29 | location: git://github.com/wereHamster/rethinkdb-client-driver.git 30 | 31 | 32 | library 33 | default-language : Haskell2010 34 | hs-source-dirs : src 35 | 36 | build-depends : base < 4.15 37 | , aeson 38 | , binary 39 | , bytestring 40 | , containers 41 | , hashable 42 | , mtl 43 | , network 44 | , old-locale 45 | , scientific 46 | , stm 47 | , template-haskell >= 2.11.0.0 48 | , text 49 | , time 50 | , unordered-containers 51 | , vector 52 | 53 | exposed-modules : Database.RethinkDB 54 | , Database.RethinkDB.TH 55 | 56 | other-modules : Database.RethinkDB.Messages 57 | , Database.RethinkDB.Types 58 | , Database.RethinkDB.Types.Datum 59 | 60 | ghc-options : -Wall 61 | 62 | 63 | test-suite spec 64 | default-language : Haskell2010 65 | hs-source-dirs : test 66 | 67 | main-is : Test.hs 68 | type : exitcode-stdio-1.0 69 | 70 | build-depends : base < 4.15 71 | , hspec 72 | , smallcheck 73 | , hspec-smallcheck 74 | 75 | , rethinkdb-client-driver 76 | , vector 77 | , text 78 | , unordered-containers 79 | , time 80 | 81 | 82 | benchmark bench 83 | default-language : Haskell2010 84 | hs-source-dirs : benchmark 85 | 86 | main-is : Benchmark.hs 87 | type : exitcode-stdio-1.0 88 | 89 | build-depends : base < 4.15 90 | , criterion 91 | 92 | , rethinkdb-client-driver 93 | , vector 94 | , text 95 | , unordered-containers 96 | , time 97 | 98 | ghc-options : -Wall -O2 -threaded -rtsopts -with-rtsopts=-N 99 | ghc-prof-options : "-with-rtsopts=-p -s -h -i0.1 -N" 100 | -------------------------------------------------------------------------------- /script/bootstrap: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | cd "$(dirname "$0")/.." 4 | 5 | test -f stack.yaml || stack init --resolver=nightly 6 | -------------------------------------------------------------------------------- /script/cibuild: -------------------------------------------------------------------------------- 1 | #!/bin/sh 2 | set -e 3 | cd "$(dirname "$0")/.." 4 | 5 | script/bootstrap 6 | 7 | stack test 8 | -------------------------------------------------------------------------------- /shell.nix: -------------------------------------------------------------------------------- 1 | let 2 | pkgs = import {}; 3 | 4 | in pkgs.mkShell { 5 | buildInputs = [ 6 | pkgs.stack 7 | pkgs.zlib 8 | pkgs.libiconv 9 | ]; 10 | } 11 | -------------------------------------------------------------------------------- /src/Database/RethinkDB.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE FlexibleContexts #-} 2 | {-# LANGUAGE OverloadedStrings #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | 5 | module Database.RethinkDB 6 | ( Handle 7 | , defaultPort, newHandle, handleDatabase, close, serverInfo 8 | 9 | -- * High-level query API 10 | , run, nextChunk, collect 11 | 12 | -- * Low-level query API 13 | , start, continue, stop, wait, nextResult 14 | 15 | , Token, Error(..), Response(..), ChangeNotification(..) 16 | 17 | -- * The Datum type 18 | , Datum(..), Array, Object, ToDatum(..), FromDatum(..) 19 | , (.=), (.:), (.:?), object 20 | 21 | -- The Exp type 22 | , Exp(..), SomeExp(..) 23 | , Bound(..), Order(..) 24 | , Sequence(..) 25 | , Table, Database, SingleSelection 26 | , Res, Result, FromResponse 27 | , ConflictResolutionStrategy(..) 28 | , emptyOptions 29 | , lift 30 | , call1, call2 31 | 32 | , IsDatum, IsObject, IsSequence 33 | ) where 34 | 35 | 36 | import Control.Monad 37 | import Control.Concurrent 38 | import Control.Concurrent.STM 39 | 40 | import Data.Monoid ((<>)) 41 | 42 | import Data.Text (Text) 43 | import qualified Data.Text as T 44 | 45 | import Data.Vector (Vector) 46 | import qualified Data.Vector as V 47 | 48 | import Data.Map.Strict (Map) 49 | import qualified Data.Map.Strict as M 50 | 51 | import qualified Data.Aeson.Types as A 52 | 53 | import Data.Sequence (Seq, ViewR(..)) 54 | import qualified Data.Sequence as S 55 | 56 | import Data.IORef 57 | 58 | import Network.Socket (Socket) 59 | 60 | import Database.RethinkDB.Types 61 | import Database.RethinkDB.Types.Datum 62 | import Database.RethinkDB.Messages 63 | 64 | 65 | ------------------------------------------------------------------------------ 66 | -- Handle 67 | 68 | data Handle = Handle 69 | { hSocket :: !(MVar Socket) 70 | -- ^ Any thread can write to the socket. In theory. But I don't think 71 | -- Haskell allows atomic writes to a socket, so it is protected inside 72 | -- an 'MVar'. 73 | -- 74 | -- When too many threads write to the socket, this may cause resource 75 | -- contention. Users are encouraged to use a resource pool to alleviate 76 | -- that. 77 | 78 | , hTokenRef :: !(IORef Token) 79 | -- ^ This is used to allocate new tokens. We use 'atomicModifyIORef' to 80 | -- efficiently allocate new tokens. 81 | -- 82 | -- RethinkDB seems to expect the token to never be zero. So we need to 83 | -- start with one and then count up. 84 | 85 | , hError :: !(TVar (Maybe Error)) 86 | -- ^ If there was a fatal error while reading from the socket, it will 87 | -- be stored here. If this is set then no further replies will be 88 | -- processed. The user needs to close and re-open the handle to recover. 89 | 90 | , hResponses :: !(TVar (Map Token (Seq (Either Error Response)))) 91 | -- ^ Responses to queries. A thread reads the responses from the socket 92 | -- and pushes them into the queues. 93 | 94 | , hReader :: !ThreadId 95 | -- ^ Thread which reads from the socket and copies responses into the 96 | -- queues in 'hResponses'. 97 | 98 | , hDatabase :: !(Exp Database) 99 | -- ^ The database which should be used when the 'Table' expression 100 | -- doesn't specify one. 101 | } 102 | 103 | 104 | -- | The default port where RethinkDB accepts client driver connections. 105 | defaultPort :: Int 106 | defaultPort = 28015 107 | 108 | 109 | -- | Create a new handle to the RethinkDB server. 110 | newHandle :: Text -> Int -> Maybe Text -> Exp Database -> IO Handle 111 | newHandle host port mbAuth db = do 112 | sock <- createSocket host port 113 | 114 | -- Do the handshake dance. Note that we currently ignore the reply and 115 | -- assume it is "SUCCESS". 116 | sendMessage sock (handshakeMessage mbAuth) 117 | _reply <- recvMessage sock handshakeReplyParser 118 | 119 | err <- newTVarIO Nothing 120 | responses <- newTVarIO M.empty 121 | 122 | readerThreadId <- forkIO $ forever $ do 123 | res <- recvMessage sock responseMessageParser 124 | case res of 125 | Left e -> atomically $ do 126 | mbError <- readTVar err 127 | case mbError of 128 | Nothing -> writeTVar err (Just e) 129 | Just _ -> pure () 130 | 131 | Right (Left (token, msg)) -> atomically $ modifyTVar' responses $ 132 | M.insertWith mappend token (S.singleton $ Left $ ProtocolError $ T.pack msg) 133 | 134 | Right (Right r) -> atomically $ modifyTVar' responses $ 135 | M.insertWith mappend (responseToken r) (S.singleton $ Right r) 136 | 137 | return () 138 | 139 | Handle 140 | <$> newMVar sock 141 | <*> newIORef 1 142 | <*> pure err 143 | <*> pure responses 144 | <*> pure readerThreadId 145 | <*> pure db 146 | 147 | 148 | -- | The 'Database' which some expressions will use when not explicitly given 149 | -- one (eg. 'Table'). 150 | handleDatabase :: Handle -> Exp Database 151 | handleDatabase = hDatabase 152 | 153 | 154 | -- | Close the given handle. You MUST NOT use the handle after this. 155 | close :: Handle -> IO () 156 | close handle = do 157 | withMVar (hSocket handle) closeSocket 158 | killThread (hReader handle) 159 | 160 | 161 | serverInfo :: Handle -> IO (Either Error ServerInfo) 162 | serverInfo handle = do 163 | token <- atomicModifyIORef' (hTokenRef handle) (\x -> (x + 1, x)) 164 | withMVar (hSocket handle) $ \socket -> 165 | sendMessage socket (queryMessage token $ singleElementArray 5) 166 | nextResult handle token 167 | 168 | 169 | 170 | -------------------------------------------------------------------------------- 171 | -- * High-level query API 172 | -- 173 | -- These are synchronous functions, they make it really easy to run a query and 174 | -- immediately get its results. 175 | -- 176 | -- If the result is a sequence, you can either manually iterate through the 177 | -- chunks ('nextChunk') or fetch the whole sequence at once ('collect'). 178 | 179 | 180 | -- | Start a new query and wait for its (first) result. If the result is an 181 | -- single value ('Datum'), then there will be no further results. If it is 182 | -- a sequence, then you must consume results until the sequence ends. 183 | run :: (FromResponse (Result a)) => Handle -> Exp a -> IO (Res a) 184 | run handle expr = do 185 | token <- start handle expr 186 | nextResult handle token 187 | 188 | 189 | -- | Get the next chunk of a sequence. It is an error to request the next chunk 190 | -- if the sequence is already 'Done', 191 | nextChunk :: (FromResponse (Sequence a)) 192 | => Handle -> Sequence a -> IO (Either Error (Sequence a)) 193 | nextChunk _ (Done _) = return $ Left $ ProtocolError "nextChunk: Done" 194 | nextChunk handle (Partial token _) = do 195 | continue handle token 196 | nextResult handle token 197 | 198 | 199 | -- | Collect all the values in a sequence and make them available as 200 | -- a 'Vector a'. 201 | collect :: (FromDatum a) => Handle -> Sequence a -> IO (Either Error (Vector a)) 202 | collect _ (Done x) = return $ Right x 203 | collect handle s@(Partial _ x) = do 204 | chunk <- nextChunk handle s 205 | case chunk of 206 | Left e -> return $ Left e 207 | Right r -> do 208 | vals <- collect handle r 209 | case vals of 210 | Left ve -> return $ Left ve 211 | Right v -> return $ Right $ x <> v 212 | 213 | 214 | 215 | -------------------------------------------------------------------------------- 216 | -- * Low-level query API 217 | -- 218 | -- These functions map almost verbatim to the wire protocol messages. They are 219 | -- asynchronous, you can send multiple queries and get the corresponding 220 | -- responses sometime later. 221 | 222 | 223 | -- | Start a new query. Returns the 'Token' which can be used to track its 224 | -- progress. 225 | start :: Handle -> Exp a -> IO Token 226 | start handle term = do 227 | token <- atomicModifyIORef' (hTokenRef handle) (\x -> (x + 1, x)) 228 | withMVar (hSocket handle) $ \socket -> 229 | sendMessage socket (queryMessage token msg) 230 | return token 231 | 232 | where 233 | msg = compileTerm (hDatabase handle) $ do 234 | term' <- toTerm term 235 | options' <- toTerm emptyOptions 236 | return $ A.Array $ V.fromList 237 | [ A.Number 1 238 | , term' 239 | , A.toJSON $ options' 240 | ] 241 | 242 | 243 | singleElementArray :: Int -> A.Value 244 | singleElementArray x = A.Array $ V.singleton $ A.Number $ fromIntegral x 245 | 246 | -- | Let the server know that it can send the next response corresponding to 247 | -- the given token. 248 | continue :: Handle -> Token -> IO () 249 | continue handle token = withMVar (hSocket handle) $ \socket -> 250 | sendMessage socket (queryMessage token $ singleElementArray 2) 251 | 252 | 253 | -- | Stop (abort?) a query. 254 | stop :: Handle -> Token -> IO () 255 | stop handle token = withMVar (hSocket handle) $ \socket -> 256 | sendMessage socket (queryMessage token $ singleElementArray 3) 257 | 258 | 259 | -- | Wait until a previous query (which was started with the 'noreply' option) 260 | -- finishes. 261 | wait :: Handle -> Token -> IO () 262 | wait handle token = withMVar (hSocket handle) $ \socket -> 263 | sendMessage socket (queryMessage token $ singleElementArray 4) 264 | 265 | 266 | 267 | -- | This function blocks until there is a response ready for the query with 268 | -- the given token. It may block indefinitely if the token refers to a query 269 | -- which has already finished or does not exist yet! 270 | responseForToken :: Handle -> Token -> IO (Either Error Response) 271 | responseForToken h token = atomically $ do 272 | m <- readTVar (hResponses h) 273 | case M.lookup token m of 274 | Nothing -> retry 275 | Just s -> case S.viewr s of 276 | EmptyR -> retry 277 | rest :> a -> do 278 | modifyTVar' (hResponses h) $ if S.null rest 279 | then M.delete token 280 | else M.insert token rest 281 | 282 | pure a 283 | 284 | 285 | nextResult :: (FromResponse a) => Handle -> Token -> IO (Either Error a) 286 | nextResult h token = do 287 | mbError <- atomically $ readTVar (hError h) 288 | case mbError of 289 | Just err -> return $ Left err 290 | Nothing -> do 291 | errorOrResponse <- responseForToken h token 292 | case errorOrResponse of 293 | Left err -> return $ Left err 294 | Right response -> case responseType response of 295 | ClientErrorType -> mkError response ClientError 296 | CompileErrorType -> mkError response CompileError 297 | RuntimeErrorType -> mkError response RuntimeError 298 | _ -> return $ parseMessage parseResponse response Right 299 | 300 | 301 | parseMessage :: (a -> A.Parser b) -> a -> (b -> Either Error c) -> Either Error c 302 | parseMessage parser value f = case A.parseEither parser value of 303 | Left e -> Left $ ProtocolError $ T.pack e 304 | Right v -> f v 305 | 306 | mkError :: Response -> (Text -> Error) -> IO (Either Error a) 307 | mkError r e = return $ case V.toList (responseResult r) of 308 | [a] -> parseMessage A.parseJSON a (Left . e) 309 | _ -> Left $ ProtocolError $ "mkError: Could not parse error" <> T.pack (show (responseResult r)) 310 | -------------------------------------------------------------------------------- /src/Database/RethinkDB/Messages.hs: -------------------------------------------------------------------------------- 1 | 2 | module Database.RethinkDB.Messages where 3 | 4 | 5 | import Control.Applicative 6 | 7 | import Data.Text (Text) 8 | import qualified Data.Text as T 9 | import qualified Data.Text.Encoding as T 10 | 11 | import Data.Aeson as A hiding (Result, Object) 12 | import Data.Aeson.Types as A hiding (Result, Object) 13 | 14 | import qualified Data.ByteString as SBS 15 | import Data.ByteString.Lazy (ByteString, toStrict) 16 | import qualified Data.ByteString.Lazy as BS 17 | 18 | import Data.Binary 19 | import Data.Binary.Put 20 | import Data.Binary.Get as Get 21 | 22 | import Network.Socket (Socket, AddrInfo(..), AddrInfoFlag(..), SocketType(..)) 23 | import Network.Socket (getAddrInfo, socket, connect, close, defaultHints) 24 | 25 | import Network.Socket.ByteString (recv) 26 | import Network.Socket.ByteString.Lazy (sendAll) 27 | 28 | import Database.RethinkDB.Types 29 | 30 | import Prelude 31 | 32 | 33 | 34 | createSocket :: Text -> Int -> IO Socket 35 | createSocket host port = do 36 | ai:_ <- getAddrInfo (Just hints) (Just $ T.unpack host) (Just $ show port) 37 | sock <- socket (addrFamily ai) (addrSocketType ai) (addrProtocol ai) 38 | connect sock (addrAddress ai) 39 | return sock 40 | where 41 | hints = defaultHints { addrSocketType = Stream, addrFlags = [ AI_NUMERICSERV ] } 42 | 43 | 44 | closeSocket :: Socket -> IO () 45 | closeSocket = close 46 | 47 | 48 | sendMessage :: Socket -> ByteString -> IO () 49 | sendMessage sock buf = sendAll sock buf 50 | 51 | 52 | -- | Receive the next message from the socket. If it fails, a (hopefully) 53 | -- descriptive error will be returned. 54 | recvMessage :: Socket -> Get a -> IO (Either Error a) 55 | recvMessage sock parser = go (runGetIncremental parser) 56 | where 57 | go (Get.Done _ _ r) = return $ Right r 58 | go (Get.Partial c) = recv sock (4 * 1024) >>= go . c . Just 59 | go (Get.Fail _ _ e) = return $ Left $ ProtocolError $ T.pack e 60 | 61 | 62 | 63 | handshakeMessage :: Maybe Text -> ByteString 64 | handshakeMessage mbAuth = runPut $ do 65 | -- Protocol version: V0_4 66 | putWord32le 0x400c2d20 67 | 68 | -- Authentication 69 | case mbAuth of 70 | Nothing -> putWord32le 0 71 | Just auth -> do 72 | let key = T.encodeUtf8 auth 73 | putWord32le $ fromIntegral $ SBS.length key 74 | putByteString key 75 | 76 | -- Protocol type: JSON 77 | putWord32le 0x7e6970c7 78 | 79 | 80 | handshakeReplyParser :: Get Text 81 | handshakeReplyParser = do 82 | (T.decodeUtf8 . toStrict) <$> getLazyByteStringNul 83 | 84 | 85 | queryMessage :: Token -> A.Value -> ByteString 86 | queryMessage token msg = runPut $ do 87 | putWord64host token 88 | putWord32le (fromIntegral $ BS.length buf) 89 | putLazyByteString buf 90 | where 91 | buf = A.encode msg 92 | 93 | 94 | responseMessageParser :: Get (Either (Token, String) Response) 95 | responseMessageParser = do 96 | token <- getWord64host 97 | len <- getWord32le 98 | buf <- getByteString (fromIntegral len) 99 | 100 | case A.eitherDecodeStrict buf of 101 | Left e -> pure $ Left (token, "responseMessageParser: response is not a JSON value (" ++ e ++ ")") 102 | Right value -> case A.parseEither (responseParser token) value of 103 | Left e -> pure $ Left (token, "responseMessageParser: could not parse response (" ++ e ++ ")") 104 | Right x -> pure $ Right x 105 | -------------------------------------------------------------------------------- /src/Database/RethinkDB/TH.hs: -------------------------------------------------------------------------------- 1 | -- Copied from aeson-0.8.0.2 2 | 3 | {-# LANGUAGE CPP, FlexibleInstances, IncoherentInstances, NamedFieldPuns, 4 | NoImplicitPrelude, TemplateHaskell, UndecidableInstances #-} 5 | 6 | {-| 7 | Module: Data.Aeson.TH 8 | Copyright: (c) 2011, 2012 Bryan O'Sullivan 9 | (c) 2011 MailRank, Inc. 10 | License: Apache 11 | Stability: experimental 12 | Portability: portable 13 | 14 | Functions to mechanically derive 'ToDatum' and 'FromDatum' instances. Note that 15 | you need to enable the @TemplateHaskell@ language extension in order to use this 16 | module. 17 | 18 | An example shows how instances are generated for arbitrary data types. First we 19 | define a data type: 20 | 21 | @ 22 | data D a = Nullary 23 | | Unary Int 24 | | Product String Char a 25 | | Record { testOne :: Double 26 | , testTwo :: Bool 27 | , testThree :: D a 28 | } deriving Eq 29 | @ 30 | 31 | Next we derive the necessary instances. Note that we make use of the 32 | feature to change record field names. In this case we drop the first 4 33 | characters of every field name. We also modify constructor names by 34 | lower-casing them: 35 | 36 | @ 37 | $('deriveDatum' 'defaultOptions'{'fieldLabelModifier' = 'drop' 4, 'constructorTagModifier' = map toLower} ''D) 38 | @ 39 | 40 | Now we can use the newly created instances. 41 | 42 | @ 43 | d :: D 'Int' 44 | d = Record { testOne = 3.14159 45 | , testTwo = 'True' 46 | , testThree = Product \"test\" \'A\' 123 47 | } 48 | @ 49 | 50 | >>> fromDatum (toDatum d) == Success d 51 | > True 52 | 53 | Please note that you can derive instances for tuples using the following syntax: 54 | 55 | @ 56 | -- FromDatum and ToDatum instances for 4-tuples. 57 | $('deriveDatum' 'defaultOptions' ''(,,,)) 58 | @ 59 | 60 | -} 61 | 62 | module Database.RethinkDB.TH 63 | ( -- * Encoding configuration 64 | Options(..), SumEncoding(..), defaultOptions, defaultTaggedObject 65 | 66 | -- * FromDatum and ToDatum derivation 67 | , deriveDatum 68 | 69 | , deriveToDatum 70 | , deriveFromDatum 71 | 72 | , mkToDatum 73 | , mkParseDatum 74 | ) where 75 | 76 | -------------------------------------------------------------------------------- 77 | -- Imports 78 | -------------------------------------------------------------------------------- 79 | 80 | import Database.RethinkDB.Types.Datum 81 | ( Datum(..), Object, object, (.=), (.:), (.:?) 82 | , ToDatum, toDatum, FromDatum, parseDatum 83 | ) 84 | 85 | -- from aeson: 86 | import Data.Aeson.Types 87 | ( Parser, Options(..), SumEncoding(..) 88 | , defaultOptions, defaultTaggedObject 89 | ) 90 | 91 | -- from base: 92 | import Control.Applicative ( pure, (<$>), (<*>) ) 93 | import Control.Monad ( return, mapM, liftM2, fail ) 94 | import Data.Bool ( Bool(False, True), otherwise, (&&) ) 95 | import Data.Eq ( (==) ) 96 | import Data.Function ( ($), (.) ) 97 | import Data.Functor ( fmap ) 98 | import Data.Int ( Int ) 99 | import Data.Either ( Either(Left, Right) ) 100 | import Data.List ( (++), foldl, foldl', intercalate 101 | , length, map, zip, genericLength, all, partition 102 | ) 103 | import Data.Maybe ( Maybe(Nothing, Just), catMaybes ) 104 | import Prelude ( String, (-), Integer, fromIntegral, error, head ) 105 | import Text.Printf ( printf ) 106 | import Text.Show ( show ) 107 | 108 | -- from unordered-containers: 109 | import qualified Data.HashMap.Strict as H ( lookup, toList ) 110 | 111 | -- from template-haskell: 112 | import Language.Haskell.TH 113 | import Language.Haskell.TH.Syntax ( VarStrictType ) 114 | 115 | -- from text: 116 | import qualified Data.Text as T ( Text, pack, unpack ) 117 | 118 | -- from vector: 119 | import qualified Data.Vector as V ( unsafeIndex, null, length, create, fromList ) 120 | import qualified Data.Vector.Mutable as VM ( unsafeNew, unsafeWrite ) 121 | 122 | 123 | -------------------------------------------------------------------------------- 124 | -- Convenience 125 | -------------------------------------------------------------------------------- 126 | 127 | -- | Generates both 'ToDatum' and 'FromDatum' instance declarations for the given 128 | -- data type. 129 | -- 130 | -- This is a convienience function which is equivalent to calling both 131 | -- 'deriveToDatum' and 'deriveFromDatum'. 132 | deriveDatum :: Options 133 | -- ^ Encoding options. 134 | -> Name 135 | -- ^ Name of the type for which to generate 'ToDatum' and 'FromDatum' 136 | -- instances. 137 | -> Q [Dec] 138 | deriveDatum opts name = 139 | liftM2 (++) 140 | (deriveToDatum opts name) 141 | (deriveFromDatum opts name) 142 | 143 | 144 | -------------------------------------------------------------------------------- 145 | -- ToDatum 146 | -------------------------------------------------------------------------------- 147 | 148 | {- 149 | TODO: Don't constrain phantom type variables. 150 | 151 | data Foo a = Foo Int 152 | instance (ToDatum a) ⇒ ToDatum Foo where ... 153 | 154 | The above (ToDatum a) constraint is not necessary and perhaps undesirable. 155 | -} 156 | 157 | -- | Generates a 'ToDatum' instance declaration for the given data type. 158 | deriveToDatum :: Options 159 | -- ^ Encoding options. 160 | -> Name 161 | -- ^ Name of the type for which to generate a 'ToDatum' instance 162 | -- declaration. 163 | -> Q [Dec] 164 | deriveToDatum opts name = 165 | withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons 166 | where 167 | fromCons :: [TyVarBndr] -> [Con] -> Q Dec 168 | fromCons tvbs cons = 169 | instanceD (applyCon ''ToDatum typeNames) 170 | (classType `appT` instanceType) 171 | [ funD 'toDatum 172 | [ clause [] 173 | (normalB $ consToDatum opts cons) 174 | [] 175 | ] 176 | ] 177 | where 178 | classType = conT ''ToDatum 179 | typeNames = map tvbName tvbs 180 | instanceType = foldl' appT (conT name) $ map varT typeNames 181 | 182 | -- | Generates a lambda expression which encodes the given data type as Datum. 183 | mkToDatum :: Options -- ^ Encoding options. 184 | -> Name -- ^ Name of the type to encode. 185 | -> Q Exp 186 | mkToDatum opts name = withType name (\_ cons -> consToDatum opts cons) 187 | 188 | -- | Helper function used by both 'deriveToDatum' and 'mkToDatum'. Generates code 189 | -- to generate the Datum encoding of a number of constructors. All constructors 190 | -- must be from the same type. 191 | consToDatum :: Options 192 | -- ^ Encoding options. 193 | -> [Con] 194 | -- ^ Constructors for which to generate Datum generating code. 195 | -> Q Exp 196 | 197 | consToDatum _ [] = error $ "Data.Aeson.TH.consToDatum: " 198 | ++ "Not a single constructor given!" 199 | 200 | -- A single constructor is directly encoded. The constructor itself may be 201 | -- forgotten. 202 | consToDatum opts [con] = do 203 | value <- newName "value" 204 | lam1E (varP value) $ caseE (varE value) [encodeArgs opts False con] 205 | 206 | consToDatum opts cons = do 207 | value <- newName "value" 208 | lam1E (varP value) $ caseE (varE value) matches 209 | where 210 | matches 211 | | allNullaryToStringTag opts && all isNullary cons = 212 | [ match (conP conName []) (normalB $ conStr opts conName) [] 213 | | con <- cons 214 | , let conName = getConName con 215 | ] 216 | | otherwise = [encodeArgs opts True con | con <- cons] 217 | 218 | conStr :: Options -> Name -> Q Exp 219 | conStr opts = appE [|String|] . conTxt opts 220 | 221 | conTxt :: Options -> Name -> Q Exp 222 | conTxt opts = appE [|T.pack|] . conStringE opts 223 | 224 | conStringE :: Options -> Name -> Q Exp 225 | conStringE opts = stringE . constructorTagModifier opts . nameBase 226 | 227 | -- | If constructor is nullary. 228 | isNullary :: Con -> Bool 229 | isNullary (NormalC _ []) = True 230 | isNullary _ = False 231 | 232 | encodeSum :: Options -> Bool -> Name -> Q Exp -> Q Exp 233 | encodeSum opts multiCons conName exp 234 | | multiCons = 235 | case sumEncoding opts of 236 | TwoElemArray -> 237 | [|Array|] `appE` ([|V.fromList|] `appE` listE [conStr opts conName, exp]) 238 | TaggedObject{tagFieldName, contentsFieldName} -> 239 | [|object|] `appE` listE 240 | [ infixApp [|T.pack tagFieldName|] [|(.=)|] (conStr opts conName) 241 | , infixApp [|T.pack contentsFieldName|] [|(.=)|] exp 242 | ] 243 | ObjectWithSingleField -> 244 | [|object|] `appE` listE 245 | [ infixApp (conTxt opts conName) [|(.=)|] exp 246 | ] 247 | UntaggedValue -> exp 248 | 249 | | otherwise = exp 250 | 251 | -- | Generates code to generate the Datum encoding of a single constructor. 252 | encodeArgs :: Options -> Bool -> Con -> Q Match 253 | -- Nullary constructors. Generates code that explicitly matches against the 254 | -- constructor even though it doesn't contain data. This is useful to prevent 255 | -- type errors. 256 | encodeArgs opts multiCons (NormalC conName []) = 257 | match (conP conName []) 258 | (normalB (encodeSum opts multiCons conName [e|toDatum ([] :: [()])|])) 259 | [] 260 | 261 | -- Polyadic constructors with special case for unary constructors. 262 | encodeArgs opts multiCons (NormalC conName ts) = do 263 | let len = length ts 264 | args <- mapM newName ["arg" ++ show n | n <- [1..len]] 265 | js <- case [[|toDatum|] `appE` varE arg | arg <- args] of 266 | -- Single argument is directly converted. 267 | [e] -> return e 268 | -- Multiple arguments are converted to a Datum array. 269 | es -> do 270 | mv <- newName "mv" 271 | let newMV = bindS (varP mv) 272 | ([|VM.unsafeNew|] `appE` 273 | litE (integerL $ fromIntegral len)) 274 | stmts = [ noBindS $ 275 | [|VM.unsafeWrite|] `appE` 276 | (varE mv) `appE` 277 | litE (integerL ix) `appE` 278 | e 279 | | (ix, e) <- zip [(0::Integer)..] es 280 | ] 281 | ret = noBindS $ [|return|] `appE` varE mv 282 | return $ [|Array|] `appE` 283 | (varE 'V.create `appE` 284 | doE (newMV:stmts++[ret])) 285 | match (conP conName $ map varP args) 286 | (normalB $ encodeSum opts multiCons conName js) 287 | [] 288 | 289 | -- Records. 290 | encodeArgs opts multiCons (RecC conName ts) = do 291 | args <- mapM newName ["arg" ++ show n | (_, n) <- zip ts [1 :: Integer ..]] 292 | let exp = [|object|] `appE` pairs 293 | 294 | pairs | omitNothingFields opts = infixApp maybeFields 295 | [|(++)|] 296 | restFields 297 | | otherwise = listE $ map toPair argCons 298 | 299 | argCons = zip args ts 300 | 301 | maybeFields = [|catMaybes|] `appE` listE (map maybeToPair maybes) 302 | 303 | restFields = listE $ map toPair rest 304 | 305 | (maybes, rest) = partition isMaybe argCons 306 | 307 | isMaybe (_, (_, _, AppT (ConT t) _)) = t == ''Maybe 308 | isMaybe _ = False 309 | 310 | maybeToPair (arg, (field, _, _)) = 311 | infixApp (infixE (Just $ toFieldName field) 312 | [|(.=)|] 313 | Nothing) 314 | [|(<$>)|] 315 | (varE arg) 316 | 317 | toPair (arg, (field, _, _)) = 318 | infixApp (toFieldName field) 319 | [|(.=)|] 320 | (varE arg) 321 | 322 | toFieldName field = [|T.pack|] `appE` fieldLabelExp opts field 323 | 324 | match (conP conName $ map varP args) 325 | ( normalB 326 | $ if multiCons 327 | then case sumEncoding opts of 328 | TwoElemArray -> [|toDatum|] `appE` tupE [conStr opts conName, exp] 329 | TaggedObject{tagFieldName} -> 330 | [|object|] `appE` 331 | -- TODO: Maybe throw an error in case 332 | -- tagFieldName overwrites a field in pairs. 333 | infixApp (infixApp [|T.pack tagFieldName|] 334 | [|(.=)|] 335 | (conStr opts conName)) 336 | [|(:)|] 337 | pairs 338 | ObjectWithSingleField -> 339 | [|object|] `appE` listE 340 | [ infixApp (conTxt opts conName) [|(.=)|] exp ] 341 | UntaggedValue -> exp 342 | else exp 343 | ) [] 344 | 345 | -- Infix constructors. 346 | encodeArgs opts multiCons (InfixC _ conName _) = do 347 | al <- newName "argL" 348 | ar <- newName "argR" 349 | match (infixP (varP al) conName (varP ar)) 350 | ( normalB 351 | $ encodeSum opts multiCons conName 352 | $ [|toDatum|] `appE` listE [ [|toDatum|] `appE` varE a 353 | | a <- [al,ar] 354 | ] 355 | ) 356 | [] 357 | -- Existentially quantified constructors. 358 | encodeArgs opts multiCons (ForallC _ _ con) = 359 | encodeArgs opts multiCons con 360 | 361 | -- GADTs. 362 | encodeArgs opts multiCons (GadtC conNames ts _) = 363 | encodeArgs opts multiCons $ NormalC (head conNames) ts 364 | 365 | encodeArgs opts multiCons (RecGadtC conNames ts _) = 366 | encodeArgs opts multiCons $ RecC (head conNames) ts 367 | 368 | 369 | -------------------------------------------------------------------------------- 370 | -- FromDatum 371 | -------------------------------------------------------------------------------- 372 | 373 | -- | Generates a 'FromDatum' instance declaration for the given data type. 374 | deriveFromDatum :: Options 375 | -- ^ Encoding options. 376 | -> Name 377 | -- ^ Name of the type for which to generate a 'FromDatum' instance 378 | -- declaration. 379 | -> Q [Dec] 380 | deriveFromDatum opts name = 381 | withType name $ \tvbs cons -> fmap (:[]) $ fromCons tvbs cons 382 | where 383 | fromCons :: [TyVarBndr] -> [Con] -> Q Dec 384 | fromCons tvbs cons = 385 | instanceD (applyCon ''FromDatum typeNames) 386 | (classType `appT` instanceType) 387 | [ funD 'parseDatum 388 | [ clause [] 389 | (normalB $ consFromDatum name opts cons) 390 | [] 391 | ] 392 | ] 393 | where 394 | classType = conT ''FromDatum 395 | typeNames = map tvbName tvbs 396 | instanceType = foldl' appT (conT name) $ map varT typeNames 397 | 398 | -- | Generates a lambda expression which parses the Datum encoding of the given 399 | -- data type. 400 | mkParseDatum :: Options -- ^ Encoding options. 401 | -> Name -- ^ Name of the encoded type. 402 | -> Q Exp 403 | mkParseDatum opts name = 404 | withType name (\_ cons -> consFromDatum name opts cons) 405 | 406 | -- | Helper function used by both 'deriveFromDatum' and 'mkParseDatum'. Generates 407 | -- code to parse the Datum encoding of a number of constructors. All constructors 408 | -- must be from the same type. 409 | consFromDatum :: Name 410 | -- ^ Name of the type to which the constructors belong. 411 | -> Options 412 | -- ^ Encoding options 413 | -> [Con] 414 | -- ^ Constructors for which to generate Datum parsing code. 415 | -> Q Exp 416 | 417 | consFromDatum _ _ [] = error $ "Data.Aeson.TH.consFromDatum: " 418 | ++ "Not a single constructor given!" 419 | 420 | consFromDatum tName opts [con] = do 421 | value <- newName "value" 422 | lam1E (varP value) (parseArgs tName opts con (Right value)) 423 | 424 | consFromDatum tName opts cons = do 425 | value <- newName "value" 426 | lam1E (varP value) $ caseE (varE value) $ 427 | if allNullaryToStringTag opts && all isNullary cons 428 | then allNullaryMatches 429 | else mixedMatches 430 | 431 | where 432 | allNullaryMatches = 433 | [ do txt <- newName "txt" 434 | match (conP 'String [varP txt]) 435 | (guardedB $ 436 | [ liftM2 (,) (normalG $ 437 | infixApp (varE txt) 438 | [|(==)|] 439 | ([|T.pack|] `appE` 440 | conStringE opts conName) 441 | ) 442 | ([|pure|] `appE` conE conName) 443 | | con <- cons 444 | , let conName = getConName con 445 | ] 446 | ++ 447 | [ liftM2 (,) 448 | (normalG [|otherwise|]) 449 | ( [|noMatchFail|] 450 | `appE` (litE $ stringL $ show tName) 451 | `appE` ([|T.unpack|] `appE` varE txt) 452 | ) 453 | ] 454 | ) 455 | [] 456 | , do other <- newName "other" 457 | match (varP other) 458 | (normalB $ [|noStringFail|] 459 | `appE` (litE $ stringL $ show tName) 460 | `appE` ([|valueConName|] `appE` varE other) 461 | ) 462 | [] 463 | ] 464 | 465 | mixedMatches = 466 | case sumEncoding opts of 467 | UntaggedValue -> parseObject varE 468 | TaggedObject {tagFieldName, contentsFieldName} -> 469 | parseObject $ parseTaggedObject tagFieldName contentsFieldName 470 | ObjectWithSingleField -> 471 | parseObject $ parseObjectWithSingleField 472 | TwoElemArray -> 473 | [ do arr <- newName "array" 474 | match (conP 'Array [varP arr]) 475 | (guardedB $ 476 | [ liftM2 (,) (normalG $ infixApp ([|V.length|] `appE` varE arr) 477 | [|(==)|] 478 | (litE $ integerL 2)) 479 | (parse2ElemArray arr) 480 | , liftM2 (,) (normalG [|otherwise|]) 481 | (([|not2ElemArray|] 482 | `appE` (litE $ stringL $ show tName) 483 | `appE` ([|V.length|] `appE` varE arr))) 484 | ] 485 | ) 486 | [] 487 | , do other <- newName "other" 488 | match (varP other) 489 | ( normalB 490 | $ [|noArrayFail|] 491 | `appE` (litE $ stringL $ show tName) 492 | `appE` ([|valueConName|] `appE` varE other) 493 | ) 494 | [] 495 | ] 496 | 497 | parseObject f = 498 | [ do obj <- newName "obj" 499 | match (conP 'Object [varP obj]) (normalB $ f obj) [] 500 | , do other <- newName "other" 501 | match (varP other) 502 | ( normalB 503 | $ [|noObjectFail|] 504 | `appE` (litE $ stringL $ show tName) 505 | `appE` ([|valueConName|] `appE` varE other) 506 | ) 507 | [] 508 | ] 509 | 510 | parseTaggedObject typFieldName valFieldName obj = do 511 | conKey <- newName "conKey" 512 | doE [ bindS (varP conKey) 513 | (infixApp (varE obj) 514 | [|(.:)|] 515 | ([|T.pack|] `appE` stringE typFieldName)) 516 | , noBindS $ parseContents conKey (Left (valFieldName, obj)) 'conNotFoundFailTaggedObject 517 | ] 518 | 519 | parse2ElemArray arr = do 520 | conKey <- newName "conKey" 521 | conVal <- newName "conVal" 522 | let letIx n ix = 523 | valD (varP n) 524 | (normalB ([|V.unsafeIndex|] `appE` 525 | varE arr `appE` 526 | litE (integerL ix))) 527 | [] 528 | letE [ letIx conKey 0 529 | , letIx conVal 1 530 | ] 531 | (caseE (varE conKey) 532 | [ do txt <- newName "txt" 533 | match (conP 'String [varP txt]) 534 | (normalB $ parseContents txt 535 | (Right conVal) 536 | 'conNotFoundFail2ElemArray 537 | ) 538 | [] 539 | , do other <- newName "other" 540 | match (varP other) 541 | ( normalB 542 | $ [|firstElemNoStringFail|] 543 | `appE` (litE $ stringL $ show tName) 544 | `appE` ([|valueConName|] `appE` varE other) 545 | ) 546 | [] 547 | ] 548 | ) 549 | 550 | parseObjectWithSingleField obj = do 551 | conKey <- newName "conKey" 552 | conVal <- newName "conVal" 553 | caseE ([e|H.toList|] `appE` varE obj) 554 | [ match (listP [tupP [varP conKey, varP conVal]]) 555 | (normalB $ parseContents conKey (Right conVal) 'conNotFoundFailObjectSingleField) 556 | [] 557 | , do other <- newName "other" 558 | match (varP other) 559 | (normalB $ [|wrongPairCountFail|] 560 | `appE` (litE $ stringL $ show tName) 561 | `appE` ([|show . length|] `appE` varE other) 562 | ) 563 | [] 564 | ] 565 | 566 | parseContents conKey contents errorFun = 567 | caseE (varE conKey) 568 | [ match wildP 569 | ( guardedB $ 570 | [ do g <- normalG $ infixApp (varE conKey) 571 | [|(==)|] 572 | ([|T.pack|] `appE` 573 | conNameExp opts con) 574 | e <- parseArgs tName opts con contents 575 | return (g, e) 576 | | con <- cons 577 | ] 578 | ++ 579 | [ liftM2 (,) 580 | (normalG [e|otherwise|]) 581 | ( varE errorFun 582 | `appE` (litE $ stringL $ show tName) 583 | `appE` listE (map ( litE 584 | . stringL 585 | . constructorTagModifier opts 586 | . nameBase 587 | . getConName 588 | ) cons 589 | ) 590 | `appE` ([|T.unpack|] `appE` varE conKey) 591 | ) 592 | ] 593 | ) 594 | [] 595 | ] 596 | 597 | parseNullaryMatches :: Name -> Name -> [Q Match] 598 | parseNullaryMatches tName conName = 599 | [ do arr <- newName "arr" 600 | match (conP 'Array [varP arr]) 601 | (guardedB $ 602 | [ liftM2 (,) (normalG $ [|V.null|] `appE` varE arr) 603 | ([|pure|] `appE` conE conName) 604 | , liftM2 (,) (normalG [|otherwise|]) 605 | (parseTypeMismatch tName conName 606 | (litE $ stringL "an empty Array") 607 | (infixApp (litE $ stringL $ "Array of length ") 608 | [|(++)|] 609 | ([|show . V.length|] `appE` varE arr) 610 | ) 611 | ) 612 | ] 613 | ) 614 | [] 615 | , matchFailed tName conName "Array" 616 | ] 617 | 618 | parseUnaryMatches :: Name -> [Q Match] 619 | parseUnaryMatches conName = 620 | [ do arg <- newName "arg" 621 | match (varP arg) 622 | ( normalB $ infixApp (conE conName) 623 | [|(<$>)|] 624 | ([|parseDatum|] `appE` varE arg) 625 | ) 626 | [] 627 | ] 628 | 629 | parseRecord :: Options -> Name -> Name -> [VarStrictType] -> Name -> ExpQ 630 | parseRecord opts tName conName ts obj = 631 | foldl' (\a b -> infixApp a [|(<*>)|] b) 632 | (infixApp (conE conName) [|(<$>)|] x) 633 | xs 634 | where 635 | x:xs = [ [|lookupField|] 636 | `appE` (litE $ stringL $ show tName) 637 | `appE` (litE $ stringL $ constructorTagModifier opts $ nameBase conName) 638 | `appE` (varE obj) 639 | `appE` ( [|T.pack|] `appE` fieldLabelExp opts field 640 | ) 641 | | (field, _, _) <- ts 642 | ] 643 | 644 | getValField :: Name -> String -> [MatchQ] -> Q Exp 645 | getValField obj valFieldName matches = do 646 | val <- newName "val" 647 | doE [ bindS (varP val) $ infixApp (varE obj) 648 | [|(.:)|] 649 | ([|T.pack|] `appE` 650 | (litE $ stringL valFieldName)) 651 | , noBindS $ caseE (varE val) matches 652 | ] 653 | 654 | -- | Generates code to parse the Datum encoding of a single constructor. 655 | parseArgs :: Name -- ^ Name of the type to which the constructor belongs. 656 | -> Options -- ^ Encoding options. 657 | -> Con -- ^ Constructor for which to generate Datum parsing code. 658 | -> Either (String, Name) Name -- ^ Left (valFieldName, objName) or 659 | -- Right valName 660 | -> Q Exp 661 | -- Nullary constructors. 662 | parseArgs tName _ (NormalC conName []) (Left (valFieldName, obj)) = 663 | getValField obj valFieldName $ parseNullaryMatches tName conName 664 | parseArgs tName _ (NormalC conName []) (Right valName) = 665 | caseE (varE valName) $ parseNullaryMatches tName conName 666 | 667 | -- Unary constructors. 668 | parseArgs _ _ (NormalC conName [_]) (Left (valFieldName, obj)) = 669 | getValField obj valFieldName $ parseUnaryMatches conName 670 | parseArgs _ _ (NormalC conName [_]) (Right valName) = 671 | caseE (varE valName) $ parseUnaryMatches conName 672 | 673 | -- Polyadic constructors. 674 | parseArgs tName _ (NormalC conName ts) (Left (valFieldName, obj)) = 675 | getValField obj valFieldName $ parseProduct tName conName $ genericLength ts 676 | parseArgs tName _ (NormalC conName ts) (Right valName) = 677 | caseE (varE valName) $ parseProduct tName conName $ genericLength ts 678 | 679 | -- Records. 680 | parseArgs tName opts (RecC conName ts) (Left (_, obj)) = 681 | parseRecord opts tName conName ts obj 682 | parseArgs tName opts (RecC conName ts) (Right valName) = do 683 | obj <- newName "recObj" 684 | caseE (varE valName) 685 | [ match (conP 'Object [varP obj]) (normalB $ parseRecord opts tName conName ts obj) [] 686 | , matchFailed tName conName "Object" 687 | ] 688 | 689 | -- Infix constructors. Apart from syntax these are the same as 690 | -- polyadic constructors. 691 | parseArgs tName _ (InfixC _ conName _) (Left (valFieldName, obj)) = 692 | getValField obj valFieldName $ parseProduct tName conName 2 693 | parseArgs tName _ (InfixC _ conName _) (Right valName) = 694 | caseE (varE valName) $ parseProduct tName conName 2 695 | 696 | -- Existentially quantified constructors. We ignore the quantifiers 697 | -- and proceed with the contained constructor. 698 | parseArgs tName opts (ForallC _ _ con) contents = 699 | parseArgs tName opts con contents 700 | 701 | -- GADTs. We ignore the refined return type and proceed as if it were a 702 | -- NormalC or RecC. 703 | parseArgs tName opts (GadtC conNames ts _) contents = 704 | parseArgs tName opts (NormalC (head conNames) ts) contents 705 | 706 | parseArgs tName opts (RecGadtC conNames ts _) contents = 707 | parseArgs tName opts (RecC (head conNames) ts) contents 708 | 709 | -- | Generates code to parse the Datum encoding of an n-ary 710 | -- constructor. 711 | parseProduct :: Name -- ^ Name of the type to which the constructor belongs. 712 | -> Name -- ^ 'Con'structor name. 713 | -> Integer -- ^ 'Con'structor arity. 714 | -> [Q Match] 715 | parseProduct tName conName numArgs = 716 | [ do arr <- newName "arr" 717 | -- List of: "parseDatum (arr `V.unsafeIndex` )" 718 | let x:xs = [ [|parseDatum|] 719 | `appE` 720 | infixApp (varE arr) 721 | [|V.unsafeIndex|] 722 | (litE $ integerL ix) 723 | | ix <- [0 .. numArgs - 1] 724 | ] 725 | match (conP 'Array [varP arr]) 726 | (normalB $ condE ( infixApp ([|V.length|] `appE` varE arr) 727 | [|(==)|] 728 | (litE $ integerL numArgs) 729 | ) 730 | ( foldl' (\a b -> infixApp a [|(<*>)|] b) 731 | (infixApp (conE conName) [|(<$>)|] x) 732 | xs 733 | ) 734 | ( parseTypeMismatch tName conName 735 | (litE $ stringL $ "Array of length " ++ show numArgs) 736 | ( infixApp (litE $ stringL $ "Array of length ") 737 | [|(++)|] 738 | ([|show . V.length|] `appE` varE arr) 739 | ) 740 | ) 741 | ) 742 | [] 743 | , matchFailed tName conName "Array" 744 | ] 745 | 746 | 747 | -------------------------------------------------------------------------------- 748 | -- Parsing errors 749 | -------------------------------------------------------------------------------- 750 | 751 | matchFailed :: Name -> Name -> String -> MatchQ 752 | matchFailed tName conName expected = do 753 | other <- newName "other" 754 | match (varP other) 755 | ( normalB $ parseTypeMismatch tName conName 756 | (litE $ stringL expected) 757 | ([|valueConName|] `appE` varE other) 758 | ) 759 | [] 760 | 761 | parseTypeMismatch :: Name -> Name -> ExpQ -> ExpQ -> ExpQ 762 | parseTypeMismatch tName conName expected actual = 763 | foldl appE 764 | [|parseTypeMismatch'|] 765 | [ litE $ stringL $ nameBase conName 766 | , litE $ stringL $ show tName 767 | , expected 768 | , actual 769 | ] 770 | 771 | class (FromDatum a) => LookupField a where 772 | lookupField :: String -> String -> Object -> T.Text -> Parser a 773 | 774 | instance (FromDatum a) => LookupField a where 775 | lookupField tName rec obj key = 776 | case H.lookup key obj of 777 | Nothing -> unknownFieldFail tName rec (T.unpack key) 778 | Just v -> parseDatum v 779 | 780 | instance (FromDatum a) => LookupField (Maybe a) where 781 | lookupField _ _ = (.:?) 782 | 783 | unknownFieldFail :: String -> String -> String -> Parser fail 784 | unknownFieldFail tName rec key = 785 | fail $ printf "When parsing the record %s of type %s the key %s was not present." 786 | rec tName key 787 | 788 | noArrayFail :: String -> String -> Parser fail 789 | noArrayFail t o = fail $ printf "When parsing %s expected Array but got %s." t o 790 | 791 | noObjectFail :: String -> String -> Parser fail 792 | noObjectFail t o = fail $ printf "When parsing %s expected Object but got %s." t o 793 | 794 | firstElemNoStringFail :: String -> String -> Parser fail 795 | firstElemNoStringFail t o = fail $ printf "When parsing %s expected an Array of 2 elements where the first element is a String but got %s at the first element." t o 796 | 797 | wrongPairCountFail :: String -> String -> Parser fail 798 | wrongPairCountFail t n = 799 | fail $ printf "When parsing %s expected an Object with a single tag/contents pair but got %s pairs." 800 | t n 801 | 802 | noStringFail :: String -> String -> Parser fail 803 | noStringFail t o = fail $ printf "When parsing %s expected String but got %s." t o 804 | 805 | noMatchFail :: String -> String -> Parser fail 806 | noMatchFail t o = 807 | fail $ printf "When parsing %s expected a String with the tag of a constructor but got %s." t o 808 | 809 | not2ElemArray :: String -> Int -> Parser fail 810 | not2ElemArray t i = fail $ printf "When parsing %s expected an Array of 2 elements but got %i elements" t i 811 | 812 | conNotFoundFail2ElemArray :: String -> [String] -> String -> Parser fail 813 | conNotFoundFail2ElemArray t cs o = 814 | fail $ printf "When parsing %s expected a 2-element Array with a tag and contents element where the tag is one of [%s], but got %s." 815 | t (intercalate ", " cs) o 816 | 817 | conNotFoundFailObjectSingleField :: String -> [String] -> String -> Parser fail 818 | conNotFoundFailObjectSingleField t cs o = 819 | fail $ printf "When parsing %s expected an Object with a single tag/contents pair where the tag is one of [%s], but got %s." 820 | t (intercalate ", " cs) o 821 | 822 | conNotFoundFailTaggedObject :: String -> [String] -> String -> Parser fail 823 | conNotFoundFailTaggedObject t cs o = 824 | fail $ printf "When parsing %s expected an Object with a tag field where the value is one of [%s], but got %s." 825 | t (intercalate ", " cs) o 826 | 827 | parseTypeMismatch' :: String -> String -> String -> String -> Parser fail 828 | parseTypeMismatch' tName conName expected actual = 829 | fail $ printf "When parsing the constructor %s of type %s expected %s but got %s." 830 | conName tName expected actual 831 | 832 | 833 | -------------------------------------------------------------------------------- 834 | -- Utility functions 835 | -------------------------------------------------------------------------------- 836 | 837 | -- | Boilerplate for top level splices. 838 | -- 839 | -- The given 'Name' must be from a type constructor. Furthermore, the 840 | -- type constructor must be either a data type or a newtype. Any other 841 | -- value will result in an exception. 842 | withType :: Name 843 | -> ([TyVarBndr] -> [Con] -> Q a) 844 | -- ^ Function that generates the actual code. Will be applied 845 | -- to the type variable binders and constructors extracted 846 | -- from the given 'Name'. 847 | -> Q a 848 | -- ^ Resulting value in the 'Q'uasi monad. 849 | withType name f = do 850 | info <- reify name 851 | case info of 852 | TyConI dec -> 853 | case dec of 854 | DataD _ _ tvbs _ cons _ -> f tvbs cons 855 | NewtypeD _ _ tvbs _ con _ -> f tvbs [con] 856 | other -> error $ "Data.Aeson.TH.withType: Unsupported type: " 857 | ++ show other 858 | _ -> error "Data.Aeson.TH.withType: I need the name of a type." 859 | 860 | -- | Extracts the name from a constructor. 861 | getConName :: Con -> Name 862 | getConName (NormalC name _) = name 863 | getConName (RecC name _) = name 864 | getConName (InfixC _ name _) = name 865 | getConName (ForallC _ _ con) = getConName con 866 | getConName (GadtC names _ _) = head names 867 | getConName (RecGadtC names _ _) = head names 868 | 869 | -- | Extracts the name from a type variable binder. 870 | tvbName :: TyVarBndr -> Name 871 | tvbName (PlainTV name ) = name 872 | tvbName (KindedTV name _) = name 873 | 874 | -- | Makes a string literal expression from a constructor's name. 875 | conNameExp :: Options -> Con -> Q Exp 876 | conNameExp opts = litE 877 | . stringL 878 | . constructorTagModifier opts 879 | . nameBase 880 | . getConName 881 | 882 | -- | Creates a string literal expression from a record field label. 883 | fieldLabelExp :: Options -- ^ Encoding options 884 | -> Name 885 | -> Q Exp 886 | fieldLabelExp opts = litE . stringL . fieldLabelModifier opts . nameBase 887 | 888 | -- | The name of the outermost 'Value' constructor. 889 | valueConName :: Datum -> String 890 | valueConName (Object _) = "Object" 891 | valueConName (Array _) = "Array" 892 | valueConName (String _) = "String" 893 | valueConName (Number _) = "Number" 894 | valueConName (Bool _) = "Boolean" 895 | valueConName (Time _) = "Time" 896 | valueConName Null = "Null" 897 | 898 | applyCon :: Name -> [Name] -> Q [Pred] 899 | applyCon con = mapM $ \t -> appT (conT con) (varT t) 900 | -------------------------------------------------------------------------------- /src/Database/RethinkDB/Types.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE DeriveGeneric #-} 2 | {-# LANGUAGE FlexibleContexts #-} 3 | {-# LANGUAGE FlexibleInstances #-} 4 | {-# LANGUAGE GADTs #-} 5 | {-# LANGUAGE MultiParamTypeClasses #-} 6 | {-# LANGUAGE OverloadedStrings #-} 7 | {-# LANGUAGE TypeFamilies #-} 8 | 9 | module Database.RethinkDB.Types where 10 | 11 | 12 | import Control.Applicative 13 | import Control.Monad.State (State, gets, modify, evalState) 14 | 15 | import Data.Word 16 | import Data.String 17 | import Data.Text (Text) 18 | import Data.Time 19 | import Data.Time.Clock.POSIX 20 | 21 | import Data.Aeson (FromJSON, parseJSON, toJSON) 22 | import Data.Aeson.Types (Parser, Value) 23 | import qualified Data.Aeson as A 24 | 25 | import Data.Vector (Vector) 26 | import qualified Data.Vector as V 27 | import Data.HashMap.Strict (HashMap) 28 | import qualified Data.HashMap.Strict as HMS 29 | import Data.Set (Set) 30 | import qualified Data.Set as S 31 | 32 | import Database.RethinkDB.Types.Datum 33 | 34 | import Prelude 35 | 36 | 37 | 38 | ------------------------------------------------------------------------------ 39 | -- | A Term is a JSON expression which can be sent to the server. Building a 40 | -- term is a stateful operation, so the whole process happens inside a 'State' 41 | -- monad. 42 | 43 | class Term a where 44 | toTerm :: a -> State Context A.Value 45 | 46 | instance Term A.Value where 47 | toTerm = pure 48 | 49 | 50 | 51 | ------------------------------------------------------------------------------ 52 | -- | Building a RethinkDB query from an expression is a stateful process, and 53 | -- is done using this as the context. 54 | 55 | data Context = Context 56 | { varCounter :: !Int 57 | -- ^ How many 'Var's have been allocated. See 'newVar'. 58 | 59 | , defaultDatabase :: !(Exp Database) 60 | -- ^ The default database for the case that the 'Table' expression 61 | -- doesn't specify one. 62 | } 63 | 64 | 65 | compileTerm :: Exp Database -> State Context A.Value -> A.Value 66 | compileTerm db e = evalState e (Context 0 db) 67 | 68 | 69 | -- | Allocate a new var index from the context. 70 | newVar :: State Context Int 71 | newVar = do 72 | ix <- gets varCounter 73 | modify $ \s -> s { varCounter = ix + 1 } 74 | pure ix 75 | 76 | 77 | 78 | class IsDatum a 79 | 80 | instance IsDatum Datum 81 | 82 | instance Term Datum where 83 | toTerm (Null ) = pure $ A.Null 84 | toTerm (Bool x) = toTerm x 85 | toTerm (Number x) = toTerm x 86 | toTerm (String x) = toTerm x 87 | toTerm (Array x) = toTerm x 88 | toTerm (Object x) = toTerm x 89 | toTerm (Time x) = toTerm x 90 | 91 | instance FromResponse Datum where 92 | parseResponse = responseAtomParser 93 | 94 | instance FromResponse (Maybe Datum) where 95 | parseResponse r = case (responseType r, V.toList (responseResult r)) of 96 | (SuccessAtom, [a]) -> do 97 | res0 <- parseWire a 98 | case res0 of 99 | Null -> pure Nothing 100 | res -> pure $ Just res 101 | _ -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r) 102 | 103 | 104 | 105 | ------------------------------------------------------------------------------ 106 | -- | For a boolean type, we're reusing the standard Haskell 'Bool' type. 107 | 108 | instance IsDatum Bool 109 | 110 | instance FromResponse Bool where 111 | parseResponse = responseAtomParser 112 | 113 | instance Term Bool where 114 | toTerm = pure . A.Bool 115 | 116 | 117 | 118 | ------------------------------------------------------------------------------ 119 | -- | Numbers are 'Double' (unlike 'Aeson', which uses 'Scientific'). No 120 | -- particular reason. 121 | 122 | instance IsDatum Double 123 | 124 | instance FromResponse Double where 125 | parseResponse = responseAtomParser 126 | 127 | instance Term Double where 128 | toTerm = pure . toJSON 129 | 130 | 131 | instance FromResponse Int where 132 | parseResponse = responseAtomParser 133 | 134 | 135 | instance FromResponse Char where 136 | parseResponse = responseAtomParser 137 | 138 | instance FromResponse [Char] where 139 | parseResponse = responseAtomParser 140 | 141 | 142 | 143 | ------------------------------------------------------------------------------ 144 | -- | For strings, we're using the Haskell 'Text' type. 145 | 146 | instance IsDatum Text 147 | 148 | instance FromResponse Text where 149 | parseResponse = responseAtomParser 150 | 151 | instance Term Text where 152 | toTerm = pure . toJSON 153 | 154 | 155 | 156 | ------------------------------------------------------------------------------ 157 | -- | Arrays are vectors of 'Datum'. 158 | 159 | instance (IsDatum a) => IsDatum (Array a) 160 | instance (IsDatum a) => IsSequence (Array a) 161 | 162 | instance (FromDatum a) => FromResponse (Array a) where 163 | parseResponse = responseAtomParser 164 | 165 | instance (Term a) => Term (Array a) where 166 | toTerm v = do 167 | vals <- mapM toTerm (V.toList v) 168 | options <- toTerm emptyOptions 169 | pure $ A.Array $ V.fromList $ 170 | [ A.Number 2 171 | , toJSON vals 172 | , toJSON $ options 173 | ] 174 | 175 | 176 | 177 | ------------------------------------------------------------------------------ 178 | -- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using 179 | -- 'HashMap'. 180 | 181 | class (IsDatum a) => IsObject a 182 | 183 | 184 | instance IsDatum Object 185 | instance IsObject Object 186 | 187 | instance FromResponse Object where 188 | parseResponse = responseAtomParser 189 | 190 | instance Term Object where 191 | toTerm x = do 192 | items <- mapM (\(k, v) -> (,) <$> pure k <*> toTerm v) $ HMS.toList x 193 | pure $ A.Object $ HMS.fromList $ items 194 | 195 | 196 | 197 | ------------------------------------------------------------------------------ 198 | -- | Time in RethinkDB is represented similar to the 'ZonedTime' type. Except 199 | -- that the JSON representation on the wire looks different from the default 200 | -- used by 'Aeson'. Therefore we have a custom 'FromRSON' and 'ToRSON' 201 | -- instances. 202 | 203 | instance IsDatum ZonedTime 204 | instance IsObject ZonedTime 205 | 206 | instance FromResponse ZonedTime where 207 | parseResponse = responseAtomParser 208 | 209 | instance Term ZonedTime where 210 | toTerm x = pure $ A.object 211 | [ "$reql_type$" A..= ("TIME" :: Text) 212 | , "timezone" A..= (timeZoneOffsetString $ zonedTimeZone x) 213 | , "epoch_time" A..= (realToFrac $ utcTimeToPOSIXSeconds $ zonedTimeToUTC x :: Double) 214 | ] 215 | 216 | 217 | 218 | ------------------------------------------------------------------------------ 219 | -- UTCTime 220 | 221 | instance IsDatum UTCTime 222 | instance IsObject UTCTime 223 | 224 | instance FromResponse UTCTime where 225 | parseResponse = responseAtomParser 226 | 227 | instance Term UTCTime where 228 | toTerm = toTerm . utcToZonedTime utc 229 | 230 | 231 | 232 | ------------------------------------------------------------------------------ 233 | -- | Tables are something you can select objects from. 234 | -- 235 | -- This type is not exported, and merely serves as a sort of phantom type. On 236 | -- the client tables are converted to a 'Sequence'. 237 | 238 | data Table = MkTable 239 | 240 | instance IsSequence Table 241 | 242 | 243 | 244 | ------------------------------------------------------------------------------ 245 | -- | 'SingleSelection' is essentially a 'Maybe Object', where 'Nothing' is 246 | -- represented with 'Null' in the network protocol. 247 | 248 | data SingleSelection = SingleSelection 249 | deriving (Show) 250 | 251 | instance IsDatum SingleSelection 252 | instance IsObject SingleSelection 253 | 254 | 255 | 256 | ------------------------------------------------------------------------------ 257 | -- | A 'Database' is something which contains tables. It is a server-only 258 | -- type. 259 | 260 | data Database = MkDatabase 261 | 262 | 263 | 264 | ------------------------------------------------------------------------------ 265 | -- | Bounds are used in 'Between'. 266 | 267 | data Bound = Open !Datum | Closed !Datum 268 | 269 | boundDatum :: Bound -> Datum 270 | boundDatum (Open x) = x 271 | boundDatum (Closed x) = x 272 | 273 | boundString :: Bound -> Text 274 | boundString (Open _) = "open" 275 | boundString (Closed _) = "closed" 276 | 277 | 278 | 279 | ------------------------------------------------------------------------------ 280 | -- | ConflictResolutionStrategy 281 | -- 282 | -- How conflicts should be resolved. 283 | 284 | data ConflictResolutionStrategy 285 | 286 | = CRError 287 | -- ^ Do not insert the new document and record the conflict as an error. 288 | -- This is the default. 289 | 290 | | CRReplace 291 | -- ^ Replace the old document in its entirety with the new one. 292 | 293 | | CRUpdate 294 | -- ^ Update fields of the old document with fields from the new one. 295 | 296 | 297 | instance ToDatum ConflictResolutionStrategy where 298 | toDatum CRError = String "error" 299 | toDatum CRReplace = String "replace" 300 | toDatum CRUpdate = String "update" 301 | 302 | 303 | 304 | ------------------------------------------------------------------------------ 305 | -- | Used in 'OrderBy'. 306 | 307 | data Order = Ascending !Text | Descending !Text 308 | 309 | instance Term Order where 310 | toTerm (Ascending key) = simpleTerm 73 [SomeExp $ lift key] 311 | toTerm (Descending key) = simpleTerm 74 [SomeExp $ lift key] 312 | 313 | 314 | 315 | ------------------------------------------------------------------------------ 316 | -- | Sequences are a bounded list of items. The server may split the sequence 317 | -- into multiple chunks when sending it to the client. When the response is 318 | -- a partial sequence, the client may request additional chunks until it gets 319 | -- a 'Done'. 320 | 321 | data Sequence a 322 | = Done !(Vector a) 323 | | Partial !Token !(Vector a) 324 | 325 | 326 | class IsSequence a 327 | 328 | 329 | instance Show (Sequence a) where 330 | show (Done v) = "Done " ++ (show $ V.length v) 331 | show (Partial _ v) = "Partial " ++ (show $ V.length v) 332 | 333 | instance (FromDatum a) => FromResponse (Sequence a) where 334 | parseResponse = responseSequenceParser 335 | 336 | instance IsSequence (Sequence a) 337 | 338 | instance (FromDatum a) => FromDatum (Sequence a) where 339 | parseDatum (Array x) = Done <$> V.mapM parseDatum x 340 | parseDatum _ = fail "Sequence" 341 | 342 | 343 | 344 | ------------------------------------------------------------------------------ 345 | 346 | data Exp a where 347 | Constant :: (ToDatum a) => a -> Exp a 348 | -- Any object which can be converted to RSON can be treated as a constant. 349 | -- Furthermore, many basic Haskell types have a 'Lift' instance which turns 350 | -- their values into constants. 351 | 352 | 353 | MkArray :: [Exp a] -> Exp (Array a) 354 | -- Create an array from a list of expressions. This is an internal function, 355 | -- you should use 'lift' instead. 356 | 357 | 358 | -------------------------------------------------------------------------- 359 | -- Database administration 360 | 361 | ListDatabases :: Exp (Array Text) 362 | CreateDatabase :: Exp Text -> Exp Object 363 | DropDatabase :: Exp Text -> Exp Object 364 | WaitDatabase :: Exp Database -> Exp Object 365 | 366 | 367 | -------------------------------------------------------------------------- 368 | -- Table administration 369 | 370 | ListTables :: Exp Database -> Exp (Array Text) 371 | CreateTable :: Exp Database -> Exp Text -> Exp Object 372 | DropTable :: Exp Database -> Exp Text -> Exp Object 373 | WaitTable :: Exp Table -> Exp Object 374 | 375 | 376 | -------------------------------------------------------------------------- 377 | -- Index administration 378 | 379 | ListIndices :: Exp Table -> Exp (Array Text) 380 | 381 | CreateIndex :: (IsDatum a) => Exp Table -> Exp Text -> (Exp Object -> Exp a) -> Exp Object 382 | -- Create a new secondary index on the table. The index has a name and a 383 | -- projection function which is applied to every object which is added to the table. 384 | 385 | DropIndex :: Exp Table -> Exp Text -> Exp Object 386 | IndexStatus :: Exp Table -> [Exp Text] -> Exp (Array Object) 387 | WaitIndex :: Exp Table -> [Exp Text] -> Exp (Array Object) 388 | 389 | 390 | Database :: Exp Text -> Exp Database 391 | Table :: Maybe (Exp Database) -> Exp Text -> Exp Table 392 | 393 | Coerce :: Exp a -> Exp Text -> Exp b 394 | Eq :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool 395 | Ne :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool 396 | Lt :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool 397 | Le :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool 398 | Gt :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool 399 | Ge :: (IsDatum a, IsDatum b) => Exp a -> Exp b -> Exp Bool 400 | Not :: Exp Bool -> Exp Bool 401 | 402 | Match :: Exp Text -> Exp Text -> Exp Datum 403 | -- First arg is the string, second a regular expression. 404 | 405 | Get :: Exp Table -> Exp Text -> Exp SingleSelection 406 | GetAll :: (IsDatum a) => Exp Table -> [Exp a] -> Exp (Array Datum) 407 | GetAllIndexed :: (IsDatum a) => Exp Table -> [Exp a] -> Text -> Exp (Sequence Datum) 408 | 409 | Add :: (Num a) => [Exp a] -> Exp a 410 | Sub :: (Num a) => [Exp a] -> Exp a 411 | Multiply :: (Num a) => [Exp a] -> Exp a 412 | 413 | All :: [Exp Bool] -> Exp Bool 414 | -- True if all the elements in the input are True. 415 | 416 | Any :: [Exp Bool] -> Exp Bool 417 | -- True if any element in the input is True. 418 | 419 | GetField :: (IsObject a, IsDatum r) => Exp Text -> Exp a -> Exp r 420 | -- Get a particular field from an object (or SingleSelection). 421 | 422 | HasFields :: (IsObject a) => [Text] -> Exp a -> Exp Bool 423 | -- True if the object has all the given fields. 424 | 425 | Take :: (IsSequence s) => Exp Double -> Exp s -> Exp s 426 | Append :: (IsDatum a) => Exp (Array a) -> Exp a -> Exp (Array a) 427 | Prepend :: (IsDatum a) => Exp (Array a) -> Exp a -> Exp (Array a) 428 | IsEmpty :: (IsSequence a) => Exp a -> Exp Bool 429 | Delete :: Exp a -> Exp Object 430 | 431 | InsertObject :: ConflictResolutionStrategy -> Exp Table -> Object -> Exp Object 432 | -- Insert a single object into the table. 433 | 434 | InsertSequence :: (IsSequence s) => Exp Table -> Exp s -> Exp Object 435 | -- Insert a sequence into the table. 436 | 437 | Filter :: (IsSequence s) => (Exp a -> Exp Bool) -> Exp s -> Exp s 438 | Map :: (IsSequence s) => (Exp a -> Exp b) -> Exp s -> Exp (Sequence b) 439 | 440 | Between :: (IsSequence s) => (Bound, Bound) -> Exp s -> Exp s 441 | -- Select all elements whose primary key is between the two bounds. 442 | 443 | BetweenIndexed :: (IsSequence s) => Text -> (Bound, Bound) -> Exp s -> Exp s 444 | -- Select all elements whose secondary index is between the two bounds. 445 | 446 | OrderBy :: (IsSequence s) => [Order] -> Exp s -> Exp s 447 | -- Order a sequence based on the given order specificiation. 448 | 449 | OrderByIndexed :: (IsSequence s) => Order -> Exp s -> Exp s 450 | -- Like OrderBy but uses a secondary index instead of a object field. 451 | 452 | Keys :: (IsObject a) => Exp a -> Exp (Array Text) 453 | 454 | Var :: Int -> Exp a 455 | -- A 'Var' is used as a placeholder in input to functions. 456 | 457 | Function :: State Context ([Int], Exp a) -> Exp f 458 | -- Creates a function. The action should take care of allocating an 459 | -- appropriate number of variables from the context. Note that you should 460 | -- not use this constructor directly. There are 'Lift' instances for all 461 | -- commonly used functions. 462 | 463 | Call :: Exp f -> [SomeExp] -> Exp r 464 | -- Call the given function. The function should take the same number of 465 | -- arguments as there are provided. 466 | 467 | Limit :: (IsSequence s) => Double -> Exp s -> Exp s 468 | -- Limit the number of items in the sequence. 469 | 470 | Nth :: (IsSequence s, IsDatum r) => Double -> Exp s -> Exp r 471 | -- Return the n-th element in the sequence. 472 | 473 | UUID :: Exp Text 474 | -- An expression which when evaluated will generate a fresh UUID (in its 475 | -- standard string encoding). 476 | 477 | Now :: Exp ZonedTime 478 | -- The time when the query was received by the server. 479 | 480 | Timezone :: Exp ZonedTime -> Exp Text 481 | -- The timezone in which the given time is. 482 | 483 | RandomInteger :: Exp Int -> Exp Int -> Exp Int 484 | -- Takes a lower and upper bound and returns a random integer between 485 | -- the two. Note that the lower bound is closed, the upper bound is open, 486 | -- ie: [min, max) 487 | 488 | RandomFloat :: Exp Double -> Exp Double -> Exp Double 489 | -- Same as 'RandomInteger' but uses floating-point numbers. 490 | 491 | Info :: Exp a -> Exp Object 492 | -- Gets info about anything. 493 | 494 | Default :: Exp a -> Exp a -> Exp a 495 | -- Evaluate the first argument. If it throws an error then the second 496 | -- argument is returned. 497 | 498 | Error :: Exp Text -> Exp a 499 | -- Throw an error with the given message. 500 | 501 | SequenceChanges :: (IsSequence s) => Exp s -> Exp (Sequence ChangeNotification) 502 | -- An infinite stream of change notifications of a seqence. 503 | 504 | SingleSelectionChanges :: (IsDatum a) => Exp a -> Exp (Sequence ChangeNotification) 505 | -- Same as 'SequenceChanges' but 506 | 507 | 508 | instance Term (Exp a) where 509 | toTerm (Constant datum) = 510 | toTerm $ toDatum datum 511 | 512 | toTerm (MkArray xs) = 513 | simpleTerm 2 (map SomeExp xs) 514 | 515 | 516 | toTerm ListDatabases = 517 | noargTerm 59 518 | 519 | toTerm (CreateDatabase name) = 520 | simpleTerm 57 [SomeExp name] 521 | 522 | toTerm (DropDatabase name) = 523 | simpleTerm 58 [SomeExp name] 524 | 525 | toTerm (WaitDatabase db) = 526 | simpleTerm 177 [SomeExp db] 527 | 528 | 529 | toTerm (ListTables db) = 530 | simpleTerm 62 [SomeExp db] 531 | 532 | toTerm (CreateTable db name) = 533 | simpleTerm 60 [SomeExp db, SomeExp name] 534 | 535 | toTerm (DropTable db name) = 536 | simpleTerm 61 [SomeExp db, SomeExp name] 537 | 538 | toTerm (WaitTable table) = 539 | simpleTerm 177 [SomeExp table] 540 | 541 | 542 | toTerm (ListIndices table) = 543 | simpleTerm 77 [SomeExp table] 544 | 545 | toTerm (CreateIndex table name f) = 546 | simpleTerm 75 [SomeExp table, SomeExp name, SomeExp (lift f)] 547 | 548 | toTerm (DropIndex table name) = 549 | simpleTerm 76 [SomeExp table, SomeExp name] 550 | 551 | toTerm (IndexStatus table indices) = 552 | simpleTerm 139 ([SomeExp table] ++ map SomeExp indices) 553 | 554 | toTerm (WaitIndex table indices) = 555 | simpleTerm 140 ([SomeExp table] ++ map SomeExp indices) 556 | 557 | 558 | toTerm (Database name) = 559 | simpleTerm 14 [SomeExp name] 560 | 561 | toTerm (Table mbDatabase name) = do 562 | db <- maybe (gets defaultDatabase) pure mbDatabase 563 | simpleTerm 15 [SomeExp db, SomeExp name] 564 | 565 | toTerm (Filter f s) = 566 | simpleTerm 39 [SomeExp s, SomeExp (lift f)] 567 | 568 | toTerm (Map f s) = 569 | simpleTerm 38 [SomeExp s, SomeExp (lift f)] 570 | 571 | toTerm (Between (l, u) s) = 572 | termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $ 573 | HMS.fromList 574 | [ ("left_bound", toJSON $ String (boundString l)) 575 | , ("right_bound", toJSON $ String (boundString u)) 576 | ] 577 | 578 | toTerm (BetweenIndexed index (l, u) s) = 579 | termWithOptions 36 [SomeExp s, SomeExp $ lift (boundDatum l), SomeExp $ lift (boundDatum u)] $ 580 | HMS.fromList 581 | [ ("left_bound", toJSON $ String (boundString l)) 582 | , ("right_bound", toJSON $ String (boundString u)) 583 | , ("index", toJSON $ String index) 584 | ] 585 | 586 | toTerm (OrderBy spec s) = do 587 | s' <- toTerm s 588 | spec' <- mapM toTerm spec 589 | simpleTerm 41 ([s'] ++ spec') 590 | 591 | toTerm (OrderByIndexed spec s) = do 592 | s' <- toTerm s 593 | spec' <- toTerm spec 594 | termWithOptions 41 [s'] $ HMS.singleton "index" spec' 595 | 596 | toTerm (InsertObject crs table obj) = 597 | termWithOptions 56 [SomeExp table, SomeExp (lift obj)] $ 598 | HMS.singleton "conflict" (toJSON $ toDatum crs) 599 | 600 | toTerm (InsertSequence table s) = 601 | termWithOptions 56 [SomeExp table, SomeExp s] HMS.empty 602 | 603 | toTerm (Delete selection) = 604 | simpleTerm 54 [SomeExp selection] 605 | 606 | toTerm (GetField field obj) = 607 | simpleTerm 31 [SomeExp obj, SomeExp field] 608 | 609 | toTerm (HasFields fields obj) = 610 | simpleTerm 32 ([SomeExp obj] ++ map (SomeExp . lift) fields) 611 | 612 | toTerm (Coerce value typeName) = 613 | simpleTerm 51 [SomeExp value, SomeExp typeName] 614 | 615 | toTerm (Add values) = 616 | simpleTerm 24 (map SomeExp values) 617 | 618 | toTerm (Sub values) = 619 | simpleTerm 25 (map SomeExp values) 620 | 621 | toTerm (Multiply values) = 622 | simpleTerm 26 (map SomeExp values) 623 | 624 | toTerm (All values) = 625 | simpleTerm 67 (map SomeExp values) 626 | 627 | toTerm (Any values) = 628 | simpleTerm 66 (map SomeExp values) 629 | 630 | toTerm (Eq a b) = 631 | simpleTerm 17 [SomeExp a, SomeExp b] 632 | 633 | toTerm (Ne a b) = 634 | simpleTerm 18 [SomeExp a, SomeExp b] 635 | 636 | toTerm (Lt a b) = 637 | simpleTerm 19 [SomeExp a, SomeExp b] 638 | 639 | toTerm (Le a b) = 640 | simpleTerm 20 [SomeExp a, SomeExp b] 641 | 642 | toTerm (Gt a b) = 643 | simpleTerm 21 [SomeExp a, SomeExp b] 644 | 645 | toTerm (Ge a b) = 646 | simpleTerm 22 [SomeExp a, SomeExp b] 647 | 648 | toTerm (Not e) = 649 | simpleTerm 23 [SomeExp e] 650 | 651 | toTerm (Match str re) = 652 | simpleTerm 97 [SomeExp str, SomeExp re] 653 | 654 | toTerm (Get table key) = 655 | simpleTerm 16 [SomeExp table, SomeExp key] 656 | 657 | toTerm (GetAll table keys) = 658 | simpleTerm 78 ([SomeExp table] ++ map SomeExp keys) 659 | 660 | toTerm (GetAllIndexed table keys index) = 661 | termWithOptions 78 ([SomeExp table] ++ map SomeExp keys) 662 | (HMS.singleton "index" (toJSON $ String index)) 663 | 664 | toTerm (Take n s) = 665 | simpleTerm 71 [SomeExp s, SomeExp n] 666 | 667 | toTerm (Append array value) = 668 | simpleTerm 29 [SomeExp array, SomeExp value] 669 | 670 | toTerm (Prepend array value) = 671 | simpleTerm 80 [SomeExp array, SomeExp value] 672 | 673 | toTerm (IsEmpty s) = 674 | simpleTerm 86 [SomeExp s] 675 | 676 | toTerm (Keys a) = 677 | simpleTerm 94 [SomeExp a] 678 | 679 | toTerm (Var a) = 680 | simpleTerm 10 [SomeExp $ lift $ (fromIntegral a :: Double)] 681 | 682 | toTerm (Function a) = do 683 | (vars, f) <- a 684 | simpleTerm 69 [SomeExp $ Constant $ V.fromList $ map (Number . fromIntegral) vars, SomeExp f] 685 | 686 | toTerm (Call f args) = 687 | simpleTerm 64 ([SomeExp f] ++ args) 688 | 689 | toTerm (Limit n s) = 690 | simpleTerm 71 [SomeExp s, SomeExp (lift n)] 691 | 692 | toTerm (Nth n s) = 693 | simpleTerm 45 [SomeExp s, SomeExp (lift n)] 694 | 695 | toTerm UUID = 696 | noargTerm 169 697 | 698 | toTerm Now = 699 | noargTerm 103 700 | 701 | toTerm (Timezone time) = 702 | simpleTerm 127 [SomeExp time] 703 | 704 | toTerm (RandomInteger lo hi) = 705 | simpleTerm 151 [SomeExp lo, SomeExp hi] 706 | 707 | toTerm (RandomFloat lo hi) = 708 | termWithOptions 151 [SomeExp lo, SomeExp hi] $ 709 | HMS.singleton "float" (toJSON $ Bool True) 710 | 711 | toTerm (Info a) = 712 | simpleTerm 79 [SomeExp a] 713 | 714 | toTerm (Default action def) = 715 | simpleTerm 92 [SomeExp action, SomeExp def] 716 | 717 | toTerm (Error message) = 718 | simpleTerm 12 [SomeExp message] 719 | 720 | toTerm (SequenceChanges stream) = 721 | simpleTerm 152 [SomeExp stream] 722 | 723 | toTerm (SingleSelectionChanges stream) = 724 | simpleTerm 152 [SomeExp stream] 725 | 726 | 727 | noargTerm :: Int -> State Context A.Value 728 | noargTerm termType = pure $ A.Array $ V.fromList [toJSON termType] 729 | 730 | simpleTerm :: (Term a) => Int -> [a] -> State Context A.Value 731 | simpleTerm termType args = do 732 | args' <- mapM toTerm args 733 | pure $ A.Array $ V.fromList [toJSON termType, toJSON args'] 734 | 735 | termWithOptions :: (Term a) => Int -> [a] -> HashMap Text Value -> State Context A.Value 736 | termWithOptions termType args options = do 737 | args' <- mapM toTerm args 738 | pure $ A.Array $ V.fromList [toJSON termType, toJSON args', toJSON options] 739 | 740 | 741 | -- | Convenience to for automatically converting a 'Text' to a constant 742 | -- expression. 743 | instance IsString (Exp Text) where 744 | fromString = lift . (fromString :: String -> Text) 745 | 746 | 747 | instance Num (Exp Double) where 748 | fromInteger = Constant . fromInteger 749 | 750 | a + b = Add [a, b] 751 | a * b = Multiply [a, b] 752 | 753 | abs _ = error "Num (Exp a): abs not implemented" 754 | signum _ = error "Num (Exp a): signum not implemented" 755 | negate _ = error "Num (Exp a): negate not implemented" 756 | 757 | 758 | 759 | ------------------------------------------------------------------------------ 760 | -- | The class of types e which can be lifted into c. All basic Haskell types 761 | -- which can be represented as 'Exp' are instances of this, as well as certain 762 | -- types of functions (unary and binary). 763 | 764 | class Lift c e where 765 | -- | Type-level function which simplifies the type of @e@ once it is lifted 766 | -- into @c@. This is used for functions where we strip the signature so 767 | -- that we don't have to define dummy 'Term' instances for those. 768 | type Simplified e 769 | 770 | lift :: e -> c (Simplified e) 771 | 772 | 773 | instance Lift Exp Bool where 774 | type Simplified Bool = Bool 775 | lift = Constant 776 | 777 | instance Lift Exp Int where 778 | type Simplified Int = Int 779 | lift = Constant 780 | 781 | instance Lift Exp Double where 782 | type Simplified Double = Double 783 | lift = Constant 784 | 785 | instance Lift Exp Char where 786 | type Simplified Char = Char 787 | lift = Constant 788 | 789 | instance Lift Exp String where 790 | type Simplified String = String 791 | lift = Constant 792 | 793 | instance Lift Exp Text where 794 | type Simplified Text = Text 795 | lift = Constant 796 | 797 | instance Lift Exp Object where 798 | type Simplified Object = Object 799 | lift = Constant 800 | 801 | instance Lift Exp Datum where 802 | type Simplified Datum = Datum 803 | lift = Constant 804 | 805 | instance Lift Exp ZonedTime where 806 | type Simplified ZonedTime = ZonedTime 807 | lift = Constant 808 | 809 | instance Lift Exp UTCTime where 810 | type Simplified UTCTime = ZonedTime 811 | lift = Constant . utcToZonedTime utc 812 | 813 | instance Lift Exp (Array Datum) where 814 | type Simplified (Array Datum) = (Array Datum) 815 | lift = Constant 816 | 817 | instance Lift Exp [Exp a] where 818 | type Simplified [Exp a] = Array a 819 | lift = MkArray 820 | 821 | instance Lift Exp (Exp a -> Exp r) where 822 | type Simplified (Exp a -> Exp r) = Exp r 823 | lift f = Function $ do 824 | v1 <- newVar 825 | pure $ ([v1], f (Var v1)) 826 | 827 | instance Lift Exp (Exp a -> Exp b -> Exp r) where 828 | type Simplified (Exp a -> Exp b -> Exp r) = Exp r 829 | lift f = Function $ do 830 | v1 <- newVar 831 | v2 <- newVar 832 | pure $ ([v1, v2], f (Var v1) (Var v2)) 833 | 834 | 835 | 836 | ------------------------------------------------------------------------------ 837 | -- 'call1', 'call2' etc generate a function call expression. These should be 838 | -- used instead of the 'Call' constructor because they provide type safety. 839 | 840 | -- | Call an unary function with the given argument. 841 | call1 :: (Exp a -> Exp r) -> Exp a -> Exp r 842 | call1 f a = Call (lift f) [SomeExp a] 843 | 844 | 845 | -- | Call an binary function with the given arguments. 846 | call2 :: (Exp a -> Exp b -> Exp r) -> Exp a -> Exp b -> Exp r 847 | call2 f a b = Call (lift f) [SomeExp a, SomeExp b] 848 | 849 | 850 | emptyOptions :: Object 851 | emptyOptions = HMS.empty 852 | 853 | 854 | 855 | ------------------------------------------------------------------------------ 856 | -- | Because the arguments to functions are polymorphic (the individual 857 | -- arguments can, and often have, different types). 858 | 859 | data SomeExp where 860 | SomeExp :: Exp a -> SomeExp 861 | 862 | instance Term SomeExp where 863 | toTerm (SomeExp e) = toTerm e 864 | 865 | 866 | 867 | ------------------------------------------------------------------------------ 868 | -- | The type of result you get when executing a query of 'Exp a'. 869 | type family Result a 870 | 871 | type instance Result Text = Text 872 | type instance Result Double = Double 873 | type instance Result Int = Int 874 | type instance Result Char = Char 875 | type instance Result String = String 876 | type instance Result Bool = Bool 877 | type instance Result ZonedTime = ZonedTime 878 | 879 | type instance Result Table = Sequence Datum 880 | type instance Result Datum = Datum 881 | type instance Result Object = Object 882 | type instance Result (Array a) = Array a 883 | type instance Result SingleSelection = Maybe Datum 884 | type instance Result (Sequence a) = Sequence a 885 | 886 | 887 | 888 | ------------------------------------------------------------------------------ 889 | -- | The result of a query. It is either an error or a result (which depends 890 | -- on the type of the query expression). This type is named to be symmetrical 891 | -- to 'Exp', so we get this nice type for 'run'. 892 | -- 893 | -- > run :: Handle -> Exp a -> IO (Res a) 894 | 895 | type Res a = Either Error (Result a) 896 | 897 | 898 | 899 | ------------------------------------------------------------------------------ 900 | -- | A value which can be converted from a 'Response'. All types which are 901 | -- defined as being a 'Result a' should have a 'FromResponse a'. Because, 902 | -- uhm.. you really want to be able to extract the result from the response. 903 | -- 904 | -- There are two parsers defined here, one for atoms and the other for 905 | -- sequences. These are the only two implementations of parseResponse which 906 | -- should be used. 907 | 908 | class FromResponse a where 909 | parseResponse :: Response -> Parser a 910 | 911 | 912 | responseAtomParser :: (FromDatum a) => Response -> Parser a 913 | responseAtomParser r = case (responseType r, V.toList (responseResult r)) of 914 | (SuccessAtom, [a]) -> parseWire a >>= parseDatum 915 | _ -> fail $ "responseAtomParser: Not a single-element vector " ++ show (responseResult r) 916 | 917 | responseSequenceParser :: (FromDatum a) => Response -> Parser (Sequence a) 918 | responseSequenceParser r = case responseType r of 919 | SuccessAtom -> Done <$> responseAtomParser r 920 | SuccessSequence -> Done <$> values 921 | SuccessPartial -> Partial <$> pure (responseToken r) <*> values 922 | rt -> fail $ "responseSequenceParser: Unexpected type " ++ show rt 923 | where 924 | values = V.mapM (\x -> parseWire x >>= parseDatum) (responseResult r) 925 | 926 | 927 | 928 | ------------------------------------------------------------------------------ 929 | -- | A token is used to refer to queries and the corresponding responses. This 930 | -- driver uses a monotonically increasing counter. 931 | 932 | type Token = Word64 933 | 934 | 935 | 936 | data ResponseType 937 | = SuccessAtom 938 | | SuccessSequence 939 | | SuccessPartial 940 | | WaitComplete 941 | | RTServerInfo 942 | | ClientErrorType 943 | | CompileErrorType 944 | | RuntimeErrorType 945 | deriving (Show, Eq) 946 | 947 | 948 | instance FromJSON ResponseType where 949 | parseJSON (A.Number 1) = pure SuccessAtom 950 | parseJSON (A.Number 2) = pure SuccessSequence 951 | parseJSON (A.Number 3) = pure SuccessPartial 952 | parseJSON (A.Number 4) = pure WaitComplete 953 | parseJSON (A.Number 5) = pure RTServerInfo 954 | parseJSON (A.Number 16) = pure ClientErrorType 955 | parseJSON (A.Number 17) = pure CompileErrorType 956 | parseJSON (A.Number 18) = pure RuntimeErrorType 957 | parseJSON _ = fail "ResponseType" 958 | 959 | 960 | data ResponseNote 961 | = SequenceFeed 962 | | AtomFeed 963 | | OrderByLimitFeed 964 | | UnionedFeed 965 | | IncludesStates 966 | deriving (Show, Eq, Ord) 967 | 968 | instance FromJSON ResponseNote where 969 | parseJSON (A.Number 1) = pure SequenceFeed 970 | parseJSON (A.Number 2) = pure AtomFeed 971 | parseJSON (A.Number 3) = pure OrderByLimitFeed 972 | parseJSON (A.Number 4) = pure UnionedFeed 973 | parseJSON (A.Number 5) = pure IncludesStates 974 | parseJSON _ = fail "ResponseNote" 975 | 976 | 977 | 978 | data Response = Response 979 | { responseToken :: !Token 980 | , responseType :: !ResponseType 981 | , responseResult :: !(Vector Value) 982 | , responseNotes :: !(Set ResponseNote) 983 | --, responseBacktrace :: () 984 | --, responseProfile :: () 985 | } deriving (Show, Eq) 986 | 987 | 988 | 989 | responseParser :: Token -> Value -> Parser Response 990 | responseParser token (A.Object o) = Response 991 | <$> pure token 992 | <*> o A..: "t" 993 | <*> o A..: "r" 994 | <*> (S.fromList <$> o A..:? "n" A..!= []) 995 | responseParser _ _ = 996 | fail "responseParser: Unexpected JSON value" 997 | 998 | 999 | 1000 | ------------------------------------------------------------------------------ 1001 | -- | Errors include a plain-text description which includes further details. 1002 | -- The RethinkDB protocol also includes a backtrace which we currently don't 1003 | -- parse. 1004 | 1005 | data Error 1006 | 1007 | = ProtocolError !Text 1008 | -- ^ An error on the protocol level. Perhaps the socket was closed 1009 | -- unexpectedly, or the server sent a message which the driver could not 1010 | -- parse. 1011 | 1012 | | ClientError !Text 1013 | -- ^ Means the client is buggy. An example is if the client sends 1014 | -- a malformed protobuf, or tries to send [CONTINUE] for an unknown 1015 | -- token. 1016 | 1017 | | CompileError !Text 1018 | -- ^ Means the query failed during parsing or type checking. For example, 1019 | -- if you pass too many arguments to a function. 1020 | 1021 | | RuntimeError !Text 1022 | -- ^ Means the query failed at runtime. An example is if you add 1023 | -- together two values from a table, but they turn out at runtime to be 1024 | -- booleans rather than numbers. 1025 | 1026 | deriving (Eq, Show) 1027 | 1028 | 1029 | 1030 | -------------------------------------------------------------------------------- 1031 | -- ServerInfo 1032 | 1033 | data ServerInfo = ServerInfo 1034 | { siId :: !Text 1035 | -- ^ This appears to be a UUID, but I don't want to add a dependency just 1036 | -- for this one field. 1037 | 1038 | , siName :: !Text 1039 | } deriving (Show) 1040 | 1041 | instance FromResponse ServerInfo where 1042 | parseResponse r = case (responseType r, V.toList (responseResult r)) of 1043 | (RTServerInfo, [a]) -> parseWire a >>= \datum -> case datum of 1044 | (Object o) -> ServerInfo <$> o .: "id" <*> o .: "name" 1045 | _ -> fail "ServerInfo" 1046 | _ -> fail $ "ServerInfo: Bad response" ++ show (responseResult r) 1047 | 1048 | 1049 | 1050 | -------------------------------------------------------------------------------- 1051 | -- ChangeNotification 1052 | 1053 | data ChangeNotification = ChangeNotification 1054 | { cnOldValue :: !Datum 1055 | , cnNewValue :: !Datum 1056 | } deriving (Show) 1057 | 1058 | instance FromDatum ChangeNotification where 1059 | parseDatum (Object o) = ChangeNotification <$> o .: "old_val" <*> o .: "new_val" 1060 | parseDatum _ = fail "ChangeNotification" 1061 | -------------------------------------------------------------------------------- /src/Database/RethinkDB/Types/Datum.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE CPP #-} 2 | {-# LANGUAGE DeriveGeneric #-} 3 | {-# LANGUAGE TypeFamilies #-} 4 | {-# LANGUAGE FlexibleInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE GADTs #-} 7 | {-# LANGUAGE OverloadedStrings #-} 8 | {-# LANGUAGE MultiParamTypeClasses #-} 9 | 10 | module Database.RethinkDB.Types.Datum where 11 | 12 | 13 | import Control.Applicative 14 | import Control.Monad 15 | 16 | import Data.Text (Text) 17 | import qualified Data.Text as T 18 | import Data.Time 19 | import Data.Scientific 20 | import Data.Time.Clock.POSIX 21 | 22 | import Data.Aeson (FromJSON(..), ToJSON(..)) 23 | import Data.Aeson.Types (Value, Parser) 24 | import qualified Data.Aeson as A 25 | 26 | import Data.Vector (Vector) 27 | import qualified Data.Vector as V 28 | import Data.HashMap.Strict (HashMap) 29 | import qualified Data.HashMap.Strict as HMS 30 | 31 | import GHC.Generics 32 | 33 | #if !MIN_VERSION_time(1,5,0) 34 | import System.Locale (defaultTimeLocale) 35 | #endif 36 | 37 | 38 | ------------------------------------------------------------------------------ 39 | -- | A sumtype covering all the primitive types which can appear in queries 40 | -- or responses. 41 | -- 42 | -- It is similar to the aeson 'Value' type, except that RethinkDB has a few 43 | -- more types (like 'Time'), which have a special encoding in JSON. 44 | 45 | data Datum 46 | = Null 47 | | Bool !Bool 48 | | Number !Double 49 | | String !Text 50 | | Array !(Array Datum) 51 | | Object !Object 52 | | Time !ZonedTime 53 | deriving (Show, Generic) 54 | 55 | 56 | 57 | ------------------------------------------------------------------------------ 58 | -- | Arrays are vectors of 'Datum'. 59 | 60 | type Array a = Vector a 61 | 62 | 63 | 64 | ------------------------------------------------------------------------------ 65 | -- | Objects are maps from 'Text' to 'Datum'. Like 'Aeson', we're using 66 | -- a strict 'HashMap'. 67 | 68 | type Object = HashMap Text Datum 69 | 70 | 71 | 72 | -- | We can't automatically derive 'Eq' because 'ZonedTime' does not have an 73 | -- instance of 'Eq'. See the 'eqTime' function for why we can compare times. 74 | instance Eq Datum where 75 | (Null ) == (Null ) = True 76 | (Bool x) == (Bool y) = x == y 77 | (Number x) == (Number y) = x == y 78 | (String x) == (String y) = x == y 79 | (Array x) == (Array y) = x == y 80 | (Object x) == (Object y) = x == y 81 | (Time x) == (Time y) = (zonedTimeToUTC x) == (zonedTimeToUTC y) 82 | _ == _ = False 83 | 84 | 85 | instance ToJSON Datum where 86 | toJSON (Null ) = A.Null 87 | toJSON (Bool x) = toJSON x 88 | toJSON (Number x) = toJSON x 89 | toJSON (String x) = toJSON x 90 | toJSON (Array x) = toJSON x 91 | toJSON (Time x) = toJSON x 92 | toJSON (Object x) = toJSON x 93 | 94 | 95 | instance FromJSON Datum where 96 | parseJSON (A.Null ) = pure Null 97 | parseJSON (A.Bool x) = pure $ Bool x 98 | parseJSON (A.Number x) = pure $ Number (realToFrac x) 99 | parseJSON v@(A.String x) = (Time <$> parseJSON v) <|> (pure $ String x) 100 | parseJSON (A.Array x) = Array <$> V.mapM parseJSON x 101 | parseJSON (A.Object x) = do 102 | -- HashMap does not provide a mapM, what a shame :( 103 | items <- mapM (\(k, v) -> (,) <$> pure k <*> parseJSON v) $ HMS.toList x 104 | pure $ Object $ HMS.fromList items 105 | 106 | 107 | 108 | parseWire :: A.Value -> Parser Datum 109 | parseWire (A.Null ) = pure Null 110 | parseWire (A.Bool x) = pure $ Bool x 111 | parseWire (A.Number x) = pure $ Number (realToFrac x) 112 | parseWire (A.String x) = pure $ String x 113 | parseWire (A.Array x) = Array <$> V.mapM parseWire x 114 | parseWire (A.Object x) = (Time <$> zonedTimeParser x) <|> do 115 | -- HashMap does not provide a mapM, what a shame :( 116 | items <- mapM (\(k, v) -> (,) <$> pure k <*> parseWire v) $ HMS.toList x 117 | pure $ Object $ HMS.fromList items 118 | 119 | 120 | zonedTimeParser :: HashMap Text A.Value -> Parser ZonedTime 121 | zonedTimeParser o = do 122 | reqlType <- o A..: "$reql_type$" 123 | guard $ reqlType == ("TIME" :: Text) 124 | 125 | -- Parse the timezone using 'parseTime'. This overapproximates the 126 | -- possible responses from the server, but better than rolling our 127 | -- own timezone parser. 128 | tz <- o A..: "timezone" >>= \tz -> case parseTimeM True defaultTimeLocale "%Z" tz of 129 | Just d -> pure d 130 | _ -> fail "Could not parse TimeZone" 131 | 132 | t <- o A..: "epoch_time" :: Parser Double 133 | pure $ utcToZonedTime tz $ posixSecondsToUTCTime $ realToFrac t 134 | #if !MIN_VERSION_time(1,5,0) 135 | where 136 | parseTimeM _ = parseTime 137 | #endif 138 | 139 | 140 | 141 | 142 | ------------------------------------------------------------------------------ 143 | -- | Types which can be converted to or from a 'Datum'. 144 | 145 | class ToDatum a where 146 | toDatum :: a -> Datum 147 | 148 | class FromDatum a where 149 | parseDatum :: Datum -> Parser a 150 | 151 | 152 | 153 | (.=) :: ToDatum a => Text -> a -> (Text, Datum) 154 | k .= v = (k, toDatum v) 155 | 156 | (.:) :: FromDatum a => HashMap Text Datum -> Text -> Parser a 157 | o .: k = maybe (fail $ "key " ++ show k ++ "not found") parseDatum $ HMS.lookup k o 158 | 159 | (.:?) :: FromDatum a => HashMap Text Datum -> Text -> Parser (Maybe a) 160 | o .:? k = maybe (pure Nothing) parseDatum $ HMS.lookup k o 161 | 162 | object :: [(Text, Datum)] -> Datum 163 | object = Object . HMS.fromList 164 | 165 | 166 | 167 | ------------------------------------------------------------------------------ 168 | -- Datum 169 | 170 | instance ToDatum Datum where 171 | toDatum = id 172 | 173 | instance FromDatum Datum where 174 | parseDatum = pure 175 | 176 | 177 | 178 | ------------------------------------------------------------------------------ 179 | -- () 180 | 181 | instance ToDatum () where 182 | toDatum () = Array V.empty 183 | 184 | instance FromDatum () where 185 | parseDatum (Array x) = if V.null x then pure () else fail "()" 186 | parseDatum _ = fail "()" 187 | 188 | 189 | 190 | ------------------------------------------------------------------------------ 191 | -- (a,b) 192 | 193 | instance (ToDatum a, ToDatum b) => ToDatum (a,b) where 194 | toDatum (a,b) = Array $ V.fromList [toDatum a, toDatum b] 195 | 196 | instance (FromDatum a, FromDatum b) => FromDatum (a,b) where 197 | parseDatum (Array x) = case V.toList x of 198 | [a,b] -> (,) <$> parseDatum a <*> parseDatum b 199 | _ -> fail "(a,b)" 200 | parseDatum _ = fail "(a,b)" 201 | 202 | 203 | 204 | ------------------------------------------------------------------------------ 205 | -- (a,b,c) 206 | 207 | instance (ToDatum a, ToDatum b, ToDatum c) => ToDatum (a,b,c) where 208 | toDatum (a,b,c) = Array $ V.fromList [toDatum a, toDatum b, toDatum c] 209 | 210 | instance (FromDatum a, FromDatum b, FromDatum c) => FromDatum (a,b,c) where 211 | parseDatum (Array x) = case V.toList x of 212 | [a,b,c] -> (,,) <$> parseDatum a <*> parseDatum b <*> parseDatum c 213 | _ -> fail "(a,b,c)" 214 | parseDatum _ = fail "(a,b,c)" 215 | 216 | 217 | 218 | ------------------------------------------------------------------------------ 219 | -- Bool 220 | 221 | instance ToDatum Bool where 222 | toDatum = Bool 223 | 224 | instance FromDatum Bool where 225 | parseDatum (Bool x) = pure x 226 | parseDatum _ = fail "Bool" 227 | 228 | 229 | 230 | ------------------------------------------------------------------------------ 231 | -- Double 232 | 233 | instance ToDatum Double where 234 | toDatum = Number 235 | 236 | instance FromDatum Double where 237 | parseDatum (Number x) = pure x 238 | parseDatum _ = fail "Double" 239 | 240 | 241 | 242 | ------------------------------------------------------------------------------ 243 | -- Float 244 | 245 | instance ToDatum Float where 246 | toDatum = Number . realToFrac 247 | 248 | instance FromDatum Float where 249 | parseDatum (Number x) = pure $ realToFrac x 250 | parseDatum _ = fail "Float" 251 | 252 | 253 | 254 | ------------------------------------------------------------------------------ 255 | -- Int 256 | 257 | instance ToDatum Int where 258 | toDatum = Number . fromIntegral 259 | 260 | instance FromDatum Int where 261 | parseDatum (Number x) = pure $ floor x 262 | parseDatum _ = fail "Int" 263 | 264 | 265 | 266 | ------------------------------------------------------------------------------ 267 | -- Char 268 | 269 | instance ToDatum Char where 270 | toDatum = String . T.singleton 271 | 272 | instance FromDatum Char where 273 | parseDatum (String x) = 274 | if T.compareLength x 1 == EQ 275 | then pure $ T.head x 276 | else fail "Expected a string of length 1" 277 | parseDatum _ = fail "Char" 278 | 279 | 280 | 281 | ------------------------------------------------------------------------------ 282 | -- [Char] (aka String) 283 | -- 284 | -- This instance overlaps the more generic 'FromDatum a => FromDatum [a]', hence 285 | -- the need for the OVERLAPPING pragma. 286 | 287 | instance {-# OVERLAPPING #-} ToDatum [Char] where 288 | toDatum = String . T.pack 289 | 290 | instance {-# OVERLAPPING #-} FromDatum [Char] where 291 | parseDatum (String x) = pure $ T.unpack x 292 | parseDatum _ = fail "String" 293 | 294 | 295 | 296 | ------------------------------------------------------------------------------ 297 | -- Text 298 | 299 | instance ToDatum Text where 300 | toDatum = String 301 | 302 | instance FromDatum Text where 303 | parseDatum (String x) = pure x 304 | parseDatum _ = fail "Text" 305 | 306 | 307 | 308 | ------------------------------------------------------------------------------ 309 | -- Array (Vector) 310 | 311 | instance (ToDatum a) => ToDatum (Array a) where 312 | toDatum = Array . V.map toDatum 313 | 314 | instance (FromDatum a) => FromDatum (Array a) where 315 | parseDatum (Array v) = V.mapM parseDatum v 316 | parseDatum _ = fail "Array" 317 | 318 | 319 | 320 | ------------------------------------------------------------------------------ 321 | -- Object (HashMap Text Datum) 322 | 323 | instance ToDatum Object where 324 | toDatum = Object 325 | 326 | instance FromDatum Object where 327 | parseDatum (Object o) = do 328 | -- HashMap does not provide a mapM, what a shame :( 329 | items <- mapM (\(k, v) -> (,) <$> pure k <*> parseDatum v) $ HMS.toList o 330 | pure $ HMS.fromList items 331 | 332 | parseDatum _ = fail "Object" 333 | 334 | 335 | 336 | ------------------------------------------------------------------------------ 337 | -- ZonedTime 338 | 339 | instance ToDatum ZonedTime where 340 | toDatum = Time 341 | 342 | instance FromDatum ZonedTime where 343 | parseDatum (Time x) = pure x 344 | parseDatum _ = fail "ZonedTime" 345 | 346 | 347 | 348 | ------------------------------------------------------------------------------ 349 | -- UTCTime 350 | 351 | instance ToDatum UTCTime where 352 | toDatum = Time . utcToZonedTime utc 353 | 354 | instance FromDatum UTCTime where 355 | parseDatum (Time x) = pure (zonedTimeToUTC x) 356 | parseDatum _ = fail "UTCTime" 357 | 358 | 359 | 360 | ------------------------------------------------------------------------------ 361 | -- [a] 362 | 363 | instance ToDatum a => ToDatum [a] where 364 | toDatum = Array . V.fromList . map toDatum 365 | 366 | instance FromDatum a => FromDatum [a] where 367 | parseDatum (Array x) = V.toList <$> V.mapM parseDatum x 368 | parseDatum _ = fail "[a]" 369 | 370 | 371 | 372 | ------------------------------------------------------------------------------ 373 | -- Maybe a 374 | 375 | instance ToDatum a => ToDatum (Maybe a) where 376 | toDatum Nothing = Null 377 | toDatum (Just x) = toDatum x 378 | 379 | instance FromDatum a => FromDatum (Maybe a) where 380 | parseDatum Null = pure Nothing 381 | parseDatum d = Just <$> parseDatum d 382 | 383 | 384 | 385 | ------------------------------------------------------------------------------ 386 | -- Value 387 | 388 | instance ToDatum Value where 389 | toDatum (A.Null ) = Null 390 | toDatum (A.Bool x) = Bool x 391 | toDatum (A.Number x) = Number $ toRealFloat x 392 | toDatum (A.String x) = String x 393 | toDatum (A.Array x) = Array $ V.map toDatum x 394 | toDatum (A.Object x) = Object $ fmap toDatum x 395 | 396 | instance FromDatum Value where 397 | parseDatum (Null ) = pure A.Null 398 | parseDatum (Bool x) = pure $ A.Bool x 399 | parseDatum (Number x) = pure $ A.Number (realToFrac x) 400 | parseDatum (String x) = pure $ A.String x 401 | parseDatum (Array x) = A.Array <$> V.mapM parseDatum x 402 | parseDatum (Object x) = do 403 | -- HashMap does not provide a mapM, what a shame :( 404 | items <- mapM (\(k, v) -> (,) <$> pure k <*> parseDatum v) $ HMS.toList x 405 | pure $ A.Object $ HMS.fromList items 406 | parseDatum (Time x) = pure $ toJSON x 407 | -------------------------------------------------------------------------------- /test/Test.hs: -------------------------------------------------------------------------------- 1 | {-# LANGUAGE OverloadedStrings #-} 2 | {-# LANGUAGE FlexibleInstances #-} 3 | {-# LANGUAGE MultiParamTypeClasses #-} 4 | {-# LANGUAGE UndecidableInstances #-} 5 | {-# LANGUAGE FlexibleContexts #-} 6 | {-# LANGUAGE ScopedTypeVariables #-} 7 | 8 | module Main where 9 | 10 | import Control.Applicative 11 | 12 | import Test.Hspec 13 | import Test.SmallCheck 14 | import Test.SmallCheck.Series 15 | import Test.Hspec.SmallCheck 16 | 17 | import Database.RethinkDB 18 | 19 | import Data.Monoid ((<>)) 20 | import Data.Function 21 | import Data.List 22 | import Data.HashMap.Strict (HashMap) 23 | import qualified Data.HashMap.Strict as HMS 24 | import Data.Text (Text) 25 | import qualified Data.Text as T 26 | import Data.Vector (Vector) 27 | import qualified Data.Vector as V 28 | import Data.Time 29 | import Data.Time.Clock.POSIX 30 | 31 | 32 | 33 | instance Monad m => Serial m Datum 34 | 35 | instance Monad m => Serial m UTCTime where 36 | series = cons1 fromInt 37 | where 38 | fromInt :: Int -> UTCTime 39 | fromInt = posixSecondsToUTCTime . fromIntegral 40 | 41 | instance Monad m => Serial m ZonedTime where 42 | series = cons1 (utcToZonedTime utc) 43 | 44 | instance Monad m => Serial m Text where 45 | series = cons1 T.pack 46 | 47 | instance Monad m => Serial m (HashMap Text Datum) where 48 | series = cons1 HMS.fromList 49 | 50 | instance (Monad m, Serial m a) => Serial m (Vector a) where 51 | series = cons1 V.fromList 52 | 53 | 54 | 55 | 56 | main :: IO () 57 | main = do 58 | h <- newHandle "localhost" defaultPort Nothing (Database "test") 59 | 60 | si <- serverInfo h 61 | putStrLn "Server Info:" 62 | print si 63 | 64 | hspec $ spec h 65 | 66 | 67 | expectSuccess 68 | :: (Eq (Result a), FromResponse (Result a), Show (Result a)) 69 | => Handle -> Exp a -> Result a -> IO Bool 70 | expectSuccess h query value = do 71 | res <- run h query 72 | return $ res == Right value 73 | 74 | 75 | spec :: Handle -> Spec 76 | spec h = do 77 | 78 | -- The roundtrips test whether the driver generates the proper terms 79 | -- and the server responds with what the driver expects. 80 | describe "roundtrips" $ do 81 | describe "primitive values" $ do 82 | it "Char" $ property $ \(x :: Char) -> 83 | monadic $ ((Right x)==) <$> run h (lift x) 84 | it "String" $ property $ \(x :: String) -> 85 | monadic $ ((Right x)==) <$> run h (lift x) 86 | it "Double" $ property $ \(x :: Double) -> 87 | monadic $ ((Right x)==) <$> run h (lift x) 88 | it "Text" $ property $ \(x :: Text) -> 89 | monadic $ ((Right x)==) <$> run h (lift x) 90 | it "Array" $ property $ \(x :: Array Datum) -> 91 | monadic $ ((Right x)==) <$> run h (lift x) 92 | it "Object" $ property $ \(x :: Object) -> 93 | monadic $ ((Right x)==) <$> run h (lift x) 94 | it "Datum" $ property $ \(x :: Datum) -> 95 | monadic $ ((Right x)==) <$> run h (lift x) 96 | it "ZonedTime" $ property $ \(x :: ZonedTime) -> 97 | monadic $ (on (==) (fmap zonedTimeToUTC) (Right x)) <$> run h (lift x) 98 | 99 | describe "function expressions" $ do 100 | it "Add" $ property $ \(xs0 :: [Double]) -> monadic $ do 101 | -- The list must not be empty, so we prepend a zero to it. 102 | let xs = 0 : xs0 103 | expectSuccess h (Add $ map lift xs) (sum xs) 104 | 105 | it "All" $ property $ \(xs0 :: [Bool]) -> monadic $ do 106 | let xs = True : xs0 107 | expectSuccess h (All $ map lift xs) (and xs) 108 | 109 | it "Any" $ property $ \(xs0 :: [Bool]) -> monadic $ do 110 | let xs = True : xs0 111 | expectSuccess h (Any $ map lift xs) (or xs) 112 | 113 | it "Eq" $ property $ \(a :: Datum, b :: Datum) -> monadic $ do 114 | expectSuccess h (Eq (lift a) (lift b)) (a == b) 115 | 116 | it "Ne" $ property $ \(a :: Datum, b :: Datum) -> monadic $ do 117 | expectSuccess h (Ne (lift a) (lift b)) (a /= b) 118 | 119 | it "Lt" $ property $ \(a :: Double, b :: Double) -> monadic $ do 120 | expectSuccess h (Lt (lift a) (lift b)) (a < b) 121 | 122 | it "Le" $ property $ \(a :: Double, b :: Double) -> monadic $ do 123 | expectSuccess h (Le (lift a) (lift b)) (a <= b) 124 | 125 | it "Gt" $ property $ \(a :: Double, b :: Double) -> monadic $ do 126 | expectSuccess h (Gt (lift a) (lift b)) (a > b) 127 | 128 | it "Ge" $ property $ \(a :: Double, b :: Double) -> monadic $ do 129 | expectSuccess h (Ge (lift a) (lift b)) (a >= b) 130 | 131 | it "Match" $ property $ \() -> monadic $ do 132 | expectSuccess h (Match "foobar" "^f(.)$") Null 133 | 134 | it "Append" $ property $ \(xs :: Array Datum, v :: Datum) -> monadic $ do 135 | expectSuccess h (Append (lift xs) (lift v)) (V.snoc xs v) 136 | 137 | it "Prepend" $ property $ \(xs :: Array Datum, v :: Datum) -> monadic $ do 138 | expectSuccess h (Prepend (lift xs) (lift v)) (V.cons v xs) 139 | 140 | it "IsEmpty" $ property $ \(xs :: Array Datum) -> monadic $ do 141 | expectSuccess h (IsEmpty (lift xs)) (V.null xs) 142 | 143 | it "Keys" $ property $ \(xs :: Array Text) -> monadic $ do 144 | let obj = HMS.fromList $ map (\x -> (x, String x)) $ V.toList xs 145 | res0 <- run h $ Keys (lift obj) 146 | let res = fmap (sort . V.toList) res0 147 | return $ res == (Right $ nub $ sort $ V.toList xs) 148 | 149 | describe "function calls" $ do 150 | it "Add" $ property $ \(a :: Double, b :: Double) -> monadic $ do 151 | res <- run h $ call2 (+) (lift a) (lift b) 152 | return $ res == (Right $ a + b) 153 | 154 | res <- run h $ call1 (1+) (lift a) 155 | return $ res == (Right $ a + 1) 156 | 157 | it "Multiply" $ property $ \(a :: Double, b :: Double) -> monadic $ do 158 | res <- run h $ call2 (*) (lift a) (lift b) 159 | return $ res == (Right $ a * b) 160 | 161 | res <- run h $ call1 (3*) (lift a) 162 | return $ res == (Right $ a * 3) 163 | 164 | describe "lifts" $ do 165 | it "[Exp a]" $ property $ \(xs :: [Datum]) -> monadic $ do 166 | expectSuccess h (lift (map lift xs :: [Exp Datum])) (V.fromList xs) 167 | 168 | describe "concurrent queries" $ do 169 | it "should read all responses from the socket" $ property $ \(a :: Double) -> monadic $ do 170 | token1 <- start h $ call2 (+) (lift a) (lift a) 171 | token2 <- start h $ call2 (*) (lift a) (lift a) 172 | Right res2 <- nextResult h token2 173 | Right res1 <- nextResult h token1 174 | 175 | return $ res1 == a+a && res2 == a*a 176 | --------------------------------------------------------------------------------