FIXUP Remove Own{Profile,Tokens} from Client

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

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

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

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

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

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
+    type AuthId DataIdClient = UserToken
-    maybeAuthId = lookupSession credsKey
+    maybeAuthId = (>>= readMaybe . toString) <$> lookupSession credsKey
     loginDest = const HomeR
     logoutDest = const HomeR
     authPlugins = const $ [authExternalBasic getToken]
-        where getToken auth = (>>= fmap (tokenData . newToken) . rightToMaybe) <$>
+        where getToken :: Text -> HandlerFor DataIdClient (Maybe Text)
-                      apiRequestAuth @GetWebUIToken [] (Just auth) ()
+              getToken auth = do
-    authenticate = pure . Authenticated . credsIdent
+                  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
+    pure $ Core.hasPermission scope permission $ 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
 
 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