{-# LANGUAGE OverloadedStrings #-}

module LdapScimBridge where

import Control.Exception (ErrorCall (ErrorCall), catch, throwIO)
import qualified Data.Aeson as Aeson
import qualified Data.Aeson.Encode.Pretty as Aeson
import qualified Data.Aeson.Key as K
import qualified Data.Aeson.KeyMap as KM
import qualified Data.ByteString.Char8 as ByteString
import qualified Data.Foldable as Foldable
import qualified Data.List
import qualified Data.Map as Map
import Data.String.Conversions (cs)
import qualified Data.String.Conversions as SC
import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import qualified Data.Yaml as Yaml
import qualified GHC.Show
import Ldap.Client as Ldap
import qualified Network.HTTP.Client as HTTP
import qualified Network.HTTP.Client.TLS as HTTP
import Servant.API.ContentTypes (NoContent)
import Servant.Client (BaseUrl (..), ClientEnv (..), Scheme (..), mkClientEnv)
import System.Environment (getProgName)
import System.Logger (Level (..))
import qualified System.Logger as Log
import qualified Text.Email.Validate
import Web.Scim.Class.Auth (AuthData)
import qualified Web.Scim.Class.Auth as AuthClass
import qualified Web.Scim.Class.Group as GroupClass
import qualified Web.Scim.Class.User as ScimClass
import qualified Web.Scim.Client as ScimClient
import qualified Web.Scim.Filter as ScimFilter
import qualified Web.Scim.Schema.Common as ScimCommon
import qualified Web.Scim.Schema.ListResponse as Scim
import qualified Web.Scim.Schema.Meta as Scim
import qualified Web.Scim.Schema.Schema as Scim
import qualified Web.Scim.Schema.User as Scim
import qualified Web.Scim.Schema.User.Email as Scim
import Prelude

data LdapConf = LdapConf
  { -- | eg. @Ldap.Tls (host conf) Ldap.defaultTlsSettings@
    LdapConf -> Host
ldapHost :: Host,
    -- | usually 389 for plaintext or 636 for TLS.
    LdapConf -> PortNumber
ldapPort :: PortNumber,
    -- | `$ slapcat | grep ^modifiersName`, eg. @Dn "cn=admin,dc=nodomain"@.
    LdapConf -> Dn
ldapDn :: Dn,
    LdapConf -> Password
ldapPassword :: Password,
    LdapConf -> LdapSearch
ldapSearch :: LdapSearch,
    -- | anything from "Data.Text.Encoding".
    LdapConf -> Codec
ldapCodec :: Codec,
    LdapConf -> Maybe LdapFilterAttr
ldapDeleteOnAttribute :: Maybe LdapFilterAttr,
    LdapConf -> Maybe LdapSearch
ldapDeleteFromDirectory :: Maybe LdapSearch
  }
  deriving stock (Int -> LdapConf -> ShowS
[LdapConf] -> ShowS
LdapConf -> String
(Int -> LdapConf -> ShowS)
-> (LdapConf -> String) -> ([LdapConf] -> ShowS) -> Show LdapConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LdapConf -> ShowS
showsPrec :: Int -> LdapConf -> ShowS
$cshow :: LdapConf -> String
show :: LdapConf -> String
$cshowList :: [LdapConf] -> ShowS
showList :: [LdapConf] -> ShowS
Show)

data LdapFilterAttr = LdapFilterAttr
  { LdapFilterAttr -> Text
key :: Text,
    LdapFilterAttr -> Text
value :: Text
  }
  deriving stock (LdapFilterAttr -> LdapFilterAttr -> Bool
(LdapFilterAttr -> LdapFilterAttr -> Bool)
-> (LdapFilterAttr -> LdapFilterAttr -> Bool) -> Eq LdapFilterAttr
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LdapFilterAttr -> LdapFilterAttr -> Bool
== :: LdapFilterAttr -> LdapFilterAttr -> Bool
$c/= :: LdapFilterAttr -> LdapFilterAttr -> Bool
/= :: LdapFilterAttr -> LdapFilterAttr -> Bool
Eq, Int -> LdapFilterAttr -> ShowS
[LdapFilterAttr] -> ShowS
LdapFilterAttr -> String
(Int -> LdapFilterAttr -> ShowS)
-> (LdapFilterAttr -> String)
-> ([LdapFilterAttr] -> ShowS)
-> Show LdapFilterAttr
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LdapFilterAttr -> ShowS
showsPrec :: Int -> LdapFilterAttr -> ShowS
$cshow :: LdapFilterAttr -> String
show :: LdapFilterAttr -> String
$cshowList :: [LdapFilterAttr] -> ShowS
showList :: [LdapFilterAttr] -> ShowS
Show, (forall x. LdapFilterAttr -> Rep LdapFilterAttr x)
-> (forall x. Rep LdapFilterAttr x -> LdapFilterAttr)
-> Generic LdapFilterAttr
forall x. Rep LdapFilterAttr x -> LdapFilterAttr
forall x. LdapFilterAttr -> Rep LdapFilterAttr x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. LdapFilterAttr -> Rep LdapFilterAttr x
from :: forall x. LdapFilterAttr -> Rep LdapFilterAttr x
$cto :: forall x. Rep LdapFilterAttr x -> LdapFilterAttr
to :: forall x. Rep LdapFilterAttr x -> LdapFilterAttr
Generic)

data LdapSearch = LdapSearch
  { -- | `$ slapcat | grep ^dn`, eg. @Dn "dc=nodomain"@.
    LdapSearch -> Dn
ldapSearchBase :: Dn,
    -- | eg. @"account"@
    LdapSearch -> Text
ldapSearchObjectClass :: Text,
    -- | eg. @[LdapFilterAttr "memberOf" "team red", LdapFilterAttr "hairColor" "yellow"]
    LdapSearch -> [LdapFilterAttr]
ldapSearchExtra :: [LdapFilterAttr]
  }
  deriving stock (LdapSearch -> LdapSearch -> Bool
(LdapSearch -> LdapSearch -> Bool)
-> (LdapSearch -> LdapSearch -> Bool) -> Eq LdapSearch
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LdapSearch -> LdapSearch -> Bool
== :: LdapSearch -> LdapSearch -> Bool
$c/= :: LdapSearch -> LdapSearch -> Bool
/= :: LdapSearch -> LdapSearch -> Bool
Eq, Int -> LdapSearch -> ShowS
[LdapSearch] -> ShowS
LdapSearch -> String
(Int -> LdapSearch -> ShowS)
-> (LdapSearch -> String)
-> ([LdapSearch] -> ShowS)
-> Show LdapSearch
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> LdapSearch -> ShowS
showsPrec :: Int -> LdapSearch -> ShowS
$cshow :: LdapSearch -> String
show :: LdapSearch -> String
$cshowList :: [LdapSearch] -> ShowS
showList :: [LdapSearch] -> ShowS
Show)

data Codec = Utf8 | Latin1
  deriving stock (Codec -> Codec -> Bool
(Codec -> Codec -> Bool) -> (Codec -> Codec -> Bool) -> Eq Codec
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: Codec -> Codec -> Bool
== :: Codec -> Codec -> Bool
$c/= :: Codec -> Codec -> Bool
/= :: Codec -> Codec -> Bool
Eq, Int -> Codec -> ShowS
[Codec] -> ShowS
Codec -> String
(Int -> Codec -> ShowS)
-> (Codec -> String) -> ([Codec] -> ShowS) -> Show Codec
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Codec -> ShowS
showsPrec :: Int -> Codec -> ShowS
$cshow :: Codec -> String
show :: Codec -> String
$cshowList :: [Codec] -> ShowS
showList :: [Codec] -> ShowS
Show)

instance Aeson.FromJSON LdapConf where
  parseJSON :: Value -> Parser LdapConf
parseJSON = String -> (Object -> Parser LdapConf) -> Value -> Parser LdapConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"LdapConf" ((Object -> Parser LdapConf) -> Value -> Parser LdapConf)
-> (Object -> Parser LdapConf) -> Value -> Parser LdapConf
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Bool
ftls :: Bool <- Object
obj Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"tls"
    String
fhost :: String <- Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"host"
    Int
fport :: Int <- Object
obj Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"port"
    Text
fdn :: Text <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"dn"
    String
fpassword :: String <- Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"password"
    LdapSearch
fsearch :: LdapSearch <- Object
obj Object -> Key -> Parser LdapSearch
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"search"
    Text
fcodec :: Text <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"codec"
    Maybe LdapFilterAttr
fdeleteOnAttribute :: Maybe LdapFilterAttr <- Object
obj Object -> Key -> Parser (Maybe LdapFilterAttr)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"deleteOnAttribute"
    Maybe LdapSearch
fdeleteFromDirectory :: Maybe LdapSearch <- Object
obj Object -> Key -> Parser (Maybe LdapSearch)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"deleteFromDirectory"

    let vhost :: Host
        vhost :: Host
vhost = if Bool
ftls then String -> TLSSettings -> Host
Ldap.Tls String
fhost TLSSettings
Ldap.defaultTlsSettings else String -> Host
Ldap.Plain String
fhost

        vport :: PortNumber
        vport :: PortNumber
vport = Int -> PortNumber
forall a b. (Integral a, Num b) => a -> b
fromIntegral Int
fport

    Codec
vcodec <- case Text
fcodec of
      Text
"utf8" -> Codec -> Parser Codec
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Codec
Utf8
      Text
"latin1" -> Codec -> Parser Codec
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Codec
Latin1
      Text
bad -> String -> Parser Codec
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Codec) -> String -> Parser Codec
forall a b. (a -> b) -> a -> b
$ String
"unsupported codec: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
bad

    LdapConf -> Parser LdapConf
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LdapConf -> Parser LdapConf) -> LdapConf -> Parser LdapConf
forall a b. (a -> b) -> a -> b
$
      LdapConf
        { ldapHost :: Host
ldapHost = Host
vhost,
          ldapPort :: PortNumber
ldapPort = PortNumber
vport,
          ldapDn :: Dn
ldapDn = Text -> Dn
Dn Text
fdn,
          ldapPassword :: Password
ldapPassword = AttrValue -> Password
Password (AttrValue -> Password) -> AttrValue -> Password
forall a b. (a -> b) -> a -> b
$ String -> AttrValue
ByteString.pack String
fpassword,
          ldapSearch :: LdapSearch
ldapSearch = LdapSearch
fsearch,
          ldapCodec :: Codec
ldapCodec = Codec
vcodec,
          ldapDeleteOnAttribute :: Maybe LdapFilterAttr
ldapDeleteOnAttribute = Maybe LdapFilterAttr
fdeleteOnAttribute,
          ldapDeleteFromDirectory :: Maybe LdapSearch
ldapDeleteFromDirectory = Maybe LdapSearch
fdeleteFromDirectory
        }

