added user endpoint for queries

src/Server.hs

@@ -1,10 +1,10 @@
-{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards #-}
+{-# LANGUAGE DataKinds, TypeOperators, OverloadedStrings, ScopedTypeVariables, TypeApplications, RecordWildCards, AllowAmbiguousTypes #-}
 
 module Server
-( insecureOAuthMock'
+{-( insecureOAuthMock'
 , runMockServer
-, runMockServer'
+-- , runMockServer'
-) where
+)-} where
 
 import AuthCode
 import User
@@ -19,7 +19,7 @@ import Control.Monad.IO.Class
 import Control.Monad.Trans.Reader
 
 import Data.Aeson
-import Data.ByteString (ByteString (..), toStrict)
+import Data.ByteString (ByteString (..), fromStrict, toStrict)
 import Data.List (find, elemIndex)
 import Data.Maybe (fromMaybe, isJust)
 import Data.String (IsString (..))
@@ -30,6 +30,8 @@ import Data.Time.Clock (NominalDiffTime (..), nominalDay, UTCTime(..), getCurren
 import qualified Data.ByteString.Char8 as BS
 import qualified Data.Map.Strict as Map
 
+import GHC.Read (readPrec, lexP)
+
 import Jose.Jwa
 import Jose.Jwe
 import Jose.Jwk (generateRsaKeyPair, generateSymmetricKey, KeyUse(Enc), KeyId)
@@ -42,8 +44,9 @@ import Servant
 import Servant.Client
 import Servant.API
 
-import Text.ParserCombinators.ReadPrec (look)
+import Text.ParserCombinators.ReadPrec (look, pfail)
-import Text.Read (readPrec)
+
+import qualified Text.Read.Lex as Lex
 
 
 testUsers :: [User] -- TODO move to db
@@ -65,15 +68,24 @@ data ResponseType = Code -- ^ authorisation code grant
                   | IDToken -- ^ implicit grant via access token & ID token
                   deriving (Eq, Show)
 instance Read ResponseType where
-  readPrec = look >>= \str -> return $ case str of
+  readPrec = do
-    "code" -> Code
+    Lex.Ident str <- lexP
-    "token" -> Token
+    Lex.EOF <- lexP
-    "id_token" -> IDToken
+    case str of
+      "code" -> return Code
+      "token" -> return Token
+      "id_token" -> return IDToken
+      _ -> pfail
+
+ ------------------------------
+---- Authorisation endpoint ----
+ ------------------------------
 
 type QScope    = String
 type QClient   = String
 type QResType  = String
 type QRedirect = String
+type QState    = String
 
 type QParam = QueryParam' [Required, Strict]
 
@@ -83,6 +95,7 @@ type Auth user userData = BasicAuth "login" user
                        :> QParam "client_id" QClient
                        :> QParam "response_type" QResType
                        :> QParam "redirect_uri" QRedirect
+                       :> QueryParam "state" QState
                        :> Get '[JSON] userData
 
 -- type Insert = "insert" :> Post '[JSON] User
@@ -102,80 +115,34 @@ authServer = handleAuth
                -> QClient
                -> QResType
                -> QRedirect
+               -> Maybe QState
                -> AuthHandler userData
-    handleAuth u scopes client responseType url = do
+    handleAuth u scopes client responseType url mState = do
       unless (isJust $ find (\c -> ident c == pack client) trustedClients) . -- TODO fetch trusted clients from db | TODO also check if the redirect url really belongs to the client
         throwError $ err404 { errBody = "Not a trusted client."}
-      let
+      let responseType' = read @ResponseType responseType
-        scopes' = map (readScope @user @userData) $ words scopes
+      liftIO $ print responseType'
-        uData = mconcat $ map (userScope @user @userData u) scopes'
+      unless (responseType' == Code) $ throwError err500 { errBody = "Unsupported response type" }  
-        responseType' = read @ResponseType responseType
       mAuthCode <- asks (genUnencryptedCode client url 600) >>= liftIO
       liftIO $ print mAuthCode
-      liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
+      -- liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
-      -- return uData
+      redirect $ addParams url mAuthCode mState
-      redirect $ url `withCode` mAuthCode
     redirect :: Maybe ByteString -> AuthHandler userData
     redirect (Just url) = throwError err303 { errHeaders = [("Location", url)]}
     redirect Nothing = throwError err500 { errBody = "Could not generate authorisation code."}
-    withCode :: String -> Maybe String -> Maybe ByteString
+    addParams :: String -> Maybe String -> Maybe String -> Maybe ByteString
-    withCode url Nothing = Nothing
+    addParams url Nothing _ = Nothing
-    withCode url (Just code) =
+    addParams url (Just code) mState =
       let qPos = fromMaybe (length url) $ elemIndex '?' url
           (pre, post) = splitAt qPos url
+          rState = case mState of {Just s -> "&state=" ++ s; Nothing -> ""}
           post' = if not (null post) then '&' : tail post else post
-      in Just . fromString $ pre ++ "?authorization_code=" ++ code ++ post'
+      in Just . fromString $ pre ++ "?authorization_code=" ++ code ++ post' ++ rState
 
 
-exampleAuthServer :: AuthServer (Auth User (Map.Map Text Text))
+ ----------------------
-exampleAuthServer = authServer
+---- Token Endpoint ----
-
+ ----------------------
-authAPI :: Proxy (Auth User (Map.Map Text Text))
-authAPI = Proxy
-
--- insecureOAuthMock :: Application
--- insecureOAuthMock = authAPI `serve` exampleAuthServer
-
-insecureOAuthMock' :: [User] -> AuthState -> Application
-insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler s) exampleAuthServer
-  where
-    c = authenticate testUsers :. EmptyContext
-    p = Proxy :: Proxy '[BasicAuthCheck User]
-
-authenticate :: [User] -> BasicAuthCheck User
-authenticate users = BasicAuthCheck $ \authData -> do
-  let
-    (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
-  case (find (\u -> email u == uEmail) users) of
-    Nothing -> return NoSuchUser
-    Just u  -> return $ if uPass == password u then Authorized u else BadPassword
-
-frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
-frontend ba = client authAPI ba "[ID]" "42" "code" ""
-
-runMockServer :: Int -> IO ()
-runMockServer port = do
-  state <- mkState
-  run port $ insecureOAuthMock' testUsers state
-
-runMockServer' :: Int -> IO ()
-runMockServer' port = do
-  mgr <- newManager defaultManagerSettings
-  state <- mkState
-  bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
-    runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
-      >>= print
-
-mkState :: IO AuthState
-mkState = do
-  (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing
-  let activeCodes = Map.empty
-  newTVarIO State{..}
-
-
-------
------- Token
-------
 
 
 data ClientData = ClientData
@@ -228,9 +195,19 @@ data JWTWrapper = JWTW
 instance ToJSON JWTWrapper where
   toJSON (JWTW t e) = object ["access_token" .= t, "token_type" .= ("JWT" :: Text), "expires_in" .= e]
 
+instance FromJSON JWTWrapper where
+  parseJSON (Object o) = JWTW
+    <$> o .: "access_token"
+    <*> o .: "expires_in"
+
+instance FromHttpApiData JWTWrapper where
+  parseHeader bs = case decode (fromStrict bs) of
+    Just x -> Right x
+    Nothing -> Left "Invalid JWT wrapper"
+
 type Token = "token"
           :> ReqBody '[JSON] ClientData
-          :> Post '[JSON] JWTWrapper
+          :> Get '[JSON] JWTWrapper
 
 tokenEndpoint :: AuthServer Token
 tokenEndpoint = provideToken
@@ -261,3 +238,100 @@ mkToken state = do
     Left e -> error $ show e
 
 
+ ----------------------
+---- Users Endpoint ----
+ ----------------------
+
+
+type Users = "users"
+
+type Me userData = Users
+                :> Header "Authorization" JWTWrapper
+                :> Get '[JSON] userData
+
+type UserList userData = Users
+                      :> Header "Authorization" JWTWrapper
+                      :> Get '[JSON] [userData] -- TODO support query params
+
+
+userEndpoint :: forall user userData . UserData user userData => AuthServer (Me userData)
+userEndpoint = handleUserData
+  where
+    handleUserData :: Maybe JWTWrapper -> AuthHandler userData
+    handleUserData jwtw = do
+      undefined
+      -- let
+      --   scopes' = map (readScope @user @userData) $ words scopes
+      --   uData = mconcat $ map (userScope @user @userData u) scopes'
+      -- liftIO . putStrLn $ "user: " ++ show u ++ " | scopes: " ++ show (map (showScope @user @userData) scopes')
+      -- return uData
+
+userListEndpoint :: forall user userData . UserData user userData => AuthServer (UserList userData)
+userListEndpoint = handleUserData
+  where
+    handleUserData :: Maybe JWTWrapper -> AuthHandler [userData]
+    handleUserData jwtw = do
+      undefined
+
+
+ -------------------
+---- Server Main ----
+ -------------------
+
+type Routing user userData = Auth user userData
+                        :<|> Token
+                        :<|> Me userData
+                        :<|> UserList userData
+
+routing :: forall user userData . UserData user userData => AuthServer (Routing user userData)
+routing = authServer @user @userData
+     :<|> tokenEndpoint
+     :<|> userEndpoint @user @userData
+     :<|> userListEndpoint @user @userData
+
+exampleAuthServer :: AuthServer (Routing User (Map.Map Text Text))
+exampleAuthServer = routing
+
+
+authAPI :: Proxy (Routing User (Map.Map Text Text))
+authAPI = Proxy
+
+-- insecureOAuthMock :: Application
+-- insecureOAuthMock = authAPI `serve` exampleAuthServer
+
+insecureOAuthMock' :: [User] -> AuthState -> Application
+insecureOAuthMock' testUsers s = serveWithContext authAPI c $ hoistServerWithContext authAPI p (toHandler s) exampleAuthServer
+  where
+    c = authenticate testUsers :. EmptyContext
+    p = Proxy :: Proxy '[BasicAuthCheck User]
+
+authenticate :: [User] -> BasicAuthCheck User
+authenticate users = BasicAuthCheck $ \authData -> do
+  let
+    (uEmail, uPass) = (,) <$> (decodeUtf8 . basicAuthUsername) <*> (decodeUtf8 . basicAuthPassword) $ authData
+  case (find (\u -> email u == uEmail) users) of
+    Nothing -> return NoSuchUser
+    Just u  -> return $ if uPass == password u then Authorized u else BadPassword
+
+-- frontend :: BasicAuthData -> ClientM (Map.Map Text Text)
+-- frontend ba = client authAPI ba "[ID]" "42" "code" ""
+
+runMockServer :: Int -> IO ()
+runMockServer port = do
+  state <- mkState
+  run port $ insecureOAuthMock' testUsers state
+
+-- runMockServer' :: Int -> IO ()
+-- runMockServer' port = do
+--   mgr <- newManager defaultManagerSettings
+--   state <- mkState
+--   bracket (forkIO . run port $ insecureOAuthMock' testUsers state) killThread $ \_ ->
+--     runClientM (frontend $ BasicAuthData "foo@bar.com" "0000") (mkClientEnv mgr (BaseUrl Http "localhost" port ""))
+--       >>= print
+
+mkState :: IO AuthState
+mkState = do
+  (publicKey, privateKey) <- generateRsaKeyPair 256 (KeyId "Oauth2MockKey") Enc Nothing
+  let activeCodes = Map.empty
+  newTVarIO State{..}
+