UVerbs, Headers and custom monads

[tchoutri]

I am trying to setup a workflow where I'm using UVerb to achieve a better way to handle redirects in Flora.

At the moment, here are my cards:

My custom monad is:

type FloraPageM = ReaderT Session Handler

My route is

type CreateSession                                           
  = "new"                                                    
  :> ReqBody '[FormUrlEncoded] LoginForm                     
  :> UVerb 'POST '[HTML] '[WithStatus 200 (Html ()), WithStatus 301 NoContent]

And the last line basically translates to “Send back Html () in case of logging error, or redirect if the log-in succeeds”.

Now, I have my redirect function, which goes like:

redirect :: Text                                                                               
         -> FloraPageM (Union '[ WithStatus 200 (Html ())                                      
                               , WithStatus 301 (Headers '[Header "Location" Text] NoContent)])
redirect destination = respond $ WithStatus @301 (addHeader destination NoContent)             

And reading the UVerb cookbook, I would think that Servant would be happy with it, but it tells me instead:

src/FloraWeb/Server/Util.hs:11:24: error:
    • Expected one of:
          '[WithStatus 200 (Html ()),
            WithStatus 301 (Headers '[Header "Location" Text] NoContent)]
      But got:
          WithStatus 301 (Headers '[Header h0 Text] NoContent)
    • In the expression:
        respond $ WithStatus @301 (addHeader destination NoContent)
      In an equation for ‘redirect’:
          redirect destination
            = respond $ WithStatus @301 (addHeader destination NoContent)
   |
11 | redirect destination = respond $ WithStatus @301 (addHeader destination NoContent)
   |                        ^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^^

Here are my questions:

0. What do I do?
1. Is this something that we can document, or is each instance of this error its very specific thing?
2. Is it going to be seamless with a custom monad? Do I need to dome some precision lifting?

[tchoutri]

Simplifying the redirect helper to:

redirect :: Text -> Headers '[Header "Location" Text] NoContent
redirect destination = addHeader destination NoContent         

brings me with such a handler:

createSessionHandler :: LoginForm -> FloraPageM (Html ())                           
createSessionHandler LoginForm{email, password, remember} = do                      
  session <- ask                                                                    
  FloraEnv{pool} <- liftIO $ fetchFloraEnv (session ^. #webEnvStore)                
  mUser <- liftIO $ withPool pool $ getUserByEmail email                            
  case mUser of                                                                     
    Nothing -> do                                                                   
      liftIO $ putStrLn "[+] Couldn't find user"                                    
      templateDefaults <- fromSession session defaultTemplateEnv                    
      let templateEnv = templateDefaults                                            
              & (#flashError ?~ mkError "Could not authenticate")                   
      render templateEnv Sessions.newSession                                        
    Just user ->                                                                    
      if validatePassword (mkPassword password) (user ^. #password)                 
      then do                                                                       
        liftIO $ putStrLn "[+] User connected!"                                     
        sessionId <- persistSession pool (session ^. #sessionId) (user ^. #userId)  
        let sessionCookie = craftSessionCookie sessionId (isJust remember)          
        addSessionCookie (session ^. #webEnvStore) sessionCookie                    
        redirect "/"                                                      
      else do                                                                       
        liftIO $ putStrLn "[+] Couldn't authenticate user"                          
        templateDefaults <- fromSession session defaultTemplateEnv                  
        let templateEnv = templateDefaults                                          
                & (#flashError ?~ mkError "Could not authenticate")                 
        render templateEnv Sessions.newSession                                      

And the error:

src/FloraWeb/Server/Pages/Sessions.hs:65:9: error:
    • Couldn't match type ‘Servant.API.ResponseHeaders.Headers
                             '[Servant.API.Header.Header "Location" T.Text]’
                     with ‘ReaderT Session Servant.Server.Internal.Handler.Handler’
      Expected type: ReaderT
                       Session Servant.Server.Internal.Handler.Handler (Html ())
        Actual type: Servant.API.ResponseHeaders.Headers
                       '[Servant.API.Header.Header "Location" T.Text]
                       Servant.API.ContentTypes.NoContent
    • In a stmt of a 'do' block: redirect "/"
      In the expression:
        do liftIO $ putStrLn "[+] User connected!"
           sessionId <- persistSession
                          pool (session ^. #sessionId) (user ^. #userId)
           let sessionCookie = craftSessionCookie sessionId (isJust remember)
           addSessionCookie (session ^. #webEnvStore) sessionCookie
           ....
      In the expression:
        if validatePassword (mkPassword password) (user ^. #password) then
            do liftIO $ putStrLn "[+] User connected!"
               sessionId <- persistSession
                              pool (session ^. #sessionId) (user ^. #userId)
               let sessionCookie = ...
               ....
        else
            do liftIO $ putStrLn "[+] Couldn't authenticate user"
               templateDefaults <- fromSession session defaultTemplateEnv
               let templateEnv = ...
               ....
   |
65 |         redirect "/"
   |         ^^^^^^^^^^^^

[gdeest]

Did you try passing an explicit type parameter to the addHeader function in your first attempt ? The problem is that the header name ("Location") is ambiguous, which prevents unification between:

WithStatus 301 (Headers '[Header "Location" Text] NoContent)

and

WithStatus 301 (Headers '[Header h0 Text] NoContent)

(h0 does not mean “any name”, but “a specific name I can't figure out, which might differ from what you want”).

It seems to me that:

addHeader @"Location" destination NoContent

should do the trick.

[tchoutri]

Wonderful. :)

In the end I've reached a solution that is a little bit meaty but correct wrt. Servant, so I think I'll put this in a cookbook on Friday. :)