module Auth.LDAP.AD
  ( ADError(..)
  , parseADError
  ) where

import Import.NoFoundation hiding (try)

import Model.Types.TH.PathPiece

import qualified Data.IntMap.Strict as IntMap
import qualified Data.Map.Strict as Map

import Text.Parsec hiding ((<|>))
import Text.Parsec.String
import Text.ParserCombinators.Parsec.Number (hexnum)

import Ldap.Client (ResultCode(..))


-- | Copied from <https://ldapwiki.com/wiki/Common%20Active%20Directory%20Bind%20Errors>
data ADError
  = ADNoSuchObject
  | ADLogonFailure
  | ADAccountRestriction
  | ADInvalidLogonHours
  | ADInvalidWorkstation
  | ADPasswordExpired
  | ADAccountDisabled
  | ADTooManyContextIds
  | ADAccountExpired
  | ADPasswordMustChange
  | ADAccountLockedOut
  deriving (Eq, Ord, Read, Show, Enum, Bounded, Generic, Typeable)
  deriving anyclass (Universe, Finite)

nullaryPathPiece ''ADError $ camelToPathPiece' 1
pathPieceJSON ''ADError
pathPieceJSONKey ''ADError
derivePersistFieldPathPiece ''ADError


fromADErrorCode :: ResultCode -> Word32 -> Maybe ADError
fromADErrorCode resCode subResCode = IntMap.lookup (fromIntegral subResCode) =<< Map.lookup resCode errorCodes
  where
    errorCodes = Map.fromList
      [ ( InvalidCredentials
        , IntMap.fromList
            [ ( 0x525,      ADNoSuchObject       )
            , ( 0x52e,      ADLogonFailure       )
            , ( 0x52f,      ADAccountRestriction )
            , ( 0x530,      ADInvalidLogonHours  )
            , ( 0x531,      ADInvalidWorkstation )
            , ( 0x532,      ADPasswordExpired    )
            , ( 0x533,      ADAccountDisabled    )
            , ( 0x568,      ADTooManyContextIds  )
            , ( 0x701,      ADAccountExpired     )
            , ( 0x773,      ADPasswordMustChange )
            , ( 0x775,      ADAccountLockedOut   )
            , ( 0x80090346, ADAccountLockedOut   )
            ]
        )
      ]

parseADError :: ResultCode -> Text -> Either ParseError ADError
parseADError resCode = parse (pADError resCode <* eof) "LDAP" . unpack

pADError :: ResultCode -> Parser ADError
pADError resCode = do
  void . manyTill anyChar . try $ string ": "
  let pItem = asum
        [ do
            void $ string "data "
            fmap Just $ hexnum >>= hoistMaybe . fromADErrorCode resCode
        , Nothing <$ manyTill anyChar (lookAhead . try $ void (string ", ") <|> eof)
        ]
  (hoistMaybe =<<) $ ala First foldMap <$> pItem `sepBy1` try (string ", ")