Skip to content

Instantly share code, notes, and snippets.

@L7R7

L7R7/servant-named-fixed.hs

Last active June 8, 2022 08:14
Show Gist options
  • Save L7R7/e0fa2d33fb4d1b452f4ac0e4272fad2f to your computer and use it in GitHub Desktop.
Save L7R7/e0fa2d33fb4d1b452f4ac0e4272fad2f to your computer and use it in GitHub Desktop.
Download ZIP
demonstrating an issue with servant NamedRoutes and basic auth
Raw
servant-named-fixed.hs
{-
compiles with:
extra-deps:
- github: haskell-servant/servant
commit: 1fba9dc6048cea6184964032b861b052cd54878c
subdirs:
- servant
- servant-server
- servant-auth/servant-auth
- servant-auth/servant-auth-server
-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}
import Control.Monad.Error.Class
import Data.Aeson
import GHC.Generics
import Servant hiding (BasicAuth)
import Servant.API.Generic
import Servant.Auth
import Servant.Auth.Server
import Servant.Auth.Server.Internal.AddSetCookie
import Servant.Server.Generic
import Servant.Server.Internal.ServerError
type API = NamedRoutes NamedAPI
data User = User
{ name :: String,
pass :: String
}
deriving (Generic)
instance ToJWT User
instance ToJSON User
instance FromBasicAuthData User where
fromBasicAuthData _ _ = pure (Authenticated (User "foo" "bar"))
type Request = String
type Response = String
type Version = String
data NamedAPI mode = NamedAPI
{ publicRoutes :: mode :- NamedRoutes PublicRoutes,
adminRoutes :: mode :- "admin" :> Auth '[BasicAuth] User :> NamedRoutes AdminRoutes
}
deriving (Generic)
data PublicRoutes mode = PublicRoutes
{ version :: mode :- "version" :> Get '[JSON] Version
}
deriving (Generic)
data AdminRoutes mode = AdminRoutes
{ doStuff :: mode :- "do_stuff" :> ReqBody '[JSON] Request :> Post '[JSON] Response
}
deriving (Generic)
type instance BasicAuthCfg = ()
app :: Application
app =
serveWithContext
(Proxy @API)
(() :. jwtSettings :. defaultCookieSettings :. EmptyContext)
( NamedAPI
{ publicRoutes = PublicRoutes (pure "version"),
adminRoutes = \case
Authenticated usr ->
AdminRoutes
{ doStuff = pure
}
_ -> throwAll err401
}
)
jwtSettings :: JWTSettings
jwtSettings = defaultJWTSettings jwk
where
jwk = fromSecret "\204\US\177\200%7\226\216\248.\153\172\232x\129n9S.\174o\CAN\178\&2\206\128\157Zgm\177\232\248H\nq\EOT\245\178Y\DC1?\137\150\249\222/OP%\175\DC1\188\&3\162\180\201\139\229\217\154\212\139#%okQ\n\173\&6\b\b7\DC2y3\a\170\207A\235\137\212\212\DEL\160\130\139\v\246ay\216\203|F\195\&2\186\175|\197hgAU\DLEm[\190\NAKE\192\240\251\DLE\ENQ\167+\ETBy\180\203\182`\220\144\138\rR\147Kn\172(\224\223\194X\172\203\STX\207.\200vM_$\179\US\250\195\169vQ\218\170/S\251\128|\238\DC3\231b\156\RS\220\158#\t\160\197\160\175\194\199\220\161WM\212W\SI\DC1\ESCf\251g.b\139\214)\133\193\242\DEL\225\210\&4\235\249\237\244\200\231D\192w\215_\DEL\240\142\176\144\212w9\ENQ$(\206\CAN\215\199}\137\b\154\243\237VpN\234y\196D{\150\&3)PX\170y\209N\247\226\197"
Raw
servant-named.hs
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE LambdaCase, TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
-- import Servant.Auth.Server.SetCookieOrphan ()
import GHC.Generics
import Servant hiding (BasicAuth)
import Servant.API.Generic
import Servant.Auth
import Servant.Auth.Server
import Servant.Server.Generic
import Servant.Server.Internal.ServerError
import Servant.Auth.Server.Internal.AddSetCookie
type API = NamedRoutes NamedAPI
data User = User
{ name :: String,
pass :: String
}
instance FromBasicAuthData User where
fromBasicAuthData _ _ = pure (Authenticated (User "foo" "bar"))
type Request = String
type Response = String
type Version = String
data NamedAPI mode = NamedAPI
{ publicRoutes :: mode :- NamedRoutes PublicRoutes,
adminRoutes :: mode :- "admin" :> Auth '[BasicAuth] User :> NamedRoutes AdminRoutes
}
deriving (Generic)
data PublicRoutes mode = PublicRoutes
{ version :: mode :- "version" :> Get '[JSON] Version
}
deriving (Generic)
data AdminRoutes mode = AdminRoutes
{ doStuff :: mode :- "do_stuff" :> ReqBody '[JSON] Request :> Post '[JSON] Response
}
deriving (Generic)
type instance BasicAuthCfg = ()
{-
...:80:3: error:
• No instance for (AddSetCookies
('S ('S 'Z))
(AdminRoutes (AsServerT Handler))
(ServerT
(AddSetCookieApi (AddSetCookieApi (NamedRoutes AdminRoutes)))
Handler))
arising from a use of ‘serveWithContext’
• In the expression:
serveWithContext
(Proxy @API) (() :. EmptyContext)
NamedAPI
{publicRoutes = PublicRoutes (pure "version"),
adminRoutes = \case
Authenticated usr -> AdminRoutes {doStuff = pure}
_ -> undefined}
In an equation for ‘app’:
app
= serveWithContext
(Proxy @API) (() :. EmptyContext)
NamedAPI
{publicRoutes = PublicRoutes (pure "version"),
adminRoutes = \case
Authenticated usr -> AdminRoutes {doStuff = pure}
_ -> undefined}
|
80 | serveWithContext
| ^^^^^^^^^^^^^^^^...
-}
app :: Application
app =
serveWithContext
(Proxy @API)
(() :. EmptyContext)
NamedAPI
{ publicRoutes = PublicRoutes (pure "version"),
adminRoutes = \case
Authenticated usr -> AdminRoutes
{ doStuff = pure
}
_ -> undefined -- throwAll err401, this throws yet another error: No instance for (mtl-2.2.2:Control.Monad.Error.Class.MonadError ServerError AdminRoutes)
}
Sign up for free to join this conversation on GitHub. Already have an account? Sign in to comment