77 lines
2.4 KiB
Haskell
77 lines
2.4 KiB
Haskell
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 ", ")
|