servant-checked-exceptions-2.2.0.0: example/EnvelopeT.hs

{-# LANGUAGE ConstraintKinds #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE EmptyCase #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | This example is very similar to @./Server.hs@, but it is making use of
-- 'EnvelopeT' instead of just 'Envelope'.

module Main where

import Control.Monad.IO.Class (MonadIO(liftIO))
import Data.Char (toLower)
import Data.Proxy (Proxy(Proxy))
import Network.Wai (Application)
import Network.Wai.Handler.Warp (run)
import Servant (Handler, (:<|>)((:<|>)), ServerT, serve)

import Servant.Checked.Exceptions
  ( Envelope
  , EnvelopeT
  , IsMember
  , pureErrEnvelope
  , pureSuccEnvelope
  , relaxEnvT
  , runEnvelopeT
  , throwErrEnvT
  )

import Api
  ( Api
  , BadSearchTermErr(BadSearchTermErr)
  , IncorrectCapitalization(IncorrectCapitalization)
  , SearchQuery(SearchQuery)
  , SearchResponse
  , port
  )

-- | This is our server root for the 'ServerT' for 'Api'.  We only have two
-- handlers, 'postStrictSearch' and 'postLaxSearch'.
serverRoot :: ServerT Api Handler
serverRoot = postStrictSearch :<|> postLaxSearch :<|> postNoErrSearch

-- | This is the handler for 'Api.ApiStrictSearch'.
postStrictSearch
  :: SearchQuery
  -> Handler (Envelope '[BadSearchTermErr, IncorrectCapitalization] SearchResponse)
postStrictSearch query =
  runEnvelopeT $ do
    res <- checkQueryInDb query
    relaxEnvT $ doubleCheckCapitalization query
    doubleCheckCapitalizationGeneral query
    pure res

-- | Check that the input 'SearchQuery' is in the DB.  (The DB is just a list
-- of greetings.)
--
-- If the input 'SearchQuery' is in the DB, return the string @"greeting"@.
-- Otherwise, throw an envelope error 'BadSearchTermErr'.
--
-- Note that this function says that it might also return an
-- 'IncorrectCapitalization' error, but it doesn't actually.  This is just for
-- demonstration.
--
-- Also note that our underlying Monad here is 'Handler'.
checkQueryInDb
  :: SearchQuery
  -> EnvelopeT '[BadSearchTermErr, IncorrectCapitalization] Handler SearchResponse
checkQueryInDb (SearchQuery query) = do
  liftIO $ putStrLn "querying DB..."
  let lowerQuery = fmap toLower query
  case lowerQuery `elem` ["hello", "goodbye", "goodnight"] of
    True -> pure "greeting"
    False -> throwErrEnvT BadSearchTermErr

-- | Check the first letter of 'SearchQuery' to make sure that it is lowercase.
--
-- If it is not lowercase, throw 'IncorrectCapitalization'.
--
-- Note that 'relaxEnvT' needs to be called on the result of this to use it in
-- do notation with the above 'checkQueryInDb'.  This is because the result of
-- this is technically a different monad than the result of 'checkQueryInDb',
-- because the error types are different.
--
-- Also note that since we only use 'MonadIO' for this, our underlying monad is
-- polymorphic.  We don't specialize it to 'Handler'.
doubleCheckCapitalization
  :: MonadIO m => SearchQuery -> EnvelopeT '[IncorrectCapitalization] m ()
doubleCheckCapitalization (SearchQuery []) = liftIO $ putStrLn "search query empty"
doubleCheckCapitalization (SearchQuery (q:query)) =
  if toLower q == q
    then pure ()
    else throwErrEnvT IncorrectCapitalization

-- | This is just like 'doubleCheckCapitalization' above, but we use the
-- 'IsMember' constraint to make this function more general.  In
-- 'postStrictSearch', you can see that we don't have to call 'relaxEnvT' when
-- using this function.
doubleCheckCapitalizationGeneral
  :: IsMember IncorrectCapitalization es => SearchQuery -> EnvelopeT es Handler ()
doubleCheckCapitalizationGeneral _ = throwErrEnvT IncorrectCapitalization

-- | This doesn't do anything interesting.
--
-- See 'postLaxSearch' in @./Server.hs@ for an example using 'Envelope'.
postLaxSearch
  :: SearchQuery
  -> Handler (Envelope '[BadSearchTermErr] SearchResponse)
postLaxSearch _ = pureSuccEnvelope "good"

-- | This doesn't do anything interesting.
--
-- See 'postNoErrSearch' in @./Server.hs@ for an example using 'Envelope'.
postNoErrSearch :: SearchQuery -> Handler (Envelope '[] SearchResponse)
postNoErrSearch (SearchQuery _) = pureSuccEnvelope "good"

-- | Create a WAI 'Application'.
app :: Application
app = serve (Proxy :: Proxy Api) serverRoot

-- | Run the WAI 'Application' using 'run' on the port defined by 'port'.
main :: IO ()
main = run port app