{-# 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@
    ldapHost :: Host,
    -- | usually 389 for plaintext or 636 for TLS.
    ldapPort :: PortNumber,
    -- | `$ slapcat | grep ^modifiersName`, eg. @Dn "cn=admin,dc=nodomain"@.
    ldapDn :: Dn,
    ldapPassword :: Password,
    ldapSearch :: LdapSearch,
    -- | anything from "Data.Text.Encoding".
    ldapCodec :: Codec,
    ldapDeleteOnAttribute :: Maybe LdapFilterAttr,
    ldapDeleteFromDirectory :: Maybe LdapSearch
  }
  deriving stock (Show)

data LdapFilterAttr = LdapFilterAttr
  { key :: Text,
    value :: Text
  }
  deriving stock (Eq, Show, Generic)

data LdapSearch = LdapSearch
  { -- | `$ slapcat | grep ^dn`, eg. @Dn "dc=nodomain"@.
    ldapSearchBase :: Dn,
    -- | eg. @"account"@
    ldapSearchObjectClass :: Text,
    -- | eg. @[LdapFilterAttr "memberOf" "team red", LdapFilterAttr "hairColor" "yellow"]
    ldapSearchExtra :: [LdapFilterAttr]
  }
  deriving stock (Eq, Show)

data Codec = Utf8 | Latin1
  deriving stock (Eq, Show)

instance Aeson.FromJSON LdapConf where
  parseJSON = Aeson.withObject "LdapConf" $ \obj -> do
    ftls :: Bool <- obj Aeson..: "tls"
    fhost :: String <- obj Aeson..: "host"
    fport :: Int <- obj Aeson..: "port"
    fdn :: Text <- obj Aeson..: "dn"
    fpassword :: String <- obj Aeson..: "password"
    fsearch :: LdapSearch <- obj Aeson..: "search"
    fcodec :: Text <- obj Aeson..: "codec"
    fdeleteOnAttribute :: Maybe LdapFilterAttr <- obj Aeson..:? "deleteOnAttribute" -- TODO: this can go into 'fdeleteFromDirectory'.
    fdeleteFromDirectory :: Maybe LdapSearch <- obj Aeson..:? "deleteFromDirectory"

    let vhost :: Host
        vhost = case ftls of
          True -> Ldap.Tls fhost Ldap.defaultTlsSettings
          False -> Ldap.Plain fhost

        vport :: PortNumber
        vport = fromIntegral fport

    vcodec <- case fcodec of
      "utf8" -> pure Utf8
      "latin1" -> pure Latin1
      bad -> fail $ "unsupported codec: " <> show bad

    pure $
      LdapConf
        { ldapHost = vhost,
          ldapPort = vport,
          ldapDn = Dn fdn,
          ldapPassword = Password $ ByteString.pack fpassword,
          ldapSearch = fsearch,
          ldapCodec = vcodec,
          ldapDeleteOnAttribute = fdeleteOnAttribute,
          ldapDeleteFromDirectory = fdeleteFromDirectory
        }

instance Aeson.FromJSON LdapFilterAttr where
  parseJSON = Aeson.withObject "LdapFilterAttr" $ \obj -> do
    LdapFilterAttr
      <$> obj Aeson..: "key"
      <*> obj Aeson..: "value"

instance Aeson.FromJSON LdapSearch where
  parseJSON = Aeson.withObject "LdapSearch" $ \obj -> do
    fbase :: Text <- obj Aeson..: "base"
    fobjectClass :: Text <- obj Aeson..: "objectClass"

    extra :: [LdapFilterAttr] <- do
      let go :: (Text, Yaml.Value) -> Yaml.Parser LdapFilterAttr
          go (key, val) = do
            str <- Aeson.withText "val" pure val
            pure $ LdapFilterAttr key str
      go `mapM` HM.toList (HM.filterWithKey (\k _ -> k `notElem` ["base", "objectClass"]) obj)
    pure $ LdapSearch (Dn fbase) fobjectClass extra

data ScimConf = ScimConf
  { scimTls :: Bool,
    scimHost :: String,
    scimPort :: Int,
    scimPath :: String,
    scimToken :: Text
  }
  deriving stock (Eq, Show, Generic)

instance Aeson.FromJSON ScimConf where
  parseJSON = Aeson.withObject "ScimConf" $ \obj -> do
    ScimConf
      <$> obj Aeson..: "tls"
      <*> obj Aeson..: "host"
      <*> obj Aeson..: "port"
      <*> obj Aeson..: "path"
      <*> obj Aeson..: "token"

