Update API schema to make better use of graphql

backend/src/Datarekisteri/Backend.hs

@@ -193,9 +193,6 @@ instance MonadDB APIM where
     dbGetUser = Sql.dbGetUser
     dbGetUserByEmail = Sql.dbGetUserByEmail
     dbGetUsers = Sql.dbGetUsers
-    dbGetUserTokens = Sql.dbGetUserTokens
-    dbGetUserKeys = Sql.dbGetUserKeys
-    dbGetUserPrimaryKey = Sql.dbGetUserPrimaryKey
     dbGetApplications = Sql.dbGetApplications
     dbGetEmailVerificationSecret = Sql.dbGetEmailVerificationSecret
     dbGetTokenBySecret = Sql.dbGetTokenBySecret

backend/src/Datarekisteri/Backend/API.hs

@@ -93,8 +93,8 @@ updateArgsToData UpdateArgs {..} user = do
     verificationSecret <- genVerificationSecret
     pure UpdateData {..}
 
-updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) =>
+updateUser :: (MonadRandom m, MonadDB m, MonadEmail m,
-    UserID -> UpdateArgs -> m (User m)
+    MonadError GQLError m, MonadTime m, MonadPermissions m) => UserID -> UpdateArgs -> m (User m)
 updateUser user args = do
     updateData@(UpdateData {..}) <- updateArgsToData args user
     updatedUser <- dbUpdateUser updateData >>= liftDBEither
@@ -152,18 +152,7 @@ resolveQuery = Query
     { users = requirePermission Members ReadOnly >> map dbUserToUser <$> dbGetUsers
     , user = \(Arg id) -> targetUser id >>= \user -> requirePermission (Profile user) ReadOnly >>
         (Just . dbUserToUser <$> (dbGetUser user >>= liftDBEither)) `catchError` const (pure Nothing)
-    , tokens = \(Arg id) -> targetUser id >>= \user -> do
-        requirePermission (Tokens user) ReadOnly
-        map dbTokenToToken <$> (dbGetUserTokens user >>= liftDBEither)
     , applications = requirePermission Applications ReadOnly >> map dbUserToUser <$> dbGetApplications
-    , keys = \(Arg id) -> targetUser id >>= \user -> do
-        requirePermission (Profile user) ReadOnly 
-        map dbPGPKeyToPGPKey <$> (dbGetUserKeys user >>= liftDBEither)
-    --, key = \(Arg id) -> resolve (pure id)
-    -- TODO is this actually useful
-    , primaryKey = \(Arg id) -> targetUser id >>= \user -> do
-        requirePermission (Profile user) ReadOnly
-        fmap dbPGPKeyToPGPKey <$> (dbGetUserPrimaryKey user >>= liftDBEither)
     , permissions = currentPermissions
     }
 
@@ -234,11 +223,13 @@ data User m = User
     , permissions :: m Text
     , isMember :: m Bool
     , application :: m Text
