Mock LDAP server for testing

.gitignore

@@ -1,3 +1,4 @@
 dist/
 .cabal-sandbox/
 cabal.sandbox.config
+node_modules

README.markdown

@@ -1,5 +1,5 @@
 ldap-client
------------
+===========
 
 **NOTE: This is work in progress. Don't use it! If you really need LDAP integration, check out [LDAP][LDAP]**
 
@@ -25,6 +25,15 @@ LDAP over TLS                | -           | ✔
 ```
 % git grep '\bString\b' | wc -l
 2
+```
+
+Testing
+-------
+
+```shell
+% sudo apt-get install npm
+% npm install ldapjs
+% cabal test
 ```
 
   [rfc4511]: https://tools.ietf.org/html/rfc4511

ldap-client.cabal

@@ -50,10 +50,11 @@ test-suite spec
   hs-source-dirs:
     test
   main-is:
-    Spec.hs
+    Main.hs
   other-modules:
     Ldap.ClientSpec
   build-depends:
       base          >= 4.7 && < 5
     , hspec
     , ldap-client
+    , process

src/Ldap/Client.hs

@@ -21,6 +21,7 @@ module Ldap.Client
   , Type.Scope(..)
   , Attr(..)
   , SearchEntry(..)
+  , SearchError(..)
   , search
   , searchEither
   , searchAsync

test/Ldap/ClientSpec.hs

@@ -5,108 +5,93 @@ module Ldap.ClientSpec (spec) where
 import           Data.Monoid ((<>))
 import           Test.Hspec
 
-import           Ldap.Client (Host(..), Dn(..), Password(..), Filter(..), Scope(..), scope, size, Attr(..), BindError(..), ResultCode(..))
+import           Ldap.Client (Dn(..), Password(..), Filter(..), Scope(..), Attr(..))
 import qualified Ldap.Client as Ldap
 
+import           SpecHelper (port)
+
 
 spec :: Spec
 spec = do
+  let locally = Ldap.with localhost port
+      search l f = Ldap.search l (Dn "o=localhost") (Ldap.scope WholeSubtree <> Ldap.typesOnly True) f []
 
-  context "public LDAP server at MIT\
-    \<https://github.com/ezyang/ldap-haskell/blob/371a200f14317f8943d2aebdcc56a09dac46c0ed/testsrc/Tests.hs>" $ do
+  context "bind" $ do
+    it "can bind" $ do
+      res <- locally $ \l -> do
+        Ldap.bind l (Dn "cn=admin") (Password "secret")
+      res `shouldBe` Right ()
 
-    it "searches the whole tree for the entries that have ‘uid’ attribute" $ do
-      Right () <- Ldap.with mit 389 $ \l -> do
-        res <- Ldap.search l (Dn "ou=People,dc=scripts,dc=mit,dc=edu")
-                             (scope WholeSubtree)
-                             (Present (Attr "uid"))
-                             []
-        res `shouldSatisfy` (not . null)
-      return ()
+    it "can try to bind with a wrong password" $ do
+      res <- locally $ \l -> do
+        Ldap.bind l (Dn "cn=admin") (Password "public")
+      res `shouldBe` Left (Ldap.BindError (Ldap.BindErrorCode Ldap.InvalidCredentials))
 
-    it "searches the single level for the first 10 entries that have ‘uid’ attribute" $ do
-      Right () <- Ldap.with mit 389 $ \l -> do
-        res <- Ldap.search l (Dn "ou=People,dc=scripts,dc=mit,dc=edu")
-                             (scope SingleLevel <> size 10)
-                             (Present (Attr "uid"))
-                             []
-        length res `shouldBe` 10
-      return ()
+    it "can login as another user" $ do
+      res <- locally $ \l -> do
+        Ldap.bind l (Dn "cn=admin") (Password "secret")
+        Ldap.SearchEntry udn _ : []
+          <- search l (Attr "cn" := "pikachu")
+        Ldap.bind l udn (Password "i-choose-you")
+      res `shouldBe` Right ()
 
-    it "searches the single level for the first 10 entries that do not have ‘uid’ attribute" $ do
-      Right () <- Ldap.with mit 389 $ \l -> do
-        res <- Ldap.search l (Dn "ou=People,dc=scripts,dc=mit,dc=edu")
-                             (scope SingleLevel <> size 10)
-                             (Not (Present (Attr "uid")))
-                             []
-        res `shouldBe` []
-      return ()
+  context "search" $ do
+    it "cannot search as ‘pikachu’" $ do
+      res <- locally $ \l -> do
+        Ldap.bind l (Dn "cn=pikachu,o=localhost") (Password "i-choose-you")
+        search l (Present (Attr "password"))
+      res `shouldBe` Left (Ldap.SearchError (Ldap.SearchErrorCode Ldap.InsufficientAccessRights))
 
