{-# LANGUAGE DeriveGeneric #-} {-# LANGUAGE OverloadedStrings #-} {-# LANGUAGE ViewPatterns #-} {-# LANGUAGE GeneralizedNewtypeDeriving #-} {-# LANGUAGE TemplateHaskell #-} module Keycloak.Types where import Data.Aeson import Data.Aeson.Types import Data.Aeson.Casing import Data.Text hiding (head, tail, map, toLower, drop) import Data.Text.Encoding import Data.Monoid import Data.Maybe import Data.Aeson.BetterErrors as AB import qualified Data.ByteString as BS import qualified Data.Word8 as W8 (isSpace, _colon, toLower) import Data.Char import Control.Monad.Except (ExceptT) import Control.Monad.Reader as R import Control.Lens hiding ((.=)) import GHC.Generics (Generic) import Web.HttpApiData (FromHttpApiData(..), ToHttpApiData(..)) import Network.HTTP.Client as HC hiding (responseBody) ---------------------- -- * Keycloak Monad -- ---------------------- type Keycloak a = ReaderT KCConfig (ExceptT KCError IO) a data KCError = HTTPError HttpException -- ^ Keycloak returned an HTTP error. | ParseError Text -- ^ Failed when parsing the response | EmptyError -- ^ Empty error to serve as a zero element for Monoid. data KCConfig = KCConfig { _baseUrl :: Text, _realm :: Text, _clientId :: Text, _clientSecret :: Text} deriving (Eq, Show) -- _adminLogin :: Username, -- _adminPassword :: Password, -- _guestLogin :: Username, -- _guestPassword :: Password} defaultKCConfig :: KCConfig defaultKCConfig = KCConfig { _baseUrl = "http://localhost:8080/auth", _realm = "waziup", _clientId = "api-server", _clientSecret = "4e9dcb80-efcd-484c-b3d7-1e95a0096ac0"} -- _adminLogin = "cdupont", -- _adminPassword = "password", -- _guestLogin = "guest", -- _guestPassword = "guest"} type Path = Text ------------- -- * Token -- ------------- newtype Token = Token {unToken :: BS.ByteString} deriving (Eq, Show, Generic) instance FromJSON Token where parseJSON (Object v) = do t <- v .: "access_token" return $ Token $ encodeUtf8 t instance FromHttpApiData Token where parseQueryParam = parseHeader . encodeUtf8 parseHeader (extractBearerAuth -> Just tok) = Right $ Token tok parseHeader _ = Left "cannot extract auth Bearer" extractBearerAuth :: BS.ByteString -> Maybe BS.ByteString extractBearerAuth bs = let (x, y) = BS.break W8.isSpace bs in if BS.map W8.toLower x == "bearer" then Just $ BS.dropWhile W8.isSpace y else Nothing instance ToHttpApiData Token where toQueryParam (Token token) = "Bearer " <> (decodeUtf8 token) data TokenDec = TokenDec { jti :: Text, exp :: Int, nbf :: Int, iat :: Int, iss :: Text, aud :: Text, sub :: Text, typ :: Text, azp :: Text, authTime :: Int, sessionState :: Text, acr :: Text, allowedOrigins :: Value, realmAccess :: Value, ressourceAccess :: Value, scope :: Text, name :: Text, preferredUsername :: Text, givenName :: Text, familyName :: Text, email :: Text } deriving (Generic, Show) parseTokenDec :: Parse e TokenDec parseTokenDec = TokenDec <$> AB.key "jti" asText <*> AB.key "exp" asIntegral <*> AB.key "nbf" asIntegral <*> AB.key "iat" asIntegral <*> AB.key "iss" asText <*> AB.key "aud" asText <*> AB.key "sub" asText <*> AB.key "typ" asText <*> AB.key "azp" asText <*> AB.key "auth_time" asIntegral <*> AB.key "session_state" asText <*> AB.key "acr" asText <*> AB.key "allowed-origins" asValue <*> AB.key "realm_access" asValue <*> AB.key "resource_access" asValue <*> AB.key "scope" asText <*> AB.key "name" asText <*> AB.key "preferred_username" asText <*> AB.key "given_name" asText <*> AB.key "family_name" asText <*> AB.key "email" asText ------------------ -- * Permission -- ------------------ type ScopeName = Text newtype ScopeId = ScopeId {unScopeId :: Text} deriving (Show, Eq, Generic) --JSON instances instance ToJSON ScopeId where toJSON = genericToJSON (defaultOptions {unwrapUnaryRecords = True}) instance FromJSON ScopeId where parseJSON = genericParseJSON (defaultOptions {unwrapUnaryRecords = True}) data Scope = Scope { scopeId :: Maybe ScopeId, scopeName :: ScopeName } deriving (Generic, Show, Eq) instance ToJSON Scope where toJSON = genericToJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 5, omitNothingFields = True} instance FromJSON Scope where parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 5} data Permission = Permission { rsname :: ResourceName, rsid :: ResourceId, scopes :: [ScopeName] } deriving (Generic, Show, Eq) instance ToJSON Permission where toJSON = genericToJSON defaultOptions {omitNothingFields = True} instance FromJSON Permission where parseJSON = genericParseJSON defaultOptions type Username = Text type Password = Text ------------ -- * User -- ------------ type First = Int type Max = Int -- Id of a user newtype UserId = UserId {unUserId :: Text} deriving (Show, Eq, Generic) --JSON instances instance ToJSON UserId where toJSON = genericToJSON (defaultOptions {unwrapUnaryRecords = True}) instance FromJSON UserId where parseJSON = genericParseJSON (defaultOptions {unwrapUnaryRecords = True}) -- | User data User = User { userId :: Maybe UserId -- ^ The unique user ID , userUsername :: Username -- ^ Username , userFirstName :: Maybe Text -- ^ First name , userLastName :: Maybe Text -- ^ Last name , userEmail :: Maybe Text -- ^ Email } deriving (Show, Eq, Generic) unCapitalize :: String -> String unCapitalize (c:cs) = toLower c : cs unCapitalize [] = [] instance FromJSON User where parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 4} instance ToJSON User where toJSON = genericToJSON defaultOptions {fieldLabelModifier = drop 4, omitNothingFields = True} ------------- -- * Owner -- ------------- data Owner = Owner { ownId :: Maybe Text, ownName :: Username } deriving (Generic, Show) instance FromJSON Owner where parseJSON = genericParseJSON $ aesonDrop 3 snakeCase instance ToJSON Owner where toJSON = genericToJSON $ (aesonDrop 3 snakeCase) {omitNothingFields = True} ---------------- -- * Resource -- ---------------- type ResourceName = Text newtype ResourceId = ResourceId {unResId :: Text} deriving (Show, Eq, Generic) -- JSON instances instance ToJSON ResourceId where toJSON = genericToJSON (defaultOptions {unwrapUnaryRecords = True}) instance FromJSON ResourceId where parseJSON = genericParseJSON (defaultOptions {unwrapUnaryRecords = True}) data Resource = Resource { resId :: Maybe ResourceId, resName :: ResourceName, resType :: Maybe Text, resUris :: [Text], resScopes :: [Scope], resOwner :: Owner, resOwnerManagedAccess :: Bool, resAttributes :: [Attribute] } deriving (Generic, Show) instance FromJSON Resource where parseJSON (Object v) = do rId <- v .:? "_id" rName <- v .: "name" rType <- v .:? "type" rUris <- v .: "uris" rScopes <- v .: "scopes" rOwn <- v .: "owner" rOMA <- v .: "ownerManagedAccess" rAtt <- v .:? "attributes" return $ Resource rId rName rType rUris rScopes rOwn rOMA (maybe [] fromJust rAtt) instance ToJSON Resource where toJSON (Resource id name typ uris scopes own uma attrs) = object ["name" .= toJSON name, "uris" .= toJSON uris, "scopes" .= toJSON scopes, "owner" .= toJSON own, "ownerManagedAccess" .= toJSON uma, "attributes" .= object (map (\(Attribute name vals) -> name .= toJSON vals) attrs)] data Attribute = Attribute { attName :: Text, attValues :: [Text] } deriving (Generic, Show) instance FromJSON Attribute where parseJSON = genericParseJSON $ aesonDrop 3 camelCase instance ToJSON Attribute where toJSON (Attribute name vals) = object [name .= toJSON vals] makeLenses ''KCConfig