instance Aeson.FromJSON LdapFilterAttr where
  parseJSON :: Value -> Parser LdapFilterAttr
parseJSON = String
-> (Object -> Parser LdapFilterAttr)
-> Value
-> Parser LdapFilterAttr
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"LdapFilterAttr" ((Object -> Parser LdapFilterAttr)
 -> Value -> Parser LdapFilterAttr)
-> (Object -> Parser LdapFilterAttr)
-> Value
-> Parser LdapFilterAttr
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Text -> Text -> LdapFilterAttr
LdapFilterAttr
      (Text -> Text -> LdapFilterAttr)
-> Parser Text -> Parser (Text -> LdapFilterAttr)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"key"
      Parser (Text -> LdapFilterAttr)
-> Parser Text -> Parser LdapFilterAttr
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"value"

instance Aeson.FromJSON LdapSearch where
  parseJSON :: Value -> Parser LdapSearch
parseJSON = String
-> (Object -> Parser LdapSearch) -> Value -> Parser LdapSearch
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"LdapSearch" ((Object -> Parser LdapSearch) -> Value -> Parser LdapSearch)
-> (Object -> Parser LdapSearch) -> Value -> Parser LdapSearch
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Text
fbase :: Text <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"base"
    Text
fobjectClass :: Text <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"objectClass"

    [LdapFilterAttr]
extra :: [LdapFilterAttr] <- do
      let go :: (KM.Key, Yaml.Value) -> Yaml.Parser LdapFilterAttr
          go :: (Key, Value) -> Parser LdapFilterAttr
go (Key
key, Value
val) = do
            Text
str <- String -> (Text -> Parser Text) -> Value -> Parser Text
forall a. String -> (Text -> Parser a) -> Value -> Parser a
Aeson.withText String
"val" Text -> Parser Text
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Value
val
            LdapFilterAttr -> Parser LdapFilterAttr
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LdapFilterAttr -> Parser LdapFilterAttr)
-> LdapFilterAttr -> Parser LdapFilterAttr
forall a b. (a -> b) -> a -> b
$ Text -> Text -> LdapFilterAttr
LdapFilterAttr (Key -> Text
K.toText Key
key) Text
str
      (Key, Value) -> Parser LdapFilterAttr
go ((Key, Value) -> Parser LdapFilterAttr)
-> [(Key, Value)] -> Parser [LdapFilterAttr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
`mapM` Object -> [(Key, Value)]
forall v. KeyMap v -> [(Key, v)]
KM.toList ((Key -> Value -> Bool) -> Object -> Object
forall v. (Key -> v -> Bool) -> KeyMap v -> KeyMap v
KM.filterWithKey (\Key
k Value
_ -> Key
k Key -> [Key] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Key
"base", Key
"objectClass"]) Object
obj)
    LdapSearch -> Parser LdapSearch
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (LdapSearch -> Parser LdapSearch)
-> LdapSearch -> Parser LdapSearch
forall a b. (a -> b) -> a -> b
$ Dn -> Text -> [LdapFilterAttr] -> LdapSearch
LdapSearch (Text -> Dn
Dn Text
fbase) Text
fobjectClass [LdapFilterAttr]
extra

data ScimConf = ScimConf
  { ScimConf -> Bool
scimTls :: Bool,
    ScimConf -> String
scimHost :: String,
    ScimConf -> Int
scimPort :: Int,
    ScimConf -> String
scimPath :: String,
    ScimConf -> Text
scimToken :: Text
  }
  deriving stock (ScimConf -> ScimConf -> Bool
(ScimConf -> ScimConf -> Bool)
-> (ScimConf -> ScimConf -> Bool) -> Eq ScimConf
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ScimConf -> ScimConf -> Bool
== :: ScimConf -> ScimConf -> Bool
$c/= :: ScimConf -> ScimConf -> Bool
/= :: ScimConf -> ScimConf -> Bool
Eq, Int -> ScimConf -> ShowS
[ScimConf] -> ShowS
ScimConf -> String
(Int -> ScimConf -> ShowS)
-> (ScimConf -> String) -> ([ScimConf] -> ShowS) -> Show ScimConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> ScimConf -> ShowS
showsPrec :: Int -> ScimConf -> ShowS
$cshow :: ScimConf -> String
show :: ScimConf -> String
$cshowList :: [ScimConf] -> ShowS
showList :: [ScimConf] -> ShowS
Show, (forall x. ScimConf -> Rep ScimConf x)
-> (forall x. Rep ScimConf x -> ScimConf) -> Generic ScimConf
forall x. Rep ScimConf x -> ScimConf
forall x. ScimConf -> Rep ScimConf x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. ScimConf -> Rep ScimConf x
from :: forall x. ScimConf -> Rep ScimConf x
$cto :: forall x. Rep ScimConf x -> ScimConf
to :: forall x. Rep ScimConf x -> ScimConf
Generic)

instance Aeson.FromJSON ScimConf where
  parseJSON :: Value -> Parser ScimConf
parseJSON = String -> (Object -> Parser ScimConf) -> Value -> Parser ScimConf
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"ScimConf" ((Object -> Parser ScimConf) -> Value -> Parser ScimConf)
-> (Object -> Parser ScimConf) -> Value -> Parser ScimConf
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Bool -> String -> Int -> String -> Text -> ScimConf
ScimConf
      (Bool -> String -> Int -> String -> Text -> ScimConf)
-> Parser Bool
-> Parser (String -> Int -> String -> Text -> ScimConf)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Object
obj Object -> Key -> Parser Bool
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"tls"
      Parser (String -> Int -> String -> Text -> ScimConf)
-> Parser String -> Parser (Int -> String -> Text -> ScimConf)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"host"
      Parser (Int -> String -> Text -> ScimConf)
-> Parser Int -> Parser (String -> Text -> ScimConf)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser Int
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"port"
      Parser (String -> Text -> ScimConf)
-> Parser String -> Parser (Text -> ScimConf)
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser String
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"path"
      Parser (Text -> ScimConf) -> Parser Text -> Parser ScimConf
forall a b. Parser (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"token"

data BridgeConf = BridgeConf
  { BridgeConf -> LdapConf
ldapSource :: LdapConf,
    BridgeConf -> ScimConf
scimTarget :: ScimConf,
    BridgeConf -> Mapping
mapping :: Mapping,
    BridgeConf -> PhantomParent Level
logLevel :: PhantomParent Level
  }
  deriving stock (Int -> BridgeConf -> ShowS
[BridgeConf] -> ShowS
BridgeConf -> String
(Int -> BridgeConf -> ShowS)
-> (BridgeConf -> String)
-> ([BridgeConf] -> ShowS)
-> Show BridgeConf
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> BridgeConf -> ShowS
showsPrec :: Int -> BridgeConf -> ShowS
$cshow :: BridgeConf -> String
show :: BridgeConf -> String
$cshowList :: [BridgeConf] -> ShowS
showList :: [BridgeConf] -> ShowS
Show, (forall x. BridgeConf -> Rep BridgeConf x)
-> (forall x. Rep BridgeConf x -> BridgeConf) -> Generic BridgeConf
forall x. Rep BridgeConf x -> BridgeConf
forall x. BridgeConf -> Rep BridgeConf x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. BridgeConf -> Rep BridgeConf x
from :: forall x. BridgeConf -> Rep BridgeConf x
$cto :: forall x. Rep BridgeConf x -> BridgeConf
to :: forall x. Rep BridgeConf x -> BridgeConf
Generic)

-- | Work around orphan instances.  Might not be a phantom, but I like the name.  :)
newtype PhantomParent a = PhantomParent {forall a. PhantomParent a -> a
unPhantomParent :: a}
  deriving stock (PhantomParent a -> PhantomParent a -> Bool
(PhantomParent a -> PhantomParent a -> Bool)
-> (PhantomParent a -> PhantomParent a -> Bool)
-> Eq (PhantomParent a)
forall a. Eq a => PhantomParent a -> PhantomParent a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: forall a. Eq a => PhantomParent a -> PhantomParent a -> Bool
== :: PhantomParent a -> PhantomParent a -> Bool
$c/= :: forall a. Eq a => PhantomParent a -> PhantomParent a -> Bool
/= :: PhantomParent a -> PhantomParent a -> Bool
Eq, Eq (PhantomParent a)
Eq (PhantomParent a) =>
(PhantomParent a -> PhantomParent a -> Ordering)
-> (PhantomParent a -> PhantomParent a -> Bool)
-> (PhantomParent a -> PhantomParent a -> Bool)
-> (PhantomParent a -> PhantomParent a -> Bool)
-> (PhantomParent a -> PhantomParent a -> Bool)
-> (PhantomParent a -> PhantomParent a -> PhantomParent a)
-> (PhantomParent a -> PhantomParent a -> PhantomParent a)
-> Ord (PhantomParent a)
PhantomParent a -> PhantomParent a -> Bool
PhantomParent a -> PhantomParent a -> Ordering
PhantomParent a -> PhantomParent a -> PhantomParent a
forall a.
Eq a =>
(a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
forall a. Ord a => Eq (PhantomParent a)
forall a. Ord a => PhantomParent a -> PhantomParent a -> Bool
forall a. Ord a => PhantomParent a -> PhantomParent a -> Ordering
forall a.
Ord a =>
PhantomParent a -> PhantomParent a -> PhantomParent a
$ccompare :: forall a. Ord a => PhantomParent a -> PhantomParent a -> Ordering
compare :: PhantomParent a -> PhantomParent a -> Ordering
$c< :: forall a. Ord a => PhantomParent a -> PhantomParent a -> Bool
< :: PhantomParent a -> PhantomParent a -> Bool
$c<= :: forall a. Ord a => PhantomParent a -> PhantomParent a -> Bool
<= :: PhantomParent a -> PhantomParent a -> Bool
$c> :: forall a. Ord a => PhantomParent a -> PhantomParent a -> Bool
> :: PhantomParent a -> PhantomParent a -> Bool
$c>= :: forall a. Ord a => PhantomParent a -> PhantomParent a -> Bool
>= :: PhantomParent a -> PhantomParent a -> Bool
$cmax :: forall a.
Ord a =>
PhantomParent a -> PhantomParent a -> PhantomParent a
max :: PhantomParent a -> PhantomParent a -> PhantomParent a
$cmin :: forall a.
Ord a =>
PhantomParent a -> PhantomParent a -> PhantomParent a
min :: PhantomParent a -> PhantomParent a -> PhantomParent a
Ord, PhantomParent a
PhantomParent a -> PhantomParent a -> Bounded (PhantomParent a)
forall a. a -> a -> Bounded a
forall a. Bounded a => PhantomParent a
$cminBound :: forall a. Bounded a => PhantomParent a
minBound :: PhantomParent a
$cmaxBound :: forall a. Bounded a => PhantomParent a
maxBound :: PhantomParent a
Bounded, Int -> PhantomParent a -> ShowS
[PhantomParent a] -> ShowS
PhantomParent a -> String
(Int -> PhantomParent a -> ShowS)
-> (PhantomParent a -> String)
-> ([PhantomParent a] -> ShowS)
-> Show (PhantomParent a)
forall a. Show a => Int -> PhantomParent a -> ShowS
forall a. Show a => [PhantomParent a] -> ShowS
forall a. Show a => PhantomParent a -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: forall a. Show a => Int -> PhantomParent a -> ShowS
showsPrec :: Int -> PhantomParent a -> ShowS
$cshow :: forall a. Show a => PhantomParent a -> String
show :: PhantomParent a -> String
$cshowList :: forall a. Show a => [PhantomParent a] -> ShowS
showList :: [PhantomParent a] -> ShowS
Show, (forall x. PhantomParent a -> Rep (PhantomParent a) x)
-> (forall x. Rep (PhantomParent a) x -> PhantomParent a)
-> Generic (PhantomParent a)
forall x. Rep (PhantomParent a) x -> PhantomParent a
forall x. PhantomParent a -> Rep (PhantomParent a) x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
forall a x. Rep (PhantomParent a) x -> PhantomParent a
forall a x. PhantomParent a -> Rep (PhantomParent a) x
$cfrom :: forall a x. PhantomParent a -> Rep (PhantomParent a) x
from :: forall x. PhantomParent a -> Rep (PhantomParent a) x
$cto :: forall a x. Rep (PhantomParent a) x -> PhantomParent a
to :: forall x. Rep (PhantomParent a) x -> PhantomParent a
Generic)

instance Aeson.FromJSON (PhantomParent Level) where
  parseJSON :: Value -> Parser (PhantomParent Level)
parseJSON =
    (Level -> PhantomParent Level)
-> Parser Level -> Parser (PhantomParent Level)
forall a b. (a -> b) -> Parser a -> Parser b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Level -> PhantomParent Level
forall a. a -> PhantomParent a
PhantomParent (Parser Level -> Parser (PhantomParent Level))
-> (Value -> Parser Level) -> Value -> Parser (PhantomParent Level)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. \case
      Value
"Trace" -> Level -> Parser Level
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Trace
      Value
"Debug" -> Level -> Parser Level
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Debug
      Value
"Info" -> Level -> Parser Level
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Info
      Value
"Warn" -> Level -> Parser Level
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Warn
      Value
"Error" -> Level -> Parser Level
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Error
      Value
"Fatal" -> Level -> Parser Level
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Fatal
      Value
bad -> String -> Parser Level
forall a. String -> Parser a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> Parser Level) -> String -> Parser Level
forall a b. (a -> b) -> a -> b
$ String
"unknown Level: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Value -> String
forall b a. (Show a, IsString b) => a -> b
show Value
bad