-  context "online LDAP test server \
-    \<http://www.forumsys.com/tutorials/integration-how-to/ldap/online-ldap-test-server>" $ do
+    it "can use ‘present’ filter" $ do
+      res <- locally $ \l -> do
+        res <- search l (Present (Attr "password"))
+        dns res `shouldBe` [Dn "cn=pikachu,o=localhost"]
+      res `shouldBe` Right ()
 
-    context "bind" $ do
-      it "can bind" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          Ldap.bind l (Dn "cn=read-only-admin,dc=example,dc=com")
-                      (Password "password")
-        return ()
+    it "can use ‘equality match’ filter" $ do
+      res <- locally $ \l -> do
+        res <- search l (Attr "type" := "flying")
+        dns res `shouldMatchList` [Dn "cn=butterfree,o=localhost", Dn "cn=charizard,o=localhost"]
+      res `shouldBe` Right ()
 
-      it "can try to bind with a wrong password" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          res <- Ldap.bindEither l (Dn "cn=read-only-admin,dc=example,dc=com")
-                                   (Password "drowssap")
-          res `shouldBe` Left (BindErrorCode InvalidCredentials)
-        return ()
+    it "can use ‘and’ filter" $ do
+      res <- locally $ \l -> do
+        res <- search l (And [ Attr "type" := "fire"
+                             , Attr "evolution" := "1"
+                             ])
+        dns res `shouldBe` [Dn "cn=charmeleon,o=localhost"]
+      res `shouldBe` Right ()
 
-      it "can login as another user" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          Ldap.bind l (Dn "cn=read-only-admin,dc=example,dc=com")
-                      (Password "password")
-          Ldap.SearchEntry udn _ : _
-              <- Ldap.search l (Dn "dc=example,dc=com")
-                               (Ldap.scope WholeSubtree <> Ldap.typesOnly True)
-                               (Attr "uid" := "euler")
-                               []
-          Ldap.bind l udn (Password "password")
-        return ()
+    it "can use ‘or’ filter" $ do
+      res <- locally $ \l -> do
+        res <- search l (Or [ Attr "type" := "fire"
+                            , Attr "evolution" := "1"
+                            ])
+        dns res `shouldMatchList`
+          [ Dn "cn=charizard,o=localhost"
+          , Dn "cn=charmeleon,o=localhost"
+          , Dn "cn=charmander,o=localhost"
+          , Dn "cn=metapod,o=localhost"
+          , Dn "cn=wartortle,o=localhost"
+          , Dn "cn=ivysaur,o=localhost"
+          ]
+      res `shouldBe` Right ()
 
-    context "search" $ do
-      let search l f = Ldap.search l (Dn "dc=example,dc=com") (Ldap.scope WholeSubtree <> Ldap.typesOnly True) f []
+    it "can use ‘or’ filter" $ do
+      res <- locally $ \l -> do
+        res <- search l (Not (Or [ Attr "type" := "fire"
+                                 , Attr "evolution" :>= "1"
+                                 ]))
+        dns res `shouldMatchList`
+          [ Dn "cn=bulbasaur,o=localhost"
+          , Dn "cn=squirtle,o=localhost"
+          , Dn "cn=caterpie,o=localhost"
+          , Dn "cn=pikachu,o=localhost"
+          ]
+      res `shouldBe` Right ()
 
-      it "can use ‘present’ filter" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          res <- search l (Present (Attr "initials"))
-          dns res `shouldMatchList` [Dn "uid=test,dc=example,dc=com"]
-        return ()
-
-      it "can use ‘equality match’ filter" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          res <- search l (Attr "sn" := "Tesla")
-          dns res `shouldMatchList` [Dn "uid=tesla,dc=example,dc=com"]
-        return ()
-
-      it "can use ‘or’ filter" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          res <- search l (Or [ Attr "sn" := "Tesla"
-                              , Attr "cn" := "Issac Newton" -- why the fuck "Issac"?
-                              ])
-          dns res `shouldMatchList` [Dn "uid=tesla,dc=example,dc=com", Dn "uid=newton,dc=example,dc=com"]
-        return ()
-
-      it "can use ‘and’ and ‘not’ filters" $ do
-        Right () <- Ldap.with forumsys 389 $ \l -> do
-          res <- search l (And [ Attr "uniqueMember" := "uid=tesla,dc=example,dc=com"
-                               , Not (Attr "uniqueMember" := "uid=einstein,dc=example,dc=com")
-                               ])
-          dns res `shouldMatchList` [Dn "ou=italians,ou=scientists,dc=example,dc=com"]
-        return ()
-
-mit :: Host
-mit = Plain "scripts.mit.edu"
-
-forumsys :: Host
-forumsys = Plain "ldap.forumsys.com"
+localhost :: Ldap.Host
+localhost = Ldap.Plain "localhost"
 
 dns :: [Ldap.SearchEntry] -> [Dn]
 dns (Ldap.SearchEntry dn _ : es) = dn : dns es

