Fix build with newer dependencies

.gitignore

@@ -1,2 +1,6 @@
 **/db/schema.sql
 **/client_session_key.aes
+**/*.o
+**/*.hi
+**/*.dyn_o
+**/*.dyn_hi

.guix/modules/datarekisteri-package.scm

@@ -7,6 +7,8 @@
   #:use-module ((guix licenses) #:prefix license:)
   #:use-module (guix packages)
   #:use-module (gnu packages golang)
+  #:use-module (gnu packages golang-xyz)
+  #:use-module (gnu packages golang-compression)
   #:use-module (gnu packages golang-check)
   #:use-module (gnu packages syncthing)
   #:use-module (gnu packages haskell)
@@ -759,7 +761,7 @@ README for more information.")
 (define-public go-github-com-jmoiron-sqlx
   (package
     (name "go-github-com-jmoiron-sqlx")
-    (version "1.3.5")
+    (version "1.4.0")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -768,7 +770,7 @@ README for more information.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "09snd3gfi3sm3gib7jdc6p8zxpn2ah0isqnibbag6f63k473yj14"))))
+                "10rg9b6cl1j7jjr6z95xa1k45016mhicii3cmz0pkwrxw3dpfzfh"))))
     (build-system go-build-system)
     (arguments
      '(#:import-path "github.com/jmoiron/sqlx"))
@@ -782,29 +784,29 @@ README for more information.")
      "Package sqlx provides general purpose extensions to database/sql.")
     (license license:expat)))
 
-(define-public go-github-com-pierrec-lz4
+(define-public go-github-com-bkaradzic-go-lz4
   (package
-    (name "go-github-com-pierrec-lz4")
-    (version "v2.0.5+incompatible")
-    (source (origin
-              (method git-fetch)
-              (uri (git-reference
-                    (url "https://github.com/pierrec/lz4")
-                    (commit (go-version->git-ref version))))
-              (file-name (git-file-name name version))
-              (sha256
-               (base32
-                "0y5rh7z01zycd59nnjpkqq0ydyjmcg9j1xw15q1i600l9j9g617p"))))
+    (name "go-github-com-bkaradzic-go-lz4")
+    (version "1.0.0")
+    (source
+     (origin
+       (method git-fetch)
+       (uri (git-reference
+             (url "https://github.com/bkaradzic/go-lz4")
+             (commit (string-append "v" version))))
+       (file-name (git-file-name name version))
+       (sha256
+        (base32 "1vdid8v0c2v2qhrg9rzn3l7ya1h34jirrxfnir7gv7w6s4ivdvc1"))))
     (build-system go-build-system)
     (arguments
-     '(#:import-path "github.com/pierrec/lz4"))
-    (home-page "https://github.com/pierrec/lz4")
-    (synopsis "lz4 : LZ4 compression in pure Go")
+     (list
+      #:import-path "github.com/bkaradzic/go-lz4"))
+    (home-page "https://github.com/bkaradzic/go-lz4")
+    (synopsis "go-lz4")
     (description
-     "Package lz4 implements reading and writing lz4 compressed data (a frame), as
-specified in
-@url{http://fastcompression.blogspot.fr/2013/04/lz4-streaming-format-final.html,http://fastcompression.blogspot.fr/2013/04/lz4-streaming-format-final.html}.")
-    (license license:bsd-3)))
+     "go-lz4 is port of LZ4 lossless compression algorithm to Go.  The original C code
+is located at:.")
+    (license license:bsd-2)))
 
 (define-public go-github-com-clickhouse-clickhouse-go
   (package
@@ -839,7 +841,7 @@ ClickHouse}")
 (define-public go-github-com-joho-godotenv
   (package
     (name "go-github-com-joho-godotenv")
-    (version "1.4.0")
+    (version "1.5.1")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -848,7 +850,7 @@ ClickHouse}")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1036h59vyhb58n817az6yg0zw5wa87yb86i7fnbdq8cw46mnjgw8"))))
+                "03vijs05k31jdf24pzj3vlk6b5jxf894v1kvzals4wzclyq2h3ch"))))
     (build-system go-build-system)
     (arguments
      '(#:import-path "github.com/joho/godotenv"))
@@ -859,9 +861,9 @@ ClickHouse}")
 (@url{https://github.com/bkeepers/dotenv,https://github.com/bkeepers/dotenv})")
     (license license:expat)))
 
-(define-public go-github-com-kami-zh-go-capturer
+(define-public go-github-com-zenizh-go-capturer
   (package
-    (name "go-github-com-kami-zh-go-capturer")
+    (name "go-github-com-zenizh-go-capturer")
     (version "0.0.0-20211219060012-52ea6c8fed04")
     (source (origin
               (method git-fetch)
@@ -874,8 +876,8 @@ ClickHouse}")
                 "0zwz9gr1863z32gz9nyysg66mg124w6nql4m99g2dg6fbq2klda4"))))
     (build-system go-build-system)
     (arguments
-     '(#:import-path "github.com/kami-zh/go-capturer"))
-    (home-page "https://github.com/kami-zh/go-capturer")
+     '(#:import-path "github.com/zenizh/go-capturer"))
+    (home-page "https://github.com/zenizh/go-capturer")
     (synopsis "go-capturer")
     (description
      "Capture @code{os.Stdout} and/or @code{os.Stderr} in Go.  This package is useful
@@ -885,7 +887,7 @@ for writing tests which print some outputs using @code{fmt} package.")
 (define-public go-github-com-cloudflare-golz4
   (package
     (name "go-github-com-cloudflare-golz4")
-    (version "0.0.0-20150217214814-ef862a3cdc58")
+    (version "0.0.0-20240916140612-caecf3c00c06")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -894,7 +896,7 @@ for writing tests which print some outputs using @code{fmt} package.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "0ckiwp3aa010sdnki6vd32f0n08768ppnggc8d7syzh3kkn9zvn1"))))
+                 "15nppvbav7kj3hh9qv9qbn15pd0c9lpljs5syl004cz6mif43as3"))))
     (build-system go-build-system)
     (arguments
      '(#:import-path "github.com/cloudflare/golz4"
@@ -904,53 +906,12 @@ for writing tests which print some outputs using @code{fmt} package.")
     (description "Package lz4 implements compression using lz4.c and lz4hc.c")
     (license license:bsd-3)))
 
