ademar@toronto

A nice Panov attack

2024-04-20T06:26:25+00:00

Hosting a static website with Suave

2013-11-15T00:00:00+00:00

What follows is the code for the webserver running at Suave.IO

#light(*
exec fsharpi --exec $0 --quiet
*)

#r "suave.dll"

open Suave.Types
open Suave.Web
open Suave.Http
open System
open System.Net

let app : WebPart = 
    choose [
       Console.OpenStandardOutput() |> log >>= never;
       url_regex "(.*?)\.(fsx|dll|mdb|log)$" >>= FORBIDDEN "Access denied.";
       GET >>= choose [ url "/" >>= file "index.html"; browse ];
       NOT_FOUND "Found no handlers." 
    ]

let config = 
    { default_config with
       bindings = [ { scheme = HTTP ; ip = IPAddress.Parse "10.0.0.5" ; port   = 80us } ]
       timeout = TimeSpan.FromMilliseconds 3000.
    }

web_server config app

On Linux I lauch the script with something like this


nohup fsharpi WebApp.fsx > web.log &

I ran a load test against Suave.IO with Load Impact; this is the resulting graph. Note how the response time stays constant as the number of client connections increases.

And the corresponding resource usage graph of the Extra Small VM (Shared Core, 768 MB memory) on Azure running it.

A Kaleidoscope in TypeScript

2012-11-09T08:42:51+00:00

Having nothing better to do I've taken TypeScript and Cloud9 IDE for a ride and coded this little kaleidoscope for your amusement.

The code can be found on Cloud9 IDE or forked on GitHub.

Haven't tested it yet on Microsoft Internet Explorer but seems to work fine on Safari, Chrome and Firefox *.

Regarding TypeScript I really appreciate the syntax and type checking which it brings to JavaScript world. Anyone who has had to deal with large JavaScript code will see the benefits.

About Cloud9 IDE I've found it very convenient to use while on the road without access to my IDE of choice; the integration with GitHub is also a plus.

*Update: It works fine on IE 9

Intermittent PHP include failures on Microsoft IIS

2012-08-28T13:40:01+00:00

This is an answer to my own StackOverflow question that I can not answer over there because of lacking enough reputation.

This issue was due to a missing permission. What I eventually found out is that PHP (or one of its modules like php_wincache.dll) wants Execute/Traverse permissions in the website’s root directory.

With the help of SysInternals Process Monitor I noticed that the following CreateFile call was failing with Access Denied. Note in the desired access field is asking for Execute/Traverse

After that, PHP tries to load the include file from the wrong location.

Solution: granting Execute/Traverse in the website’s root directory to the identity under which the PHP process is running solve the intermittent ‘No such file or directory’ include issue.

Notes on installing Movable Type version 5.11 on Microsoft Internet Information Services (IIS)

2011-07-15T15:29:24+00:00

Recently migrated my blog to a new server Windows Server 2008 R2 (also changed the painting) and had to re-install Movable Type. Whenever I have done this I usually hit the following two issues:

First Issue:

HTTP Error 502.2 - Bad Gateway
The specified CGI application misbehaved by not returning a complete set of HTTP headers. The headers it did return are "Can't locate MT/Bootstrap.pm in @INC (@INC contains: lib D:/Perl/site/lib D:/Perl/lib .) at \\nas-005\winspace\10-ademar.name\www\mt\mt.cgi line 11. BEGIN failed--compilation aborted at \\nas-005\winspace\10-ademar.name\www\mt\mt.cgi line 11. ".

Movable Type directory layout

p. To solve this you need to convert the folder containing the Movable Type installation into a virtual directory. Lets say you are installing it in folder mt, then you need to create a virtual directory with the same name pointing to the folder in question.

Second Issue

p. Plugins fail to load. In my case Movable Type had problems loading plugins like MarkDown,SmartyPants and Textile. In the logs messages like the following could be found:

bq. Plugin error: \nas-005\winspace\10-ademar.name\www\mt\plugins\Markdown\SmartyPants.pl Can’t locate \nas-005\winspace\10-ademar.name\www\mt\plugins\Markdown\SmartyPants.pl in @INC (@INC contains: \nas-005\winspace\10-ademar.name\www\mt\extlib \nas-005\winspace\10-ademar.name\www\mt\extlib lib D:/Perl/site/lib D:/Perl/lib .) at lib/MT.pm line 1396

p. To solve this I modified MT.pm by substituting lines 1396,1397 (as of version 5.11)

eval "# line " . __LINE__ . " " . __FILE__
        . "\nrequire '$plugin';";

by the following:

eval { require $plugin };

p. I’m not sure how wise is that change but it solves the problem.

Combinators for logic programming

2011-06-09T15:01:52+00:00

Digging in my hard drive found this piece of code from my functional programming studies that implements the logic unification algorithm described in the article ‘Combinators for logic programming’ by Michael Spivey and Silvija Seres.

Here are some samples of what kind of problems it can solve.

Sample #1 - append

let X = var "x"
let Y = var "y"

let problem1 = append X Y (list [1;2;3;4;5])

run problem1 |> printSolutions

returns:

{x=Nil,y=[1, 2, 3, 4, 5]}
{x=[1],y=[2, 3, 4, 5]}
{x=[1, 2],y=[3, 4, 5]}
{x=[1, 2, 3],y=[4, 5]}
{x=[1, 2, 3, 4],y=[5]}
{x=[1, 2, 3, 4, 5],y=Nil}

Sample #2 - good sequence

let rec good s = 
    step( (s == cons (Int 0) Nil) 
            ||| exists (fun t -> 
                    exists(fun q -> 
                        exists(fun r -> 
                            (s == cons (Int 1) t) &&& append q r t  &&& (good q) &&& (good r)))) )

let problem2 = good  (var "s")

run problem2 |> printSolutions

returns:

