{-# 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)
type Keycloak a = ReaderT KCConfig (ExceptT KCError IO) a
data KCError = HTTPError HttpException
| ParseError Text
| EmptyError
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"}
type Path = Text
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
type ScopeName = Text
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
{ 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
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
} 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}
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}
type ResourceName = Text
newtype ResourceId = ResourceId {unResId :: Text} deriving (Show, Eq, Generic)
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