instance Aeson.FromJSON BridgeConf

data MappingError
  = MissingMandatoryValue Text Text
  | WrongNumberOfAttrValues Text Text String Int
  | CouldNotParseEmail Text Text Text String
  deriving stock (MappingError -> MappingError -> Bool
(MappingError -> MappingError -> Bool)
-> (MappingError -> MappingError -> Bool) -> Eq MappingError
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: MappingError -> MappingError -> Bool
== :: MappingError -> MappingError -> Bool
$c/= :: MappingError -> MappingError -> Bool
/= :: MappingError -> MappingError -> Bool
Eq)

renderMappingError :: MappingError -> String
renderMappingError :: MappingError -> String
renderMappingError (MissingMandatoryValue Text
ldapAttr Text
scimAttr) =
  String
"MissingMandatoryValue: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
ldapAttr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
scimAttr
renderMappingError (WrongNumberOfAttrValues Text
ldapAttr Text
scimAttr String
expected Int
actual) =
  (String
"Wrong number of attribute values: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
ldapAttr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
scimAttr)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
" (got <> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Int -> String
forall b a. (Show a, IsString b) => a -> b
show Int
actual String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; expected " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
expected String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")")
renderMappingError (CouldNotParseEmail Text
ldapAttr Text
scimAttr Text
bad String
err) =
  (String
"Could not parse email: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
ldapAttr String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" -> " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
Text.unpack Text
scimAttr)
    String -> ShowS
forall a. Semigroup a => a -> a -> a
<> (String
" (input: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> Text -> String
forall b a. (Show a, IsString b) => a -> b
show Text
bad String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
"; error: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
err String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
")")

renderSearchError :: [(SearchEntry, MappingError)] -> String
renderSearchError :: [(SearchEntry, MappingError)] -> String
renderSearchError = [(SearchEntry, String)] -> String
forall b a. (Show a, IsString b) => a -> b
show ([(SearchEntry, String)] -> String)
-> ([(SearchEntry, MappingError)] -> [(SearchEntry, String)])
-> [(SearchEntry, MappingError)]
-> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((SearchEntry, MappingError) -> (SearchEntry, String))
-> [(SearchEntry, MappingError)] -> [(SearchEntry, String)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\(SearchEntry
s, MappingError
m) -> (SearchEntry
s, MappingError -> String
renderMappingError MappingError
m))

data FieldMapping = FieldMapping
  { -- | This is the SCIM label (the LDAP label is in the key of the `Mapping`)
    FieldMapping -> Text
fieldMappingLabel :: Text,
    FieldMapping
-> [Text] -> Either MappingError (User ScimTag -> User ScimTag)
fieldMappingFun ::
      [Text] ->
      Either
        MappingError
        ( Scim.User ScimTag ->
          Scim.User ScimTag
        )
  }

instance Show FieldMapping where
  show :: FieldMapping -> String
show = Text -> String
forall b a. (Show a, IsString b) => a -> b
show (Text -> String)
-> (FieldMapping -> Text) -> FieldMapping -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FieldMapping -> Text
fieldMappingLabel

