Here's the SQLite3 Haskell bindings with the ability to create function: http://hackage.haskell.org/packages/archive/sqlite/0.5.1/doc/html/Database-SQLite.html
But I can't get to use this feature, I wrote the code like this:
increment a = a + 1
checkout = do
handle <- openConnection "test.db"
ok <- createFunction handle "woot" (IsFunctionHandler increment)
return $ execStatement handle "SELECT woot(5)";
But it isn't compile with "Not in scope: data constructor `IsFunctionHandler'" error
The correct code is:
module Test where
import Database.SQLite
import Int
increment :: Int64 -> Int64
increment a = a + 1
checkout :: IO (Either String [[Row Value]])
checkout = do
handle <- openConnection "test.db"
ok <- createFunction handle "woot" increment
execStatement handle "SELECT woot(5), woot(7), woot(128)"
Thanks to HaskellElephant
IsFunctionHandler is a class, not a data constructor. It has several instances so if increment is an instance of IsFunctionHandler, wich it in this case is, you should be able to write:
createFunction handle "woot" increment
Related
I'm trying to write an F# computational expression that permits reading and writing thread-safe variables only from within a critical section.
I've got a type, ThreadSafeVar<'t> that wraps a value, a CriticalSection<'t> and a computational expression builder, LockContext, as follows:
// wraps a value and restricts access to it
type ThreadSafeVar<'t> (value: 't) =
member val internal Value = value with get, set
// Encapsulates a critical section
type CriticalSection<'t> =
private
{ LockObj: obj
fn: unit -> 't }
static member Lock(lc: CriticalSection<'t>) = lock lc.LockObj lc.fn
// Expression builder for a locked context
type LockContext () =
member internal this.SyncRoot = obj()
member this.Return(value: 'v) = value
member this.ReturnFrom(value: ThreadSafeVar<'t>) = value.Value
member __.Bind(value: ThreadSafeVar<'t>, fn: 't -> 'u) = fn value.Value
// returns a CriticalSection
member this.Run(fn : unit -> 'u) = { LockObj = this.SyncRoot
fn=fn }
.
.
.
Reading the thread-safe values from within a lock context is simple enough thanks to Bind. e.g.
let lockedInt = ThreadSafeVar(1) // create a thread-safe variable
let context = LockContext()
let wrapperVal = context {
let! i = lockedInt // get the wrapper value inside lockedInt
return i
} |> CriticalSection.Lock
But I'm struggling to understand how to implement a means setting the value from within a LockContext instance. The approach I've thus taken is to implement a custom operation called, for instance, setVal. I've included my attempts thus far but I'm afraid they'd just muddy the waters. It seems that custom operations operate upon the computation built so far within the expression, encoded as a tuple, but I don't see that this is required in my case.
Any hints, pointing to resources, or direct help would be appreciated.
I'm not at all sure of the wisdom of this, but I came up with something based on the State monad that might work for you. First, define a "stateful" function as one that takes a ThreadSafeVar and returns some type of result:
ThreadSafeVar<'state> -> 'result
We then put that signature into a type that represents a stateful computation:
type Stateful<'state, 'result> =
MkStateful of (ThreadSafeVar<'state> -> 'result)
Now we need a way to run such a computation safely using a given TSV:
let run (tsv : ThreadSafeVar<_>) (MkStateful f) =
lock tsv (fun () -> f tsv)
Note that I've gotten rid of your CriticalSection type and instead just lock the TSV itself.
Next, we need a way to lift a pure value into a stateful computation:
let lift value =
MkStateful (fun _ -> value)
And a way to bind two stateful computations together:
let bind binder stateful =
MkStateful (fun tsv ->
run tsv stateful
|> binder
|> run tsv)
Defining the builder is then trivial:
type LockContext () =
member __.Return(value) = lift value
member __.Bind(stateful, binder) = bind binder stateful
let context = LockContext()
We also need helper computations for setting and getting a value safely:
let getValue =
MkStateful (fun tsv ->
tsv.Value)
let setValue value =
MkStateful (fun tsv ->
tsv.Value <- value)
Putting it all together, we can define a computation that increments the value of a TSV:
let comp =
context {
let! oldValue = getValue
let newValue = oldValue + 1
do! setValue newValue
return newValue
}
And we can run it like this:
let lockedInt = ThreadSafeVar(1)
let result = comp |> run lockedInt
printfn "%A" result // output is: 2
You can see the full solution and try it yourself here.
I am trying to implement an Evernote Sync client in Haskell. For initial testing I want to connect to the Userstore with a developer authentication token. My code below causes the exception:
ProtocolExn PE_BAD_VERSION "Missing version identifier"
import Thrift.Transport.HttpClient
import Thrift.Protocol.Binary
import Network.URI
import Data.Text.Lazy
import System.Exit
import UserStore_Client
import UserStore_Consts
-- hardcoded parameters to establish test connnection
auth_token = -- developer-token-for-my-sandbox-account
user_endpoint = "https://sandbox.evernote.com/edam/user"
main :: IO()
main = do
-- parse url and open thrift http_client
let uri = parseURI user_endpoint
http_client <- case uri of
(Nothing) -> die "Not a valid uri"
(Just uri_string) -> do http_cl <- (openHttpClient uri_string)
return http_cl
-- create a binary protocol that will be passed to store methods
let user_prot = BinaryProtocol http_client
-- try to use protocol to call a user_store method
version_ok <- checkVersion (user_prot, user_prot) (pack auth_token) eDAM_VERSION_MAJOR eDAM_VERSION_MINOR
I assume that it is being thrown in the readMessage function in the implementation of BinaryProtocol. Excerpt from Thrift.Protocol.Binary:
readMessage p = (readMessageBegin p >>=)
where
readMessageBegin p = runParser p $ do
TI32 ver <- parseBinaryValue T_I32
if ver .&. versionMask /= version1
then throw $ ProtocolExn PE_BAD_VERSION "Missing version identifier" -- This is the error I get
else do
TString s <- parseBinaryValue T_STRING
TI32 sz <- parseBinaryValue T_I32
return (decodeUtf8 s, toEnum $ fromIntegral $ ver .&. 0xFF, sz)
writeVal p = tWrite (getTransport p) . toLazyByteString . buildBinaryValue
readVal p = runParser p . parseBinaryValue
Do I need to configure the BinaryProtocol in a different way? Or can this be due to a version difference/datatype mismatch etc between server and client?
The UserStore module is auto-generated by Thrift (version 0.13.0) from Evernote's Thrift files.
Any leads on how I can further debug my code to understand what is going wrong would be very much appreciated.
The exception is thrown because the server returns a 403 error. This is due to the HttpClient connecting to port 80 by default.
Hi I have a similar to the following haskell function
test :: Int -> Bool
test 1 = error "shouldnt have been 1"
test 2 = error "shouldnt have been 2"
test 11 = error "shouldnt have been 11"
test 77 = error "shouldnt have been 77"
test _ = True
I have a testing scheme to test bad inputs to make sure they return the correct error
tc1 = test 1
tc2 = test 2
tc3 = test 11
tc4 = test 77
allTests = [tc1, tc2, tc3, tc4]
But the problem is that when I run allTests in ghci, I only get the first error. I would like to have a list of all the errors
How can this be done or some way I can catch the errors?
You could try to use catch from Control.Exception, but that's still an awkward way to achieve the goal.
It'd be better to use a pure data type to capture errors, as they're easier to compose and collect. Normally, you'd use Either for that, but in this particular case, the success case would carry no information, so the type would be Either String (), which is isomorphic to Maybe String. Rewriting test to return Maybe String is trivial:
test :: Int -> Maybe String
test 1 = Just "shouldnt have been 1"
test 2 = Just "shouldnt have been 2"
test 11 = Just "shouldnt have been 11"
test 77 = Just "shouldnt have been 77"
test _ = Nothing
tc1 = test 1
tc2 = test 2
tc3 = test 11
tc4 = test 77
tc5 = test 5
I added a tc5 value in order to demonstrate what happens when a test succeeds.
You can evaluate all of those test cases, but if you want only the failure cases, you can use catMaybes from Data.Maybe:
allTests = catMaybes [tc1, tc2, tc3, tc4, tc5]
Here's the result of running allTests:
*Q46376632> allTests
["shouldnt have been 1",
"shouldnt have been 2",
"shouldnt have been 11",
"shouldnt have been 77"]
If you can't change the function you're testing, you can try something like the following, but it's hardly elegant:
tc1 = catch (print $ test 1) (\err -> print (err :: SomeException))
tc2 = catch (print $ test 2) (\err -> print (err :: SomeException))
tc3 = catch (print $ test 11) (\err -> print (err :: SomeException))
tc4 = catch (print $ test 77) (\err -> print (err :: SomeException))
tc5 = catch (print $ test 5) (\err -> print (err :: SomeException))
allTests = sequence_ [tc1, tc2, tc3, tc4, tc5]
When running it, you get output like this:
*Q46376632> allTests
shouldnt have been 1
CallStack (from HasCallStack):
error, called at 46376632.hs:14:10 in main:Q46376632
shouldnt have been 2
CallStack (from HasCallStack):
error, called at 46376632.hs:15:10 in main:Q46376632
shouldnt have been 11
CallStack (from HasCallStack):
error, called at 46376632.hs:16:11 in main:Q46376632
shouldnt have been 77
CallStack (from HasCallStack):
error, called at 46376632.hs:17:11 in main:Q46376632
True
At this point, you'd probably be better of using a proper testing framework.
I am experimenting with js_of_ocaml and node.js. As you know, node.js makes extensive use of callbacks to implement asynchronous requests without introducing explicit threads.
In OCaml we have a very nice threading library, Lwt, coming with a very useful syntax extension. I wrote a prototype with a binding to some node library (a AWS S3 client) and added a lwt-ish layer to hide the callback.
open Lwt.Infix
open Printf
open Js
let require_module s =
Js.Unsafe.fun_call
(Js.Unsafe.js_expr "require")
[|Js.Unsafe.inject (Js.string s)|]
let _js_aws = require_module "aws-sdk"
let array_to_list a =
let ax = ref [] in
begin
for i = 0 to a##.length - 1 do
Optdef.iter (array_get a i) (fun x -> ax := x :: !ax)
done;
!ax
end
class type error = object
end
class type bucket = object
method _Name : js_string t readonly_prop
method _CreationDate : date t readonly_prop
end
class type listBucketsData = object
method _Buckets : (bucket t) js_array t readonly_prop
end
class type s3 = object
method listBuckets :
(error -> listBucketsData t -> unit) callback -> unit meth
end
let createClient : unit -> s3 t = fun () ->
let constr_s3 = _js_aws##.S3 in
new%js constr_s3 ()
module S3 : sig
type t
val create : unit -> t
val list_buckets : t -> (string * string) list Lwt.t
end = struct
type t = s3 Js.t
let create () =
createClient ()
let list_buckets client =
let cell_of_bucket_data data =
((to_string data##._Name),
(to_string data##._CreationDate##toString))
in
let mvar = Lwt_mvar.create_empty () in
let callback error buckets =
let p () =
if true then
Lwt_mvar.put mvar
(`Ok(List.map cell_of_bucket_data ## array_to_list buckets##._Buckets))
else
Lwt_mvar.put mvar (`Error("Ups"))
in
Lwt.async p
in
begin
client##listBuckets (wrap_callback callback);
Lwt.bind
(Lwt_mvar.take mvar)
(function
| `Ok(whatever) -> Lwt.return whatever
| `Error(mesg) -> Lwt.fail_with mesg)
end
end
let () =
let s3 = S3.create() in
let dump lst =
Lwt_list.iter_s
(fun (name, creation_date) ->
printf "%32s\t%s\n" name creation_date;
Lwt.return_unit)
lst
in
let t () =
S3.list_buckets s3
>>= dump
in
begin
Lwt.async t
end
Since there is no binding to Lwt_main for node.js, I had to run my code with Lwt.async. What are the differences between running the code with Lwt.async rather than with Lwt_main.run – the latter not existing in node.js? Is it guaranteed that the program will wait until the asynchronous threads are completed before exiting, or is this rather a lucky but random behaviour of my code?
The Lwt_main.run function recursively polls the thread whose execution it supervises. At each iteration, if this thread is still running, the scheduler uses one engine (from Lwt_engine) to execute threads waiting for I/Os, either by selecting or synchronising on events.
The natural way to translate this in Node.JS is to use the process.nextTick method, which relies on Node.JS own scheduler. Implementing the Lwt_main.run function in this case can be as simple as:
let next_tick (callback : unit -> unit) =
Js.Unsafe.(fun_call
(js_expr "process.nextTick")
[| inject (Js.wrap_callback callback) |])
let rec run t =
Lwt.wakeup_paused ();
match Lwt.poll t with
| Some x -> x
| None -> next_tick (fun () -> run t)
This function only run threads of type unit Lwt.t but this is the main case for a program. It is possible to compute arbitrary values using a Lwt_mvar.t to communicate.
It is also possible to extend this example to support all sort of hooks, as in the original Lwt_main.run implementation.
Here's some simple code that demonstrates what I'm trying to do
myVar = 1
reader = () ->
getDataFromServer1().then ->
# uses myVar and does stuff according to its value
# returns promise
writer = () ->
getDataFromServer2().then ->
# assigns to myVar
# returns promise
Q.all([reader(), reader(), reader(), writer(), writer(), writer()]).done ->
console.log 'done'
So I have multiple threads running at the same time. some of them change the value of myVar and some read the value and rely on it. And I don't want a writer to write while another writer is writing or a reader is reading. Readers can read at the same time though. This is similar to the Readers–writers problem.
I tried to solve this by defining a sharedResource function as follows
sharedResource = (initialValue) ->
readLock = Q.fcall ->
writeLock = Q.fcall ->
value: initialValue
read: (action) ->
newPromise = writeLock.then action
readLock = Q.all([newPromise, readLock]).then -> null
newPromise
write: (action) ->
newPromise = Q.all([readLock, writeLock]).then action
writeLock = Q.all([newPromise, writeLock]).then -> null
newPromise
and then changed my code to use it
myVar = sharedResource 1
reader = () ->
myVar.read ->
# noone is writing to myVar while doing this request:
getDataFromServer1().then (data) ->
# read myVar.value instead of myVar, e.g.
expect(data == myVar.value)
writer = () ->
myVar.write ->
# noone reads or writes myVar while doing this request:
getDataFromServer2().then (data) ->
# change myVar.value instead of myVar, e.g.
myVar.value = data
Q.all([reader(), reader(), reader(), writer(), writer(), writer()]).done ->
console.log 'done'
This worked perfectly when I had only one sharedResource. Here's where the problem occurs
myVar1 = sharedResource 1
myVar2 = sharedResource 2
action1 = () ->
myVar1.read ->
myVar2.write ->
getDataFromServer1().then (data) ->
myVar2.value = data + myVar1.value
action2 = () ->
myVar2.read ->
myvar1.write ->
getDataFromServer2().then (data) ->
myVar1.value = data + myVar2.value
Q.all([action1(), action1(), action1(), action2(), action2(), action2()]).done ->
console.log 'done'
Here a case of deadlock happens. Each promise is waiting for the other one to resolve. None of them get resolved and the program stops.
Edit
I'll try my best to explain:
This is actually code to test my server. To see how it performs when multiple clients send multiple requests at the same time. Say for example every time action1 sends a request, the server increments a value stored in it's database. On the client side (the code that you are seeing) I also increment a variable which contains the value I expect to be on the server. And then when action2 sends a request, the server responds with that value and I assert the value in the response to be the same as my local variable.
So I have to get the lock before I send a request to make sure action2 doesn't ask for the variable while it is being changed.
I hope that helps.