Error

/Users/bmartin/Work/pixomondo/vendor-tool-api/src/Main.hs:48:14:
    Couldn't match type ‘t0 (ExceptT ServantErr m0)’ with ‘App’
    Expected type: App Value
      Actual type: t0 (ExceptT ServantErr m0) Value
    In the expression: serverErr $ ServerError "Oops!"
    In an equation for ‘name’: name n = serverErr $ ServerError "Oops!"
    In an equation for ‘apiServer’:
        apiServer
          = appVersion :<|> name
          where
              name :: Text -> App Value
              name n = serverErr $ ServerError "Oops!"

Error.hs

{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE OverloadedStrings #-}


module Lib.Error where


import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Except (ExceptT, throwError)
import Control.Monad.Trans (lift)
import Servant.Server.Internal.ServantErr
import Network.HTTP.Types
import Data.Text
import Data.Aeson


data ErrorResponse = BadRequest Text
  | NotAuthorized
  | NotFound
  | ServerError Text
  | NotImplemented
  deriving (Show)


instance ToJSON ErrorResponse where
  toJSON f = case message f of
    (s, e, m) -> object
      [ pack "statusCode" .= (s :: Integer)
      , pack "error" .= (e :: Text)
      , pack "message" .= (m :: Text)
      ]


message :: ErrorResponse -> (Integer, Text, Text)
message (BadRequest s) = (400, "Bad Request", s)
message NotAuthorized = (401, "Not Authorized", "")
message NotFound = (404, "Not Found", "")
message (ServerError s) = (500, "Server Error", s)
message NotImplemented = (501, "Not Implemented", "")


serverErr :: (MonadTrans t, Monad m) => ErrorResponse -> t (ExceptT ServantErr m) a
serverErr f = lift . throwError $ case message f of
  (s, e, m) -> ServantErr {
    errHTTPCode = fromInteger s
    , errReasonPhrase = unpack e
    , errBody = encode f
    , errHeaders = [(hContentType, "application/json")]
    }

Main.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DataKinds #-}


module Main where


import Network.Wreq hiding (Proxy, proxy, responseStatus)
import Control.Lens
import Data.Text (Text)
import Data.Monoid ((<>))
import Data.Proxy
import Data.Aeson
import Data.Time.Calendar
import GHC.Generics
import Servant
import System.Environment
import Control.Monad.Trans.Except
import Network.Wai
import Network.Wai.Handler.Warp
import Network.Wai.Handler.WarpTLS
import Network.Wai.Middleware.RequestLogger
import Network.HTTP.Types
import Data.ByteString.Lazy (toStrict)
import Blaze.ByteString.Builder.ByteString (fromByteString)
import qualified Data.Aeson as A
import qualified Data.Aeson.Lens as AL


import Debug.Trace


import Lib.Config
import Lib.Error


type Api = Get '[JSON] AppInfo
  :<|> "name" :> Capture "name" Text :> Get '[JSON] A.Value


apiServer :: ServerT Api App
apiServer = appVersion
  :<|> name
  where
    name :: Text -> App A.Value
    name n = serverErr $ ServerError "Oops!" --return $ A.object ["name" A..= n]


server :: AppConfig -> Server Api
server cfg = enter (Nat $ (runApp cfg)) apiServer


logger :: AppSettings -> Application -> Application
logger settings = case env settings of
  Production -> logStdout
  _ -> logStdoutDev


-- TODO not really using just for testing
customErrorMessages :: Application -> Application
customErrorMessages = modifyResponse $ \r -> if responseStatus r == status404
  then responseBuilder
    status404
    [("Content-Type", "application/json")]
    (fromByteString $ toStrict $ encode $ A.object ["error" A..= ("Not Found" :: Text)])
  else r


proxy :: Proxy Api
proxy = Proxy


runServer :: AppConfig -> IO ()
runServer cfg = do
  let settings = appSettings cfg
      cert = certificate settings
      key' = key settings
      port' = port settings

  case env settings of
    Production -> runTLS
      (tlsSettings cert key')
      (setPort port' defaultSettings)
      (logger settings $ serve proxy (server cfg))
    _ -> run port' $ customErrorMessages $ logger settings $ serve proxy (server cfg)


main :: IO ()
main = do
  -- setup environment
  env <- getAppEnv "ENV" Development
  cfg <- parseConfig env

  putStrLn $ "Running on " <> (show $ port $ appSettings cfg)
  runServer cfg