data BridgeConf = BridgeConf
  { ldapSource :: LdapConf,
    scimTarget :: ScimConf,
    mapping :: Mapping,
    logLevel :: Level
  }
  deriving stock (Show, Generic)

instance Aeson.FromJSON Level where
  parseJSON "Trace" = pure Trace
  parseJSON "Debug" = pure Debug
  parseJSON "Info" = pure Info
  parseJSON "Warn" = pure Warn
  parseJSON "Error" = pure Error
  parseJSON "Fatal" = pure Fatal
  parseJSON bad = fail $ "unknown Level: " <> show bad

instance Aeson.FromJSON BridgeConf

data MappingError
  = MissingAttr Text
  | WrongNumberOfAttrValues Text String Int
  | CouldNotParseEmail Text String
  deriving stock (Eq, Show)

data FieldMapping = FieldMapping
  { fieldMappingLabel :: Text,
    fieldMappingFun ::
      [Text] ->
      Either
        MappingError
        ( Scim.User ScimTag ->
          Scim.User ScimTag
        )
  }

instance Show FieldMapping where
  show = show . 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 = [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 {fromMapping :: Map Text [FieldMapping]}
  deriving stock (Show)

instance Aeson.FromJSON Mapping where
  parseJSON = Aeson.withObject "Mapping" $ \obj -> do
    mfdisplayName <- obj Aeson..:? "displayName"
    fuserName <- obj Aeson..: "userName"
    fexternalId <- obj Aeson..: "externalId"
    mfemail <- obj Aeson..:? "email"

    let listToMap :: [(Text, a)] -> Map Text [a]
        listToMap = foldl' go mempty
          where
            go mp (k, b) = Map.alter (Just . maybe [b] (b :)) k mp

    pure . Mapping . listToMap . catMaybes $
      [ (\fdisplayName -> (fdisplayName, mapDisplayName fdisplayName)) <$> mfdisplayName,
        Just (fuserName, mapUserName fuserName),
        Just (fexternalId, mapExternalId fexternalId),
        (\femail -> (femail, mapEmail femail)) <$> mfemail
      ]
    where
      -- The name that shows for this user in wire.
      mapDisplayName :: Text -> FieldMapping
      mapDisplayName ldapFieldName = FieldMapping "displayName" $
        \case
          [val] -> Right $ \usr -> usr {Scim.displayName = Just val}
          bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad)

      -- Really, not username, but handle.
      mapUserName :: Text -> FieldMapping
      mapUserName ldapFieldName = FieldMapping "userName" $
        \case
          [val] -> Right $ \usr -> usr {Scim.userName = val}
          bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad)

      mapExternalId :: Text -> FieldMapping
      mapExternalId ldapFieldName = FieldMapping "externalId" $
        \case
          [val] -> Right $ \usr -> usr {Scim.externalId = Just val}
          bad -> Left $ WrongNumberOfAttrValues ldapFieldName "1" (Prelude.length bad)

      mapEmail :: Text -> FieldMapping
      mapEmail ldapFieldName = FieldMapping "emails" $
        \case
          [] -> Right id
          [val] -> case Text.Email.Validate.validate (SC.cs val) of
            Right email -> Right $ \usr ->
              usr
                { Scim.emails =
                    [Scim.Email Nothing (Scim.EmailAddress2 email) Nothing]
                }
            Left err -> Left $ CouldNotParseEmail val err
          bad ->
            Left $
              WrongNumberOfAttrValues
                ldapFieldName
                "<=1 (with more than one email, which one should be primary?)"
                (Prelude.length bad)

type LdapResult a = IO (Either LdapError a)

ldapObjectClassFilter :: Text -> Filter -- TODO: inline?
ldapObjectClassFilter = (Attr "objectClass" :=) . cs

ldapFilterAttrToFilter :: LdapFilterAttr -> Filter -- TODO: inline?  replace LdapFilterAttr with `Attr` and `:=`?
ldapFilterAttrToFilter (LdapFilterAttr key val) = Attr key := (cs val)

listLdapUsers :: LdapConf -> LdapSearch -> LdapResult [SearchEntry]
listLdapUsers conf searchConf = Ldap.with (ldapHost conf) (ldapPort conf) $ \l -> do
  Ldap.bind l (ldapDn conf) (ldapPassword conf)
  let fltr :: Filter =
        And
          ( ldapObjectClassFilter (ldapSearchObjectClass searchConf)
              :| (ldapFilterAttrToFilter <$> ldapSearchExtra searchConf)
          )
  Ldap.search l (ldapSearchBase searchConf) mempty fltr 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 =
  Scim.empty scimSchemas (error "undefined") Scim.NoUserExtra

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

