Haskell Servant - login endpoint with two error states

Question

Here is one a handler for dealing with logins, I've recently refactored it to try and make dealing with the different error cases a bit more elegant, though I still think there is room for improvement:

import Config
import Control.Monad.Reader
import Data.Aeson
import Data.Aeson.Types
import Data.Bifunctor (bimap)
import Data.Char
import Data.List as List
import Data.Text.Lazy
import Data.Text.Lazy.Encoding
import Database.Persist
import Database.Persist.Postgresql
import GHC.Generics
import Servant
import Servant.Auth.Server
import Types (Account(..))
import Queries
type Route = "login" :> ReqBody '[JSON] Credentials :> Post '[JSON] LoginAttempt
instance FromJWT (Key Account)
instance ToJWT (Key Account)
data Credentials = Credentials
 { loginEmail :: String
 , loginPass :: String
 } deriving (Eq, Show, Read, Generic)
instance FromJSON Credentials
instance ToJSON Credentials where
 toJSON creds =
 object
 [ "account" .= loginEmail creds
 ]
data LoginAttempt
 = Ok { authToken :: Text }
 | AuthenticationErr
 | TokenGenerationErr
 deriving (Generic)
instance ToJSON LoginAttempt where
 toJSON (Ok token) =
 object [ "token" .= token ]
 toJSON AuthenticationErr =
 object [ "error" .= ("Invalid username or password" :: Text) ]
 toJSON TokenGenerationErr =
 object [ "error" .= ("Error generating token" :: Text) ]
action :: Config -> JWTSettings -> Credentials -> Handler LoginAttempt
action config jwt (Credentials email pass) = do
 login <- runSqlPool (Queries.validateAccount email pass) $ getPool config
 result <- either (const $ return AuthenticationErr) generateToken login
 case result of
 AuthenticationErr -> throwError $ err401 { errBody = encode . toJSON $ result }
 TokenGenerationErr -> throwError $ err500 { errBody = encode . toJSON $ result }
 _ -> return result
 where
 generateToken :: Key Account -> Handler LoginAttempt
 generateToken k = do
 token <- liftIO $ makeJWT k jwt Nothing
 pure $ either (const TokenGenerationErr) (Ok . decodeUtf8) token

Answer 1

Since the Handler LoginAttempt from action only ever contains Ok, its result should instead be Handler Text. And then nobody ever sees a LoginAttempt object, so we don't need it.

action :: Config -> JWTSettings -> Credentials -> Handler Text
action config jwt (Credentials email pass) = do
 login <- either authenticationError pure =<<
 runSqlPool (Queries.validateAccount email pass) (getPool config)
 token <- either tokenGenerationError pure =<<
 liftIO (makeJWT login jwt Nothing)
 pure $ decodeUtf8 token -- perhaps: pure $ decode $ object [ "token" .= decodeUtf8 token ]
 where
 autheticationError _ = throwError $ err401 { errBody = encode $ object [ "error" .= ("Invalid username or password" :: Text) ] }
 tokenGenerationError _ = throwError $ err500 { errBody = encode $ object [ "error" .= ("Error generating token" :: Text) ] }