query related errors are now returned as json

src/Server.hs

@@ -3,7 +3,16 @@
 --
 -- SPDX-License-Identifier: AGPL-3.0-or-later
 
-{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards, AllowAmbiguousTypes #-}
+{-# LANGUAGE
+      DataKinds
+    , TypeOperators
+    , OverloadedStrings
+    , ScopedTypeVariables
+    , TypeApplications
+    , RecordWildCards
+    , AllowAmbiguousTypes
+    , LambdaCase
+#-}
 
 module Server
 {-( insecureOAuthMock'
@@ -214,18 +223,16 @@ instance Error Text where
 
 
 type Token = "token"
-          :> ReqBody '[FormUrlEncoded] Form --ClientData
+          :> ReqBody '[FormUrlEncoded] ClientData
           :> Post '[JSON] JWTWrapper
 
 
 tokenEndpoint :: forall user userData . UserData user userData => AuthServer user Token
 tokenEndpoint = provideToken
   where
-    provideToken :: Form -> AuthHandler user JWTWrapper
+    provideToken :: ClientData -> AuthHandler user JWTWrapper
-    provideToken clienty = do
+    provideToken client = do
-      liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show clienty
+      liftIO . putStrLn $ "Mock Server: received client data @ /token: " ++ show client
-      liftIO . print $ fromForm @ClientData clienty
-      let Right client = fromForm @ClientData clienty
       unless (isNothing (clientID client >> clientSecret client)
         || Client (pack . fromJust $ clientID client) (pack . fromJust $ clientSecret client) `elem` trustedClients) .
           throwError $ err500 { errBody = "Invalid client" }
@@ -243,7 +250,6 @@ tokenEndpoint = provideToken
           unless (grantType client == "refresh_token") . throwError $ err500 { errBody = "Invalid grant_type" }
           liftIO $ putStrLn "... checking refresh token"
           mToken <- asks (renewToken @user jwtw) >>= liftIO
-          liftIO $ putStrLn "woohoo"
           case mToken of
             Just token -> liftIO (putStrLn $ "refreshed token: " ++ show token) >> return token
             Nothing -> throwError $ err500 { errBody = "Invalid refresh token" }
@@ -260,13 +266,23 @@ type HeaderR = Header' [Strict, Required]
 type Me userData = Users
                 :> "me"
                 :> HeaderR "Authorization" Text
-                :> Get '[JSON] (Maybe userData)
+                :> Get '[JSON] (QueryResult userData)
 
 type UserList userData = Users
                       :> "query"
                       :> HeaderR "Authorization" Text
                       :> QParam "id" Text
-                      :> Get '[JSON] [userData]
+                      :> Get '[JSON] (QueryResult [userData])
+
+data QueryResult result = QLeft QueryError | QRight result
+newtype QueryError = QError Text
+
+instance ToJSON QueryError where
+  toJSON (QError code) = object ["error" .= object ["code" .= code]]
+
+instance ToJSON result => ToJSON (QueryResult result) where
+  toJSON (QLeft x) = toJSON x
+  toJSON (QRight x) = toJSON x
 
 
 verifyToken :: forall user userData . UserData user userData => Text -> AuthHandler user (Maybe (user, [Scope user]))
@@ -287,26 +303,21 @@ verifyToken jwtw = do
 userEndpoint :: forall user userData . UserData user userData => AuthServer user (Me userData)
 userEndpoint = handleUserData
   where
-    handleUserData :: Text -> AuthHandler user (Maybe userData)
+    handleUserData :: Text -> AuthHandler user (QueryResult userData)
-    handleUserData jwtw = do
+    handleUserData jwtw = verifyToken @user @userData jwtw >>= \case
-      mUser <- verifyToken @user @userData jwtw
+      Just (u, scopes) -> return . QRight . mconcat $ map (userScope @user @userData u) scopes
-      case mUser of
+      Nothing -> return . QLeft $ QError "UnknownToken"
-        Just (u, scopes) -> return . Just . mconcat $ map (userScope @user @userData u) scopes
-        Nothing -> throwError $ err500 { errBody = "Unknown token" }
       
 
 userListEndpoint :: forall user userData . UserData user userData => AuthServer user (UserList userData)
 userListEndpoint = handleUserData
   where
-    handleUserData :: Text -> Text -> AuthHandler user [userData]
+    handleUserData :: Text -> Text -> AuthHandler user (QueryResult [userData])
-    handleUserData jwtw userID = do
+    handleUserData jwtw userID = verifyToken @user @userData jwtw >>= \case -- TODO check if this user is allowed query other users
-      mAdmin <- verifyToken @user @userData jwtw
+      Nothing -> return . QLeft $ QError "UnknownToken"
-      unless (isJust mAdmin) . throwError $ err500 { errBody = "Unknown token" }
+      Just admin -> liftIO $ lookupUser @user @userData userID Nothing >>= \case
-      -- TODO check if this user is allowed query other users
+        Just u -> return $ QRight [mconcat $ map (userScope @user @userData u) (snd admin)] -- TODO support queries that fit for multiple users
-      mUser <- liftIO $ lookupUser @user @userData userID Nothing
+        Nothing -> return . QLeft $ QError "UserDoesNotExist"
-      case mUser of
-        Just u -> return [mconcat $ map (userScope @user @userData u) (snd $ fromJust mAdmin)] -- TODO support queries that fit for multiple users
-        Nothing -> throwError $ err500 { errBody = "This user does not exist" }
 
 
  -------------------