diff --git a/ChangeLog.md b/ChangeLog.md new file mode 100644 --- /dev/null +++ b/ChangeLog.md @@ -0,0 +1,3 @@ +# Changelog for keycloak-hs + +## Unreleased changes diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Corentin Dupont (c) 2019 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,20 @@ +keycloak-hs +=========== + +keycloak-hs is a library for connecting to Keycloak made in Haskell. +Keycloak allows to authenticate users and protect resources. + +Warning: This package is experimental and still under development. + +Install +======= + +Installation follows the standard approach to installing Stack-based projects. + +1. Install the [Haskell `stack` tool](http://docs.haskellstack.org/en/stable/README). +2. Run `stack install --fast` to install this package. + +Tutorial +======== + +TBD diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/keycloak-hs.cabal b/keycloak-hs.cabal new file mode 100644 --- /dev/null +++ b/keycloak-hs.cabal @@ -0,0 +1,61 @@ +cabal-version: 1.12 +name: keycloak-hs +version: 0.0.0.0 +description: Please see the README on GitHub at +homepage: https://github.com/cdupont/keycloak-hs#readme +bug-reports: https://github.com/cdupont/keycloak-hs/issues +author: Corentin Dupont +maintainer: corentin.dupont@gmail.com +copyright: 2019 Corentin Dupont +license: BSD3 +license-file: LICENSE +build-type: Simple +extra-source-files: + README.md + ChangeLog.md + +source-repository head + type: git + location: https://github.com/cdupont/keycloak-hs + +library + exposed-modules: + Keycloak.Client + Keycloak.Types + other-modules: + Paths_keycloak_hs + hs-source-dirs: + src + build-depends: + base >=4.7 && <5 + , http-client + , lens + , mtl + , word8 + , bytestring + , text + , aeson + , aeson-casing + , aeson-better-errors + , http-api-data + , http-types + , hslogger + , string-conversions + , wreq + , base64-bytestring + , exceptions + default-language: Haskell2010 + + +test-suite keycloak-hs-test + type: exitcode-stdio-1.0 + main-is: Spec.hs + other-modules: + Paths_keycloak_hs + hs-source-dirs: + test + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: + base >=4.7 && <5 + , keycloak-hs + default-language: Haskell2010 diff --git a/src/Keycloak/Client.hs b/src/Keycloak/Client.hs new file mode 100644 --- /dev/null +++ b/src/Keycloak/Client.hs @@ -0,0 +1,270 @@ +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE ViewPatterns #-} + +module Keycloak.Client where + +import Control.Lens hiding ((.=)) +import Control.Monad.Reader as R +import qualified Control.Monad.Catch as C +import Control.Monad.Except (throwError, catchError, MonadError) +import Data.Aeson as JSON +import Data.Aeson.Types hiding ((.=)) +import Data.Aeson.BetterErrors as AB +import Data.Text hiding (head, tail, map) +import Data.Text.Encoding +import Data.Maybe +import Data.ByteString.Base64 as B64 +import Data.String.Conversions +import Data.Monoid hiding (First) +import qualified Data.ByteString.Char8 as BS +import qualified Data.ByteString.Lazy as BL +import Keycloak.Types +import Network.HTTP.Client as HC hiding (responseBody) +import Network.HTTP.Types.Status +import Network.HTTP.Types.Method +import Network.HTTP.Types (renderQuery) +import Network.Wreq as W hiding (statusCode) +import Network.Wreq.Types +import System.Log.Logger +import Debug.Trace +import System.IO.Unsafe + + +------------------- +-- * Permissions -- +------------------- + +-- Checks is a scope is permitted on a resource. An HTTP Exception 403 will be thrown if not. +checkPermission :: ResourceId -> ScopeName -> Token -> Keycloak () +checkPermission (ResourceId res) scope tok = do + debug $ "Checking permissions: " ++ (show res) ++ " " ++ (show scope) + client <- asks _clientId + let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), + "audience" := client, + "permission" := res <> "#" <> scope] + keycloakPost "protocol/openid-connect/token" dat tok + return () + +isAuthorized :: ResourceId -> ScopeName -> Token -> Keycloak Bool +isAuthorized res scope tok = do + r <- try $ checkPermission res scope tok + case r of + Right _ -> return True + Left e | (statusCode <$> getErrorStatus e) == Just 403 -> return False + Left e -> throwError e --rethrow the error + +getAllPermissions :: [ScopeName] -> Token -> Keycloak [Permission] +getAllPermissions scopes tok = do + debug "Get all permissions" + client <- asks _clientId + let dat = ["grant_type" := ("urn:ietf:params:oauth:grant-type:uma-ticket" :: Text), + "audience" := client, + "response_mode" := ("permissions" :: Text)] + <> map (\s -> "permission" := ("#" <> s)) scopes + body <- keycloakPost "protocol/openid-connect/token" dat tok + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + + +-------------- +-- * Tokens -- +-------------- + +getUserAuthToken :: Text -> Text -> Keycloak Token +getUserAuthToken username password = do + debug "Get user token" + client <- asks _clientId + secret <- asks _clientSecret + let dat = ["client_id" := client, + "client_secret" := secret, + "grant_type" := ("password" :: Text), + "password" := password, + "username" := username] + body <- keycloakPost' "protocol/openid-connect/token" dat + debug $ "Keycloak: " ++ (show body) + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return ret + Left err2 -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +getClientAuthToken :: Keycloak Token +getClientAuthToken = do + debug "Get client token" + client <- asks _clientId + secret <- asks _clientSecret + let dat = ["client_id" := client, + "client_secret" := secret, + "grant_type" := ("client_credentials" :: Text)] + body <- keycloakPost' "protocol/openid-connect/token" dat + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return $ ret + Left err2 -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +decodeToken :: Token -> Either String TokenDec +decodeToken (Token tok) = case (BS.split '.' tok) ^? element 1 of + Nothing -> Left "Token is not formed correctly" + Just part2 -> case AB.parse parseTokenDec (traceShowId $ convertString $ B64.decodeLenient $ traceShowId part2) of + Right td -> Right td + Left (e :: ParseError String) -> Left $ show e + +getUsername :: Token -> Maybe Username +getUsername tok = do + case decodeToken tok of + Right t -> Just $ preferredUsername t + Left e -> do + traceM $ "Error while decoding token: " ++ (show e) + Nothing + +---------------- +-- * Resource -- +---------------- + +createResource :: Resource -> Token -> Keycloak ResourceId +createResource r tok = do + debug $ convertString $ "Creating resource: " <> (JSON.encode r) + body <- keycloakPost "authz/protection/resource_set" (toJSON r) tok + debug $ convertString $ "Created resource: " ++ convertString body + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return $ fromJust $ resId ret + Left err2 -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +deleteResource :: ResourceId -> Token -> Keycloak () +deleteResource (ResourceId rid) tok = do + keycloakDelete ("authz/protection/resource_set/" <> rid) tok + return () + + +------------- +-- * Users -- +------------- + +getUsers :: Maybe Max -> Maybe First -> Token -> Keycloak [User] +getUsers max first tok = do + let query = maybe [] (\l -> [("limit", Just $ convertString $ show l)]) max + ++ maybe [] (\m -> [("max", Just $ convertString $ show m)]) first + body <- keycloakAdminGet ("users" <> (convertString $ renderQuery True query)) tok + debug $ "Keycloak success: " ++ (show body) + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + +getUser :: UserId -> Token -> Keycloak User +getUser (UserId id) tok = do + body <- keycloakAdminGet ("users/" <> (convertString id)) tok + debug $ "Keycloak success: " ++ (show body) + case eitherDecode body of + Right ret -> do + debug $ "Keycloak success: " ++ (show ret) + return ret + Left (err2 :: String) -> do + debug $ "Keycloak parse error: " ++ (show err2) + throwError $ ParseError $ pack (show err2) + + +------------------------- +-- * Keycloak requests -- +------------------------- +-- Perform post to Keycloak. +keycloakPost :: (Postable dat, Show dat) => Path -> dat -> Token -> Keycloak BL.ByteString +keycloakPost path dat tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK POST with url: " ++ (show url) + debug $ " data: " ++ (show dat) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.postWith opts url dat + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left err -> do + warn $ "Keycloak HTTP error: " ++ (show err) + throwError $ HTTPError err + +keycloakPost' :: (Postable dat, Show dat) => Path -> dat -> Keycloak BL.ByteString +keycloakPost' path dat = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK POST with url: " ++ (show url) + debug $ " data: " ++ (show dat) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.postWith opts url dat + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left err -> do + warn $ "Keycloak HTTP error: " ++ (show err) + throwError $ HTTPError err + +-- Perform delete to Keycloak. +keycloakDelete :: Path -> Token -> Keycloak () +keycloakDelete path tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] + let url = (unpack $ baseUrl <> "/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK DELETE with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.deleteWith opts url + case eRes of + Right res -> return () + Left err -> do + warn $ "Keycloak HTTP error: " ++ (show err) + throwError $ HTTPError err + +-- Perform get to Keycloak on admin API +keycloakAdminGet :: Path -> Token -> Keycloak BL.ByteString +keycloakAdminGet path tok = do + (KCConfig baseUrl realm _ _) <- ask + let opts = W.defaults & W.header "Authorization" .~ ["Bearer " <> (unToken tok)] + let url = (unpack $ baseUrl <> "/admin/realms/" <> realm <> "/" <> path) + info $ "Issuing KEYCLOAK GET with url: " ++ (show url) + debug $ " headers: " ++ (show $ opts ^. W.headers) + eRes <- C.try $ liftIO $ W.getWith opts url + case eRes of + Right res -> do + return $ fromJust $ res ^? responseBody + Left err -> do + warn $ "Keycloak HTTP error: " ++ (show err) + throwError $ HTTPError err + + +--------------- +-- * Helpers -- +--------------- + +debug, warn, info, err :: (MonadIO m) => String -> m () +debug s = liftIO $ debugM "API" s +info s = liftIO $ infoM "API" s +warn s = liftIO $ warningM "API" s +err s = liftIO $ errorM "API" s + +getErrorStatus :: KCError -> Maybe Status +getErrorStatus (HTTPError (HttpExceptionRequest _ (StatusCodeException r _))) = Just $ HC.responseStatus r +getErrorStatus _ = Nothing + +try :: MonadError a m => m b -> m (Either a b) +try act = catchError (Right <$> act) (return . Left) + diff --git a/src/Keycloak/Types.hs b/src/Keycloak/Types.hs new file mode 100644 --- /dev/null +++ b/src/Keycloak/Types.hs @@ -0,0 +1,290 @@ +{-# 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 diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"