-- | Fill in the parameters for hscim 'User' type with plausible defaults.  (You may want to
-- touch this if you're using the library for something new.)
data ScimTag

instance Scim.UserTypes ScimTag where
  type UserId ScimTag = Text
  type UserExtra ScimTag = Scim.NoUserExtra
  supportedSchemas :: [Schema]
supportedSchemas = [Schema
Scim.User20]

instance GroupClass.GroupTypes ScimTag where
  type GroupId ScimTag = Text

instance AuthClass.AuthTypes ScimTag where
  type AuthData ScimTag = Text
  type AuthInfo ScimTag = ()

-- | Map attribute keys to functions from attribute values to changes to scim records.  We'll
-- start off with an empty scim record, and change it based on attributes we find that are
-- listed in the mapping.  Mappigns can fail, eg. if there is more than one attribute value
-- for the attribute mapping to externalId.
newtype Mapping = Mapping {Mapping -> Map Text [FieldMapping]
fromMapping :: Map Text [FieldMapping]}
  deriving stock (Int -> Mapping -> ShowS
[Mapping] -> ShowS
Mapping -> String
(Int -> Mapping -> ShowS)
-> (Mapping -> String) -> ([Mapping] -> ShowS) -> Show Mapping
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> Mapping -> ShowS
showsPrec :: Int -> Mapping -> ShowS
$cshow :: Mapping -> String
show :: Mapping -> String
$cshowList :: [Mapping] -> ShowS
showList :: [Mapping] -> ShowS
Show)

instance Aeson.FromJSON Mapping where
  parseJSON :: Value -> Parser Mapping
parseJSON = String -> (Object -> Parser Mapping) -> Value -> Parser Mapping
forall a. String -> (Object -> Parser a) -> Value -> Parser a
Aeson.withObject String
"Mapping" ((Object -> Parser Mapping) -> Value -> Parser Mapping)
-> (Object -> Parser Mapping) -> Value -> Parser Mapping
forall a b. (a -> b) -> a -> b
$ \Object
obj -> do
    Maybe Text
mfdisplayName <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"displayName"
    Text
fuserName <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"userName"
    Text
fexternalId <- Object
obj Object -> Key -> Parser Text
forall a. FromJSON a => Object -> Key -> Parser a
Aeson..: Key
"externalId"
    Maybe Text
mfemail <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"email"
    Maybe Text
mfrole <- Object
obj Object -> Key -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Key -> Parser (Maybe a)
Aeson..:? Key
"roles"

    let listToMap :: [(Text, a)] -> Map Text [a]
        listToMap :: forall a. [(Text, a)] -> Map Text [a]
listToMap = (Map Text [a] -> (Text, a) -> Map Text [a])
-> Map Text [a] -> [(Text, a)] -> Map Text [a]
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' Map Text [a] -> (Text, a) -> Map Text [a]
forall {k} {a}. Ord k => Map k [a] -> (k, a) -> Map k [a]
go Map Text [a]
forall a. Monoid a => a
mempty
          where
            go :: Map k [a] -> (k, a) -> Map k [a]
go Map k [a]
mp (k
k, a
b) = (Maybe [a] -> Maybe [a]) -> k -> Map k [a] -> Map k [a]
forall k a.
Ord k =>
(Maybe a -> Maybe a) -> k -> Map k a -> Map k a
Map.alter ([a] -> Maybe [a]
forall a. a -> Maybe a
Just ([a] -> Maybe [a]) -> (Maybe [a] -> [a]) -> Maybe [a] -> Maybe [a]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> ([a] -> [a]) -> Maybe [a] -> [a]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [a
b] (a
b a -> [a] -> [a]
forall a. a -> [a] -> [a]
:)) k
k Map k [a]
mp

    Mapping -> Parser Mapping
forall a. a -> Parser a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Mapping -> Parser Mapping)
-> ([Maybe (Text, FieldMapping)] -> Mapping)
-> [Maybe (Text, FieldMapping)]
-> Parser Mapping
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map Text [FieldMapping] -> Mapping
Mapping (Map Text [FieldMapping] -> Mapping)
-> ([Maybe (Text, FieldMapping)] -> Map Text [FieldMapping])
-> [Maybe (Text, FieldMapping)]
-> Mapping
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Text, FieldMapping)] -> Map Text [FieldMapping]
forall a. [(Text, a)] -> Map Text [a]
listToMap ([(Text, FieldMapping)] -> Map Text [FieldMapping])
-> ([Maybe (Text, FieldMapping)] -> [(Text, FieldMapping)])
-> [Maybe (Text, FieldMapping)]
-> Map Text [FieldMapping]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Maybe (Text, FieldMapping)] -> [(Text, FieldMapping)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (Text, FieldMapping)] -> Parser Mapping)
-> [Maybe (Text, FieldMapping)] -> Parser Mapping
forall a b. (a -> b) -> a -> b
$
      [ (\Text
fdisplayName -> (Text
fdisplayName, Text -> Text -> FieldMapping
mapDisplayName Text
fdisplayName Text
"displayName")) (Text -> (Text, FieldMapping))
-> Maybe Text -> Maybe (Text, FieldMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mfdisplayName,
        (Text, FieldMapping) -> Maybe (Text, FieldMapping)
forall a. a -> Maybe a
Just (Text
fuserName, Text -> Text -> FieldMapping
mapUserName Text
fuserName Text
"userName"),
        (Text, FieldMapping) -> Maybe (Text, FieldMapping)
forall a. a -> Maybe a
Just (Text
fexternalId, Text -> Text -> FieldMapping
mapExternalId Text
fexternalId Text
"externalId"),
        (\Text
femail -> (Text
femail, Text -> Text -> FieldMapping
mapEmail Text
femail Text
"email")) (Text -> (Text, FieldMapping))
-> Maybe Text -> Maybe (Text, FieldMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mfemail,
        (\Text
frole -> (Text
frole, Text -> Text -> FieldMapping
mapRole Text
frole Text
"roles")) (Text -> (Text, FieldMapping))
-> Maybe Text -> Maybe (Text, FieldMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mfrole
      ]
    where
      -- The name that shows for this user in wire.
      mapDisplayName :: Text -> Text -> FieldMapping
      mapDisplayName :: Text -> Text -> FieldMapping
mapDisplayName Text
ldapFieldName Text
scimFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
scimFieldName (([Text] -> Either MappingError (User ScimTag -> User ScimTag))
 -> FieldMapping)
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
forall a b. (a -> b) -> a -> b
$
        \case
          [Text
val] -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right ((User ScimTag -> User ScimTag)
 -> Either MappingError (User ScimTag -> User ScimTag))
-> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ \User ScimTag
usr -> User ScimTag
usr {Scim.displayName = Just val}
          [Text]
bad -> MappingError -> Either MappingError (User ScimTag -> User ScimTag)
forall a b. a -> Either a b
Left (MappingError
 -> Either MappingError (User ScimTag -> User ScimTag))
-> MappingError
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName Text
scimFieldName String
"1" ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      -- Wire user handle (the one with the '@').
      mapUserName :: Text -> Text -> FieldMapping
      mapUserName :: Text -> Text -> FieldMapping
mapUserName Text
ldapFieldName Text
scimFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
scimFieldName (([Text] -> Either MappingError (User ScimTag -> User ScimTag))
 -> FieldMapping)
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
forall a b. (a -> b) -> a -> b
$
        \case
          [Text
val] -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right ((User ScimTag -> User ScimTag)
 -> Either MappingError (User ScimTag -> User ScimTag))
-> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ \User ScimTag
usr -> User ScimTag
usr {Scim.userName = val}
          [Text]
bad -> MappingError -> Either MappingError (User ScimTag -> User ScimTag)
forall a b. a -> Either a b
Left (MappingError
 -> Either MappingError (User ScimTag -> User ScimTag))
-> MappingError
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName Text
scimFieldName String
"1" ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      mapExternalId :: Text -> Text -> FieldMapping
      mapExternalId :: Text -> Text -> FieldMapping
mapExternalId Text
ldapFieldName Text
scimFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
scimFieldName (([Text] -> Either MappingError (User ScimTag -> User ScimTag))
 -> FieldMapping)
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
forall a b. (a -> b) -> a -> b
$
        \case
          [Text
val] -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right ((User ScimTag -> User ScimTag)
 -> Either MappingError (User ScimTag -> User ScimTag))
-> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ \User ScimTag
usr -> User ScimTag
usr {Scim.externalId = Just val}
          [Text]
bad -> MappingError -> Either MappingError (User ScimTag -> User ScimTag)
forall a b. a -> Either a b
Left (MappingError
 -> Either MappingError (User ScimTag -> User ScimTag))
-> MappingError
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName Text
scimFieldName String
"1" ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      mapEmail :: Text -> Text -> FieldMapping
      mapEmail :: Text -> Text -> FieldMapping
mapEmail Text
ldapFieldName Text
scimFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
scimFieldName (([Text] -> Either MappingError (User ScimTag -> User ScimTag))
 -> FieldMapping)
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
forall a b. (a -> b) -> a -> b
$
        \case
          [] -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right User ScimTag -> User ScimTag
forall a. a -> a
id
          [Text
val] -> case AttrValue -> Either String EmailAddress
Text.Email.Validate.validate (Text -> AttrValue
forall a b. ConvertibleStrings a b => a -> b
SC.cs Text
val) of
            Right EmailAddress
email -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right ((User ScimTag -> User ScimTag)
 -> Either MappingError (User ScimTag -> User ScimTag))
-> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ \User ScimTag
usr ->
              User ScimTag
usr
                { Scim.emails =
                    [Scim.Email Nothing (Scim.EmailAddress email) Nothing]
                }
            Left String
err -> MappingError -> Either MappingError (User ScimTag -> User ScimTag)
forall a b. a -> Either a b
Left (MappingError
 -> Either MappingError (User ScimTag -> User ScimTag))
-> MappingError
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Text -> String -> MappingError
CouldNotParseEmail Text
ldapFieldName Text
scimFieldName Text
val String
err
          [Text]
bad ->
            MappingError -> Either MappingError (User ScimTag -> User ScimTag)
forall a b. a -> Either a b
Left (MappingError
 -> Either MappingError (User ScimTag -> User ScimTag))
-> MappingError
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$
              Text -> Text -> String -> Int -> MappingError
WrongNumberOfAttrValues
                Text
ldapFieldName
                Text
scimFieldName
                String
"<=1 (with more than one email, which one should be primary?)"
                ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      mapRole :: Text -> Text -> FieldMapping
      mapRole :: Text -> Text -> FieldMapping
mapRole Text
ldapFieldName Text
scimFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
scimFieldName (([Text] -> Either MappingError (User ScimTag -> User ScimTag))
 -> FieldMapping)
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
forall a b. (a -> b) -> a -> b
$
        \case
          [] -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right User ScimTag -> User ScimTag
forall a. a -> a
id
          [Text
val] -> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. b -> Either a b
Right ((User ScimTag -> User ScimTag)
 -> Either MappingError (User ScimTag -> User ScimTag))
-> (User ScimTag -> User ScimTag)
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ \User ScimTag
usr -> User ScimTag
usr {Scim.roles = [val]}
          [Text]
bad -> MappingError -> Either MappingError (User ScimTag -> User ScimTag)
forall a b. a -> Either a b
Left (MappingError
 -> Either MappingError (User ScimTag -> User ScimTag))
-> MappingError
-> Either MappingError (User ScimTag -> User ScimTag)
forall a b. (a -> b) -> a -> b
$ Text -> Text -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName Text
scimFieldName String
"1" ([Text] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

type LdapResult a = IO (Either LdapError a)

ldapObjectClassFilter :: Text -> Filter
ldapObjectClassFilter :: Text -> Filter
ldapObjectClassFilter = (Text -> Attr
Attr Text
"objectClass" Attr -> AttrValue -> Filter
:=) (AttrValue -> Filter) -> (Text -> AttrValue) -> Text -> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> AttrValue
forall a b. ConvertibleStrings a b => a -> b
cs

ldapFilterAttrToFilter :: LdapFilterAttr -> Filter
ldapFilterAttrToFilter :: LdapFilterAttr -> Filter
ldapFilterAttrToFilter (LdapFilterAttr Text
key Text
val) = Text -> Attr
Attr Text
key Attr -> AttrValue -> Filter
:= Text -> AttrValue
forall a b. ConvertibleStrings a b => a -> b
cs Text
val

listLdapUsers :: LdapConf -> LdapSearch -> LdapResult [SearchEntry]
listLdapUsers :: LdapConf -> LdapSearch -> LdapResult [SearchEntry]
listLdapUsers LdapConf
conf LdapSearch
searchConf = Host
-> PortNumber
-> (Ldap -> IO [SearchEntry])
-> LdapResult [SearchEntry]
forall a.
Host -> PortNumber -> (Ldap -> IO a) -> IO (Either LdapError a)
Ldap.with (LdapConf -> Host
ldapHost LdapConf
conf) (LdapConf -> PortNumber
ldapPort LdapConf
conf) ((Ldap -> IO [SearchEntry]) -> LdapResult [SearchEntry])
-> (Ldap -> IO [SearchEntry]) -> LdapResult [SearchEntry]
forall a b. (a -> b) -> a -> b
$ \Ldap
l -> do
  Ldap -> Dn -> Password -> IO ()
Ldap.bind Ldap
l (LdapConf -> Dn
ldapDn LdapConf
conf) (LdapConf -> Password
ldapPassword LdapConf
conf)
  let Filter
fltr :: Filter =
        NonEmpty Filter -> Filter
And
          ( Text -> Filter
ldapObjectClassFilter (LdapSearch -> Text
ldapSearchObjectClass LdapSearch
searchConf)
              Filter -> [Filter] -> NonEmpty Filter
forall a. a -> [a] -> NonEmpty a
:| (LdapFilterAttr -> Filter
ldapFilterAttrToFilter (LdapFilterAttr -> Filter) -> [LdapFilterAttr] -> [Filter]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LdapSearch -> [LdapFilterAttr]
ldapSearchExtra LdapSearch
searchConf)
          )
  Ldap -> Dn -> Mod Search -> Filter -> [Attr] -> IO [SearchEntry]
Ldap.search Ldap
l (LdapSearch -> Dn
ldapSearchBase LdapSearch
searchConf) Mod Search
forall a. Monoid a => a
mempty Filter
fltr [Attr]
forall a. Monoid a => a
mempty

type User = Scim.User ScimTag

type StoredUser = ScimClass.StoredUser ScimTag

-- | Note that the `userName` field is mandatory in SCIM, but we gloss over this by setting it
-- to an empty Text here.  See 'RequireUserName', 'ldapToScim' if you wonder whether this is a
-- good idea.
emptyScimUser :: User
emptyScimUser :: User ScimTag
emptyScimUser =
  [Schema] -> Text -> UserExtra ScimTag -> User ScimTag
forall tag. [Schema] -> Text -> UserExtra tag -> User tag
Scim.empty [Schema]
scimSchemas Text
"" UserExtra ScimTag
NoUserExtra
Scim.NoUserExtra

scimSchemas :: [Scim.Schema]
scimSchemas :: [Schema]
scimSchemas = [Schema
Scim.User20]

data RequireUserName = Lenient | Strict
  deriving stock (RequireUserName -> RequireUserName -> Bool
(RequireUserName -> RequireUserName -> Bool)
-> (RequireUserName -> RequireUserName -> Bool)
-> Eq RequireUserName
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: RequireUserName -> RequireUserName -> Bool
== :: RequireUserName -> RequireUserName -> Bool
$c/= :: RequireUserName -> RequireUserName -> Bool
/= :: RequireUserName -> RequireUserName -> Bool
Eq, Int -> RequireUserName -> ShowS
[RequireUserName] -> ShowS
RequireUserName -> String
(Int -> RequireUserName -> ShowS)
-> (RequireUserName -> String)
-> ([RequireUserName] -> ShowS)
-> Show RequireUserName
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
$cshowsPrec :: Int -> RequireUserName -> ShowS
showsPrec :: Int -> RequireUserName -> ShowS
$cshow :: RequireUserName -> String
show :: RequireUserName -> String
$cshowList :: [RequireUserName] -> ShowS
showList :: [RequireUserName] -> ShowS
Show)

-- | Translate an LDAP record into a SCIM record.  If username is not provided in the LDAP
-- record, behavior is defined by the first argument: if `Lenient`, just fill in an empty
-- Text; if `Strict`, throw an error.
ldapToScim ::
  forall m.
  (m ~ Either [(SearchEntry, MappingError)]) =>
  RequireUserName ->
  BridgeConf ->
  SearchEntry ->
  m (SearchEntry, User)
ldapToScim :: forall (m :: * -> *).
(m ~ Either [(SearchEntry, MappingError)]) =>
RequireUserName
-> BridgeConf -> SearchEntry -> m (SearchEntry, User ScimTag)
ldapToScim RequireUserName
reqUserName BridgeConf
conf entry :: SearchEntry
entry@(SearchEntry Dn
_ AttrList []
attrs) = do
  m ()
Either [(SearchEntry, MappingError)] ()
guardUserName
  (SearchEntry
entry,) (User ScimTag -> (SearchEntry, User ScimTag))
-> m (User ScimTag) -> m (SearchEntry, User ScimTag)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (m (User ScimTag) -> (Attr, [AttrValue]) -> m (User ScimTag))
-> m (User ScimTag) -> AttrList [] -> m (User ScimTag)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' m (User ScimTag) -> (Attr, [AttrValue]) -> m (User ScimTag)
go (User ScimTag -> Either [(SearchEntry, MappingError)] (User ScimTag)
forall a b. b -> Either a b
Right User ScimTag
emptyScimUser) AttrList []
attrs
  where
    guardUserName :: Either [(SearchEntry, MappingError)] ()
guardUserName = do
      let raw :: [(Text, [FieldMapping])]
          raw :: [(Text, [FieldMapping])]
raw = Map Text [FieldMapping] -> [(Text, [FieldMapping])]
forall k a. Map k a -> [(k, a)]
Map.assocs (Map Text [FieldMapping] -> [(Text, [FieldMapping])])
-> (BridgeConf -> Map Text [FieldMapping])
-> BridgeConf
-> [(Text, [FieldMapping])]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Mapping -> Map Text [FieldMapping]
fromMapping (Mapping -> Map Text [FieldMapping])
-> (BridgeConf -> Mapping) -> BridgeConf -> Map Text [FieldMapping]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BridgeConf -> Mapping
mapping (BridgeConf -> [(Text, [FieldMapping])])
-> BridgeConf -> [(Text, [FieldMapping])]
forall a b. (a -> b) -> a -> b
$ BridgeConf
conf

          fltr :: [(Text, [FieldMapping])] -> [(Text, [FieldMapping])]
          fltr :: [(Text, [FieldMapping])] -> [(Text, [FieldMapping])]
fltr = ((Text, [FieldMapping]) -> Bool)
-> [(Text, [FieldMapping])] -> [(Text, [FieldMapping])]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Text
_, [FieldMapping]
fm) -> (FieldMapping -> Text
fieldMappingLabel (FieldMapping -> Text) -> [FieldMapping] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [FieldMapping]
fm) [Text] -> [Text] -> Bool
forall a. Eq a => a -> a -> Bool
== [Text
"userName"])

          userNameInLdap :: Text
userNameInLdap = case [(Text, [FieldMapping])] -> [(Text, [FieldMapping])]
fltr [(Text, [FieldMapping])]
raw of
            [(Text
ldapName, [FieldMapping]
_)] -> Text
ldapName
            [(Text, [FieldMapping])]
bad ->
              -- `userName` is a mandatory field, the `Mapping` parser guarantees that it's always present.
              Text -> Text
forall a t. (HasCallStack, IsText t) => t -> a
error (Text -> Text) -> Text -> Text
forall a b. (a -> b) -> a -> b
$ Text
"impossible: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [(Text, [FieldMapping])] -> Text
forall b a. (Show a, IsString b) => a -> b
show [(Text, [FieldMapping])]
bad

      if RequireUserName
reqUserName RequireUserName -> RequireUserName -> Bool
forall a. Eq a => a -> a -> Bool
== RequireUserName
Strict Bool -> Bool -> Bool
&& Text -> Attr
Attr Text
userNameInLdap Attr -> [Attr] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` ((Attr, [AttrValue]) -> Attr
forall a b. (a, b) -> a
fst ((Attr, [AttrValue]) -> Attr) -> AttrList [] -> [Attr]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AttrList [] -> AttrList []
forall a. [a] -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
toList AttrList []
attrs)
        then [(SearchEntry, MappingError)]
-> Either [(SearchEntry, MappingError)] ()
forall a b. a -> Either a b
Left [(SearchEntry
entry, Text -> Text -> MappingError
MissingMandatoryValue Text
userNameInLdap Text
"userName")]
        else () -> Either [(SearchEntry, MappingError)] ()
forall a b. b -> Either a b
Right ()

    codec :: AttrValue -> Text
codec = case LdapConf -> Codec
ldapCodec (BridgeConf -> LdapConf
ldapSource BridgeConf
conf) of
      Codec
Utf8 -> AttrValue -> Text
Text.decodeUtf8
      Codec
Latin1 -> AttrValue -> Text
Text.decodeLatin1

    go :: m User -> (Attr, [AttrValue]) -> m User
    go :: m (User ScimTag) -> (Attr, [AttrValue]) -> m (User ScimTag)
go m (User ScimTag)
scimval (Attr Text
key, [AttrValue]
vals) = case Text -> Map Text [FieldMapping] -> Maybe [FieldMapping]
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Text
key (Mapping -> Map Text [FieldMapping]
fromMapping (Mapping -> Map Text [FieldMapping])
-> Mapping -> Map Text [FieldMapping]
forall a b. (a -> b) -> a -> b
$ BridgeConf -> Mapping
mapping BridgeConf
conf) of
      Maybe [FieldMapping]
Nothing -> m (User ScimTag)
scimval
      Just [FieldMapping]
fieldMappings -> (m (User ScimTag) -> FieldMapping -> m (User ScimTag))
-> m (User ScimTag) -> [FieldMapping] -> m (User ScimTag)
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([AttrValue] -> m (User ScimTag) -> FieldMapping -> m (User ScimTag)
go' [AttrValue]
vals) m (User ScimTag)
scimval [FieldMapping]
fieldMappings

    go' :: [ByteString] -> m User -> FieldMapping -> m User
    go' :: [AttrValue] -> m (User ScimTag) -> FieldMapping -> m (User ScimTag)
go' [AttrValue]
vals m (User ScimTag)
scimval (FieldMapping Text
_ [Text] -> Either MappingError (User ScimTag -> User ScimTag)
f) = case (m (User ScimTag)
scimval, [Text] -> Either MappingError (User ScimTag -> User ScimTag)
f (AttrValue -> Text
codec (AttrValue -> Text) -> [AttrValue] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [AttrValue]
vals)) of
      (Right User ScimTag
scimusr, Right User ScimTag -> User ScimTag
f') -> User ScimTag -> Either [(SearchEntry, MappingError)] (User ScimTag)
forall a b. b -> Either a b
Right (User ScimTag -> User ScimTag
f' User ScimTag
scimusr)
      (Right User ScimTag
_, Left MappingError
err) -> [(SearchEntry, MappingError)]
-> Either [(SearchEntry, MappingError)] (User ScimTag)
forall a b. a -> Either a b
Left [(SearchEntry
entry, MappingError
err)]
      (Left [(SearchEntry, MappingError)]
errs, Right User ScimTag -> User ScimTag
_) -> [(SearchEntry, MappingError)]
-> Either [(SearchEntry, MappingError)] (User ScimTag)
forall a b. a -> Either a b
Left [(SearchEntry, MappingError)]
errs
      (Left [(SearchEntry, MappingError)]
errs, Left MappingError
err) -> [(SearchEntry, MappingError)]
-> Either [(SearchEntry, MappingError)] (User ScimTag)
forall a b. a -> Either a b
Left ((SearchEntry
entry, MappingError
err) (SearchEntry, MappingError)
-> [(SearchEntry, MappingError)] -> [(SearchEntry, MappingError)]
forall a. a -> [a] -> [a]
: [(SearchEntry, MappingError)]
errs)

connectScim :: Logger -> ScimConf -> IO ClientEnv
connectScim :: Logger -> ScimConf -> IO ClientEnv
connectScim Logger
lgr ScimConf
conf = (IO ClientEnv -> (SomeException -> IO ClientEnv) -> IO ClientEnv
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` SomeException -> IO ClientEnv
logErrors) (IO ClientEnv -> IO ClientEnv) -> IO ClientEnv -> IO ClientEnv
forall a b. (a -> b) -> a -> b
$ do
  let settings :: ManagerSettings
settings =
        if ScimConf -> Bool
scimTls ScimConf
conf
          then ManagerSettings
HTTP.tlsManagerSettings
          else ManagerSettings
HTTP.defaultManagerSettings
      schema :: Scheme
schema =
        if ScimConf -> Bool
scimTls ScimConf
conf
          then Scheme
Https
          else Scheme
Http
  Manager
manager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
settings
  let base :: BaseUrl
base = Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
schema (ScimConf -> String
scimHost ScimConf
conf) (ScimConf -> Int
scimPort ScimConf
conf) (ScimConf -> String
scimPath ScimConf
conf)
  ClientEnv -> IO ClientEnv
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ClientEnv -> IO ClientEnv) -> ClientEnv -> IO ClientEnv
forall a b. (a -> b) -> a -> b
$ Manager -> BaseUrl -> ClientEnv
mkClientEnv Manager
manager BaseUrl
base
  where
    logErrors :: SomeException -> IO ClientEnv
