diff --git a/backend/src/Datarekisteri/Backend.hs b/backend/src/Datarekisteri/Backend.hs index d97ea38..75e6033 100644 --- a/backend/src/Datarekisteri/Backend.hs +++ b/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 diff --git a/backend/src/Datarekisteri/Backend/API.hs b/backend/src/Datarekisteri/Backend/API.hs index 33dae46..e7aa8e6 100644 --- a/backend/src/Datarekisteri/Backend/API.hs +++ b/backend/src/Datarekisteri/Backend/API.hs @@ -42,7 +42,7 @@ targetUser :: (MonadError GQLError m, MonadRequest m) => Maybe UserID -> m UserI targetUser = maybe (fromMaybeFail "No target user specified!" =<< currentUser) pure fromMaybeFail :: MonadError GQLError m => GQLError -> Maybe a -> m a -fromMaybeFail txt = maybe (throwError txt) pure +fromMaybeFail txt = maybe (throwError txt) pure voidU :: Monad m => m a -> m Unit voidU m = m >> pure Unit @@ -93,8 +93,8 @@ updateArgsToData UpdateArgs {..} user = do verificationSecret <- genVerificationSecret pure UpdateData {..} -updateUser :: (MonadRandom m, MonadDB m, MonadEmail m, MonadError GQLError m, MonadTime m) => - UserID -> UpdateArgs -> m (User m) +updateUser :: (MonadRandom m, MonadDB m, MonadEmail 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,25 +152,14 @@ 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 } resolveMutation :: (MonadRequest m, MonadEmail m, MonadRandom m, MonadTime m, MonadDB m, MonadError GQLError m, MonadPermissions m) => Mutation m resolveMutation = Mutation - { apply = newUser + { apply = newUser , verifyEmail = \(Arg secret) -> voidU $ dbVerifyEmail secret , resendVerificationEmail = \(Arg id) -> targetUser id >>= dbGetUserPendingEmail >>= liftDBEither >>= maybe (pure Unit) (dbGetUserByEmail >=> liftDBEither >=> voidU . sendVerificationSecret) @@ -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 diff --git a/backend/src/Datarekisteri/Backend/Sql.hs b/backend/src/Datarekisteri/Backend/Sql.hs index 6fe83ea..3202ca5 100644 --- a/backend/src/Datarekisteri/Backend/Sql.hs +++ b/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 diff --git a/backend/src/Datarekisteri/Backend/Types.hs b/backend/src/Datarekisteri/Backend/Types.hs index 4c13841..1bf3309 100644 --- a/backend/src/Datarekisteri/Backend/Types.hs +++ b/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 diff --git a/frontend/schema.gql b/frontend/schema.gql index e6be1f4..421d4a7 100644 --- a/frontend/schema.gql +++ b/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 {