{-# 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.String.Conversions
import Data.Maybe
import Data.Map hiding (drop, map)
import qualified Data.ByteString as BS
import qualified Data.Word8 as W8 (isSpace, _colon, toLower)
import Data.Char
import Control.Monad.Except (ExceptT, runExceptT)
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)
import Web.JWT as JWT
type Keycloak a = ReaderT KCConfig (ExceptT KCError IO) a
data KCError = HTTPError HttpException
| ParseError Text
| EmptyError
deriving (Show)
data KCConfig = KCConfig {
_baseUrl :: Text,
_realm :: Text,
_clientId :: Text,
_clientSecret :: Text} deriving (Eq, Show)
defaultKCConfig :: KCConfig
defaultKCConfig = KCConfig {
_baseUrl = "http://localhost:8080/auth",
_realm = "waziup",
_clientId = "api-server",
_clientSecret = "4e9dcb80-efcd-484c-b3d7-1e95a0096ac0"}
runKeycloak :: Keycloak a -> KCConfig -> IO (Either KCError a)
runKeycloak kc conf = runExceptT $ runReaderT kc conf
type Path = Text
newtype Token = Token {unToken :: BS.ByteString} deriving (Eq, Show, Generic)
instance ToJSON Token where
toJSON (Token t) = String $ convertString 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)
tokNonce, tokAuthTime, tokSessionState, tokAtHash, tokCHash, tokName, tokGivenName, tokFamilyName, tokMiddleName, tokNickName, tokPreferredUsername, tokProfile, tokPicture, tokWebsite, tokEmail, tokEmailVerified, tokGender, tokBirthdate, tokZoneinfo, tokLocale, tokPhoneNumber, tokPhoneNumberVerified,tokAddress, tokUpdateAt, tokClaimsLocales, tokACR :: Text
tokNonce = "nonce";
tokAuthTime = "auth_time";
tokSessionState = "session_state";
tokAtHash = "at_hash";
tokCHash = "c_hash";
tokName = "name";
tokGivenName = "given_name";
tokFamilyName = "family_name";
tokMiddleName = "middle_name";
tokNickName = "nickname";
tokPreferredUsername = "preferred_username";
tokProfile = "profile";
tokPicture = "picture";
tokWebsite = "website";
tokEmail = "email";
tokEmailVerified = "email_verified";
tokGender = "gender";
tokBirthdate = "birthdate";
tokZoneinfo = "zoneinfo";
tokLocale = "locale";
tokPhoneNumber = "phone_number";
tokPhoneNumberVerified = "phone_number_verified";
tokAddress = "address";
tokUpdateAt = "updated_at";
tokClaimsLocales = "claims_locales";
tokACR = "acr";
data TokenRep = TokenRep {
accessToken :: Text,
expiresIn :: Int,
refreshExpriresIn :: Int,
refreshToken :: Text,
tokenType :: Text,
notBeforePolicy :: Int,
sessionState :: Text,
tokenScope :: Text} deriving (Show, Eq)
instance FromJSON TokenRep where
parseJSON (Object v) = TokenRep <$> v .: "access_token"
<*> v .: "expires_in"
<*> v .: "refresh_expires_in"
<*> v .: "refresh_token"
<*> v .: "token_type"
<*> v .: "not-before-policy"
<*> v .: "session_state"
<*> v .: "scope"
newtype ScopeName = ScopeName {unScopeName :: Text} deriving (Eq, Generic, Ord)
instance ToJSON ScopeName where
toJSON = genericToJSON (defaultOptions {unwrapUnaryRecords = True})
instance FromJSON ScopeName where
parseJSON = genericParseJSON (defaultOptions {unwrapUnaryRecords = True})
instance Show ScopeName where
show (ScopeName s) = convertString s
newtype ScopeId = ScopeId {unScopeId :: Text} deriving (Show, Eq, Generic)
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
{ permRsid :: Maybe ResourceId,
permRsname :: Maybe ResourceName,
permScopes :: [ScopeName]
} deriving (Generic, Show, Eq)
instance ToJSON Permission where
toJSON = genericToJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 4, omitNothingFields = True}
instance FromJSON Permission where
parseJSON = genericParseJSON defaultOptions {fieldLabelModifier = unCapitalize . drop 4}
data PermReq = PermReq
{ permReqResourceId :: Maybe ResourceId,
permReqScopes :: [ScopeName]
} deriving (Generic, Eq, Ord)
instance Show PermReq where
show (PermReq (Just (ResourceId res1)) scopes) = (show res1) <> " " <> (show scopes)
show (PermReq Nothing scopes) = "none " <> (show scopes)
type Username = Text
type Password = Text
type First = Int
type Max = Int
newtype UserId = UserId {unUserId :: Text} deriving (Show, Eq, Generic)
instance ToJSON UserId where
toJSON = genericToJSON (defaultOptions {unwrapUnaryRecords = True})
instance FromJSON UserId where
parseJSON = genericParseJSON (defaultOptions {unwrapUnaryRecords = True})
data User = User
{ userId :: Maybe UserId
, userUsername :: Username
, userFirstName :: Maybe Text
, userLastName :: Maybe Text
, userEmail :: Maybe Text
, userAttributes :: Maybe (Map Text [Text])
} 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 = unCapitalize . drop 4, omitNothingFields = True}
data Owner = Owner {
ownId :: Maybe Text,
ownName :: Maybe Username
} deriving (Generic, Show)
instance FromJSON Owner where
parseJSON = genericParseJSON $ aesonDrop 3 snakeCase
instance ToJSON Owner where
toJSON = genericToJSON $ (aesonDrop 3 snakeCase) {omitNothingFields = True}
type ResourceName = Text
type ResourceType = Text
newtype ResourceId = ResourceId {unResId :: Text} deriving (Show, Eq, Generic, Ord)
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 ResourceType,
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"
let atts = if isJust rAtt then toList $ fromJust rAtt else []
return $ Resource rId rName rType rUris rScopes rOwn rOMA (map (\(a, b) -> Attribute a b) atts)
instance ToJSON Resource where
toJSON (Resource id name typ uris scopes own uma attrs) =
object ["_id" .= toJSON id,
"name" .= toJSON name,
"type" .= toJSON typ,
"uris" .= toJSON uris,
"scopes" .= toJSON scopes,
"owner" .= (toJSON $ ownName 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