logErrors (SomeException e
e) = do
      Logger
lgr Level
Error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"could not connect to scim peer: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> e -> Text
forall b a. (Show a, IsString b) => a -> b
show e
e
      e -> IO ClientEnv
forall e a. Exception e => e -> IO a
throwIO e
e

isDeletee :: LdapConf -> SearchEntry -> Bool
isDeletee :: LdapConf -> SearchEntry -> Bool
isDeletee LdapConf
conf = case LdapConf -> Maybe LdapFilterAttr
ldapDeleteOnAttribute LdapConf
conf of
  Maybe LdapFilterAttr
Nothing -> Bool -> SearchEntry -> Bool
forall a b. a -> b -> a
const Bool
False
  Just (LdapFilterAttr Text
key Text
value) ->
    \(SearchEntry Dn
_ AttrList []
attrs) ->
      Bool -> ([AttrValue] -> Bool) -> Maybe [AttrValue] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> AttrValue
forall a b. ConvertibleStrings a b => a -> b
cs Text
value AttrValue -> [AttrValue] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem`) (Attr -> AttrList [] -> Maybe [AttrValue]
forall a b. Eq a => a -> [(a, b)] -> Maybe b
Data.List.lookup (Text -> Attr
Attr Text
key) AttrList []
attrs)

updateScimPeer :: Logger -> BridgeConf -> IO ()
updateScimPeer :: Logger -> BridgeConf -> IO ()
updateScimPeer Logger
lgr BridgeConf
conf = do
  ClientEnv
clientEnv <- Logger -> ScimConf -> IO ClientEnv
connectScim Logger
lgr (BridgeConf -> ScimConf
scimTarget BridgeConf
conf)
  let tok :: Maybe Text
tok = Text -> Maybe Text
forall a. a -> Maybe a
Just (Text -> Maybe Text)
-> (BridgeConf -> Text) -> BridgeConf -> Maybe Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ScimConf -> Text
scimToken (ScimConf -> Text)
-> (BridgeConf -> ScimConf) -> BridgeConf -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BridgeConf -> ScimConf
scimTarget (BridgeConf -> Maybe Text) -> BridgeConf -> Maybe Text
forall a b. (a -> b) -> a -> b
$ BridgeConf
conf
  [SearchEntry]
ldaps :: [SearchEntry] <-
    (LdapError -> IO [SearchEntry])
-> ([SearchEntry] -> IO [SearchEntry])
-> Either LdapError [SearchEntry]
-> IO [SearchEntry]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorCall -> IO [SearchEntry]
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO [SearchEntry])
-> (LdapError -> ErrorCall) -> LdapError -> IO [SearchEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall)
-> (LdapError -> String) -> LdapError -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapError -> String
forall b a. (Show a, IsString b) => a -> b
show) [SearchEntry] -> IO [SearchEntry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LdapError [SearchEntry] -> IO [SearchEntry])
-> LdapResult [SearchEntry] -> IO [SearchEntry]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LdapConf -> LdapSearch -> LdapResult [SearchEntry]
listLdapUsers (BridgeConf -> LdapConf
ldapSource BridgeConf
conf) (LdapConf -> LdapSearch
ldapSearch (BridgeConf -> LdapConf
ldapSource BridgeConf
conf))
  do
    -- put, post
    Logger
lgr Level
Info Text
"[post/put: started]"
    let ldapKeepees :: [SearchEntry]
ldapKeepees = (SearchEntry -> Bool) -> [SearchEntry] -> [SearchEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (SearchEntry -> Bool) -> SearchEntry -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapConf -> SearchEntry -> Bool
isDeletee (BridgeConf -> LdapConf
ldapSource BridgeConf
conf)) [SearchEntry]
ldaps
    [(SearchEntry, User ScimTag)]
scims :: [(SearchEntry, User)] <-
      (Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
 -> IO (SearchEntry, User ScimTag))
-> [Either
      [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)]
-> IO [(SearchEntry, User ScimTag)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([(SearchEntry, MappingError)] -> IO (SearchEntry, User ScimTag))
-> ((SearchEntry, User ScimTag) -> IO (SearchEntry, User ScimTag))
-> Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
-> IO (SearchEntry, User ScimTag)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorCall -> IO (SearchEntry, User ScimTag)
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO (SearchEntry, User ScimTag))
-> ([(SearchEntry, MappingError)] -> ErrorCall)
-> [(SearchEntry, MappingError)]
-> IO (SearchEntry, User ScimTag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall)
-> ([(SearchEntry, MappingError)] -> String)
-> [(SearchEntry, MappingError)]
-> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SearchEntry, MappingError)] -> String
renderSearchError) (SearchEntry, User ScimTag) -> IO (SearchEntry, User ScimTag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (RequireUserName
-> BridgeConf
-> SearchEntry
-> Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
forall (m :: * -> *).
(m ~ Either [(SearchEntry, MappingError)]) =>
RequireUserName
-> BridgeConf -> SearchEntry -> m (SearchEntry, User ScimTag)
ldapToScim RequireUserName
Strict BridgeConf
conf (SearchEntry
 -> Either
      [(SearchEntry, MappingError)] (SearchEntry, User ScimTag))
-> [SearchEntry]
-> [Either
      [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SearchEntry]
ldapKeepees)
    Logger
lgr Level
Debug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Pulled the following ldap users for post/put:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SearchEntry] -> Text
forall b a. (Show a, IsString b) => a -> b
show ((SearchEntry, User ScimTag) -> SearchEntry
forall a b. (a, b) -> a
fst ((SearchEntry, User ScimTag) -> SearchEntry)
-> [(SearchEntry, User ScimTag)] -> [SearchEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SearchEntry, User ScimTag)]
scims)
    Logger
lgr Level
Debug (Text -> IO ()) -> (ByteString -> Text) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Translated to scim:\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [User ScimTag] -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty ((SearchEntry, User ScimTag) -> User ScimTag
forall a b. (a, b) -> b
snd ((SearchEntry, User ScimTag) -> User ScimTag)
-> [(SearchEntry, User ScimTag)] -> [User ScimTag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SearchEntry, User ScimTag)]
scims)
    Logger
-> ClientEnv -> Maybe (AuthData ScimTag) -> [User ScimTag] -> IO ()
updateScimPeerPostPut Logger
lgr ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok ((SearchEntry, User ScimTag) -> User ScimTag
forall a b. (a, b) -> b
snd ((SearchEntry, User ScimTag) -> User ScimTag)
-> [(SearchEntry, User ScimTag)] -> [User ScimTag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SearchEntry, User ScimTag)]
scims)
    Logger
lgr Level
Info Text
"[post/put: done]"
  do
    -- delete
    Logger
lgr Level
Info Text
"[delete: started]"
    let ldapDeleteesAttr :: [SearchEntry]
ldapDeleteesAttr = (SearchEntry -> Bool) -> [SearchEntry] -> [SearchEntry]
forall a. (a -> Bool) -> [a] -> [a]
filter (LdapConf -> SearchEntry -> Bool
isDeletee (BridgeConf -> LdapConf
ldapSource BridgeConf
conf)) [SearchEntry]
ldaps
    [SearchEntry]
ldapDeleteesDirectory :: [SearchEntry] <- case LdapConf -> Maybe LdapSearch
ldapDeleteFromDirectory (BridgeConf -> LdapConf
ldapSource BridgeConf
conf) of
      Just (LdapSearch
searchConf :: LdapSearch) ->
        (LdapError -> IO [SearchEntry])
-> ([SearchEntry] -> IO [SearchEntry])
-> Either LdapError [SearchEntry]
-> IO [SearchEntry]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorCall -> IO [SearchEntry]
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO [SearchEntry])
-> (LdapError -> ErrorCall) -> LdapError -> IO [SearchEntry]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall)
-> (LdapError -> String) -> LdapError -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LdapError -> String
forall b a. (Show a, IsString b) => a -> b
show) [SearchEntry] -> IO [SearchEntry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either LdapError [SearchEntry] -> IO [SearchEntry])
-> LdapResult [SearchEntry] -> IO [SearchEntry]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< LdapConf -> LdapSearch -> LdapResult [SearchEntry]
listLdapUsers (BridgeConf -> LdapConf
ldapSource BridgeConf
conf) LdapSearch
searchConf
      Maybe LdapSearch
Nothing ->
        [SearchEntry] -> IO [SearchEntry]
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [SearchEntry]
forall a. Monoid a => a
mempty

    [(SearchEntry, User ScimTag)]
scims :: [(SearchEntry, User)] <-
      (Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
 -> IO (SearchEntry, User ScimTag))
-> [Either
      [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)]
-> IO [(SearchEntry, User ScimTag)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (([(SearchEntry, MappingError)] -> IO (SearchEntry, User ScimTag))
-> ((SearchEntry, User ScimTag) -> IO (SearchEntry, User ScimTag))
-> Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
-> IO (SearchEntry, User ScimTag)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorCall -> IO (SearchEntry, User ScimTag)
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO (SearchEntry, User ScimTag))
-> ([(SearchEntry, MappingError)] -> ErrorCall)
-> [(SearchEntry, MappingError)]
-> IO (SearchEntry, User ScimTag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
ErrorCall (String -> ErrorCall)
-> ([(SearchEntry, MappingError)] -> String)
-> [(SearchEntry, MappingError)]
-> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(SearchEntry, MappingError)] -> String
renderSearchError) (SearchEntry, User ScimTag) -> IO (SearchEntry, User ScimTag)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (RequireUserName
-> BridgeConf
-> SearchEntry
-> Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
forall (m :: * -> *).
(m ~ Either [(SearchEntry, MappingError)]) =>
RequireUserName
-> BridgeConf -> SearchEntry -> m (SearchEntry, User ScimTag)
ldapToScim RequireUserName
Lenient BridgeConf
conf (SearchEntry
 -> Either
      [(SearchEntry, MappingError)] (SearchEntry, User ScimTag))
-> [SearchEntry]
-> [Either
      [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([SearchEntry]
ldapDeleteesAttr [SearchEntry] -> [SearchEntry] -> [SearchEntry]
forall a. Semigroup a => a -> a -> a
<> [SearchEntry]
ldapDeleteesDirectory))
    Logger
lgr Level
Debug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"Pulled the following ldap users for delete:\n" Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> [SearchEntry] -> Text
forall b a. (Show a, IsString b) => a -> b
show ((SearchEntry, User ScimTag) -> SearchEntry
forall a b. (a, b) -> a
fst ((SearchEntry, User ScimTag) -> SearchEntry)
-> [(SearchEntry, User ScimTag)] -> [SearchEntry]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SearchEntry, User ScimTag)]
scims)
    Logger
lgr Level
Debug (Text -> IO ()) -> (ByteString -> Text) -> ByteString -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ByteString -> Text
forall a b. ConvertibleStrings a b => a -> b
cs (ByteString -> IO ()) -> ByteString -> IO ()
forall a b. (a -> b) -> a -> b
$ ByteString
"Translated to scim:\n" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> [User ScimTag] -> ByteString
forall a. ToJSON a => a -> ByteString
Aeson.encodePretty ((SearchEntry, User ScimTag) -> User ScimTag
forall a b. (a, b) -> b
snd ((SearchEntry, User ScimTag) -> User ScimTag)
-> [(SearchEntry, User ScimTag)] -> [User ScimTag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SearchEntry, User ScimTag)]
scims)
    Logger
-> ClientEnv -> Maybe (AuthData ScimTag) -> [User ScimTag] -> IO ()
updateScimPeerDelete Logger
lgr ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok ((SearchEntry, User ScimTag) -> User ScimTag
forall a b. (a, b) -> b
snd ((SearchEntry, User ScimTag) -> User ScimTag)
-> [(SearchEntry, User ScimTag)] -> [User ScimTag]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(SearchEntry, User ScimTag)]
scims)
    Logger
lgr Level
Info Text
"[delete: done]"

lookupScimByExternalId :: ClientEnv -> Maybe Text -> Scim.User tag -> IO (Maybe StoredUser)
lookupScimByExternalId :: forall tag.
ClientEnv -> Maybe Text -> User tag -> IO (Maybe StoredUser)
lookupScimByExternalId ClientEnv
clientEnv Maybe Text
tok User tag
scim = do
  Text
eid <- IO Text -> (Text -> IO Text) -> Maybe Text -> IO Text
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Text -> IO Text
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"impossible") Text -> IO Text
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Text -> IO Text) -> Maybe Text -> IO Text
forall a b. (a -> b) -> a -> b
$ User tag -> Maybe Text
forall tag. User tag -> Maybe Text
Scim.externalId User tag
scim
  let fltr :: Maybe Filter
fltr = Filter -> Maybe Filter
forall a. a -> Maybe a
Just (Filter -> Maybe Filter) -> Filter -> Maybe Filter
forall a b. (a -> b) -> a -> b
$ Text -> Text -> Filter
filterBy Text
"externalId" Text
eid
  [StoredUser]
mbold :: [StoredUser] <-
    forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag)
-> Maybe Filter
-> IO (ListResponse (StoredUser tag))
ScimClient.getUsers @ScimTag ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok Maybe Filter
fltr
      IO (ListResponse (WithMeta (WithId Text (User ScimTag))))
-> (ListResponse (WithMeta (WithId Text (User ScimTag)))
    -> [WithMeta (WithId Text (User ScimTag))])
-> IO [WithMeta (WithId Text (User ScimTag))]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> ListResponse (WithMeta (WithId Text (User ScimTag)))
-> [WithMeta (WithId Text (User ScimTag))]
forall a. ListResponse a -> [a]
Scim.resources
  case [StoredUser]
mbold of
    [StoredUser
old] -> Maybe (WithMeta (WithId Text (User ScimTag)))
-> IO (Maybe (WithMeta (WithId Text (User ScimTag))))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (WithMeta (WithId Text (User ScimTag)))
 -> IO (Maybe (WithMeta (WithId Text (User ScimTag)))))
-> Maybe (WithMeta (WithId Text (User ScimTag)))
-> IO (Maybe (WithMeta (WithId Text (User ScimTag))))
forall a b. (a -> b) -> a -> b
$ WithMeta (WithId Text (User ScimTag))
-> Maybe (WithMeta (WithId Text (User ScimTag)))
forall a. a -> Maybe a
Just WithMeta (WithId Text (User ScimTag))
StoredUser
old
    [] -> Maybe (WithMeta (WithId Text (User ScimTag)))
-> IO (Maybe (WithMeta (WithId Text (User ScimTag))))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (WithMeta (WithId Text (User ScimTag)))
forall a. Maybe a
Nothing
    (StoredUser
_ : StoredUser
_ : [StoredUser]
_) -> Text -> IO (Maybe (WithMeta (WithId Text (User ScimTag))))
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"impossible" -- externalId must be unique in the scope of the scim auth token.
  where
    filterBy :: Text -> Text -> ScimFilter.Filter
    filterBy :: Text -> Text -> Filter
filterBy Text
name Text
value =
      AttrPath -> CompareOp -> CompValue -> Filter
ScimFilter.FilterAttrCompare
        (Text -> AttrPath
ScimFilter.topLevelAttrPath Text
name)
        CompareOp
ScimFilter.OpEq
        (Text -> CompValue
ScimFilter.ValString Text
value)

updateScimPeerPostPut ::
  Logger ->
  ClientEnv ->
  Maybe (AuthData ScimTag) ->
  [User] ->
  IO ()
updateScimPeerPostPut :: Logger
-> ClientEnv -> Maybe (AuthData ScimTag) -> [User ScimTag] -> IO ()
updateScimPeerPostPut Logger
lgr ClientEnv
clientEnv Maybe (AuthData ScimTag)
tok = (User ScimTag -> IO ()) -> [User ScimTag] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((User ScimTag -> IO ()) -> [User ScimTag] -> IO ())
-> (User ScimTag -> IO ()) -> [User ScimTag] -> IO ()
forall a b. (a -> b) -> a -> b
$ \User ScimTag
scim -> do
  case User ScimTag -> Maybe Text
forall tag. User tag -> Maybe Text
Scim.externalId User ScimTag
scim of
    Maybe Text
Nothing -> Logger
lgr Level
Error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"scim user without 'externalId' field: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> User ScimTag -> Text
forall b a. (Show a, IsString b) => a -> b
show User ScimTag
scim
    Just Text
eid -> Logger -> ClientEnv -> Maybe Text -> User ScimTag -> Text -> IO ()
updateScimPeerPostPutStep Logger
lgr ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok User ScimTag
scim Text
eid

updateScimPeerPostPutStep ::
  Logger ->
  ClientEnv ->
  Maybe Text ->
  Scim.User ScimTag ->
  Text ->
  IO ()
updateScimPeerPostPutStep :: Logger -> ClientEnv -> Maybe Text -> User ScimTag -> Text -> IO ()
updateScimPeerPostPutStep Logger
lgr ClientEnv
clientEnv Maybe Text
tok User ScimTag
scim Text
eid = do
  ClientEnv -> Maybe Text -> User ScimTag -> IO (Maybe StoredUser)
forall tag.
ClientEnv -> Maybe Text -> User tag -> IO (Maybe StoredUser)
lookupScimByExternalId ClientEnv
clientEnv Maybe Text
tok User ScimTag
scim IO (Maybe (WithMeta (WithId Text (User ScimTag))))
-> (Maybe (WithMeta (WithId Text (User ScimTag))) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just WithMeta (WithId Text (User ScimTag))
old ->
      if WithId Text (User ScimTag) -> User ScimTag
forall id a. WithId id a -> a
ScimCommon.value (WithMeta (WithId Text (User ScimTag)) -> WithId Text (User ScimTag)
forall a. WithMeta a -> a
Scim.thing WithMeta (WithId Text (User ScimTag))
old) User ScimTag -> User ScimTag -> Bool
forall a. Eq a => a -> a -> Bool
== User ScimTag
scim
        then do
          Logger
lgr Level
Info (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"unchanged: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
eid
        else do
          Logger
lgr Level
Info (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"update: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
eid
          IO StoredUser -> IO ()
process (IO StoredUser -> IO ()) -> IO StoredUser -> IO ()
forall a b. (a -> b) -> a -> b
$ forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag)
-> UserId tag
-> User tag
-> IO (StoredUser tag)
ScimClient.putUser @ScimTag ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok (WithId Text (User ScimTag) -> Text
forall id a. WithId id a -> id
ScimCommon.id (WithMeta (WithId Text (User ScimTag)) -> WithId Text (User ScimTag)
forall a. WithMeta a -> a
Scim.thing WithMeta (WithId Text (User ScimTag))
old)) User ScimTag
scim
    Maybe (WithMeta (WithId Text (User ScimTag)))
Nothing -> do
      Logger
lgr Level
Info (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"new user: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
eid
      IO StoredUser -> IO ()
process (IO StoredUser -> IO ()) -> IO StoredUser -> IO ()
forall a b. (a -> b) -> a -> b
$ ClientEnv
-> Maybe (AuthData ScimTag) -> User ScimTag -> IO StoredUser
forall tag.
HasScimClient tag =>
ClientEnv
-> Maybe (AuthData tag) -> User tag -> IO (StoredUser tag)
ScimClient.postUser ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok User ScimTag
scim
  where
    process :: IO StoredUser -> IO ()
    process :: IO StoredUser -> IO ()
process IO StoredUser
action = do
      Either SomeException StoredUser
result :: Either SomeException StoredUser <-
        (WithMeta (WithId Text (User ScimTag))
-> Either SomeException (WithMeta (WithId Text (User ScimTag)))
forall a b. b -> Either a b
Right (WithMeta (WithId Text (User ScimTag))
 -> Either SomeException (WithMeta (WithId Text (User ScimTag))))
-> IO (WithMeta (WithId Text (User ScimTag)))
-> IO
     (Either SomeException (WithMeta (WithId Text (User ScimTag))))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO (WithMeta (WithId Text (User ScimTag)))
IO StoredUser
action) IO (Either SomeException (WithMeta (WithId Text (User ScimTag))))
-> (SomeException
    -> IO
         (Either SomeException (WithMeta (WithId Text (User ScimTag)))))
-> IO
     (Either SomeException (WithMeta (WithId Text (User ScimTag))))
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either SomeException (WithMeta (WithId Text (User ScimTag)))
-> IO
     (Either SomeException (WithMeta (WithId Text (User ScimTag))))
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException (WithMeta (WithId Text (User ScimTag)))
 -> IO
      (Either SomeException (WithMeta (WithId Text (User ScimTag)))))
-> (SomeException
    -> Either SomeException (WithMeta (WithId Text (User ScimTag))))
-> SomeException
-> IO
     (Either SomeException (WithMeta (WithId Text (User ScimTag))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException
-> Either SomeException (WithMeta (WithId Text (User ScimTag)))
forall a b. a -> Either a b
Left)
      Either SomeException (WithMeta (WithId Text (User ScimTag)))
Either SomeException StoredUser
result
        Either SomeException (WithMeta (WithId Text (User ScimTag)))
-> (Either SomeException (WithMeta (WithId Text (User ScimTag)))
    -> IO ())
-> IO ()
forall a b. a -> (a -> b) -> b
& (SomeException -> IO ())
-> (WithMeta (WithId Text (User ScimTag)) -> IO ())
-> Either SomeException (WithMeta (WithId Text (User ScimTag)))
-> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Logger
lgr Level
Error (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show)
          (\WithMeta (WithId Text (User ScimTag))
new -> Logger
lgr Level
Debug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"UserId: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> (Text -> Text
forall b a. (Show a, IsString b) => a -> b
show (Text -> Text)
-> (WithMeta (WithId Text (User ScimTag)) -> Text)
-> WithMeta (WithId Text (User ScimTag))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithId Text (User ScimTag) -> Text
forall id a. WithId id a -> id
ScimCommon.id (WithId Text (User ScimTag) -> Text)
-> (WithMeta (WithId Text (User ScimTag))
    -> WithId Text (User ScimTag))
-> WithMeta (WithId Text (User ScimTag))
-> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithMeta (WithId Text (User ScimTag)) -> WithId Text (User ScimTag)
forall a. WithMeta a -> a
Scim.thing (WithMeta (WithId Text (User ScimTag)) -> Text)
-> WithMeta (WithId Text (User ScimTag)) -> Text
forall a b. (a -> b) -> a -> b
$ WithMeta (WithId Text (User ScimTag))
new))

updateScimPeerDelete ::
  Logger ->
  ClientEnv ->
  Maybe (AuthData ScimTag) ->
  [User] ->
  IO ()
updateScimPeerDelete :: Logger
-> ClientEnv -> Maybe (AuthData ScimTag) -> [User ScimTag] -> IO ()
updateScimPeerDelete Logger
lgr ClientEnv
clientEnv Maybe (AuthData ScimTag)
tok = (User ScimTag -> IO ()) -> [User ScimTag] -> IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((User ScimTag -> IO ()) -> [User ScimTag] -> IO ())
-> (User ScimTag -> IO ()) -> [User ScimTag] -> IO ()
forall a b. (a -> b) -> a -> b
$ \User ScimTag
scim -> do
  ClientEnv -> Maybe Text -> User ScimTag -> IO (Maybe StoredUser)
forall tag.
ClientEnv -> Maybe Text -> User tag -> IO (Maybe StoredUser)
lookupScimByExternalId ClientEnv
clientEnv Maybe Text
Maybe (AuthData ScimTag)
tok User ScimTag
scim IO (Maybe (WithMeta (WithId Text (User ScimTag))))
-> (Maybe (WithMeta (WithId Text (User ScimTag))) -> IO ())
-> IO ()
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just WithMeta (WithId Text (User ScimTag))
old -> do
      IO NoContent -> IO ()
process (forall tag.
HasScimClient tag =>
ClientEnv -> Maybe (AuthData tag) -> UserId tag -> IO NoContent
ScimClient.deleteUser @ScimTag ClientEnv
clientEnv Maybe (AuthData ScimTag)
tok (WithId Text (User ScimTag) -> Text
forall id a. WithId id a -> id
ScimCommon.id (WithMeta (WithId Text (User ScimTag)) -> WithId Text (User ScimTag)
forall a. WithMeta a -> a
Scim.thing WithMeta (WithId Text (User ScimTag))
old)))
        IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \e :: SomeException
e@(SomeException e
_) -> Logger
lgr Level
Error (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show SomeException
e
    Maybe (WithMeta (WithId Text (User ScimTag)))
Nothing -> do
      () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  where
    process :: IO NoContent -> IO ()
    process :: IO NoContent -> IO ()
process IO NoContent
action = do
      Either SomeException NoContent
result :: Either SomeException NoContent <-
        (NoContent -> Either SomeException NoContent
forall a b. b -> Either a b
Right (NoContent -> Either SomeException NoContent)
-> IO NoContent -> IO (Either SomeException NoContent)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IO NoContent
action) IO (Either SomeException NoContent)
-> (SomeException -> IO (Either SomeException NoContent))
-> IO (Either SomeException NoContent)
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` (Either SomeException NoContent
-> IO (Either SomeException NoContent)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either SomeException NoContent
 -> IO (Either SomeException NoContent))
