{-# LANGUAGE OverloadedStrings #-}
{-# OPTIONS_GHC -Wno-orphans -Wno-missing-export-lists #-}

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.ByteString.Char8 as ByteString
import qualified Data.Foldable as Foldable
import qualified Data.HashMap.Lazy as HM
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.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

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
showList :: [LdapConf] -> ShowS
$cshowList :: [LdapConf] -> ShowS
show :: LdapConf -> String
$cshow :: LdapConf -> String
showsPrec :: Int -> LdapConf -> ShowS
$cshowsPrec :: Int -> 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
/= :: LdapFilterAttr -> LdapFilterAttr -> Bool
$c/= :: LdapFilterAttr -> LdapFilterAttr -> Bool
== :: LdapFilterAttr -> LdapFilterAttr -> Bool
$c== :: 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
showList :: [LdapFilterAttr] -> ShowS
$cshowList :: [LdapFilterAttr] -> ShowS
show :: LdapFilterAttr -> String
$cshow :: LdapFilterAttr -> String
showsPrec :: Int -> LdapFilterAttr -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep LdapFilterAttr x -> LdapFilterAttr
$cfrom :: forall x. LdapFilterAttr -> Rep LdapFilterAttr x
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
/= :: LdapSearch -> LdapSearch -> Bool
$c/= :: LdapSearch -> LdapSearch -> Bool
== :: LdapSearch -> LdapSearch -> Bool
$c== :: 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
showList :: [LdapSearch] -> ShowS
$cshowList :: [LdapSearch] -> ShowS
show :: LdapSearch -> String
$cshow :: LdapSearch -> String
showsPrec :: Int -> LdapSearch -> ShowS
$cshowsPrec :: Int -> 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
/= :: Codec -> Codec -> Bool
$c/= :: Codec -> Codec -> Bool
== :: Codec -> Codec -> Bool
$c== :: 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
showList :: [Codec] -> ShowS
$cshowList :: [Codec] -> ShowS
show :: Codec -> String
$cshow :: Codec -> String
showsPrec :: Int -> Codec -> ShowS
$cshowsPrec :: Int -> 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 -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"tls"
    String
fhost :: String <- Object
obj Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"host"
    Int
fport :: Int <- Object
obj Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"port"
    Text
fdn :: Text <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"dn"
    String
fpassword :: String <- Object
obj Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"password"
    LdapSearch
fsearch :: LdapSearch <- Object
obj Object -> Text -> Parser LdapSearch
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"search"
    Text
fcodec :: Text <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"codec"
    Maybe LdapFilterAttr
fdeleteOnAttribute :: Maybe LdapFilterAttr <- Object
obj Object -> Text -> Parser (Maybe LdapFilterAttr)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:? Text
"deleteOnAttribute" -- TODO: this can go into 'fdeleteFromDirectory'.
    Maybe LdapSearch
fdeleteFromDirectory :: Maybe LdapSearch <- Object
obj Object -> Text -> Parser (Maybe LdapSearch)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:? Text
"deleteFromDirectory"

    let vhost :: Host
        vhost :: Host
vhost = case Bool
ftls of
          Bool
True -> String -> TLSSettings -> Host
Ldap.Tls String
fhost TLSSettings
Ldap.defaultTlsSettings
          Bool
False -> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Codec
Utf8
      Text
"latin1" -> Codec -> Parser Codec
forall (f :: * -> *) a. Applicative f => a -> f a
pure Codec
Latin1
      Text
bad -> String -> Parser Codec
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 (f :: * -> *) a. Applicative f => a -> f a
pure (LdapConf -> Parser LdapConf) -> LdapConf -> Parser LdapConf
forall a b. (a -> b) -> a -> b
$
      LdapConf :: Host
-> PortNumber
-> Dn
-> Password
-> LdapSearch
-> Codec
-> Maybe LdapFilterAttr
-> Maybe LdapSearch
-> LdapConf
LdapConf
        { ldapHost :: Host
ldapHost = Host
vhost,
          ldapPort :: PortNumber
ldapPort = PortNumber
vport,
          ldapDn :: Dn
ldapDn = Text -> Dn
Dn Text
fdn,
          ldapPassword :: Password
ldapPassword = ByteString -> Password
Password (ByteString -> Password) -> ByteString -> Password
forall a b. (a -> b) -> a -> b
$ String -> ByteString
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 -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"key"
      Parser (Text -> LdapFilterAttr)
-> Parser Text -> Parser LdapFilterAttr
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"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 -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"base"
    Text
fobjectClass :: Text <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"objectClass"

    [LdapFilterAttr]
extra :: [LdapFilterAttr] <- do
      let go :: (Text, Yaml.Value) -> Yaml.Parser LdapFilterAttr
          go :: (Text, Value) -> Parser LdapFilterAttr
go (Text
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 (f :: * -> *) a. Applicative f => a -> f a
pure Value
val
            LdapFilterAttr -> Parser LdapFilterAttr
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 Text
key Text
str
      (Text, Value) -> Parser LdapFilterAttr
go ((Text, Value) -> Parser LdapFilterAttr)
-> [(Text, Value)] -> Parser [LdapFilterAttr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
`mapM` Object -> [(Text, Value)]
forall k v. HashMap k v -> [(k, v)]
HM.toList ((Text -> Value -> Bool) -> Object -> Object
forall k v. (k -> v -> Bool) -> HashMap k v -> HashMap k v
HM.filterWithKey (\Text
k Value
_ -> Text
k Text -> [Text] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`notElem` [Text
"base", Text
"objectClass"]) Object
obj)
    LdapSearch -> Parser LdapSearch
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
/= :: ScimConf -> ScimConf -> Bool
$c/= :: ScimConf -> ScimConf -> Bool
== :: ScimConf -> ScimConf -> Bool
$c== :: 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
showList :: [ScimConf] -> ShowS
$cshowList :: [ScimConf] -> ShowS
show :: ScimConf -> String
$cshow :: ScimConf -> String
showsPrec :: Int -> ScimConf -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep ScimConf x -> ScimConf
$cfrom :: forall x. ScimConf -> Rep ScimConf x
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 -> Text -> Parser Bool
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"tls"
      Parser (String -> Int -> String -> Text -> ScimConf)
-> Parser String -> Parser (Int -> String -> Text -> ScimConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"host"
      Parser (Int -> String -> Text -> ScimConf)
-> Parser Int -> Parser (String -> Text -> ScimConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser Int
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"port"
      Parser (String -> Text -> ScimConf)
-> Parser String -> Parser (Text -> ScimConf)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser String
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"path"
      Parser (Text -> ScimConf) -> Parser Text -> Parser ScimConf
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"token"

data BridgeConf = BridgeConf
  { BridgeConf -> LdapConf
ldapSource :: LdapConf,
    BridgeConf -> ScimConf
scimTarget :: ScimConf,
    BridgeConf -> Mapping
mapping :: Mapping,
    BridgeConf -> Level
logLevel :: 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
showList :: [BridgeConf] -> ShowS
$cshowList :: [BridgeConf] -> ShowS
show :: BridgeConf -> String
$cshow :: BridgeConf -> String
showsPrec :: Int -> BridgeConf -> ShowS
$cshowsPrec :: Int -> 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
$cto :: forall x. Rep BridgeConf x -> BridgeConf
$cfrom :: forall x. BridgeConf -> Rep BridgeConf x
Generic)

instance Aeson.FromJSON Level where
  parseJSON :: Value -> Parser Level
parseJSON Value
"Trace" = Level -> Parser Level
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Trace
  parseJSON Value
"Debug" = Level -> Parser Level
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Debug
  parseJSON Value
"Info" = Level -> Parser Level
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Info
  parseJSON Value
"Warn" = Level -> Parser Level
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Warn
  parseJSON Value
"Error" = Level -> Parser Level
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Error
  parseJSON Value
"Fatal" = Level -> Parser Level
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level
Fatal
  parseJSON Value
bad = String -> Parser Level
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
  = MissingAttr Text
  | WrongNumberOfAttrValues Text String Int
  | CouldNotParseEmail 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
/= :: MappingError -> MappingError -> Bool
$c/= :: MappingError -> MappingError -> Bool
== :: MappingError -> MappingError -> Bool
$c== :: MappingError -> MappingError -> Bool
Eq, Int -> MappingError -> ShowS
[MappingError] -> ShowS
MappingError -> String
(Int -> MappingError -> ShowS)
-> (MappingError -> String)
-> ([MappingError] -> ShowS)
-> Show MappingError
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [MappingError] -> ShowS
$cshowList :: [MappingError] -> ShowS
show :: MappingError -> String
$cshow :: MappingError -> String
showsPrec :: Int -> MappingError -> ShowS
$cshowsPrec :: Int -> MappingError -> ShowS
Show)

data FieldMapping = FieldMapping
  { 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

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
showList :: [Mapping] -> ShowS
$cshowList :: [Mapping] -> ShowS
show :: Mapping -> String
$cshow :: Mapping -> String
showsPrec :: Int -> Mapping -> ShowS
$cshowsPrec :: Int -> 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 -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:? Text
"displayName"
    Text
fuserName <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"userName"
    Text
fexternalId <- Object
obj Object -> Text -> Parser Text
forall a. FromJSON a => Object -> Text -> Parser a
Aeson..: Text
"externalId"
    Maybe Text
mfemail <- Object
obj Object -> Text -> Parser (Maybe Text)
forall a. FromJSON a => Object -> Text -> Parser (Maybe a)
Aeson..:? Text
"email"

    let listToMap :: [(Text, a)] -> Map Text [a]
        listToMap :: [(Text, a)] -> Map Text [a]
listToMap = (Map Text [a] -> (Text, a) -> Map Text [a])
-> Map Text [a] -> [(Text, a)] -> Map Text [a]
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 (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 -> FieldMapping
mapDisplayName Text
fdisplayName)) (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 -> FieldMapping
mapUserName Text
fuserName),
        (Text, FieldMapping) -> Maybe (Text, FieldMapping)
forall a. a -> Maybe a
Just (Text
fexternalId, Text -> FieldMapping
mapExternalId Text
fexternalId),
        (\Text
femail -> (Text
femail, Text -> FieldMapping
mapEmail Text
femail)) (Text -> (Text, FieldMapping))
-> Maybe Text -> Maybe (Text, FieldMapping)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Text
mfemail
      ]
    where
      -- The name that shows for this user in wire.
      mapDisplayName :: Text -> FieldMapping
      mapDisplayName :: Text -> FieldMapping
mapDisplayName Text
ldapFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
"displayName" (([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 {displayName :: Maybe Text
Scim.displayName = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
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 -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName String
"1" ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      -- Really, not username, but handle.
      mapUserName :: Text -> FieldMapping
      mapUserName :: Text -> FieldMapping
mapUserName Text
ldapFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
"userName" (([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 {userName :: Text
Scim.userName = Text
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 -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName String
"1" ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      mapExternalId :: Text -> FieldMapping
      mapExternalId :: Text -> FieldMapping
mapExternalId Text
ldapFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
"externalId" (([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 {externalId :: Maybe Text
Scim.externalId = Text -> Maybe Text
forall a. a -> Maybe a
Just Text
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 -> String -> Int -> MappingError
WrongNumberOfAttrValues Text
ldapFieldName String
"1" ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

      mapEmail :: Text -> FieldMapping
      mapEmail :: Text -> FieldMapping
mapEmail Text
ldapFieldName = Text
-> ([Text] -> Either MappingError (User ScimTag -> User ScimTag))
-> FieldMapping
FieldMapping Text
"emails" (([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 ByteString -> Either String EmailAddress
Text.Email.Validate.validate (Text -> ByteString
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
                { emails :: [Email]
Scim.emails =
                    [Maybe Text -> EmailAddress2 -> Maybe ScimBool -> Email
Scim.Email Maybe Text
forall a. Maybe a
Nothing (EmailAddress -> EmailAddress2
Scim.EmailAddress2 EmailAddress
email) Maybe ScimBool
forall a. Maybe a
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 -> String -> MappingError
CouldNotParseEmail 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 -> String -> Int -> MappingError
WrongNumberOfAttrValues
                Text
ldapFieldName
                String
"<=1 (with more than one email, which one should be primary?)"
                ([Text] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
Prelude.length [Text]
bad)

type LdapResult a = IO (Either LdapError a)

ldapObjectClassFilter :: Text -> Filter -- TODO: inline?
ldapObjectClassFilter :: Text -> Filter
ldapObjectClassFilter = (Text -> Attr
Attr Text
"objectClass" Attr -> ByteString -> Filter
:=) (ByteString -> Filter) -> (Text -> ByteString) -> Text -> Filter
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs

ldapFilterAttrToFilter :: LdapFilterAttr -> Filter -- TODO: inline?  replace LdapFilterAttr with `Attr` and `:=`?
ldapFilterAttrToFilter :: LdapFilterAttr -> Filter
ldapFilterAttrToFilter (LdapFilterAttr Text
key Text
val) = Text -> Attr
Attr Text
key Attr -> ByteString -> Filter
:= (Text -> ByteString
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

-- | the 'undefined' is ok, the mapping is guaranteed to contain a filler for this, or the
-- mapping parser would have failed.
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 -> Text
forall a t. (HasCallStack, IsText t) => t -> a
error Text
"undefined") NoUserExtra
UserExtra ScimTag
Scim.NoUserExtra

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

ldapToScim ::
  forall m.
  m ~ Either [(SearchEntry, MappingError)] =>
  BridgeConf ->
  SearchEntry ->
  m (SearchEntry, User)
ldapToScim :: BridgeConf -> SearchEntry -> m (SearchEntry, User ScimTag)
ldapToScim BridgeConf
conf entry :: SearchEntry
entry@(SearchEntry Dn
_ AttrList []
attrs) = (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, [ByteString]) -> m (User ScimTag))
-> m (User ScimTag) -> AttrList [] -> m (User ScimTag)
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
Foldable.foldl' m (User ScimTag) -> (Attr, [ByteString]) -> 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
    codec :: ByteString -> Text
codec = case LdapConf -> Codec
ldapCodec (BridgeConf -> LdapConf
ldapSource BridgeConf
conf) of
      Codec
Utf8 -> ByteString -> Text
Text.decodeUtf8
      Codec
Latin1 -> ByteString -> Text
Text.decodeLatin1

    go :: m User -> (Attr, [AttrValue]) -> m User
    go :: m (User ScimTag) -> (Attr, [ByteString]) -> m (User ScimTag)
go m (User ScimTag)
scimval (Attr Text
key, [ByteString]
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 (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl' ([ByteString]
-> m (User ScimTag) -> FieldMapping -> m (User ScimTag)
go' [ByteString]
vals) m (User ScimTag)
scimval [FieldMapping]
fieldMappings

    go' :: [ByteString] -> m User -> FieldMapping -> m User
    go' :: [ByteString]
-> m (User ScimTag) -> FieldMapping -> m (User ScimTag)
go' [ByteString]
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 (ByteString -> Text
codec (ByteString -> Text) -> [ByteString] -> [Text]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [ByteString]
vals)) of
      (Right 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 _, Left MappingError
err) -> [(SearchEntry, MappingError)]
-> Either [(SearchEntry, MappingError)] (User ScimTag)
forall a b. a -> Either a b
Left [(SearchEntry
entry, MappingError
err)]
      (Left 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 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
  Manager
manager <- ManagerSettings -> IO Manager
HTTP.newManager ManagerSettings
settings
  let base :: BaseUrl
base = Scheme -> String -> Int -> String -> BaseUrl
BaseUrl Scheme
Http (ScimConf -> String
scimHost ScimConf
conf) (ScimConf -> Int
scimPort ScimConf
conf) (ScimConf -> String
scimPath ScimConf
conf)
  ClientEnv -> IO ClientEnv
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 -> ([ByteString] -> Bool) -> Maybe [ByteString] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False (Text -> ByteString
forall a b. ConvertibleStrings a b => a -> b
cs Text
value ByteString -> [ByteString] -> Bool
forall (f :: * -> *) a.
(Foldable f, DisallowElem f, Eq a) =>
a -> f a -> Bool
`elem`) (Attr -> AttrList [] -> Maybe [ByteString]
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 (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)
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
forall b a. (Show a, IsString b) => a -> b
show) (SearchEntry, User ScimTag) -> IO (SearchEntry, User ScimTag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (BridgeConf
-> SearchEntry
-> Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
forall (m :: * -> *).
(m ~ Either [(SearchEntry, MappingError)]) =>
BridgeConf -> SearchEntry -> m (SearchEntry, User ScimTag)
ldapToScim 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 (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 (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)
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
forall b a. (Show a, IsString b) => a -> b
show) (SearchEntry, User ScimTag) -> IO (SearchEntry, User ScimTag)
forall (f :: * -> *) a. Applicative f => a -> f a
pure) (BridgeConf
-> SearchEntry
-> Either [(SearchEntry, MappingError)] (SearchEntry, User ScimTag)
forall (m :: * -> *).
(m ~ Either [(SearchEntry, MappingError)]) =>
BridgeConf -> SearchEntry -> m (SearchEntry, User ScimTag)
ldapToScim 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 :: 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 (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
  mbold :: [StoredUser] <-
    ClientEnv
-> Maybe (AuthData ScimTag)
-> Maybe Filter
-> IO (ListResponse 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 (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 (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 (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
$ ClientEnv
-> Maybe (AuthData ScimTag)
-> UserId ScimTag
-> User ScimTag
-> IO StoredUser
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
      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 (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 (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 (ClientEnv
-> Maybe (AuthData ScimTag) -> UserId ScimTag -> IO NoContent
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 (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 (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 (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 (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 (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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    [String
file] -> do
      ByteString
content <- String -> IO ByteString
ByteString.readFile String
file IO ByteString -> (SomeException -> IO ByteString) -> IO ByteString
forall e a. Exception e => IO a -> (e -> IO a) -> IO a
`catch` \(SomeException e
err) -> ErrorCall -> IO ByteString
forall e a. Exception e => e -> IO a
throwIO (ErrorCall -> IO ByteString)
-> (String -> ErrorCall) -> String -> IO ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> ErrorCall
usage (String -> IO ByteString) -> String -> IO ByteString
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 (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
$ ByteString -> Either ParseException BridgeConf
forall a. FromJSON a => ByteString -> Either ParseException a
Yaml.decodeEither' ByteString
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 (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 (ToBytes Text => Text -> Msg -> Msg
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 (BridgeConf -> 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 :: 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