+    , tokens :: m [Token m]
+    , keys :: m [PGPKey m]
+    , primaryKey :: m (Maybe (PGPKey m))
     } deriving (Generic, GQLType)
 
 data PGPKey m = PGPKey
     { id :: m KeyID
-    , user :: m (User m)
     , pgpKeyData :: m Base64
     , expires :: m (Maybe Time)
     , uploaded :: m Time
@@ -247,7 +238,6 @@ data PGPKey m = PGPKey
 
 data Token m = Token
     { id :: m TokenID
-    , user :: m (User m)
     , name :: m (Maybe Text)
     , tokenData :: m Text
     , comment :: m Text
@@ -260,11 +250,7 @@ data Query m = Query
     { users :: m [User m]
     , user :: Arg "id" (Maybe UserID) -> m (Maybe (User m))
     , applications :: m [User m]
-    , tokens :: Arg "user" (Maybe UserID) -> m [Token m]
-    , keys :: Arg "user" (Maybe UserID) -> m [PGPKey m]
     , permissions :: m Text
-    --, key :: Arg "id" KeyID -> m (PGPKey m)
-    , primaryKey :: Arg "user" (Maybe UserID) -> m (Maybe (PGPKey m))
     } deriving (Generic, GQLType)
 
 data Mutation m = Mutation
@@ -278,7 +264,7 @@ data Mutation m = Mutation
     , reject :: Arg "user" UserID -> m Unit
     } deriving (Generic, GQLType)
 
-dbUserToUser :: Monad m => DBUser m -> User m
+dbUserToUser :: (MonadPermissions m, MonadError GQLError m) => DBUser m -> User m
 dbUserToUser DBUser {..} = User
     { id = dbUserId
     , email = dbUserEmail
@@ -293,12 +279,14 @@ dbUserToUser DBUser {..} = User
     , permissions = dbUserPermissions
     , isMember = isJust <$> dbUserAccepted
     , application = dbUserApplication
+    , tokens = dbUserId >>= flip requirePermission ReadOnly . Tokens >> map dbTokenToToken <$> dbUserTokens
+    , keys = map dbPGPKeyToPGPKey <$> dbUserKeys
+    , primaryKey = fmap dbPGPKeyToPGPKey <$> dbUserPrimaryKey
     }
 
 dbPGPKeyToPGPKey :: Monad m => DBPGPKey m -> PGPKey m
 dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
     { id = dbPGPKeyId
-    , user = dbUserToUser <$> dbPGPKeyUser
     , pgpKeyData = dbPGPKeyData
     , expires = dbPGPKeyExpires
     , uploaded = dbPGPKeyUploaded
@@ -308,7 +296,6 @@ dbPGPKeyToPGPKey DBPGPKey {..} = PGPKey
 dbTokenToToken :: Monad m => DBToken m -> Token m
 dbTokenToToken DBToken {..} = Token
     { id = dbTokenId
-    , user = dbUserToUser <$> dbTokenUser
     , name = dbTokenName
     , tokenData = dbTokenData
     , comment = dbTokenComment

backend/src/Datarekisteri/Backend/Sql.hs

@@ -175,6 +175,9 @@ sqlUserToDBUser userID SqlUser {..} =
          , dbUserAccepted = pure sqlUserAccepted
          , dbUserPermissions = pure sqlUserPermissions
          , dbUserPasswordHash = pure sqlUserPasswordCrypt
+         , dbUserTokens = fmap (map entityToDBToken) $ runQuery $ Sql.getUserTokens userID
+         , dbUserKeys = fmap (map entityToDBKey) $ runQuery $ Sql.getKeys userID
+         , dbUserPrimaryKey = fmap (fmap entityToDBKey) $ runQuery $ Sql.getPrimaryKey userID
          }
 
 entityToDBToken :: MonadSql m => Entity SqlToken -> DBToken m
@@ -201,10 +204,6 @@ entityToDBKey (Entity keyKey sqlKey) = sqlKeyToDBKey (toID keyKey) sqlKey
 sqlKeyToDBKey :: MonadSql m => KeyID -> SqlKey -> DBPGPKey m
 sqlKeyToDBKey keyID SqlKey {..} = DBPGPKey
     { dbPGPKeyId = pure keyID
-    , dbPGPKeyUser = 
-        let userID = toID sqlKeyUid
-         in fmap (sqlUserToDBUser userID . fromMaybe (error "Inconsistent DB at sqlKeyToDBKey!")) $
-             runQuery $ Sql.getUser userID
     , dbPGPKeyData = pure $ base64Encode sqlKeyData
     , dbPGPKeyExpires = pure sqlKeyExpires
     , dbPGPKeyUploaded = pure sqlKeyUploaded

backend/src/Datarekisteri/Backend/Types.hs

@@ -124,11 +124,13 @@ data DBUser m = DBUser
     , dbUserPermissions :: m Text
     , dbUserApplication :: m Text
     , dbUserPasswordHash :: m PasswordHash
+    , dbUserTokens :: m [DBToken m]
+    , dbUserKeys :: m [DBPGPKey m]
+    , dbUserPrimaryKey :: m (Maybe (DBPGPKey m))
     }
 
 data DBPGPKey m = DBPGPKey
     { dbPGPKeyId :: m KeyID
-    , dbPGPKeyUser :: m (DBUser m)
     , dbPGPKeyData :: m Base64
     , dbPGPKeyExpires :: m (Maybe Time)
     , dbPGPKeyUploaded :: m Time
@@ -165,9 +167,6 @@ class Monad m => MonadDB m where
     dbGetUser :: UserID -> m (DBEither (DBUser m))
     dbGetUserByEmail :: Email -> m (DBEither (DBUser m)) -- XXX should this be Maybe instead
     dbGetUsers :: m [DBUser m]
-    dbGetUserTokens :: UserID -> m (DBEither [DBToken m])
-    dbGetUserKeys :: UserID -> m (DBEither [DBPGPKey m])
-    dbGetUserPrimaryKey :: UserID -> m (DBEither (Maybe (DBPGPKey m)))
     dbGetApplications :: m [DBUser m]
     dbGetTokenBySecret :: Text -> m (DBEither (DBToken m))
     dbGetEmailVerificationSecret :: UserID -> m (DBEither (Maybe Text))
@@ -196,9 +195,6 @@ instance (MonadDB m, LiftOperation o) => MonadDB (Resolver o () m) where
     dbGetUser = fmap (fmap liftUser) . lift . dbGetUser
     dbGetUserByEmail = fmap (fmap liftUser) . lift . dbGetUserByEmail
     dbGetUsers = fmap (map liftUser) $ lift $ dbGetUsers
-    dbGetUserTokens = fmap (fmap (map liftToken)) . lift . dbGetUserTokens
-    dbGetUserKeys = fmap (fmap (map liftKey)) . lift . dbGetUserKeys
-    dbGetUserPrimaryKey = fmap (fmap (fmap liftKey)) . lift . dbGetUserPrimaryKey
     dbGetApplications = fmap (map liftUser) $ lift $ dbGetApplications
     dbGetEmailVerificationSecret = lift . dbGetEmailVerificationSecret
     dbGetTokenBySecret = fmap (fmap liftToken) . lift . dbGetTokenBySecret
@@ -222,7 +218,7 @@ instance (MonadRandom m, LiftOperation o) => MonadRandom (Resolver o () m) where
 instance (MonadTime m, LiftOperation o) => MonadTime (Resolver o () m) where
     currentTime = lift currentTime
 
-liftUser :: (MonadTrans t, Monad m) => DBUser m -> DBUser (t m)
+liftUser :: (MonadTrans t, Monad m, Monad (t m)) => DBUser m -> DBUser (t m)
 liftUser DBUser {..} = DBUser
     { dbUserId = lift dbUserId
     , dbUserEmail = lift dbUserEmail
@@ -237,6 +233,9 @@ liftUser DBUser {..} = DBUser
     , dbUserPermissions = lift dbUserPermissions
     , dbUserApplication = lift dbUserApplication
     , dbUserPasswordHash = lift dbUserPasswordHash
+    , dbUserTokens = map liftToken <$> lift dbUserTokens
+    , dbUserKeys = map liftKey <$> lift dbUserKeys
+    , dbUserPrimaryKey = fmap liftKey <$> lift dbUserPrimaryKey
     }
 
 liftToken :: (MonadTrans t, Monad m, Monad (t m)) => DBToken m -> DBToken (t m)
@@ -254,7 +253,6 @@ liftToken DBToken {..} = DBToken
 liftKey :: (MonadTrans t, Monad m, Monad (t m)) => DBPGPKey m -> DBPGPKey (t m)
 liftKey DBPGPKey {..} = DBPGPKey
     { dbPGPKeyId = lift dbPGPKeyId
-    , dbPGPKeyUser = fmap liftUser $ lift dbPGPKeyUser
     , dbPGPKeyData = lift dbPGPKeyData
     , dbPGPKeyExpires = lift dbPGPKeyExpires
     , dbPGPKeyUploaded = lift dbPGPKeyUploaded

frontend/schema.gql

@@ -21,7 +21,6 @@ enum Unit {
 
 type PGPKey {
   id: KeyID!
-  user: User!
   pgpKeyData: Base64!
   expires: Time
   uploaded: Time!
@@ -30,7 +29,6 @@ type PGPKey {
 
 type Token {
   id: TokenID!
-  user: User!
   name: String
   tokenData: String!
   comment: String!
@@ -53,16 +51,16 @@ type User {
   permissions: String!
   isMember: Boolean!
   application: String!
+  tokens: [Token!]!
+  keys: [PGPKey!]!
+  primaryKey: PGPKey
 }
 
 type Query {
   users: [User!]!
   user(id: UserID): User
   applications: [User!]!
-  tokens(user: UserID): [Token!]!
-  keys(user: UserID): [PGPKey!]!
   permissions: String!
-  primaryKey(user: UserID): PGPKey
 }
 
 type Mutation {