-(define-public go-github-com-cpuguy83-go-md2man-v2
-  (package
-    (name "go-github-com-cpuguy83-go-md2man-v2")
-    (version "2.0.2")
-    (source (origin
-              (method git-fetch)
-              (uri (git-reference
-                    (url "https://github.com/cpuguy83/go-md2man")
-                    (commit (string-append "v" version))))
-              (file-name (git-file-name name version))
-              (sha256
-               (base32
-                "19qri18cinpzxblkid6ngz2vcxslv73s1aid900q0gfzvc71mqqb"))))
-    (build-system go-build-system)
-    (arguments
-     '(#:import-path "github.com/cpuguy83/go-md2man/v2"))
-    (propagated-inputs (list go-github-com-russross-blackfriday-v2))
-    (home-page "https://github.com/cpuguy83/go-md2man")
-    (synopsis "go-md2man")
-    (description "Converts markdown into roff (man pages).")
-    (license license:expat)))
 
-(define-public go-github-com-russross-blackfriday-v2
-  (package
-    (name "go-github-com-russross-blackfriday-v2")
-    (version "2.1.0")
-    (source (origin
-              (method git-fetch)
-              (uri (git-reference
-                    (url "https://github.com/russross/blackfriday")
-                    (commit (string-append "v" version))))
-              (file-name (git-file-name name version))
-              (sha256
-               (base32
-                "0d1rg1drrfmabilqjjayklsz5d0n3hkf979sr3wsrw92bfbkivs7"))))
-    (build-system go-build-system)
-    (arguments
-     '(#:import-path "github.com/russross/blackfriday/v2"))
-    (home-page "https://github.com/russross/blackfriday")
-    (synopsis "Blackfriday")
-    (description "Package blackfriday is a markdown processor.")
-    (license license:bsd-2)))
 
 (define-public dbmate
   (package
     (name "dbmate")
-    (version "1.15.0")
+    (version "1.16.2")
     (source (origin
               (method git-fetch)
               (uri (git-reference
@@ -959,22 +920,16 @@ for writing tests which print some outputs using @code{fmt} package.")
               (file-name (git-file-name name version))
               (sha256
                (base32
-                "1dbhm2aqppn4m55xnx18017shsy109hqv2nhksxb4ix83bjaq5vq"))))
+                "0mp06dg8x19pkbl51k0b5xj7bamaj6f61fyi0cfbd1dldwzw0676"))))
     (build-system go-build-system)
     (arguments
      '(#:import-path "github.com/amacneil/dbmate"))
     (propagated-inputs
-     (list go-gopkg-in-yaml-v3
-           go-github-com-russross-blackfriday-v2
-           go-github-com-pmezard-go-difflib
-           go-github-com-davecgh-go-spew
-           go-github-com-cpuguy83-go-md2man-v2
-           go-github-com-cloudflare-golz4
+     (list go-github-com-zenizh-go-capturer
            go-github-com-urfave-cli-v2
            go-github-com-stretchr-testify
            go-github-com-mattn-go-sqlite3
            go-github-com-lib-pq
-           go-github-com-kami-zh-go-capturer
            go-github-com-joho-godotenv
            go-github-com-go-sql-driver-mysql
            go-github-com-clickhouse-clickhouse-go))

backend/src/Datarekisteri/Backend.hs

@@ -114,7 +114,7 @@ authBearer Nothing m = m
 authBearer (Just (BearerToken bearer)) m = do
     let getUserPermissions = do
             Right DBToken {..} <- lift $ dbGetTokenBySecret bearer
-            permissions' <- fromMaybe mempty . readPermission <$> lift dbTokenPermissions
+            permissions' <- lift dbTokenPermissions
             DBUser {..} <- lift dbTokenUser
             userID <- lift dbUserId
             pure (Just userID, permissions')
@@ -140,8 +140,7 @@ authBasic :: Maybe BasicAuth -> ActionT LText APIM a -> ActionT LText APIM a
 authBasic Nothing m = m
 authBasic (Just basic) m = do
     DBUser {..} <- verifyBasic basic
-    permissions <- readPermission <$> lift dbUserPermissions >>=
-        fromMaybeFail status500 "Internal server error"
+    permissions <- lift dbUserPermissions
     userID <- lift dbUserId
     flip local m $ \state -> state
         { stateCurrentUser = Just userID
@@ -166,7 +165,7 @@ newtype APIM a = APIM (ReaderT RequestState IO a)
 
 data RequestState = RequestState
     { stateCurrentUser :: Maybe UserID
-    , statePermissions :: Map Scope Permission
+    , statePermissions :: Permissions
     , stateConfig :: Config
     }
 
@@ -214,28 +213,15 @@ instance MonadRandom APIM where
     getRandomBytes = liftIO . getRandomBytes
 
 instance MonadPermissions APIM where
-    currentPermissions = show <$> asks statePermissions
-    defaultPermissions = pure $ show $ (fromList [(OwnProfile, ReadWrite)] :: Map Scope Permission)
-    toPermissions = pure . fmap show . readPermission
-    hasPermission scope permission = (>= permission) <$> findPermission scope
-        where findPermission :: Scope -> APIM Permission
-              findPermission scope@(Profile user) = selfPermissions scope user OwnProfile
-              findPermission scope@(Tokens user) = selfPermissions scope user OwnTokens
-              findPermission scope = findPermission' scope <$> asks statePermissions
-              findPermission' :: Scope -> Map Scope Permission -> Permission
-              findPermission' = findWithDefault None
-              selfPermissions :: Scope -> UserID -> Scope -> APIM Permission
-              selfPermissions scope user own = do
-                  isSelf <- (Just user ==) <$> currentUser
-                  let f = if isSelf then max <$> findPermission' own <*> findPermission' scope
-                                    else findPermission' scope
-
-                  f <$> asks statePermissions
+    currentPermissions = asks statePermissions
+    defaultPermissions =
+        maybe mempty (\user -> Permissions $ fromList [(Profile user, ReadWrite)]) <$>
+            asks stateCurrentUser
 
 runAPIM :: Config -> APIM a -> IO a
 runAPIM config (APIM m) = runReaderT m RequestState
     { stateCurrentUser = Nothing
-    , statePermissions = fromList []
+    , statePermissions = Permissions $ fromList []
     , stateConfig = config
     }
 

backend/src/Datarekisteri/Backend/API.hs

@@ -24,6 +24,7 @@ import "cryptonite" Crypto.Random (getRandomBytes, MonadRandom)
 import qualified "base64" Data.ByteString.Base64 as B64
 
 import Control.Monad.Except (MonadError, throwError, catchError)
+import qualified Data.Map as Map
 import Data.Morpheus.Server (deriveApp, runApp)
 import Data.Morpheus.Server.Types (defaultRootResolver, RootResolver(..), Undefined)
 import Data.Morpheus.Types (Arg(..), GQLType, GQLError, App)
@@ -82,18 +83,24 @@ sendVerificationSecret DBUser {..} = do
           sendVerificationEmail secret' pendingEmail' >> pure True
       _ -> pure False
 
-updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m) =>
+updateArgsToData :: (MonadTime m, MonadRandom m, MonadError GQLError m, MonadDB m, MonadPermissions m) =>
     UpdateArgs -> UserID -> m UpdateData
 updateArgsToData UpdateArgs {..} user = do
     when (maybe False T.null name) $ throwError "Name must not be empty"
     when (maybe False T.null password) $ throwError "Password must not be empty"
     when (maybe False T.null homeplace) $ throwError "Homeplace must not be empty"
-    isMember <- dbGetUser user >>= liftDBEither >>= fmap isJust . dbUserAccepted
+    requestPermissions <- currentPermissions
+    let permissions' = inputPermissionsToPermissions <$> permissions
+    when (maybe False (> requestPermissions) permissions') $ throwError "Permissions must not be greater than the request's"
+    dbUser <- dbGetUser user >>= liftDBEither
+    isMember <- fmap isJust $ dbUserAccepted $ dbUser
     when (isMember && isJust application) $ throwError "Members can't update their applications"
     passwordHash <- sequence $ hashPassword <$> password
     updateTime <- currentTime
     verificationSecret <- genVerificationSecret
-    pure UpdateData {..}
+    oldPermissions <- dbUserPermissions dbUser
+    pure UpdateData {permissions = (<> oldPermissions) <$> permissions', ..}
+      -- Map's (and thus Permissions') <> prefers values from the left operand
 
 updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
     MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
@@ -108,7 +115,7 @@ newTokenArgsToData :: (MonadRandom m, MonadTime m, MonadPermissions m) =>
 newTokenArgsToData NewTokenArgs {..} user = do
     tokenData <- B64.encodeBase64 <$> getRandomBytes 128
     issued <- currentTime
-    permissions <- maybe currentPermissions pure =<< maybe (pure Nothing) toPermissions permissions
+    permissions <- maybe currentPermissions pure $ inputPermissionsToPermissions <$> permissions
     let expires = Nothing
     pure NewTokenData {..}
 
@@ -155,7 +162,7 @@ resolveQuery = Query
     , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
         (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
     , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
-    , permissions = currentPermissions
+    , permissions = fromPermissions <$> currentPermissions
     }
 
 resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m,
@@ -203,13 +210,14 @@ data UpdateArgs = UpdateArgs
     , nickname :: Maybe Text
     , homeplace :: Maybe Text
     , application :: Maybe Text
+    , permissions :: Maybe [InputScopePermission]
     } deriving (Generic, GQLType, Eq, Show)
 
 data NewKeyArgs = NewKeyArgs { comment :: Maybe Text, keyData :: Base64, expires :: Maybe Time }
     deriving (Generic, GQLType, Eq, Show)
 
 data NewTokenArgs = NewTokenArgs
-    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe Text }
+    { comment :: Maybe Text, name :: Maybe Text, permissions :: Maybe [InputScopePermission] }
     deriving (Generic, GQLType)
 
 data User m = User
@@ -223,7 +231,7 @@ data User m = User
     , homeplace :: m Text
     , registered :: m Time
     , accepted :: m (Maybe Time)
-    , permissions :: m Text
+    , permissions :: m [ScopePermission]
     , isMember :: m Bool
     , application :: m Text
     , tokens :: m [Token m]
@@ -246,14 +254,15 @@ data Token m = Token
     , comment :: m Text
     , issued :: m Time
     , expires :: m (Maybe Time)
-    , permissions :: m Text
+    , permissions :: m [ScopePermission]
+    , owner :: m (User m)
     } deriving (Generic, GQLType)
 
 data Query m = Query
     { users :: m [User m]
     , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
     , applications :: m [User m]
-    , permissions :: m Text
+    , permissions :: m [ScopePermission]
     } deriving (Generic, GQLType)
 
 data Mutation m = Mutation
@@ -279,7 +288,7 @@ dbUserToUser DBUser {..} = User
     , homeplace = dbUserHomeplace
     , registered = dbUserRegistered
     , accepted = dbUserAccepted
-    , permissions = dbUserPermissions
+    , permissions = fromPermissions <$> dbUserPermissions
     , isMember = isJust <$> dbUserAccepted
     , application = dbUserApplication
     , tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
@@ -296,7 +305,7 @@ dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
     , comment = dbPGPKeyComment
     }
 
-dbTokenToToken :: Monad m => DBToken m -> Token m
+dbTokenToToken :: (MonadPermissions m, MonadError GQLError m) => DBToken m -> Token m
 dbTokenToToken DBToken {..} = Token
     { id = dbTokenId
     , name = dbTokenName
@@ -304,5 +313,20 @@ dbTokenToToken DBToken {..} = Token
     , comment = dbTokenComment
     , issued = dbTokenIssued
     , expires = dbTokenExpires
-    , permissions = dbTokenPermissions
+    , permissions = fromPermissions <$> dbTokenPermissions
+    , owner = dbUserToUser <$> dbTokenUser
     }
+
+inputPermissionsToPermissions :: [InputScopePermission] -> Permissions
+inputPermissionsToPermissions = Permissions .
+    Map.fromList . map (\InputScopePermission {..} -> (scope, permission))
+
+fromPermissions :: Permissions -> [ScopePermission]
+fromPermissions (Permissions perms) =
+    map (\(scope, permission) -> ScopePermission scope permission) $ Map.toList perms
+
+data InputScopePermission = InputScopePermission {scope :: Scope, permission :: Permission}
+    deriving (Generic, GQLType, Eq, Show)
+
+data ScopePermission = ScopePermission {scope :: Scope, permission :: Permission}
+    deriving (Generic, GQLType)

backend/src/Datarekisteri/Backend/Sql.hs

@@ -31,7 +31,10 @@ dbUpdateUser UpdateData {..} = do
             , SetUserPhoneNumber <$> phoneNumber
             , SetUserApplication <$> application
             ]
-        userUpdates = maybeToList $ (SqlUserPasswordCrypt =.) <$> passwordHash
+        userUpdates = catMaybes
+            [ (SqlUserPasswordCrypt =.) <$> passwordHash
+            , (SqlUserPermissions =.) <$> permissions
+            ]
     sqlUser <- runQuery $ do
         Sql.updateUserData user userUpdates memberDataUpdates
         case email of

backend/src/Datarekisteri/Backend/Sql/Queries.hs

@@ -6,6 +6,7 @@
 
 module Datarekisteri.Backend.Sql.Queries where
 
+import Control.Monad (void)
 import Control.Monad.Logger (LoggingT)
 import Data.Aeson (fromJSON, toJSON, Result(..))
 import Data.Maybe (listToMaybe)
@@ -46,11 +47,11 @@ getKeys user = select $ do
 getKey :: KeyID -> SqlM (Maybe SqlKey)
 getKey = get . fromID
 
-getPermissions :: UserID -> SqlM (Maybe Text)
+getPermissions :: UserID -> SqlM (Maybe Permissions)
 getPermissions user = fmap (fmap sqlUserPermissions) $ get $ fromID user
 
-setPermissions :: UserID -> Text -> SqlM ()
-setPermissions user txt = updateUserData user [SqlUserPermissions Persist.=. txt] [] >> return ()
+setPermissions :: UserID -> Permissions -> SqlM ()
+setPermissions user permissions = void $ updateUserData user [SqlUserPermissions Persist.=. permissions] []
 
 getPrimaryKey :: UserID -> SqlM (Maybe (Entity SqlKey))
 getPrimaryKey user = fmap listToMaybe $ select $ do

backend/src/Datarekisteri/Backend/Sql/Types.hs

@@ -28,7 +28,7 @@ mkPersist sqlSettings [persistUpperCase|
 SqlUser sql=users
   registered Time
   passwordCrypt PasswordHash
-  permissions Text
+  permissions Permissions
   accepted (Maybe Time)
   memberData Value sqltype=jsonb
 
@@ -68,7 +68,7 @@ SqlToken sql=tokens
   comment Text
   issued Time
   expires (Maybe Time)
-  permissions Text
+  permissions Permissions
 
   UniqueNameUid name uid
   UniqueData data

backend/src/Datarekisteri/Backend/Types.hs

@@ -36,7 +36,7 @@ forward :: Monad m => [a] -> m [Maybe a]
 forward = pure . map Just
 
 requirePermission :: (MonadPermissions m, MonadError GQLError m) => Scope -> Permission -> m ()
-requirePermission scope permission = unlessM (hasPermission scope permission) $
+requirePermission scope permission = unlessM (hasPermission scope permission <$> currentPermissions) $
     throwError $ "Insufficient permissions, " <> show permission <> " for "
         <> show scope <> " required."
 
@@ -64,7 +64,7 @@ data ApplicationData = ApplicationData
     , registered :: Time
     , verificationSecret :: Text
     , passwordHash :: PasswordHash
-    , permissions :: Text
+    , permissions :: Permissions
     } deriving (Generic, Eq, Show)
 
 data UpdateData = UpdateData
@@ -78,6 +78,7 @@ data UpdateData = UpdateData
     , user :: UserID
     , updateTime :: Time
     , verificationSecret :: Text
+    , permissions :: Maybe Permissions
     } deriving (Generic, Eq, Show)
 
 data NewKeyData = NewKeyData