{s=[0]}
{s=[1, 0, 0]}
{s=[1, 0, 1, 0, 0]}
{s=[1, 1, 0, 0, 0]}
{s=[1, 0, 1, 0, 1, 0, 0]}
{s=[1, 1, 0, 0, 1, 0, 0]}
{s=[1, 1, 0, 1, 0, 0, 0]}
{s=[1, 0, 1, 1, 0, 0, 0]}
{s=[1, 1, 0, 0, 1, 0, 1, 0, 0]}
{s=[1, 1, 0, 1, 0, 0, 1, 0, 0]}
... ad infinitum

Sample #3 - Difference lists & Grammars

let append' (a1,a2) (b1,b2) (c1,c2) = 
    (a1 == c1) &&& (a2 == b1) &&& (b2 == c2) // -- difference list axiom

let list3 xs  ys = List.foldBack (cons) xs ys

let (++) f1 f2  = 
    fun (list1,r) -> exists( fun x -> append' (list1,x) (x,r) (list1,r) &&& f1(list1,x) &&& f2(x,r))

let final s (list,rest) = exists(fun x -> ((list == list3  ([String(s)]) x)) &&& (x == rest))
let or' f g  (list,rest) = f  (list,rest) ||| g  (list,rest)

let noun =  final "cat" |>  or' <| final "mouse"
let determiner =  final "the" |>  or' <| final "a" 
let verb =  final "scares" |> or' <| final "hates" 

let noun_phrase = determiner ++ noun 
let verb_phrase = verb ++ noun_phrase

let sentence = noun_phrase ++ verb_phrase

run ( sentence (var "q", Nil)) |> printSolutions

returns:

{q=[the, cat, scares, the, cat]}
{q=[the, cat, scares, the, mouse]}
{q=[the, mouse, scares, the, cat]}
{q=[the, cat, hates, the, cat]}
{q=[the, mouse, scares, the, mouse]}
{q=[a, cat, scares, the, cat]}
{q=[the, cat, scares, a, cat]}
{q=[the, mouse, hates, the, cat]}
{q=[a, cat, scares, the, mouse]}
{q=[a, mouse, scares, the, cat]}
{q=[the, cat, hates, the, mouse]}
{q=[the, mouse, scares, a, cat]}
{q=[a, cat, hates, the, cat]}
{q=[a, mouse, scares, the, mouse]}
{q=[the, cat, scares, a, mouse]}
{q=[the, mouse, hates, the, mouse]}
{q=[a, cat, scares, a, cat]}
{q=[a, mouse, hates, the, cat]}
{q=[the, cat, hates, a, cat]}
{q=[the, mouse, scares, a, mouse]}
{q=[a, cat, hates, the, mouse]}
{q=[a, mouse, scares, a, cat]}
{q=[the, cat, hates, a, mouse]}
{q=[the, mouse, hates, a, cat]}
{q=[a, cat, scares, a, mouse]}
{q=[a, mouse, hates, the, mouse]}
{q=[the, mouse, hates, a, mouse]}
{q=[a, cat, hates, a, cat]}
{q=[a, mouse, scares, a, mouse]}
{q=[a, cat, hates, a, mouse]}
{q=[a, mouse, hates, a, cat]}
{q=[a, mouse, hates, a, mouse]}

The code is here

Typed SQL access, second take

2010-10-29T14:28:22+00:00

It gets better. Using this nifty trick from Mauricio Scheffer we can enhance our previous SQL computations with typed parameters and protect our code against SQL injections.

open Suave.Data
open System.Data.SQLite

type Person  = { FirstName: string; LastName: string; Age: int }

let cn = new SQLiteConnection("Data Source = database")
cn.Open()

let tx = sql cn

let queries = 
    [ 
        ("Albert", "Einstein", 32);
        ("Leonard", "Euler", 33);
        ("Benoit", "Mandelbrot", 34)
    ]
    |> List.iter (fun (a,b,c)  
                    -> tx.Query @"insert into family (first_name,last_name,age) 
                                                    values (%s,%s,%d)" a b c 
                    |> executeNonQuery)
    
    tx { 
        // binding to records
        for each in tx.Query "SELECT * FROM family WHERE age>%d" 30 do
                printfn "%s, %s, %d" each.FirstName each.LastName each.Age

        // binding to tuples       
        for (a,b,c) in tx.Query "SELECT * FROM family WHERE last_name like %s" "%brot" do
                printfn "%s, %s, %d" a b c
        
        // let! binds to option types, fails the evaluation by returning None 
        //if the query does not have any results
        let!  age = tx.Query "SELECT age FROM family WHERE first_name = %s" "Leonard"
        let query = tx.Query "SELECT * FROM family WHERE age = %d and first_name = %s"
        let! person =   query 33 "Leonard" 

        return person
     }

match queries with 
|Some(first_name,last_name,age) -> printfn "%s, %s, %d" first_name last_name age
|None -> printfn "query failed."

tx.Query "delete from family" |> executeNonQuery

System.Console.ReadLine() |> ignore 

A recipe for typed SQL database access.

2010-10-16T14:29:38+00:00

This is a rehash of ideas I’ve seen around. Here we introduce a workflow encoding typed SQL queries computations. Consider the following code snippet.

open Suave.Data
open System.Data.SQLite

type Person  = { FirstName: string; LastName: string; Age: int }

let cn = new SQLiteConnection(@"Data Source = database")
cn.Open()

let queries = 
    sql cn { 
        //binding to records
        for each in "SELECT first_name, last_name, age FROM family" do
                printfn "%s, %s, %d" each.FirstName each.LastName each.Age

        //binding to tuples       
        for (a,b,c) in "SELECT first_name, last_name, age FROM family" do
                printfn "%s, %s, %d" a b c

        //let! binds to option types, fails the evaluation by returning None 
        //if the query does not have any results
        let! age = "SELECT age FROM family WHERE age = 34"
        let! person = "SELECT first_name, last_name, age FROM family WHERE age = 33"

        return person
     }

match queries with 
|Some(first_name,last_name,age) -> printfn "%s, %s, %d" first_name last_name age
|None -> printfn "query failed"
 

There are several advantages of using such approach. The workflow provides type safety since F# will infer the types for the binding values and hides all of the boilerplate code associated with querying SQL databases. Throught the let! bindings we provide success/failure semantics with its obvious benefits.

The code for the workflow is here

A minimal TCP/IP proxy implementation with F# asynchronous workflows

2010-06-04T18:32:28+00:00

open System.IO
open System.Threading
open System.Net
open System.Net.Sockets

let mirror (clientStream:Stream) (serverStream:Stream) = async {
    while true do
        let! onebyte = clientStream.AsyncRead(1)
        do! serverStream.AsyncWrite(onebyte) 
}

let proxy (clientStream:Stream) (serverStream:Stream) = 
    [| mirror clientStream serverStream; mirror serverStream clientStream |]
        |> Async.Parallel
        |> Async.RunSynchronously 
        
let stream (client:TcpClient) = client.GetStream()

let tcp_ip_proxy (sourceip,sourceport) (targetip,targetport) = 
    let server = new TcpListener(IPAddress.Parse(sourceip),sourceport)
    server.Start()
    while true do 
        let client = server.AcceptTcpClient()
        let up = new TcpClient(targetip,targetport)
        let t = new Thread(ThreadStart(fun _ -> 
            try      
                stream (client) |> proxy <| stream(up) |> ignore 
            with |_ -> ())
        , IsBackground = true)
        t.Start()   

tcp_ip_proxy ("127.0.0.1",8080) ("66.249.81.104",80)

A little Nmap clone

2010-02-06T01:26:17+00:00

This is an anemic clone of the famous hacker tool nmap. It takes advantage of F# asynchronous workflows to parallelize the network and port scanning. It is notable that without any low level TCP trickery this little program achieves performance comparable to the original nmap.

open System
open System.Net
open System.Net.Sockets
open System.Net.NetworkInformation

let parallelize input f = input |> Seq.map (f)  |> Async.Parallel

let is_port_open (ip:IPAddress) (port:int)=
    try
       let ipe = new IPEndPoint(ip, port)
       use tempSocket = 
            new Socket(ipe.AddressFamily, SocketType.Stream, ProtocolType.Tcp)
       tempSocket.Connect(ipe);
       tempSocket.Connected
    with
       |_ -> false

let inline is_port_open_async (ip:IPAddress) (port:int) = 
    async { return (port, is_port_open ip port) }

let scan_ports ports ip = parallelize ports (is_port_open_async ip)

let inline q (x:uint32[]) = 
    (x.[0] <<< 24) 
    ||| (x.[1] <<< 16) 
    ||| (x.[2] <<< 8) 
    ||| x.[3]

let getip z =
    ((z &&& uint32(0xFF000000))>>>24),
    ((z &&& uint32(0x00FF0000))>>>16),
    ((z &&& uint32(0x0000FF00))>>> 8),
    ( z &&& uint32(0x000000FF))

let _generate n m =
    seq {
          let j = ref n
          while (!j<m) do
             let (a,b,c,d) = getip !j;
             yield (new IPAddress([| byte(a);byte(b);byte(c);byte(d) |]));
             j := !j + uint32(1)
        }

let generate (ip:IPAddress) bits =
    let mask = ~~~(UInt32.MaxValue >>> bits)
    let ipBytes = ip.GetAddressBytes();
    let maskBytes = Array.rev(BitConverter.GetBytes(mask));
    let firstIPBytes = Array.map2 (fun x y -> uint32(x &&& y)) ipBytes maskBytes
    let lastIPBytes = Array.map2 (fun x y -> uint32(x ||| ~~~y)) ipBytes maskBytes
    let n = q (firstIPBytes)
    let m = q (lastIPBytes)
    _generate n m

let pingSender = new Ping()

let is_host_up (t:int) (ip:IPAddress)  =
    let reply = pingSender.Send(ip,t)
    reply.Status = IPStatus.Success

let inline is_host_up_async (t:int) (ip:IPAddress)  
    =  async { return (ip, is_host_up t ip) }

let scan_hosts ip bits = 
    parallelize (generate ip bits) (is_host_up_async 1)

let parallel_port_scanner ports host =
    async {
        let! ports = scan_ports ports host
        for (port,_open) in ports do
        if _open then printf "port\t%d\tis open\n" port
    }

let parallel_host_scanner ip bits f =
    async  {
        let! hosts = scan_hosts ip bits
        for (host,up) in hosts do
            if up then do! f host
 }

let mutable ip = IPAddress.Parse("192.168.13.146");
let mutable bits = 24;

let args = System.Environment.GetCommandLineArgs()

let all_ports     = {1 .. 65535}
let default_ports = {1 .. 1024}

let mutable port_scanning_enabled = false
let mutable range_scanning_enabled = false
let mutable ports  = default_ports

let set_port_params param_index =
    port_scanning_enabled <- true
    if Array.length  args > param_index then
        if args.[param_index].Equals("all") then ports <- all_ports
        else failwith "bad input"

let set_params _ =
    if Array.length  args < 2 then failwith "bad input"
    else
        ip <- IPAddress.Parse(args.[1])
        if Array.length args > 2 then
            if args.[2].Equals("-p") then set_port_params 3
            else
                bits <- Int32.Parse(args.[2])
                range_scanning_enabled <- true
                if Array.length args > 3 && args.[3].Equals("-p") 
                then set_port_params 4

try
    set_params()
with
    |_  ->  printf "usage: netdiscover ipaddress [bits] [-p [all]]\n"
            exit(1);

let timer = new System.Diagnostics.Stopwatch()
timer.Start();

Async.RunSynchronously <|
match range_scanning_enabled, port_scanning_enabled with
|true,true  ->  parallel_host_scanner ip bits 
                  (fun x -> async { printf "%A is up\n" x; 
                                    do! parallel_port_scanner ports x })
|true,false ->  parallel_host_scanner ip bits 
                  (fun x -> async { printf "%A is up\n" x } )
|_          ->  parallel_port_scanner ports ip

printf  "took %dms\n" timer.ElapsedMilliseconds;

For example to scan the network 10.0.1.1/24 including a port scan you would go like this:

sh-3.2# mono discover.exe 10.0.1.1 24 -p
10.0.1.1 is up
port	53	is open
port	554	is open
10.0.1.200 is up
port	53	is open
10.0.1.201 is up
10.0.1.205 is up
port	88	is open
port	548	is open
took 37742ms 

Monadic diagonalization

2009-10-17T15:03:59+00:00

Suppose we want to find all two factors decompositions of a positive integer. We could try the following naive solution.

> let rec inf_seq n = seq { yield n; yield! inf_seq (n+1) };;

val inf_seq : int -> seq<int>

> let omega = inf_seq 1;;

val omega : seq<int>

> for i in omega do
       for j in omega do 
        if (i*j=24) then printf "(%d,%d)" i j;;

- Interrupt
(1,24)

This goes on ad infinitum and prints only one solution after interrupting the evaluation on the F# console.The reason is the following, not all pairs are treated fairly equal. Notice the generated output on the following expression:

> seq { for i in (inf_seq 1) do
                for j in (inf_seq 1) do yield (i,j)};;
val it : seq<int * int> = seq [(1, 1); (1, 2); (1, 3); (1, 4); ...]

The sequence only generates (1,x) pairs, because the first inner loop will never end iterating.

To address this issue we need a mechanism where the pairs are generated in a fair order. This mechanism is known as diagonalization (because of Cantor’s diagonalization proof). Our diagonalization process will take a lazy list of lazy lists and will rearrange its items following Cantor’s method. The implementation of the function diagonal is given at the end of the post.

> let x = diag (LazyList.of_list [omega;omega;omega]);;

val x : LazyList<LazyList<int>>

> x;;
val it : LazyList<LazyList<int>> =
  seq [seq [1]; seq [2; 1]; seq [3; 2; 1]; seq [4; 3; 2]; ...]

We can embed this process into a work-flow (monad)

type DiagBuilder () = 
    member b.Return(x)  = LazyList.of_list [x]
    member b.Bind(x, rest) =  LazyList.concat (diag (LazyList.map rest x))
    member b.Let(p, rest)  = rest p
    member b.Delay(f ) = f ()
    member b.Zero() = LazyList.empty()

let diagonal = new DiagBuilder ()

Using the diagonal monad, our initial factorization problem can be solved like this

> let all_pairs = diagonal { 
    let! n = LazyList.of_seq(inf_seq 1)
    let! m = LazyList.of_seq(inf_seq 1)
    return (n,m)
    } ;;

val all_pairs : LazyList<int * int>

> let factors = seq { for (n,m) in all_pairs do if (n*m=24) then yield (n,m) } ;;

val factors : seq<int * int>

> factors;;
val it : seq<int * int> = seq [(4, 6); (6, 4); (3, 8); (8, 3); ...]

There is some small caveat thought, our algorithm does not stop. Also notice that diagonal is not a real monad because our bind operator is not associative.

Here is the function diagonal which completes the program.

let rec lzw f l1 l2 =
    LazyList.delayed ( fun () -> 
    match l1,l2 with
    |LazyList.Nil, _ -> l2
    |_, LazyList.Nil -> l1
    |LazyList.Cons(p1,tail1),LazyList.Cons(p2,tail2)
         -> LazyList.consf (f p1 p2) (fun () -> lzw f tail1 tail2))
         
let rec diag input = 
    LazyList.delayed ( fun () -> 
        match input with 
        |LazyList.Nil -> LazyList.empty()
        |LazyList.Cons(p,tail) 
            -> lzw (LazyList.append) 
                (LazyList.of_seq (seq {for x in p do yield LazyList.of_list [x]})) 
                (LazyList.consf (LazyList.empty()) (fun () -> diag tail)))

References

Combinators for logic programming, Michael Spivey and Silvija Seres
Enumerating a context-free language, Luke Palmer

Look and say sequence

2009-10-16T13:45:36+00:00

Also known as the Morris Number Sequence

let morris list =
    let rec morris' p' counter = function
        |[] -> [counter;p']
        |p::tail -> if (p<>p') 
                    then counter::p'::(morris' p 1 tail) 
                    else morris' p (counter+1) tail
    match list with
    |[] -> []
    |a::b ->  morris' a 1 b

The sequence looks like this

> let rec applyN f n x = 
    if n = 0 then x else f (applyN f (n-1) x);;
val applyN : ('a -> 'a) -> int -> 'a -> 'a
> applyN morris 0 [1];;
val it : int list = [1]
> applyN morris 1 [1];;
val it : int list = [1; 1]
> applyN morris 2 [1];;
val it : int list = [2; 1]
> applyN morris 3 [1];;
val it : int list = [1; 2; 1; 1]
> applyN morris 4 [1];;
val it : int list = [1; 1; 1; 2; 2; 1]
> applyN morris 5 [1];;
val it : int list = [3; 1; 2; 2; 1; 1]
> applyN morris 6 [1];;
val it : int list = [1; 3; 1; 1; 2; 2; 2; 1]

The ratio between the length of consecutive terms converges and is called Conway’s constant.

> let S n = List.length (applyN morris n [1]);;
val S : int -> int
> let epsilon = 10E-5 ;;
val epsilon : float = 0.0001
> let limit f =
    let rec limit' n =
        if abs(f (n+1) - (f n))<epsilon then f (n+1) else limit' (n+1)
    limit' 1;;
val limit : (int -> float) -> float
> let conways_constant = limit (fun n -> float(S (n+1)) / float(S n));;
val conways_constant : float = 1.308504399 

Dining philosophers - An STM example in F#

2009-10-07T21:52:54+00:00

The dining philosophers problem is a well known problem that illustrate the complexities of managing shared state in a concurrent scenario. The following is a sample solution utilizing Gregory Neverov’s implementation of Shared Transactional Memory for F#.

We start be defining some functions to deal with our shared resources, in this case the forks. Here we use computation expressions syntax to code our transactional operations.

let check = function
  | true -> stm.Return(())
  | false -> retry ()

let take fork = 
    stm {
        let! ref_fork = readTVar (fork)
        do! check ref_fork
        do! writeTVar (fork) false } 

let acquire left_fork right_fork  =  
    stm { 
        do! take left_fork
        do! take right_fork } |> atomically    

let release left_fork right_fork = 
    stm { 
        do! writeTVar left_fork true
        do! writeTVar right_fork true
    } |> atomically

The function @take fork@ checks if a fork is available, if that is the case it marks it as taken and returns, otherwise it retries the transaction. Notice that the retry statement discard the whole enclosing transaction and starts again from the beginning. In this little bit lies the reason why STM programs do not lock out.

For example; lets suppose philosopher A takes the left fork and when he reaches for the second fork finds out it is already taken. In this case we call retry and start from the beginning again. As a result you will never find a philosopher waiting to obtain a second fork while he is holding one.

The remaining of the program is pretty straightforward.

let forkIO (f : unit -> unit) = (new Thread(f)).Start()

let rec forever act : unit = act (); forever act

let rng = new Random()

let randomDelay () = Thread.Sleep(rng.Next(1000))   

let eatOrThink i left_fork right_fork = 
    if ((rng.Next(100)) > 50) 
    then 
        acquire left_fork right_fork
        printf "philosopher [%d] is eating.\n" i
        randomDelay ()
        release left_fork right_fork
    else 
        printf "philosopher [%d] is thinking.\n" i
        randomDelay ()

let philosopher i leftfork rightfork = 
    fun () -> forever (fun () -> eatOrThink i leftfork rightfork)

let main n = 
    let forks = Array.map (fun x -> newTVar(true)) [| 0..(n-1) |]
    List.iter (fun i -> forkIO (philosopher i forks.[i] forks.[(i + 1) % n] )) 
                 [0..(n-1)]
    
do main 5

We can add to this little program some counters and analyze its performance, in particular how much contention there is in this scenario. Running the simulation for a long period of time we can gather some interesting statistics. These are some numbers I collected.

With two philosophers:

philosopher [0] - percents: 40.16 eating, 41.42 thinking, 18.42 obtaining forks
philosopher [1] - percents: 39.57 eating, 41.96 thinking, 18.47 obtaining forks

With five philosophers:

philosopher [0] - percents: 34.54 eating, 35.70 thinking, 29.76 obtaining forks
philosopher [1] - percents: 34.25 eating, 35.86 thinking, 29.89 obtaining forks
philosopher [2] - percents: 34.37 eating, 35.81 thinking, 29.82 obtaining forks
philosopher [3] - percents: 34.46 eating, 35.75 thinking, 29.79 obtaining forks
philosopher [4] - percents: 34.32 eating, 35.58 thinking, 30.10 obtaining forks

Notice there is a lot of contention and it seems to go up with the number of philosophers.

L-Systems and the Fibonacci word fractal

2009-07-09T22:13:04+00:00

Check out this article for a lot of interesting properties of this fractal and its relation to the Fibonacci sequence. F# code follows after the image.

Fibonacci word fractal

open System
open System.Drawing
open System.Drawing.Imaging

let right = Math.PI / 2.0
let left  = 3.0 * Math.PI / 2.0

type Alphabet = 
    |K of float
    |Q of float
    |R of float
    |L of float
    |T of float

let fibonacci_word = function
    |L(x) -> [T(left) ; R(x); T(right); L(x); K(x); L(x); T(right); R(x); T(left) ]
    |R(x) -> [T(right); L(x); T(left) ; R(x); Q(x); R(x); T(left) ; L(x); T(right)]
    |K(x) -> [L(x)]
    |Q(x) -> [R(x)]
    |T(x) -> [T(x)]
    
let rec internal applyN f n x = 
    if n = 0 then x else f (applyN f (n-1) x)
    
type ITurtle =
    abstract draw_forward : float -> unit
    abstract move_forward : float -> unit
    abstract turn         : float -> unit

let interpreter (turtle: ITurtle) = function 
    |L(x) -> turtle.draw_forward(x)
    |R(x) -> turtle.draw_forward(x)
    |K(x) -> turtle.move_forward(x)
    |Q(x) -> turtle.move_forward(x)
    |T(x) -> turtle.turn(x)

let rotate (x,y) theta = 
    let x' = x * cos theta - y * sin theta
    let y' = x * sin theta + y * cos theta
    (x',y')

let Turtle(screen:Graphics) =  
    let x = ref 1.0 
    let y = ref 500.0  
    let dx = ref 1.0 
    let dy = ref 0.0 
    { new ITurtle with 
        member t.draw_forward(scale) = screen.DrawLine( new Pen(Color.Red),
                                                PointF(float32 !x,float32  !y),
                                                PointF(float32(!x + (!dx*scale)), 
                                                       float32( !y + (!dy*scale))))
                                       t.move_forward(scale)
        member t.move_forward(scale) = x := !x + (!dx*scale)
                                       y := !y + (!dy*scale)
        member t.turn(theta)    = let dx',dy' = rotate (!dx,!dy) (theta)
                                  dx := dx'
                                  dy := dy'
        
    };;

let bitmap = new Bitmap(1000,1000)    

let turtle = Turtle(Graphics.FromImage(bitmap))

List.iter (interpreter turtle) (applyN (List.collect fibonacci_word) 8 [L(0.5)])

bitmap.Save("fibonacci_word.bmp")

ICFP Programming Contest 2009

2009-06-29T19:49:58+00:00

I gave it a try at this year’s contest (http://icfpcontest.org/) and although it was a failed attempt it was a very interesting problem.

It is given a virtual machine specification and a set of binaries that runs different simulation scenarios involving satellites orbiting earth. For each scenario the contestant needs to provide a set of instructions to control the satellite thrusters and achieve the designated goals.

The first case involves performing a Hohmann transfer orbit. That is, transferring a satellite from one orbit to another using the thrusters only two times.

Hohmann transfer orbit

Apparently there are some rounding errors in my implementation since even thought the trajectories appear correct to the eye (see picture above) the satellite doesn’t hold within the 1000 meters of the target orbit required to scored any points.

Here is the link to the code, which contains the virtual machine implementation and the attempt to perform the Hohmann maneuver: satellites.fs

Finding figures of constant width on a chessboard

2009-04-27T19:23:12+00:00

Constant width figure of type (11,11,3)

p.. We will say a collection of squares on an nxn board is a figure of constant width w if every row, column and diagonal (both main diagonals) intersects the collection in exactly w squares or does not intersects it at all. Such a figure will contain exactly k*w squares and we will say it is of type @(n,k,w)@. Note that the figures of type @(n,n,1)@ are the solutions to the n-queens problem.

Finding figures of constant width with the computer is an interesting problem. This problem was first described here.

The following is a backtracking algorithm that enumerates all connected figures of type @(n,_,w)@.

I use the word connected in the following sense. Imagine each point in the figure is a teleportation unit and you are allowed to jump between any two points laying on the same row or column or any of the two main diagonals. A figure will be connected if there is a path of jumps between any two points in it.

For example, the n-queens solutions (figures of constant width 1) are totally disconnected; so this program does not find them.

We will start by defining, for every finite subset S of the infinite board, the function such that:

where p is point on the board, row(p) is the row containing p, column(p) the column containing p and so on.

This function is locally defined, meaning that it satisfies the following expression:

where :

The algorithm assumes f_S(p)=(w,w,w,w) for every p belonging to the solution S, it then attempts to recursively satisfy the above mentioned locally defined property. This process either converges to a figure of type (n,_,w) or escapes the nxn board boundary.

Here is the link to the full F# program (cwfigures.fs) and bellow is the function @find@ that performs the search strategy.

let find len F availables buffer =
    let rec search sol len (avlen,avail) (bufflen,buff) =
        match buff with
        |_ when avlen + bufflen < len -> () //not enough left to complete a solution
        |[]      -> F sol //found one!
        |p::tail -> let (r,rows), (c,columns), (d1,diag1), (d2,diag2), remaining = collect p avail
                    if     r  < state.r  p 
                        || c  < state.c  p 
                        || d1 < state.pd p 
                        || d2 < state.nd p then () //can not satisfy local constraint
                    else
                    (search (p::sol) (len-1)
                        |> (prune_before_continue remaining 
                            >> combinator diag2   (state.nd p)
                            >> combinator diag1   (state.pd p)
                            >> combinator columns (state.c  p)
                            >> combinator rows    (state.r  p)
                            )) (bufflen - 1, tail)
    search [] len availables buffer;;      

While there are other backtracking strategies, some of them more aesthetically appealing, this was the faster combination I could come up with. To generate all figures of type (11,_, 3) it took roughly 31 days on a Windows XP virtual machine hosted on Linux running on a quad-core. The same program running on the Linux host (with Mono 2.0.1) performed about twice slower.

There are 21 solutions of type (11,11,3) and 1 solution of type (11,10,3), module the symmetries of the square. You can see them here

Combinatorics and F#

2009-04-22T14:23:35+00:00

Calculates non-repeating k-combinations of a list.

> let rec choices = function
  | []      -> []
  | p::tail -> (p,tail) :: [ for (y,l) in choices tail -> (y,l) ];;


val choices : 'a list -> ('a * 'a list) list

> choices [1..6];;
val it : (int * int list) list
= [(1, [2; 3; 4; 5; 6]); (2, [3; 4; 5; 6]); (3, [4; 5; 6]); (4, [5; 6]);
   (5, [6]); (6, [])]

> let rec combinations S k =
    [ if k=0 then yield [] else
            for (e,r) in choices S do
                for o in combinations r (k-1) do yield e::o  ];;


val combinations : 'a list -> int -> 'a list list

> combinations [1..6] 3;;
val it : int list list
= [[1; 2; 3]; [1; 2; 4]; [1; 2; 5]; [1; 2; 6]; [1; 3; 4]; [1; 3; 5]; [1; 3; 6];
   [1; 4; 5]; [1; 4; 6]; [1; 5; 6]; [2; 3; 4]; [2; 3; 5]; [2; 3; 6]; [2; 4; 5];
   [2; 4; 6]; [2; 5; 6]; [3; 4; 5]; [3; 4; 6]; [3; 5; 6]; [4; 5; 6]]

> let binomial n k = List.length (combinations [1..n] k);; 


val binomial : int -> int -> int

> binomial 52 5;;
val it : int = 2598960 

Parsing CSS style-like attributes with XSLT

2009-01-03T15:31:38+00:00

p.. Lets say we need to transform @<div style="width:236px; height:33px" />@ into @@

The following snippet does it with the help of the function @getCssProperty@:

<xsl:template match="div" >
    <xsl:variable name="height" 
        select="substring-before(melon:getCssProperty(@style,'height'),'px')"/>
    <xsl:variable name="width" 
        select="substring-before(melon:getCssProperty(@style,'width'),'px')"/>
    <element width="{$width}" height="{$height}" />
</xsl:template>

getCssProperty definition:

<xsl:function name="melon:getCssProperty">
    <xsl:param name="style"/>
    <xsl:param name="propertyName"/>
    <xsl:for-each select="tokenize($style,';')">
        <xsl:if test="normalize-space(substring-before(.,':'))=$propertyName">
            <xsl:value-of select="normalize-space(substring-after(.,':'))" />
        </xsl:if>
    </xsl:for-each>
</xsl:function>

Update: I noticed XSLT 1.0 does not support the construct @@, so I end up using the following expression:

<xsl:variable name="height" 
    select="normalize-space(substring-before(substring-after(@style,'height:'),'px'))"/>
<xsl:variable name="width" 
    select="normalize-space(substring-before(substring-after(@style,'width:'),'px'))"/>

On Insecure uploads

2008-10-11T19:31:54+00:00

It is a common requirement these days for web applications to allow and provide users with a file upload interface.
You may want to allow your users upload and share images or documents. Handling user provided files is dangerous and the files should be treated with utmost care.

How was my website hacked/defaced ?

The intruder using the poorly secured interface uploads a file, the file is saved in a predictable location, accessible through the web and, most important, the file name stays unmodified.

If these conditions are met, the attacker can upload a prepared file and later request it from the web server by simply typing in his browser the URL to the uploaded file, example: http://victim.com/uploads/myexploit.php .

Basically the attacker uploads an script providing a file manager or shell-like interface which will allow him to execute commands in the security context of your web application. Depending on the capabilities of the web server, he could upload an ASP or PHP script, coded his own or find one in milw0rm.com. If he could get the server to execute a .cgi, .exe or .dll file the possibilities are broader.

Usually it will give the attacker enough to at least browse and read any files within your own application's reach. As a bonus he could also obtain write/delete privileges and things could get nastier. He could simply substitute your homepage with a "Here waz 3lite haxor!" and list your site in zone-h.org or worst he could start serving spy-ware and/or mount another attack from your web server.

How to prevent it?

There are several specific solutions to this, depending on platform, web server, technology combination. I will describe a general approach:

For performance reasons you may want to rely on the web server capabilities to serve static content like images and documents. In this case we would expose the uploads folder through the web server either by placing the folder under the root of the web site or creating a virtual directory pointing to the folder. If the files are served directly by the server we then must make sure these files are never executed or invoked by the server as it would be the case if the file had a .ASP or .PHP extensions. The following measures should be taken towards avoiding hosting or executing a maliciously injected script.

Require authentication to access the files.
Check the file extension against a list of allowed extensions and not allowed extensions.
Make sure your own scripts extension is included in the not allowed extensions list.
Save the file with a random generated name and track it in a database.
Web Server: Disable Script Execution and Directory Browsing in the uploads (virtual) directory.
File System: Remove Modify/Delete from any ACLs under your web folder.
File System: Remove Execution from any ACLs in the upload folder. Really you shouldn't need Execution anywhere on the web content unless you were using CGIs.
Anti Virus: It is wise to have an anti-virus monitoring your upload folder.
Visual Inspection: Check whats in the upload folder once in a while. I'm sure that naively named file filemanager.php will call your attention.

Melon-reports is up at Google Code.

2008-06-11T15:17:00+00:00

It is a library providing basic reporting and PDF printing. The following test methods illustrate its usage.

Generating a PDF document.

[Test]
public void Works()
{
	var pdf = new PdfDocument();

	var font  = pdf.CreateFont(PdfFontTypes.TYPE1, "Helvetica");
	var image = pdf.CreateImage(@"C:\Temp\dotnet.gif");

	var page = pdf.CreatePage( 612, 792);

	page.DrawText("a GIF image :",50,550,font,24, 
		new RgbColor());

	page.DrawImage(image, 20, 100);
	page.DrawImage(image, 250, 570, 61, 35);
			
	page.DrawRectangle(20, 40, 400, 50, new RgbColor("#330000"), 
		new RgbColor(Color.Red));

	pdf.MakeOutline(pdf.OutlineRoot, "root", page);
	pdf.Print(new FileStream(@"C:\Temp\test.pdf", FileMode.Create, 
		FileAccess.Write));
			
}

Loading and generating a report.

private Report report;
private Document document;

[Test]
public void Load()
{
	var reader = new ReportReader();
	report = reader.Load("WorldPopulation.xml");
}

[Test]
public void Generate()
{
	IDbConnection cn = 
		new MySqlConnection("Server=localhost;Database=world;User ID=user;Password=password;");

	var generator = new Generator(report) {Connection = cn};
	generator.FillReport();

	document = generator.Doc;

}

[Test]
public void Print()
{
	var printer = new PrintManager();
	var f = new FileStream("report.pdf", FileMode.Create, FileAccess.Write);
	var driver = new PDFDriver(f);

	printer.Print(document, driver);

	f.Close();
}

The code is hosted at : http://code.google.com/p/melon-reports/

Quick ASP.NET visitor counter

2008-06-11T14:22:30+00:00

private static Mutex mut = new Mutex();

private MemoryStream GetImage(string s,int width,int height,ImageFormat f) {
          
	Bitmap b = new Bitmap(width,height);
	Graphics g = Graphics.FromImage(b);
	g.FillRectangle(new SolidBrush(Color.White), new Rectangle(0,0,width,height));
	g.DrawString(s,new Font("Arial",16),new SolidBrush(Color.Black),new RectangleF(0,0,width,height));
	MemoryStream mstream = new MemoryStream();
	b.Save(mstream,f);
		
	return mstream ;
}
      
private string GetCount(){

	int count = 0 ; 
	FileStream fs ;
	string FILE_NAME = Server.MapPath("~") + @"\counter.txt";
		
	mut.WaitOne();
	
	if (File.Exists(FILE_NAME)){
		
		fs = new FileStream(FILE_NAME, FileMode.Open, FileAccess.Read);
		BinaryReader r = new BinaryReader(fs);
		
		count = r.ReadInt32();r.Close();fs.Close();
	}
	else
	{
		fs = new FileStream(FILE_NAME, FileMode.CreateNew);
		fs.Close() ;
	}
		
	count++ ;
        
	fs = new FileStream(FILE_NAME, FileMode.Open);
	BinaryWriter w = new BinaryWriter(fs);
		
	w.Write(count);w.Close();fs.Close();
	mut.ReleaseMutex();

	return count.ToString() ;	
}

Hail the Internet Archive Project

2008-04-10T15:48:16+00:00

Phew! Long time no post. Thank GOD the collective memory, I've been all morning up digging my old blog posts out of the internet archive.

SMTP authentication with Perl

2006-07-11T14:44:58+00:00

#!/usr/local/bin/perl -w
use Net::SMTP;
$recipient = 'somebody@somewhere.com' ;
$from	   = 'not.me@ademar.name' ;
$smtp = Net::SMTP->new('smtp.ademar.name', 
			Timeout => 60,
			Debug   => 1);
## smtp server requires authentication 
$smtp->auth('not.me@ademar.name','*******');
$smtp->mail($from);
$smtp->to($recipient);

$smtp->data();
$smtp->datasend("To: $recipient\n");
$smtp->datasend("Subject: test message\n");
$smtp->datasend("\n");
$smtp->datasend("A simple test message\n");
$smtp->dataend();

$smtp->quit;

Something funny, while testing the above script, my Postfix server complained with the following message -

221 Error: I can break rules, too. Goodbye. - i LOLed.

Curl: SSL certificate problem, verify that the CA cert is OK

2006-04-07T15:24:34+00:00

When opening a secure url with Curl you may get the following error:

SSL certificate problem, verify that the CA cert is OK

I will explain why the error and what you should do about it.

The easiest way of getting rid of the error would be adding the following two lines to your script . This solution poses a security risk tho.


//WARNING: this would prevent curl from detecting a 'man in the middle' attack
curl_setopt ($ch, CURLOPT_SSL_VERIFYHOST, 0);
curl_setopt ($ch, CURLOPT_SSL_VERIFYPEER, 0);

p.. Let see what this two parameters do. Quoting the manual.

CURLOPT_SSL_VERIFYHOST: 1 to check the existence of a common name in the SSL peer certificate. 2 to check the existence of a common name and also verify that it matches the hostname provided.
CURLOPT_SSL_VERIFYPEER: FALSE to stop CURL from verifying the peer's certificate. Alternate certificates to verify against can be specified with the CURLOPT_CAINFO option or a certificate directory can be specified with the CURLOPT_CAPATH option. CURLOPT_SSL_VERIFYHOST may also need to be TRUE or FALSE if CURLOPT_SSL_VERIFYPEER is disabled (it defaults to 2).

Setting CURLOPT_SSL_VERIFYHOST to 2 (This is the default value) will garantee that the certificate being presented to you have a ‘common name’ matching the URN you are using to access the remote resource. This is a healthy check but it doesn’t guarantee your program is not being decieved.

Enter the ‘man in the middle’

Your program could be misleaded into talking to another server instead. This can be achieved through several mechanisms, like dns or arp poisoning ( This is a story for another day). The intruder can also self-sign a certificate with the same ‘comon name’ your program is expecting. The communication would still be encrypted but you would be giving away your secrets to an impostor. This kind of attack is called ‘man in the middle’

Defeating the ‘man in the middle’

Well, we need to to verify the certificate being presented to us is good for real. We do this by comparing it against a certificate we reasonable* trust.

If the remote resource is protected by a certificate issued by one of the main CA’s like Verisign, GeoTrust et al, you can safely compare against Mozilla’s CA certificate bundle which you can get from http://curl.haxx.se/docs/caextract.html

Save the file cacert.pem somewhere in your server and set the following options in your script.

 
curl_setopt ($ch, CURLOPT_SSL_VERIFYPEER, TRUE); 
curl_setopt ($ch, CURLOPT_CAINFO, "pathto/cacert.pem");

p.. If you are connecting to a resource protected by a self-signed certificate, all you need to do is obtain a copy of the certificate in PEM format and append it to the cacert.pem of the above paragraph.

By now you should be pretty safe from the man in the middle. But there is still a weak point here, there is nothing that says the trust chain can’t been subverted. In fact it have happened before : http://news.cnet.com/2100-1001-254586.html

The web 2.0 validator

2006-01-14T06:38:39+00:00

The dudes at 30 second rule have coded this very kool consensual web 2.0 validator. You can add your own rule via a del.icio.us bookmark. I have added a rule to check for .rail extensions which would indicate use of the MonoRail engine. MonoRail is an open source MVC framework for .NET inspired in the successful Ruby on Rails. Recently i have started using MonoRail in one of my company's projects and have found it a very productive framework that promotes simplicity and separation of concerns. After being introduced to it you will find that the Webforms idea is actually bloated and introduces too much complexity.

Calling IIsWebServer.Status via ADSI and C#

2005-11-09T06:26:25+00:00

The IIS ADSI Provider reference (incorrectly) states that IIsWebServer.Status is a method call, but the following code snippet fails with HRESULT 0x80020003.

DirectoryEntry ent = 
                 new DirectoryEntry("IIS://localhost/W3SVC/1");
// next call throws 
// System.Runtime.InteropServices.COMException (0x80020003): Member not found.
int status  = (int) ent.Invoke("Status",null);

It happens that IIsWebServer.Status is actually a property and the proper calling mechanism would be :

DirectoryEntry ent = 
                 new DirectoryEntry("IIS://localhost/W3SVC/1");
Object ads = ent.NativeObject; Type type = ads.GetType();
int status  = (int)type.InvokeMember("Status", 
                                       BindingFlags.GetProperty,
                                       null, ads, null); 

A simple .NET interface to dnscmd.exe

2005-07-01T03:49:52+00:00

Example of usage:

DnsCmd dnsCmd = new DnsCmd("my.dns.server");

dnsCmd.CreatePrimaryZone("zone.ademar.name");
dnsCmd.CreateRecord("zone.ademar.name",
    new SOARecord("@","ns1.isqsolutions.com",
DateTime.Today.ToString("yyyyMMdd") + "00",
    "admin.ademar.name",3600,600,1209600,172800));
dnsCmd.CreateRecord("zone.ademar.name",
    new ARecord("comfort","127.0.0.1"));

MXRecord mx = new MXRecord("@",10,"ma.isqsolutions.com.");
dnsCmd.CreateRecord("zone.ademar.name",mx);

Here is the link to the class implementation : DnsCmd.cs