ldapToScim ::
  forall m.
  m ~ Either [(SearchEntry, MappingError)] =>
  BridgeConf ->
  SearchEntry ->
  m (SearchEntry, User)
ldapToScim conf entry@(SearchEntry _ attrs) = (entry,) <$> Foldable.foldl' go (Right emptyScimUser) attrs
  where
    codec = case ldapCodec (ldapSource conf) of
      Utf8 -> Text.decodeUtf8
      Latin1 -> Text.decodeLatin1

    go :: m User -> (Attr, [AttrValue]) -> m User
    go scimval (Attr key, vals) = case Map.lookup key (fromMapping $ mapping conf) of
      Nothing -> scimval
      Just fieldMappings -> foldl' (go' vals) scimval fieldMappings

    go' :: [ByteString] -> m User -> FieldMapping -> m User
    go' vals scimval (FieldMapping _ f) = case (scimval, f (codec <$> vals)) of
      (Right scimusr, Right f') -> Right (f' scimusr)
      (Right _, Left err) -> Left [(entry, err)]
      (Left errs, Right _) -> Left errs
      (Left errs, Left err) -> Left ((entry, err) : errs)

connectScim :: Logger -> ScimConf -> IO ClientEnv
connectScim lgr conf = (`catch` logErrors) $ do
  let settings =
        if scimTls conf
          then HTTP.tlsManagerSettings
          else HTTP.defaultManagerSettings
      schema =
        if scimTls conf
          then Https
          else Http
  manager <- HTTP.newManager settings
  let base = BaseUrl schema (scimHost conf) (scimPort conf) (scimPath conf)
  pure $ mkClientEnv manager base
  where
    logErrors (SomeException e) = do
      lgr Error $ "could not connect to scim peer: " <> show e
      throwIO e

isDeletee :: LdapConf -> SearchEntry -> Bool
isDeletee conf = case ldapDeleteOnAttribute conf of
  Nothing -> const False
  Just (LdapFilterAttr key value) ->
    \(SearchEntry _ attrs) ->
      maybe False (cs value `elem`) (Data.List.lookup (Attr key) attrs)

updateScimPeer :: Logger -> BridgeConf -> IO ()
updateScimPeer lgr conf = do
  clientEnv <- connectScim lgr (scimTarget conf)
  let tok = Just . scimToken . scimTarget $ conf
  ldaps :: [SearchEntry] <-
    either (throwIO . ErrorCall . show) pure =<< listLdapUsers (ldapSource conf) (ldapSearch (ldapSource conf))
  do
    -- put, post
    lgr Info "[post/put: started]"
    let ldapKeepees = filter (not . isDeletee (ldapSource conf)) ldaps
    scims :: [(SearchEntry, User)] <-
      mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim conf <$> ldapKeepees)
    lgr Debug $ "Pulled the following ldap users for post/put:\n" <> show (fst <$> scims)
    lgr Debug . cs $ "Translated to scim:\n" <> Aeson.encodePretty (snd <$> scims)
    updateScimPeerPostPut lgr clientEnv tok (snd <$> scims)
    lgr Info "[post/put: done]"
  do
    -- delete
    lgr Info "[delete: started]"
    let ldapDeleteesAttr = filter (isDeletee (ldapSource conf)) ldaps
    ldapDeleteesDirectory :: [SearchEntry] <- case (ldapDeleteFromDirectory (ldapSource conf)) of
      Just (searchConf :: LdapSearch) ->
        either (throwIO . ErrorCall . show) pure =<< listLdapUsers (ldapSource conf) searchConf
      Nothing ->
        pure mempty

    scims :: [(SearchEntry, User)] <-
      mapM (either (throwIO . ErrorCall . show) pure) (ldapToScim conf <$> (ldapDeleteesAttr <> ldapDeleteesDirectory))
    lgr Debug $ "Pulled the following ldap users for delete:\n" <> show (fst <$> scims)
    lgr Debug . cs $ "Translated to scim:\n" <> Aeson.encodePretty (snd <$> scims)
    updateScimPeerDelete lgr clientEnv tok (snd <$> scims)
    lgr Info "[delete: done]"

