From 9921b3178e756035905dd714caaa6e97600a48f1 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Matthias=20H=C3=B6rmann?= <hoermann@saltation.de>
Date: Tue, 17 Jan 2017 22:03:23 +0100
Subject: [PATCH] implement SASL EXTERNAL authentication (tested with OpenLDAP
 and client-side certificates as the external auth)

---
 src/Ldap/Asn1/ToAsn1.hs | 13 ++++++++++++-
 src/Ldap/Asn1/Type.hs   |  9 ++++++++-
 src/Ldap/Client.hs      |  3 ++-
 src/Ldap/Client/Bind.hs | 39 +++++++++++++++++++++++++++++++++++++++
 4 files changed, 61 insertions(+), 3 deletions(-)

diff --git a/src/Ldap/Asn1/ToAsn1.hs b/src/Ldap/Asn1/ToAsn1.hs
index 5987294..e706a7b 100644
--- a/src/Ldap/Asn1/ToAsn1.hs
+++ b/src/Ldap/Asn1/ToAsn1.hs
@@ -15,6 +15,7 @@ import           Data.Foldable (fold, foldMap)
 import           Data.List.NonEmpty (NonEmpty)
 import           Data.Maybe (maybe)
 import           Data.Monoid (Endo(Endo), (<>), mempty)
+import qualified Data.Text as Text
 import qualified Data.Text.Encoding as Text
 import           Prelude (Integer, (.), fromIntegral)
 
@@ -309,12 +310,22 @@ instance ToAsn1 ProtocolClientOp where
 @
 AuthenticationChoice ::= CHOICE {
      simple                  [0] OCTET STRING,
+     sasl                    [3] SaslCredentials,
      ...  }
+
+
+SaslCredentials ::= SEQUENCE {
+     mechanism               LDAPString,
+     credentials             OCTET STRING OPTIONAL }
 @
 -}
 instance ToAsn1 AuthenticationChoice where
   toAsn1 (Simple s) = other Asn1.Context 0 s
-
+  toAsn1 (Sasl External c) =
+    context 3 (fold
+      [ toAsn1 (LdapString (Text.pack "EXTERNAL"))
+      , maybe mempty (toAsn1 . LdapString) c
+      ])
 {- |
 @
 AttributeSelection ::= SEQUENCE OF selector LDAPString
diff --git a/src/Ldap/Asn1/Type.hs b/src/Ldap/Asn1/Type.hs
index b8f954e..897d4c2 100644
--- a/src/Ldap/Asn1/Type.hs
+++ b/src/Ldap/Asn1/Type.hs
@@ -48,7 +48,14 @@ data ProtocolServerOp =
     deriving (Show, Eq)
 
 -- | Not really a choice until SASL is supported.
-newtype AuthenticationChoice = Simple ByteString
+data AuthenticationChoice =
+    Simple ByteString
+  | Sasl !SaslMechanism !(Maybe Text)
+    deriving (Show, Eq)
+
+-- | SASL Mechanism, for now only SASL EXTERNAL is supported
+data SaslMechanism =
+    External
     deriving (Show, Eq)
 
 -- | Scope of the search to be performed.
diff --git a/src/Ldap/Client.hs b/src/Ldap/Client.hs
index b65f085..2b4c98c 100644
--- a/src/Ldap/Client.hs
+++ b/src/Ldap/Client.hs
@@ -18,6 +18,7 @@ module Ldap.Client
     -- * Bind
   , Password(..)
   , bind
+  , externalBind
     -- * Search
   , search
   , SearchEntry(..)
@@ -90,7 +91,7 @@ import           Ldap.Asn1.ToAsn1 (ToAsn1(toAsn1))
 import           Ldap.Asn1.FromAsn1 (FromAsn1, parseAsn1)
 import qualified Ldap.Asn1.Type as Type
 import           Ldap.Client.Internal
-import           Ldap.Client.Bind (Password(..), bind)
+import           Ldap.Client.Bind (Password(..), bind, externalBind)
 import           Ldap.Client.Search
   ( search
   , Search
diff --git a/src/Ldap/Client/Bind.hs b/src/Ldap/Client/Bind.hs
index cff7fa2..07abf16 100644
--- a/src/Ldap/Client/Bind.hs
+++ b/src/Ldap/Client/Bind.hs
@@ -17,6 +17,10 @@ module Ldap.Client.Bind
   , bindEither
   , bindAsync
   , bindAsyncSTM
+  , externalBind
+  , externalBindEither
+  , externalBindAsync
+  , externalBindAsyncSTM
   , Async
   , wait
   , waitSTM
@@ -24,6 +28,7 @@ module Ldap.Client.Bind
 
 import           Control.Monad.STM (STM, atomically)
 import           Data.ByteString (ByteString)
+import           Data.Text (Text)
 import           Data.List.NonEmpty (NonEmpty((:|)))
 
 import qualified Ldap.Asn1.Type as Type
@@ -73,3 +78,37 @@ bindResult req (Type.BindResponse (Type.LdapResult code (Type.LdapDn (Type.LdapS
   | Type.Success <- code = Right ()
   | otherwise = Left (ResponseErrorCode req code (Dn dn) msg)
 bindResult req res = Left (ResponseInvalid req res)
+
+-- | Perform a SASL EXTERNAL Bind operation synchronously. Raises 'ResponseError' on failures.
+externalBind :: Ldap -> Dn -> Maybe Text -> IO ()
+externalBind l username mCredentials =
+  raise =<< externalBindEither l username mCredentials
+
+-- | Perform a SASL EXTERNAL Bind operation synchronously. Returns @Left e@ where
+-- @e@ is a 'ResponseError' on failures.
+externalBindEither :: Ldap -> Dn -> Maybe Text -> IO (Either ResponseError ())
+externalBindEither l username mCredentials =
+  wait =<< externalBindAsync l username mCredentials
+
+-- | Perform the SASL EXTERNAL Bind operation asynchronously. Call 'Ldap.Client.wait' to wait
+-- for its completion.
+externalBindAsync :: Ldap -> Dn -> Maybe Text -> IO (Async ())
+externalBindAsync l username mCredentials =
+  atomically (externalBindAsyncSTM l username mCredentials)
+
+-- | Perform the SASL EXTERNAL Bind operation asynchronously.
+--
+-- Don't wait for its completion (with 'Ldap.Client.waitSTM') in the
+-- same transaction you've performed it in.
+externalBindAsyncSTM :: Ldap -> Dn -> Maybe Text -> STM (Async ())
+externalBindAsyncSTM l username mCredentials =
+  let req = externalBindRequest username mCredentials in sendRequest l (bindResult req) req
+
+externalBindRequest :: Dn -> Maybe Text -> Request
+externalBindRequest (Dn username) mCredentials =
+  Type.BindRequest ldapVersion
+                   (Type.LdapDn (Type.LdapString username))
+                   (Type.Sasl Type.External mCredentials)
+ where
+  ldapVersion = 3
+