@@ -99,7 +100,7 @@ data Page a m = Page { pageData :: m a, cursor :: m (Maybe Cursor) }
 data NewTokenData = NewTokenData
     { comment :: Maybe Text
     , name :: Maybe Text
-    , permissions :: Text 
+    , permissions :: Permissions
     , tokenData :: Text
     , issued :: Time
     , expires :: Maybe Time
@@ -122,7 +123,7 @@ data DBUser m = DBUser
     , dbUserHomeplace :: m Text
     , dbUserRegistered :: m Time
     , dbUserAccepted :: m (Maybe Time)
-    , dbUserPermissions :: m Text
+    , dbUserPermissions :: m Permissions
     , dbUserApplication :: m Text
     , dbUserPasswordHash :: m PasswordHash
     , dbUserTokens :: m [DBToken m]
@@ -146,7 +147,7 @@ data DBToken m = DBToken
     , dbTokenComment :: m Text
     , dbTokenIssued :: m Time
     , dbTokenExpires :: m (Maybe Time)
-    , dbTokenPermissions :: m Text
+    , dbTokenPermissions :: m Permissions
     }
 
 class Monad m => MonadTime m where
@@ -180,10 +181,8 @@ class Monad m => MonadRequest m where
     currentUser :: m (Maybe UserID)
 
 class Monad m => MonadPermissions m where