-> (SomeException -> Either SomeException NoContent)
-> SomeException
-> IO (Either SomeException NoContent)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Either SomeException NoContent
forall a b. a -> Either a b
Left)
      Either SomeException NoContent
result
        Either SomeException NoContent
-> (Either SomeException NoContent -> IO ()) -> IO ()
forall a b. a -> (a -> b) -> b
& (SomeException -> IO ())
-> (NoContent -> IO ()) -> Either SomeException NoContent -> IO ()
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either
          (Logger
lgr Level
Error (Text -> IO ())
-> (SomeException -> Text) -> SomeException -> IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SomeException -> Text
forall b a. (Show a, IsString b) => a -> b
show)
          (IO () -> NoContent -> IO ()
forall a b. a -> b -> a
const (IO () -> NoContent -> IO ()) -> IO () -> NoContent -> IO ()
forall a b. (a -> b) -> a -> b
$ () -> IO ()
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ())

parseCli :: IO BridgeConf
parseCli :: IO BridgeConf
parseCli = do
  String -> ErrorCall
usage <- do
    String
progName <- IO String
getProgName
    let usage :: String -> ErrorCall
        usage :: String -> ErrorCall
usage = String -> ErrorCall
ErrorCall (String -> ErrorCall) -> ShowS -> String -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
help)
        help :: String
