diff --git a/frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs b/frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs index 133d97e..8b771e8 100644 --- a/frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs +++ b/frontend/src/Datarekisteri/Frontend/Handlers/Applications.hs @@ -115,12 +115,12 @@ applicationsW applications = do .#{detailsClass}[open] { border-color: #339ca1; } |] -getApplicationsR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +getApplicationsR :: Handler Html getApplicationsR = do Applications applications <- apiRequest @Applications True () defaultLayout $ applicationsW applications -postAcceptR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +postAcceptR :: Handler Html postAcceptR = do ((result, _), _) <- runFormPost $ resolveApplicationForm Nothing case result of @@ -128,7 +128,7 @@ postAcceptR = do _ -> pure () redirect ApplicationsR -postRejectR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +postRejectR :: Handler Html postRejectR = do ((result, _), _) <- runFormPost $ resolveApplicationForm Nothing case result of diff --git a/frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs b/frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs index ecf8589..e77950a 100644 --- a/frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs +++ b/frontend/src/Datarekisteri/Frontend/Handlers/Apply.hs @@ -75,12 +75,12 @@ applyW (applyWidget, applyEnctype) = do ^{form ApplyR applyEnctype formContent} |] -getApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +getApplyR :: Handler Html getApplyR = do applyForm <- liftHandler $ generateFormPost applyForm defaultLayout $ applyW applyForm -postApplyR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +postApplyR :: Handler Html postApplyR = do ((result, widget), enctype) <- runFormPost applyForm case result of diff --git a/frontend/src/Datarekisteri/Frontend/Handlers/Members.hs b/frontend/src/Datarekisteri/Frontend/Handlers/Members.hs index 8d2927e..99dbcbe 100644 --- a/frontend/src/Datarekisteri/Frontend/Handlers/Members.hs +++ b/frontend/src/Datarekisteri/Frontend/Handlers/Members.hs @@ -38,7 +38,7 @@ instance ToTableRow DataIdClient MembersPageUsers where tableHeader _ = toWidget <$> ["Nimi" :: Text, "Kutsumanimi", "Kotipaikka"] toCells MembersPageUsers {..} = toWidget <$> [name, nickname, homeplace] -getMembersR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +getMembersR :: Handler Html getMembersR = do MembersPage {..} <- apiRequest True () defaultLayout $ do diff --git a/frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs b/frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs index 7ff6919..505572b 100644 --- a/frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs +++ b/frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs @@ -119,7 +119,7 @@ profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) = ^{form route passwordEnctype passwordFormContent} |] -getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html +getProfile :: (Maybe UserID) -> Handler Html getProfile userID = do ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID}) passwordForm <- liftHandler $ generateFormPost passwordForm @@ -130,13 +130,13 @@ getProfile userID = do fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user" -getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +getOwnProfileR :: Handler Html getOwnProfileR = getProfile Nothing -getProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html +getProfileR :: UserID -> Handler Html getProfileR = getProfile . Just -postProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html +postProfileR :: UserID -> Handler Html postProfileR userID = do ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID}) ((result, widget), enctype) <- runFormPost $ profileForm (fromJust user) @@ -147,7 +147,7 @@ postProfileR userID = do defaultLayout $ profile (fromJust user) (widget, enctype) passwordForm --- XXX fromJust explodes if the user no longer exists -postUpdatePasswordR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => UserID -> Handler Html +postUpdatePasswordR :: UserID -> Handler Html postUpdatePasswordR userID = do ((result, widget), enctype) <- runFormPost passwordForm case result of diff --git a/frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs b/frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs index aee1f77..ca4a302 100644 --- a/frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs +++ b/frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs @@ -33,7 +33,7 @@ getVerifyEmailR = do codeForm <- generateFormPost verifyForm defaultLayout $ verifyEmailW codeForm -postVerifyEmailR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html +postVerifyEmailR :: Handler Html postVerifyEmailR = do ((result, widget), enctype) <- runFormPost verifyForm case result of diff --git a/frontend/src/Datarekisteri/Frontend/Types.hs b/frontend/src/Datarekisteri/Frontend/Types.hs index 62d7a73..0687f91 100644 --- a/frontend/src/Datarekisteri/Frontend/Types.hs +++ b/frontend/src/Datarekisteri/Frontend/Types.hs @@ -1,5 +1,6 @@ {-# LANGUAGE DeriveAnyClass #-} {-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} {-# LANGUAGE FlexibleContexts #-} {-# LANGUAGE MultiParamTypeClasses #-} {-# LANGUAGE OverloadedStrings #-} @@ -76,9 +77,6 @@ query GetPermissions { scope permission } - user { - id - } } |] @@ -86,19 +84,36 @@ declareLocalTypesInline "schema.gql" [raw| mutation GetWebUIToken { newToken(comment: "id.datat.fi webui") { tokenData + owner { + id + } } } |] +data UserToken = UserToken + { userID :: UserID + , token :: Text + } deriving (Read, Show) + +instance PathPiece UserToken where + toPathPiece userToken = show userToken + fromPathPiece s = readMaybe (toString s) + instance YesodAuth DataIdClient where - type AuthId DataIdClient = Text - maybeAuthId = lookupSession credsKey + type AuthId DataIdClient = UserToken + maybeAuthId = (>>= readMaybe . toString) <$> lookupSession credsKey loginDest = const HomeR logoutDest = const HomeR authPlugins = const $ [authExternalBasic getToken] - where getToken auth = (>>= fmap (tokenData . newToken) . rightToMaybe) <$> - apiRequestAuth @GetWebUIToken [] (Just auth) () - authenticate = pure . Authenticated . credsIdent + where getToken :: Text -> HandlerFor DataIdClient (Maybe Text) + getToken auth = do + response <- (>>= rightToMaybe) <$> apiRequestAuth @GetWebUIToken [] (Just auth) () + pure $ do + token <- tokenData . newToken <$> response + userID <- (\GetWebUITokenNewTokenOwner {..} -> id) . owner . newToken <$> response + pure $ show $ UserToken userID token + authenticate = pure . maybe (ServerError "Couldn't read UserToken") Authenticated . readMaybe . toString . credsIdent withAuthenticated :: (AuthId DataIdClient -> Handler AuthResult) -> Handler AuthResult withAuthenticated m = maybeAuthId >>= maybe (pure AuthenticationRequired) m @@ -109,14 +124,7 @@ readPermissions = Permissions . fromList . map (\GetPermissionsPermissions {..} hasPermission :: Scope -> Permission -> Handler Bool hasPermission scope permission = do GetPermissions {..} <- apiRequest @GetPermissions False () - let permissions' = readPermissions permissions - userID = (\x -> id (x :: GetPermissionsUser)) <$> user - scopes = scope :| case scope of - Tokens uid | Just uid == userID -> [OwnTokens] - Profile uid | Just uid == userID -> [OwnProfile] - _ -> [] - -- TODO add Members and Applications to Profile Scopes if profile owner is member/applicant - pure $ any (\scope -> Core.hasPermission scope permission permissions') scopes + pure $ Core.hasPermission scope permission $ readPermissions permissions requirePermission :: Scope -> Permission -> Handler AuthResult requirePermission scope permission = ifM (hasPermission scope permission) @@ -125,9 +133,7 @@ requirePermission scope permission = ifM (hasPermission scope permission) where renderPermission ReadWrite = "kirjoitusoikeuden" renderPermission ReadOnly = "lukuoikeuden" renderPermission None = "nollaoikeuden" - renderScope OwnProfile = "omaan profiliin" renderScope (Profile _) = "käyttäjän profiliin" - renderScope OwnTokens = "omiin tokeneihin" -- TODO kunnon suomennos renderScope (Tokens _) = "käyttäjän tokeneihin" -- TODO kunnon suomennos renderScope Members = "kaikkiin jäseniin" renderScope Applications = "jäsenhakemuksiin" @@ -146,7 +152,7 @@ instance Yesod DataIdClient where isAuthorized HomeR _ = pure Authorized isAuthorized ApplyR _ = pure Authorized isAuthorized VerifyEmailR _ = pure Authorized - isAuthorized OwnProfileR isWrite = withAuthenticated $ const $ authorizedHelper OwnProfile isWrite + isAuthorized OwnProfileR isWrite = withAuthenticated $ \UserToken {..} -> isAuthorized (ProfileR userID) isWrite isAuthorized (ProfileR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite isAuthorized (UpdatePasswordR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite @@ -308,7 +314,7 @@ fgColor = "#181c22" instance ApiRequest DataIdClient where getApiUrl = configServerUrl . getConfig <$> getYesod - authIdToAuthorization = flip const + authIdToAuthorization _ UserToken {..} = token instance RenderMessage DataIdClient FormMessage where renderMessage _ _ = defaultFormMessage