-    hasPermission :: Scope -> Permission -> m Bool
-    currentPermissions :: m Text
-    defaultPermissions :: m Text
-    toPermissions :: Text -> m (Maybe Text)
+    currentPermissions :: m Permissions
+    defaultPermissions :: m Permissions
 
 instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
     dbUpdateUser = fmap (fmap liftUser) . lift . dbUpdateUser
@@ -204,10 +203,8 @@ instance (MonadRequest m, LiftOperation o) => MonadRequest (Resolver o () m) whe
     currentUser = lift currentUser
 
 instance (MonadPermissions m, LiftOperation o) => MonadPermissions (Resolver o () m) where
-    hasPermission scope permission = lift $ hasPermission scope permission
     defaultPermissions = lift defaultPermissions
     currentPermissions = lift currentPermissions
-    toPermissions = lift . toPermissions
 
 instance (MonadEmail m, LiftOperation o) => MonadEmail (Resolver o () m) where
     sendEmail = lift . sendEmail

backend/src/Datarekisteri/CLI.hs

@@ -43,7 +43,7 @@ addUserMain AddUserOpts {..} = do
         userID <- Sql.addUser $ SqlUser
             { sqlUserRegistered = time
             , sqlUserPasswordCrypt = passwordHash
-            , sqlUserPermissions = show addUserPermissions
+            , sqlUserPermissions = addUserPermissions
             , sqlUserAccepted = Just time
             , sqlUserMemberData = toJSON $ MemberData
                 { nickname = addUserNickname
@@ -82,7 +82,7 @@ updateUserMain UpdateUserOpts {..} = runQuery $ do
       Just application -> Sql.updateUserData updateUserId [] [Sql.SetUserApplication application]
     case updateUserPermissions of
       Nothing -> pure ()
-      Just permissions -> Sql.setPermissions updateUserId $ show permissions
+      Just permissions -> Sql.setPermissions updateUserId permissions
 
 cliOptions :: Parser CLIOptions
 cliOptions = CLIOptions
@@ -114,8 +114,8 @@ updateUserCommand = fmap UpdateUser $ UpdateUserOpts
     <*> optional (strOption (long "application" <> metavar "TEXT"))
     <*> optional permissionsParser
 
-permissionsParser :: Parser (Map Scope Permission)
-permissionsParser = fromList <$> many permissionParser
+permissionsParser :: Parser Permissions
+permissionsParser = Permissions . fromList <$> many permissionParser
 
 permissionParser :: Parser (Scope, Permission)
 permissionParser = (,)
@@ -136,7 +136,7 @@ data CLISubCommand = AddUser AddUserOpts
 data UpdateUserOpts = UpdateUserOpts
     { updateUserId :: UserID
     , updateUserApplication :: Maybe Text
-    , updateUserPermissions :: Maybe (Map Scope Permission)
+    , updateUserPermissions :: Maybe Permissions
     }
 
 data AddUserOpts = AddUserOpts
@@ -146,7 +146,7 @@ data AddUserOpts = AddUserOpts
         , addUserHomeplace :: Text
         , addUserPhoneNumber :: PhoneNumber
         , addUserEmail :: Email
-        , addUserPermissions :: Map Scope Permission
+        , addUserPermissions :: Permissions
         , addUserApplication :: Text
         }
 

channels.scm

@@ -3,7 +3,7 @@
         (url "https://git.savannah.gnu.org/git/guix.git")
         (branch "master")
         (commit
-          "a96f1c1bc0fa186414359890025e8acacbb1de02")
+          "faf8ba9b43323dc61988a368690b20008611fc87")
         (introduction
           (make-channel-introduction
             "9edb3f66fd807b096b48283debdcddccfea34bad"

core/datarekisteri-core.cabal

@@ -20,6 +20,7 @@ library
     morpheus-graphql-core,
     morpheus-graphql-server,
     persistent,
+    persistent-postgresql,
     relude,
     text,
     time,

core/src/Datarekisteri/Core/Types.hs

@@ -12,6 +12,7 @@ module Datarekisteri.Core.Types
     , Email
     , KeyID(..)
     , Permission(..)
+    , Permissions(..)
     , PhoneNumber
     , Scope(..)
     , Time(..)
@@ -21,7 +22,7 @@ module Datarekisteri.Core.Types
     , addTime
     , base64Decode
     , base64Encode
-    , readPermission
+    , hasPermission
     , renderDate
     , renderEmail
     , renderPhoneNumber
@@ -36,18 +37,22 @@ import Relude
 
 import qualified "base64" Data.ByteString.Base64 as B64
 
-import Data.Aeson (ToJSON(..), FromJSON(..))
+import Data.Aeson (Value, ToJSON(..), FromJSON(..), Result(..), ToJSONKey(..), FromJSONKey(..), FromJSONKeyFunction(..), ToJSONKeyFunction(..), fromJSON, eitherDecodeStrict)
+import Data.Aeson.Encoding (string)
 import Data.Char (isSpace)
-import Data.Morpheus.Server.Types (SCALAR)
+import qualified Data.Map as Map
+import Data.Morpheus.Server.Types (SCALAR, TYPE)
 import Data.Morpheus.Types (GQLType, DecodeScalar(..), KIND, EncodeScalar(..), ScalarValue(..))
 import Data.Morpheus.Types.GQLScalar (scalarToJSON, scalarFromJSON)
 import Data.Time (UTCTime, NominalDiffTime, addUTCTime, Day)
 import Data.Time.Format.ISO8601 (iso8601Show, iso8601ParseM)
 import Database.Persist.Class (PersistField(..))
 import Database.Persist.PersistValue (PersistValue(..))
+import Database.Persist.Postgresql.JSON () -- persistent instances for Aeson's Value
 import Database.Persist.Sql (PersistFieldSql(..))
 import Text.Email.Validate (EmailAddress, toByteString, validate, emailAddress)
 
+import qualified Data.Map as Map
 import qualified Data.Text as T
 
 base64Encode :: ByteString -> Base64
@@ -77,21 +82,63 @@ renderDate (Date x) = toText $ iso8601Show x
 addTime :: NominalDiffTime -> Time -> Time
 addTime diff (Time time) = Time $ addUTCTime diff time
 
-data Scope = OwnProfile
-           | OwnTokens
-           | Profile UserID
+data Scope = Profile UserID
            | Tokens UserID
            | Members
            | Applications
-           deriving (Show, Eq, Ord, Read)
+           deriving (Show, Eq, Ord, Read, Generic)
+
+instance DecodeScalar Scope where
+    decodeScalar (String s) = maybe (Left $ "invalid Scope: \"" <> s <> "\"") Right $ readMaybe (toString s)
+    decodeScalar _ = Left "Invalid type for Scope, should be string"
+
+instance EncodeScalar Scope where
+    encodeScalar = String . show
+
+instance GQLType Scope where type KIND Scope = SCALAR
+instance ToJSON Scope where toJSON = scalarToJSON
+instance FromJSON Scope where parseJSON = scalarFromJSON <=< parseJSON
+instance ToJSONKey Scope where toJSONKey = ToJSONKeyText (fromString . show) (string . show)
+instance FromJSONKey Scope
+    where fromJSONKey = FromJSONKeyTextParser $
+              either fail pure . (eitherDecodeStrict . encodeUtf8)
 
 data Permission = None
                 | ReadOnly
                 | ReadWrite
-                deriving (Show, Eq, Ord, Read)
+                deriving (Show, Eq, Ord, Read, Generic)
 
-readPermission :: Text -> Maybe (Map Scope Permission)
-readPermission = rightToMaybe . readEither . toString 
+instance DecodeScalar Permission where
+    decodeScalar (String s) = maybe (Left $ "invalid Permission: \"" <> s <> "\"") Right $ readMaybe (toString s)
+    decodeScalar _ = Left "Invalid type for Permission, should be string"
+
+instance EncodeScalar Permission where
+    encodeScalar = String . show
+
+instance GQLType Permission where type KIND Permission = SCALAR
+instance ToJSON Permission where toJSON = scalarToJSON
+instance FromJSON Permission where parseJSON = scalarFromJSON <=< parseJSON
+
+hasPermission :: Scope -> Permission -> Permissions -> Bool
+hasPermission scope permission (Permissions permissionMap) =
+    Map.findWithDefault None scope permissionMap >= permission
+
+newtype Permissions = Permissions (Map Scope Permission)
+    deriving (Show, Eq, Read, Generic, ToJSON, FromJSON, Semigroup, Monoid)
+
+instance GQLType Permissions where type KIND Permissions = TYPE
+
+instance PersistField Permissions where
+    toPersistValue = toPersistValue . toJSON
+    fromPersistValue = resultToEither . fromJSON <=< fromPersistValue
+        where resultToEither (Success x) = Right x
+              resultToEither (Error err) = Left $ T.pack err
+
+instance PersistFieldSql Permissions where sqlType _ = sqlType (Proxy :: Proxy Value)
+
+instance Ord Permissions where
+    (Permissions a) <= (Permissions b) =
+        and $ Map.intersectionWith (<=) a $ b <> (const None <$> Map.difference a b)
 
 newtype PhoneNumber = PhoneNumber Text deriving (Show, Generic)
 

frontend/schema.gql

@@ -6,8 +6,12 @@ scalar Email
 
 scalar KeyID
 
+scalar Permission
+
 scalar PhoneNumber
 
+scalar Scope
+
 scalar Time
 
 scalar TokenID
@@ -19,6 +23,11 @@ enum Unit {
   Unit2
 }
 
+input InputScopePermission {
+  scope: Scope!
+  permission: Permission!
+}
+
 type PGPKey {
   id: KeyID!
   pgpKeyData: Base64!
@@ -27,6 +36,11 @@ type PGPKey {
   comment: String!
 }
 
+type ScopePermission {
+  scope: Scope!
+  permission: Permission!
+}
+
 type Token {
   id: TokenID!
   name: String
@@ -34,7 +48,8 @@ type Token {
   comment: String!
   issued: Time!
   expires: Time
-  permissions: String!
+  permissions: [ScopePermission!]!
+  owner: User!
 }
 
 type User {
@@ -48,7 +63,7 @@ type User {
   homeplace: String!
   registered: Time!
   accepted: Time
-  permissions: String!
+  permissions: [ScopePermission!]!
   isMember: Boolean!
   application: String!
   tokens: [Token!]!
@@ -60,15 +75,15 @@ type Query {
   users: [User!]!
   user(id: UserID): User
   applications: [User!]!
-  permissions: String!
+  permissions: [ScopePermission!]!
 }
 
 type Mutation {
   apply(email: Email!, phoneNumber: PhoneNumber!, password: String!, name: String!, nickname: String, birthdate: Date!, homeplace: String!, application: String!): User!
   verifyEmail(secret: String!): Boolean!
   resendVerificationEmail(user: UserID): Unit!
-  update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, user: UserID): User!
-  newToken(comment: String, name: String, permissions: String): Token!
+  update(email: Email, phoneNumber: PhoneNumber, password: String, name: String, nickname: String, homeplace: String, application: String, permissions: [InputScopePermission!], user: UserID): User!
+  newToken(comment: String, name: String, permissions: [InputScopePermission!]): Token!
   newKey(comment: String, keyData: Base64!, expires: Time): PGPKey!
   accept(user: UserID!): Unit!
   reject(user: UserID!): Unit!

frontend/src/Datarekisteri/Frontend/Handlers.hs

@@ -9,7 +9,8 @@
 {-# LANGUAGE NoImplicitPrelude #-}
 
 module Datarekisteri.Frontend.Handlers
-    ( module Datarekisteri.Frontend.Handlers.Profile
+    ( module Datarekisteri.Frontend.Handlers.Permissions
+    , module Datarekisteri.Frontend.Handlers.Profile
     , module Datarekisteri.Frontend.Handlers.Applications
     , module Datarekisteri.Frontend.Handlers.Apply
     , module Datarekisteri.Frontend.Handlers.Members
@@ -23,6 +24,7 @@ import Yesod
 import Yesod.Auth
 
 import Datarekisteri.Frontend.Handlers.Profile
+import Datarekisteri.Frontend.Handlers.Permissions
 import Datarekisteri.Frontend.Handlers.Apply
 import Datarekisteri.Frontend.Handlers.Applications
 import Datarekisteri.Frontend.Handlers.VerifyEmail
@@ -30,4 +32,4 @@ import Datarekisteri.Frontend.Handlers.Members
 import Datarekisteri.Frontend.Types
 
 getHomeR :: Handler Html
-getHomeR = ifM (isJust <$> maybeAuthId) (redirect OwnProfileR) (redirect $ AuthR LoginR)
+getHomeR = maybeAuthId >>= maybe (redirect $ AuthR LoginR) (redirect . ProfileR . userID)

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/Permissions.hs

@@ -0,0 +1,62 @@
+{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
+{-# LANGUAGE FlexibleContexts #-}
+{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE QuasiQuotes #-}
+{-# LANGUAGE RecordWildCards #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeApplications #-}
+{-# LANGUAGE TypeFamilies #-}
+
+{-# LANGUAGE NoImplicitPrelude #-}
+
+module Datarekisteri.Frontend.Handlers.Permissions where
+
+import Relude hiding (id)
+
+import Data.Morpheus.Client (raw, declareLocalTypesInline)
+
+import Yesod
+import Yesod.Auth
+
+import Datarekisteri.Core.Types
+import Datarekisteri.Frontend.ApiRequests
+import Datarekisteri.Frontend.Types
+import Datarekisteri.Frontend.Widgets
+
+declareLocalTypesInline "schema.gql" [raw|
+query PermissionsPage($id: UserID!) {
+  user(id: $id) {
+    id
+    name
+    nickname
+    permissions {
+      scope
+      permission
+    }
+  }
+}
+|]
+
+-- declareLocalTypesInline "schema.gql" [raw|
+-- mutation UpdatePermissions($user: UserID, $permissions: [InputScopePermission!]!) {
+--   update(user: $user, permissions: $permissions) {
+--     id
+--   }
+-- }
+-- |]
+
+getPermissionsR :: UserID -> Handler Html
+getPermissionsR userID = defaultLayout $ do
+    PermissionsPage {..} <- liftHandler $ apiRequest True (PermissionsPageArgs {id = userID})
+    PermissionsPageUser {..} <- maybe undefined pure user
+    let permissions' = (\PermissionsPageUserPermissions {..} -> (show scope, show permission) :: (Text, Text)) <$> permissions
+    setTitle "Käyttöoikeudet"
+    [whamlet|
+        <h1>
+            Käyttöoikeudet
+        ^{keyValueTable permissions'}
+    |]
+
+postPermissionsR :: UserID -> Handler Html
+postPermissionsR = undefined

frontend/src/Datarekisteri/Frontend/Handlers/Profile.hs

@@ -26,7 +26,7 @@ import Datarekisteri.Frontend.FormFields
 import Datarekisteri.Frontend.Widgets
 
 declareLocalTypesInline "schema.gql" [raw|
-query ProfilePage($id: UserID) {
+query ProfilePage($id: UserID!) {
   user(id: $id) {
     id
     name
@@ -39,7 +39,6 @@ query ProfilePage($id: UserID) {
     isMember
     application
   }
-  permissions
 }
 |]
 
@@ -120,8 +119,8 @@ profile user (profileWidget, profileEnctype) (passwordWidget, passwordEnctype) =
             ^{form route passwordEnctype passwordFormContent}
     |]
 
-getProfile :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => (Maybe UserID) -> Handler Html
-getProfile userID = do
+getProfileR :: UserID -> Handler Html
+getProfileR userID = do
     ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
     passwordForm <- liftHandler $ generateFormPost passwordForm
     profileForm <- liftHandler $ generateFormPost $
@@ -131,15 +130,9 @@ getProfile userID = do
 
 fromJust = fromMaybe $ error "Tried to access the profile of an inexistent user"
 
-getOwnProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => Handler Html
-getOwnProfileR = getProfile Nothing
-
-getProfileR :: (YesodAuth DataIdClient, AuthId DataIdClient ~ Text) => 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})
+    ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
     ((result, widget), enctype) <- runFormPost $ profileForm (fromJust user)
     case result of
       FormSuccess update -> apiRequest @UpdateProfile True update >> redirect (ProfileR userID)
@@ -148,14 +141,14 @@ 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
       FormSuccess new ->
           apiRequest @UpdatePassword True (UpdatePasswordArgs {password = new, user = Just userID}) >> redirect (ProfileR userID)
       _ -> do
-          ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = Just userID})
+          ProfilePage {..} <- apiRequest True (ProfilePageArgs {id = userID})
           profileForm <- liftHandler $ generateFormPost $ profileForm (fromJust user)
           defaultLayout $ profile (fromJust user) profileForm (widget, enctype)
           --- XXX fromJust explodes if the user no longer exists

frontend/src/Datarekisteri/Frontend/Handlers/VerifyEmail.hs

@@ -33,14 +33,17 @@ 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
       FormSuccess verify -> do
           success <- apiRequest @VerifyEmail False verify
           case success of
-            VerifyEmail True -> setMessage "Sähköpostiosoite vahvistettu" >> redirect OwnProfileR
+            VerifyEmail True -> do
+                setMessage "Sähköpostiosoite vahvistettu"
+                user <- userID <$> requireAuthId
+                redirect $ ProfileR user
             VerifyEmail False -> setMessage "Virheellinen vahvistuskoodi" >> redirect VerifyEmailR
       _ -> defaultLayout $ verifyEmailW (widget, enctype)
 

frontend/src/Datarekisteri/Frontend/Types.hs

@@ -1,5 +1,6 @@
 {-# LANGUAGE DeriveAnyClass #-}
 {-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE MultiParamTypeClasses #-}
 {-# LANGUAGE OverloadedStrings #-}
@@ -29,10 +30,12 @@ import Yesod
 import Yesod.Auth
 import Yesod.Static
 
-import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), readPermission)
+import Datarekisteri.Core.Types (UserID(..), Scope(..), Permission(..), Permissions(..))
 import Datarekisteri.Frontend.ApiRequests
 import Datarekisteri.Frontend.Auth
 
+import qualified Datarekisteri.Core.Types as Core
+
 data DataIdClient = DataIdClient
     { getStatic :: Static
     , getConfig :: Config
@@ -51,8 +54,8 @@ instance PathPiece UserID where
 mkYesodData "DataIdClient" [parseRoutes|
 / HomeR GET
 
-/profile OwnProfileR GET
-/profile/#UserID ProfileR GET POST
+/user/#UserID/profile ProfileR GET POST
+/user/#UserID/permissions PermissionsR GET POST
 /update-password/#UserID UpdatePasswordR POST
 /verify-email VerifyEmailR GET POST
 
@@ -70,9 +73,9 @@ mkYesodData "DataIdClient" [parseRoutes|
 
 declareLocalTypesInline "schema.gql" [raw|
 query GetPermissions {
-  permissions
-  user {
-    id
+  permissions {
+    scope
+    permission
   }
 }
 |]
@@ -81,35 +84,47 @@ 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
 
+readPermissions :: [GetPermissionsPermissions] -> Permissions
+readPermissions = Permissions . fromList . map (\GetPermissionsPermissions {..} -> (scope, permission))
+
 hasPermission :: Scope -> Permission -> Handler Bool
 hasPermission scope permission = do
     GetPermissions {..} <- apiRequest @GetPermissions False ()
-    let permissionMap = fromMaybe mempty $ readPermission permissions
-        findPermission scope = findWithDefault None scope permissionMap
-        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 $ (>= permission) $ maximum1 $ findPermission <$> scopes
+    pure $ Core.hasPermission scope permission $ readPermissions permissions
 
 requirePermission :: Scope -> Permission -> Handler AuthResult
 requirePermission scope permission = ifM (hasPermission scope permission)
@@ -118,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"
@@ -139,7 +152,6 @@ 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 (ProfileR user) isWrite = withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
     isAuthorized (UpdatePasswordR user) isWrite =
         withAuthenticated $ const $ authorizedHelper (Profile user) isWrite
@@ -191,8 +203,10 @@ instance Yesod DataIdClient where
                 |]
             navigationBar :: Widget
             navigationBar = do
+                maybeUser <- fmap userID <$> maybeAuthId
                 applicationsRoute <- handlerToWidget $ maybeAuthorized ApplicationsR False
-                profileRoute <- handlerToWidget $ maybeAuthorized OwnProfileR False
+                profileRoute <- handlerToWidget $ maybe (pure Nothing)
+                    (\user -> maybeAuthorized (ProfileR user) False) maybeUser
                 membersRoute <- handlerToWidget $ maybeAuthorized MembersR False
                 currentRoute <- getCurrentRoute
                 loggedIn <- isJust <$> maybeAuthId
@@ -301,7 +315,7 @@ fgColor = "#181c22"
 
 instance ApiRequest DataIdClient where
     getApiUrl = configServerUrl . getConfig <$> getYesod
-    authIdToAuthorization = flip const
+    authIdToAuthorization _ UserToken {..} = token
 
 instance RenderMessage DataIdClient FormMessage where
     renderMessage _ _ = defaultFormMessage