test/Main.hs

@@ -0,0 +1,20 @@
+module Main (main) where
+
+import           Control.Concurrent (threadDelay)
+import           Control.Exception (bracket)
+import           System.IO (hGetLine)
+import           System.Process (runInteractiveProcess, terminateProcess, waitForProcess)
+import           Test.Hspec
+
+import qualified Spec
+import           SpecHelper (port)
+
+
+main :: IO ()
+main =
+  bracket (do (_, out, _, h) <- runInteractiveProcess "./test/ldap.js" [] Nothing (Just [("PORT", show port)])
+              hGetLine out
+              return h)
+          (\h -> do terminateProcess h
+                    waitForProcess h)
+          (\_ -> hspec Spec.spec)

test/Spec.hs

@@ -1 +1 @@
-{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
+{-# OPTIONS_GHC -F -pgmF hspec-discover -optF --module-name=Spec #-}

test/SpecHelper.hs

@@ -0,0 +1,4 @@
+module SpecHelper (port) where
+
+port :: Num a => a
+port = 24620

test/ldap.js

@@ -0,0 +1,90 @@
+#!/usr/bin/env nodejs
+
+var ldapjs = require('ldapjs');
+var server = ldapjs.createServer();
+var port = process.env.PORT
+
+// <http://bulbapedia.bulbagarden.net/wiki/List_of_Pok%C3%A9mon_by_National_Pok%C3%A9dex_number>
+var pokemon = [
+  { dn: 'cn=bulbasaur,o=localhost',
+    attributes: { cn: 'bulbasaur', evolution: "0", type: ["grass", "poison"], }
+  },
+  { dn: 'cn=ivysaur,o=localhost',
+    attributes: { cn: 'ivysaur', evolution: "1", type: ["grass", "poison"], }
+  },
+  { dn: 'cn=venusaur,o=localhost',
+    attributes: { cn: 'venusaur', evolution: "2", type: ["grass", "poison"], }
+  },
+  { dn: 'cn=charmander,o=localhost',
+    attributes: { cn: 'charmander', evolution: "0", type: ["fire"], }
+  },
+  { dn: 'cn=charmeleon,o=localhost',
+    attributes: { cn: 'charmeleon', evolution: "1", type: ["fire"], }
+  },
+  { dn: 'cn=charizard,o=localhost',
+    attributes: { cn: 'charizard', evolution: "2", type: ["fire", "flying"], }
+  },
+  { dn: 'cn=squirtle,o=localhost',
+    attributes: { cn: 'squirtle', evolution: "0", type: ["water"], }
+  },
+  { dn: 'cn=wartortle,o=localhost',
+    attributes: { cn: 'wartortle', evolution: "1", type: ["water"], }
+  },
+  { dn: 'cn=blastoise,o=localhost',
+    attributes: { cn: 'blastoise', evolution: "2", type: ["water"], }
+  },
+  { dn: 'cn=caterpie,o=localhost',
+    attributes: { cn: 'caterpie', evolution: "0", type: ["bug"], }
+  },
+  { dn: 'cn=metapod,o=localhost',
+    attributes: { cn: 'metapod', evolution: "1", type: ["bug"], }
+  },
+  { dn: 'cn=butterfree,o=localhost',
+    attributes: { cn: 'butterfree', evolution: "2", type: ["bug", "flying"], }
+  },
+  { dn: 'cn=pikachu,o=localhost',
+    attributes: { cn: 'pikachu', evolution: "0", type: ["electic"], password: "i-choose-you" }
+  },
+  ];
+
+server.bind('cn=admin', function(req, res, next) {
+  if ((req.dn.toString() === 'cn=admin') && (req.credentials === 'secret')) {
+    res.end();
+    return next();
+  } else {
+    return next(new ldapjs.InvalidCredentialsError());
+  }
+});
+
+server.bind('cn=pikachu,o=localhost', function(req, res, next) {
+  if ((req.dn.toString() === 'cn=pikachu,o=localhost') && (req.credentials === 'i-choose-you')) {
+    res.end();
+    return next();
+  } else {
+    return next(new ldapjs.InvalidCredentialsError());
+  }
+});
+
+function authorize(req, res, next) {
+  var bindDN = req.connection.ldap.bindDN;
+  if ((bindDN.equals('cn=admin')) ||
+      (bindDN.equals('cn=anonymous'))) {
+    return next();
+  } else {
+    return next(new ldapjs.InsufficientAccessRightsError());
+  }
+}
+
+server.search('o=localhost', [authorize], function(req, res, next) {
+  for (var i = 0; i < pokemon.length; i++) {
+    if (req.filter.matches(pokemon[i].attributes))
+      res.send(pokemon[i]);
+  };
+
+  res.end();
+  return next();
+});
+
+server.listen(port, function() {
+  console.log("ldap://localhost:%d", port);
+});