lookupScimByExternalId :: ClientEnv -> Maybe Text -> Scim.User tag -> IO (Maybe StoredUser)
lookupScimByExternalId clientEnv tok scim = do
  eid <- maybe (error "impossible") pure $ Scim.externalId scim
  let fltr = Just $ filterBy "externalId" eid
  mbold :: [StoredUser] <-
    ScimClient.getUsers @ScimTag clientEnv tok fltr
      <&> Scim.resources
  case mbold of
    [old] -> pure $ Just old
    [] -> pure Nothing
    (_ : _ : _) -> error "impossible" -- externalId must be unique in the scope of the scim auth token.
  where
    filterBy :: Text -> Text -> ScimFilter.Filter
    filterBy name value =
      ScimFilter.FilterAttrCompare
        (ScimFilter.topLevelAttrPath name)
        ScimFilter.OpEq
        (ScimFilter.ValString value)

updateScimPeerPostPut ::
  Logger ->
  ClientEnv ->
  Maybe (AuthData ScimTag) ->
  [User] ->
  IO ()
updateScimPeerPostPut lgr clientEnv tok = mapM_ $ \scim -> do
  case Scim.externalId scim of
    Nothing -> lgr Error $ "scim user without 'externalId' field: " <> show scim
    Just eid -> updateScimPeerPostPutStep lgr clientEnv tok scim eid

updateScimPeerPostPutStep ::
  Logger ->
  ClientEnv ->
  Maybe Text ->
  Scim.User ScimTag ->
  Text ->
  IO ()
updateScimPeerPostPutStep lgr clientEnv tok scim eid = do
  lookupScimByExternalId clientEnv tok scim >>= \case
    Just old ->
      if ScimCommon.value (Scim.thing old) == scim
        then do
          lgr Info $ "unchanged: " <> show eid
        else do
          lgr Info $ "update: " <> show eid
          process $ ScimClient.putUser @ScimTag clientEnv tok (ScimCommon.id (Scim.thing old)) scim
    Nothing -> do
      lgr Info $ "new user: " <> show eid
      process $ ScimClient.postUser clientEnv tok scim
  where
    process :: IO StoredUser -> IO ()
    process action = do
      result :: Either SomeException StoredUser <-
        (Right <$> action) `catch` (pure . Left)
      result
        & either
          (lgr Error . show)
          (\new -> lgr Debug $ "UserId: " <> (show . ScimCommon.id . Scim.thing $ new))

updateScimPeerDelete ::
  Logger ->
  ClientEnv ->
  Maybe (AuthData ScimTag) ->
  [User] ->
  IO ()
updateScimPeerDelete lgr clientEnv tok = mapM_ $ \scim -> do
  lookupScimByExternalId clientEnv tok scim >>= \case
    Just old -> do
      process (ScimClient.deleteUser @ScimTag clientEnv tok (ScimCommon.id (Scim.thing old)))
        `catch` \e@(SomeException _) -> lgr Error $ show e
    Nothing -> do
      pure ()
  where
    process :: IO NoContent -> IO ()
    process action = do
      result :: Either SomeException NoContent <-
        (Right <$> action) `catch` (pure . Left)
      result
        & either
          (lgr Error . show)
          (const $ pure ())

parseCli :: IO BridgeConf
parseCli = do
  usage <- do
    progName <- getProgName
    let usage :: String -> ErrorCall
        usage = ErrorCall . (<> help)
        help =
          cs . unlines . fmap cs $
            [ "",
              "",
              "usage: " <> progName <> " <config.yaml>",
              "see https://github.com/wireapp/ldap-scim-bridge for a sample config."
            ]
    pure usage

  getArgs >>= \case
    [file] -> do
      content <- ByteString.readFile file `catch` \(SomeException err) -> throwIO . usage $ show err
      either (throwIO . usage . show) pure $ Yaml.decodeEither' content
    bad -> throwIO . usage $ "bad number of arguments: " <> show bad

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

mkLogger :: Level -> IO Logger
mkLogger lvl = do
  lgr :: Log.Logger <-
    Log.defSettings
      & Log.setLogLevel lvl
      & Log.new
  pure $ \msgLvl msgContent -> do
    Log.log lgr msgLvl (Log.msg @Text $ show msgContent)
    Log.flush lgr

main :: IO ()
main = do
  myconf :: BridgeConf <- parseCli
  lgr :: Logger <- mkLogger (logLevel myconf)
  lgr Debug $ show (mapping myconf)
  updateScimPeer lgr myconf `catch` logErrors lgr
  where
    logErrors :: Logger -> SomeException -> IO a
    logErrors lgr (SomeException e) = do
      lgr Fatal $ "uncaught exception: " <> show e
      throwIO e