help =
          Text -> String
forall a b. ConvertibleStrings a b => a -> b
cs (Text -> String) -> ([String] -> Text) -> [String] -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Text] -> Text
forall t. IsText t "unlines" => [t] -> t
unlines ([Text] -> Text) -> ([String] -> [Text]) -> [String] -> Text
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (String -> Text) -> [String] -> [Text]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap String -> Text
forall a b. ConvertibleStrings a b => a -> b
cs ([String] -> String) -> [String] -> String
forall a b. (a -> b) -> a -> b
$
            [ String
"",
              String
"",
              String
"usage: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
progName String -> ShowS
forall a. Semigroup a => a -> a -> a
<> String
" <config.yaml>",
              String
"see https://github.com/wireapp/ldap-scim-bridge for a sample config."
            ]
    (String -> ErrorCall) -> IO (String -> ErrorCall)
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure String -> ErrorCall
usage

  IO [String]
forall (m :: * -> *). MonadIO m => m [String]
getArgs IO [String] -> ([String] -> IO BridgeConf) -> IO BridgeConf
forall a b. IO a -> (a -> IO b) -> IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [String
file] -> do
      AttrValue
content <- String -> IO AttrValue
ByteString.readFile String
file IO AttrValue -> (SomeException -> IO AttrValue) -> IO AttrValue
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException e
err) -> ErrorCall -> IO AttrValue
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO AttrValue)
-> (String -> ErrorCall) -> String -> IO AttrValue
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
usage (String -> IO AttrValue) -> String -> IO AttrValue
forall a b. (a -> b) -> a -> b
$ e -> String
forall b a. (Show a, IsString b) => a -> b
show e
err
      (ParseException -> IO BridgeConf)
