Posts tagged "servant":

Validation of data in a servant server

I've been playing around with adding more validation of data received by an HTTP endpoint in a servant server. Defining a type with a FromJSON instance is very easy, just derive a Generic instance and it just works. Here's a simple example

data Person = Person
    { name :: Text
    , age :: Int
    , occupation :: Occupation
    }
    deriving (Generic, Show)
    deriving (FromJSON, ToJSON) via (Generically Person)

data Occupation = UnderAge | Student | Unemployed | SelfEmployed | Retired | Occupation Text
    deriving (Eq, Generic, Ord, Show)
    deriving (FromJSON, ToJSON) via (Generically Occupation)

However, the validation is rather limited, basically it's just checking that each field is present and of the correct type. For the type above I'd like to enforce some constraints for the combination of age and occupation.

The steps I thought of are

1. Hide the default constructor and define a smart one. (This is the standard suggestion for placing extra constraints values.)
2. Manually define the FromJSON instance using the Generic instance to limit the amount of code and the smart constructor.

mkPerson :: Text -> Int -> Occupation -> Either String Person
mkPerson name age occupation = do
    guardE mustBeUnderAge
    guardE notUnderAge
    guardE tooOldToBeStudent
    guardE mustBeRetired
    pure $ Person name age occupation
  where
    guardE (pred, err) = when pred $ Left err
    mustBeUnderAge = (age < 8 && occupation > UnderAge, "too young for occupation")
    notUnderAge = (age > 15 && occupation == UnderAge, "too old to be under age")
    tooOldToBeStudent = (age > 45 && occupation == Student, "too old to be a student")
    mustBeRetired = (age > 65 && occupation /= Retired, "too old to not be retired")

instance FromJSON Person where
    parseJSON v = do
        Person{name, age, occupation} <- genericParseJSON defaultOptions v
        either fail pure $ mkPerson name age occupation

Servant and a weirdness in Keycloak

When writing a small tool to interface with Keycloak I found an endpoint that require the content type to be application/json while the body should be plain text. (The details are in the issue.) Since servant assumes that the content type and the content match (I know, I'd always thought that was a safe assumption to make too) it doesn't work with ReqBody '[JSON] Text. Instead I had to create a custom type that's a combination of JSON and PlainText, something that turned out to required surprisingly little code:

data KeycloakJSON deriving (Typeable)

instance Accept KeycloakJSON where
    contentType _ = "application" // "json"

instance MimeRender KeycloakJSON Text where
    mimeRender _ = fromStrict . encodeUtf8

The bug has already been fixed in Keycloak, but I'm sure there are other APIs with similar weirdness so maybe this will be useful to someone else.

The timeout manager exception

The other day I bumped the dependencies of a Haskell project at work and noticed a new exception being thrown:

Thread killed by timeout manager

After a couple of false starts (it wasn't the connection pool, nor was it servant) I realised that a better approach would be to look at the list of packages that were updated as part of the dependency bumping.¹ Most of them I thought would be very unlikely sources of it, but two in the list stood out:

warp since the exception seemed to be thrown shortly after handling an HTTP request, and unliftio since the exception was caught by the handler for uncaught exceptions and its description contains "thread". Also, when looking at the code changes in warp on GitHub² I found that some of the changes introduced was increased use of unliftio for async stuff. The changes contain mentions of TimeoutThread and System.TimeManager. That sounded promising, and it lead me to the TimeoutThread exception in time-manager.

With that knowledge I could quickly adjust the handler for uncaught exceptions to not log TimeoutThread as fatal:

lastExceptionHandler :: LoggerSet -> SomeException -> IO ()
lastExceptionHandler logger e
  | Just TimeoutThread <- fromException e = return ()
  | otherwise = do
      logFatalIoS logger $ pack $ "uncaught exception: " <> displayException e
      flushLogStr logger

I have to say it was a bit more work to arrive at this than I'd have liked. I reckon there are easier ways to track down the information I needed. So I'd love to hear what tricks and tips others have.

Custom monad with servant and throwing errors

In the past I've always used scotty when writing web services. This was mostly due to laziness, I found working out how to use scotty a lot easier than servant, so basically I was being lazy. Fairly quickly I bumped into some limitations in scotty, but at first the workarounds didn't add too much complexity and were acceptable. A few weeks ago they started weighing on me though and I decided to look into servant and since I really liked what I found I've started moving all projects to use servant.

In several of the projects I've used tagless final style and defined a type based on ReaderT holding configuration over IO, that is something like

newtype AppM a = AppM {unAppM : ReaderT Config IO a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader Config
    )

runAppM :: AppM a -> Config -> IO a
runAppM app = runReaderT (unAppM app)

I found that servant is very well suited to this style through hoistServer and there are several examples on how to use it with a ReaderT-based type like above. The first one I found is in the servant cookbook. However, as I realised a bit later, using a simple type like this doesn't make it easy to trigger responses with status other than 200 OK. When I looked at the definition of the type for writing handlers that ships with servant, Handler, I decided to try to use the following type in my service

newtype AppM a = AppM {unAppM : ReaderT Config (ExceptT ServerError IO) a}
  deriving
    ( Functor,
      Applicative,
      Monad,
      MonadIO,
      MonadReader Config
    )

runAppM :: AppM a -> Config -> IO (Either ServerError a)
runAppM app = runExceptT . runReaderT (unAppM app)

The natural transformation required by hoistServer can then be written like

nt :: AppM a -> Handler a
nt x =
  liftIO (runAppM x cfg) >>= \case
    Right v -> pure v
    Left err -> throwError err

I particularly like how clearly this suggests a way to add custom errors if I want that.

1. Swap out ServerError for my custom error type in AppM.
2. Write a function to transform my custom error type into a ServerError, transformCustomError :: CustomError -> ServerError.
3. use throwError $ transformCustomError err in the Left branch of nt.

instance MonadBaseControl IO AppM where
  type StM AppM a = Either ServerError a

  liftBaseWith f = AppM (liftBaseWith (\g -> f (g . unAppM)))
  restoreM = AppM . restoreM