More flexible route

backend/Obelisk/OAuth/AccessToken.hs

@@ -7,7 +7,9 @@ module Obelisk.OAuth.AccessToken where
 import Data.ByteString
 import Data.Functor.Identity
 import Data.Text (Text)
+import Data.Text as T
 import qualified Data.Text.Encoding as T
+import Network.URI
 import Network.HTTP.Client (Request(..), parseRequest)
 import Network.HTTP.Client.MultipartFormData (partBS, formDataBody)
 
@@ -21,22 +23,20 @@ data TokenRequest r = TokenRequest
   { _tokenRequest_grant :: TokenGrant
   , _tokenRequest_clientId :: Text
   , _tokenRequest_clientSecret :: Text
-  , _tokenRequest_redirectUri :: (R OAuth -> R r)
   }
 
 getOauthToken
   :: String -- ^ Request url
-  -> Text -- ^ Application route
-  -> Encoder Identity Identity (R (FullRoute r a)) PageName
+  -> (R OAuth -> URI)
   -> TokenRequest r
   -> IO Request
-getOauthToken reqUrl appRoute enc t = do
+getOauthToken reqUrl encodeRoute t = do
   req <- parseRequest reqUrl
   let form =
         [ partBS "client_id" $ T.encodeUtf8 $ _tokenRequest_clientId t
         , partBS "client_secret" $ T.encodeUtf8 $ _tokenRequest_clientSecret t
-        , partBS "redirect_uri" $ T.encodeUtf8 $
-            appRoute <> renderBackendRoute enc (_tokenRequest_redirectUri t $ OAuth_RedirectUri :/ Nothing)
+        , partBS "redirect_uri" $ T.encodeUtf8 $ T.pack $
+          uriToString id (encodeRoute (OAuth_RedirectUri :/ Nothing)) ""
         ] ++ case _tokenRequest_grant t of
           TokenGrant_AuthorizationCode code ->
             [ partBS "grant_type" "authorization_code"

backend/obelisk-oauth-backend.cabal

@@ -19,6 +19,7 @@ library
     base >=4.11,
     bytestring >=0.10,
     http-client,
+    network-uri >=2.6.3.0,
     obelisk-oauth-common,
     obelisk-route,
     text >=1.2

common/Obelisk/OAuth/Authorization.hs

@@ -1,3 +1,4 @@
+{-# LANGUAGE ConstraintKinds #-}
 {-# LANGUAGE DeriveGeneric #-}
 {-# LANGUAGE FlexibleContexts #-}
 {-# LANGUAGE FlexibleInstances #-}
@@ -30,6 +31,7 @@ import qualified Data.Map as Map
 import Data.Text (Text)
 import qualified Data.Text as T
 import GHC.Generics (Generic)
+import Network.URI
 
 import Obelisk.Route
 import Obelisk.Route.TH
@@ -63,7 +65,7 @@ data AuthorizationRequest r = AuthorizationRequest
     -- ^ The type of authorization grant being requested. See 'AuthorizationResponseType'.
   , _authorizationRequest_clientId :: Text
     -- ^ The client application identifier, issued by the authorization server. See section <https://tools.ietf.org/html/rfc6749#section-2.2 of the spec.
-  , _authorizationRequest_redirectUri :: Maybe (R OAuth -> R r)
+  , _authorizationRequest_redirectUri :: Maybe (R OAuth -> URI)
     -- ^ The client application's callback URI, where it expects to receive the authorization code. See section <https://tools.ietf.org/html/rfc6749#section-3.1.2 3.1.2> of the spec. The @r@ represents the client application's route type, of which the OAuth route will be a sub-route.
   , _authorizationRequest_scope :: [Text]
     -- ^ See section <https://tools.ietf.org/html/rfc6749#section-3.3 3.3>, "Access Token Scope"
@@ -76,20 +78,18 @@ data AuthorizationRequest r = AuthorizationRequest
 -- defined in <https://tools.ietf.org/html/rfc6749#section-4.1.1 4.1.1> of the specification.
 -- This does not insert a leading @?@.
 authorizationRequestParams
-  :: Text -- ^ Base url
-  -> Encoder Identity Identity (R (FullRoute br a)) PageName
-  -> AuthorizationRequest br
+  :: AuthorizationRequest br
   -> Text
-authorizationRequestParams route enc ar = encode (queryParametersTextEncoder @Identity @Identity) $
+authorizationRequestParams ar = encode (queryParametersTextEncoder @Identity @Identity) $
   Map.toList $ fmap Just $ mconcat
     [ Map.singleton "response_type" $ case _authorizationRequest_responseType ar of
         AuthorizationResponseType_Code -> "code"
         AuthorizationResponseType_Token -> "token"
     , Map.singleton "client_id" (_authorizationRequest_clientId ar)
     , case _authorizationRequest_redirectUri ar of
         Nothing -> Map.empty
-        Just r -> Map.singleton "redirect_uri" $
-          route <> renderBackendRoute enc (r $ OAuth_RedirectUri :/ Nothing)
+        Just renderRoute -> Map.singleton "redirect_uri" $ T.pack $
+          uriToString id (renderRoute $ OAuth_RedirectUri :/ Nothing) ""
     , case _authorizationRequest_scope ar of
         [] -> Map.empty
         xs -> Map.singleton "scope" $ T.intercalate " " xs
@@ -101,12 +101,10 @@ authorizationRequestParams route enc ar = encode (queryParametersTextEncoder @Id
 -- | Render the authorization request
 authorizationRequestHref
   :: Text -- ^ API request url
-  -> Text -- ^ Base application route url
-  -> Encoder Identity Identity (R (FullRoute br a)) PageName -- ^ Backend route encoder
   -> AuthorizationRequest br
   -> Text -- ^ Authorization grant request endpoint with query string
-authorizationRequestHref reqUrl appUrl enc ar =
-  reqUrl <> "?" <> authorizationRequestParams appUrl enc ar
+authorizationRequestHref reqUrl ar =
+  reqUrl <> "?" <> authorizationRequestParams ar
 
 -- | Parameters that the authorization server is expected to provide when granting
 -- an authorization code request. See section <https://tools.ietf.org/html/rfc6749#section-4.1.2 4.1.2>

common/obelisk-oauth-common.cabal

@@ -34,6 +34,7 @@ library
     categories,
     containers >=0.5,
     mtl >=2,
+    network-uri >=2.6.3.0,
     obelisk-route,
     text >= 1.2
   default-language: Haskell2010