-> (BridgeConf -> IO BridgeConf)
-> Either ParseException BridgeConf
-> IO BridgeConf
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (ErrorCall -> IO BridgeConf
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO BridgeConf)
-> (ParseException -> ErrorCall) -> ParseException -> IO BridgeConf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
usage (String -> ErrorCall)
-> (ParseException -> String) -> ParseException -> ErrorCall
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ParseException -> String
forall b a. (Show a, IsString b) => a -> b
show) BridgeConf -> IO BridgeConf
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Either ParseException BridgeConf -> IO BridgeConf)
-> Either ParseException BridgeConf -> IO BridgeConf
forall a b. (a -> b) -> a -> b
$ AttrValue -> Either ParseException BridgeConf
forall a. FromJSON a => AttrValue -> Either ParseException a
Yaml.decodeEither' AttrValue
content
    [String]
bad -> ErrorCall -> IO BridgeConf
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO BridgeConf)
-> (String -> ErrorCall) -> String -> IO BridgeConf
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
usage (String -> IO BridgeConf) -> String -> IO BridgeConf
forall a b. (a -> b) -> a -> b
$ String
"bad number of arguments: " String -> ShowS
forall a. Semigroup a => a -> a -> a
<> [String] -> String
forall b a. (Show a, IsString b) => a -> b
show [String]
bad

type Logger = Level -> Text -> IO ()

mkLogger :: Level -> IO Logger
mkLogger :: Level -> IO Logger
mkLogger Level
lvl = do
  Logger
lgr :: Log.Logger <-
    Settings
Log.defSettings
      Settings -> (Settings -> Settings) -> Settings
forall a b. a -> (a -> b) -> b
& Level -> Settings -> Settings
Log.setLogLevel Level
lvl
      Settings -> (Settings -> IO Logger) -> IO Logger
forall a b. a -> (a -> b) -> b
& Settings -> IO Logger
forall (m :: * -> *). MonadIO m => Settings -> m Logger
Log.new
  Logger -> IO Logger
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Logger -> IO Logger) -> Logger -> IO Logger
forall a b. (a -> b) -> a -> b
$ \Level
msgLvl Text
msgContent -> do
    Logger -> Level -> (Msg -> Msg) -> IO ()
forall (m :: * -> *).
MonadIO m =>
Logger -> Level -> (Msg -> Msg) -> m ()
Log.log Logger
lgr Level
msgLvl (forall a. ToBytes a => a -> Msg -> Msg
Log.msg @Text (Text -> Msg -> Msg) -> Text -> Msg -> Msg
forall a b. (a -> b) -> a -> b
$ Text -> Text
forall b a. (Show a, IsString b) => a -> b
show Text
msgContent)
    Logger -> IO ()
forall (m :: * -> *). MonadIO m => Logger -> m ()
Log.flush Logger
lgr

main :: IO ()
main :: IO ()
main = do
  BridgeConf
myconf :: BridgeConf <- IO BridgeConf
parseCli
  Logger
lgr :: Logger <- Level -> IO Logger
mkLogger (PhantomParent Level -> Level
forall a. PhantomParent a -> a
unPhantomParent (PhantomParent Level -> Level) -> PhantomParent Level -> Level
forall a b. (a -> b) -> a -> b
$ BridgeConf -> PhantomParent Level
logLevel BridgeConf
myconf)
  Logger
lgr Level
Debug (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Mapping -> Text
forall b a. (Show a, IsString b) => a -> b
show (BridgeConf -> Mapping
mapping BridgeConf
myconf)
  Logger -> BridgeConf -> IO ()
updateScimPeer Logger
lgr BridgeConf
myconf IO () -> (SomeException -> IO ()) -> IO ()
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` Logger -> SomeException -> IO ()
forall a. Logger -> SomeException -> IO a
logErrors Logger
lgr
  where
    logErrors :: Logger -> SomeException -> IO a
    logErrors :: forall a. Logger -> SomeException -> IO a
logErrors Logger
lgr (SomeException e
e) = do
      Logger
lgr Level
Fatal (Text -> IO ()) -> Text -> IO ()
forall a b. (a -> b) -> a -> b
$ Text
"uncaught exception: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> e -> Text
forall b a. (Show a, IsString b) => a -> b
show e
e
      e -> IO a
forall e a. Exception e => e -> IO a
throwIO e
e