Put errors in swagger

guide.cabal

@@ -49,6 +49,7 @@ library
       Guide.Api.Methods
       Guide.Api.Server
       Guide.Api.Types
+      Guide.Api.Error
     Guide.Main
     Guide.ServerStuff
     Guide.Session

src/Guide/Api/Error.hs

@@ -0,0 +1,46 @@
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE FlexibleInstances #-}
+{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE TypeOperators #-}
+{-# LANGUAGE KindSignatures #-}
+{-# LANGUAGE ScopedTypeVariables #-}
+
+
+module Guide.Api.Error
+  ( ErrorResponse
+  ) where
+
+
+import Imports
+
+import GHC.TypeLits
+import Servant
+import Servant.Swagger
+import Data.Swagger
+import qualified Data.Text.All as T
+
+
+-- Taken from https://github.com/haskell-servant/servant-swagger/issues/59
+data ErrorResponse (code :: Nat) (description :: Symbol)
+
+instance
+  ( HasSwagger api
+  , KnownNat code
+  , KnownSymbol desc )
+  => HasSwagger (ErrorResponse code desc :> api) where
+  toSwagger _ = toSwagger (Proxy :: Proxy api)
+    & setResponse (fromInteger code) (return responseSchema)
+    where
+      code = natVal (Proxy :: Proxy code)
+      desc = symbolVal (Proxy :: Proxy desc)
+      responseSchema = mempty
+        & description .~ T.toStrict desc
+
+instance HasLink sub => HasLink (ErrorResponse code desc :> sub) where
+    type MkLink (ErrorResponse code desc :> sub) = MkLink sub
+    toLink _ = toLink (Proxy :: Proxy sub)
+
+instance HasServer api ctx => HasServer (ErrorResponse code desc :> api) ctx where
+  type ServerT (ErrorResponse code desc :> api) m = ServerT api m
+  route _ = route (Proxy :: Proxy api)
+  hoistServerWithContext _ pc nt s = hoistServerWithContext (Proxy :: Proxy api) pc nt s

src/Guide/Api/Methods.hs

@@ -17,15 +17,15 @@ import Data.Acid as Acid
 import Guide.Types
 import Guide.State
 import Guide.Utils (Uid)
-import Guide.Api.Types (ApiError(..), CategoryInfo, CCategoryDetail, toCategoryInfo, toCCategoryDetail)
+import Guide.Api.Types (CategoryInfo, CCategoryDetail, toCategoryInfo, toCCategoryDetail)
 
 getCategories :: DB -> Handler [CategoryInfo]
 getCategories db = do
   liftIO (Acid.query db GetCategories) <&> \xs ->
     map toCategoryInfo xs
 
-getCategory :: DB -> Uid Category -> Handler (Either ApiError CCategoryDetail)
+getCategory :: DB -> Uid Category -> Handler CCategoryDetail
 getCategory db catId =
-  liftIO (Acid.query db (GetCategoryMaybe catId)) <&> \case
-    Nothing  -> Left (ApiError "category not found")
-    Just cat -> Right $ toCCategoryDetail cat
+  liftIO (Acid.query db (GetCategoryMaybe catId)) >>= \case
+    Nothing  -> throwError err404
+    Just cat -> pure (toCCategoryDetail cat)

src/Guide/Api/Server.hs

@@ -30,13 +30,9 @@ import Guide.Api.Types (Api, Site(..))
 import Guide.Api.Methods (getCategories, getCategory)
 
 apiServer :: DB -> Site AsServer
-apiServer db = Site {
-  -- NB. we do @fmap Right@ because some handlers return ApiError and others
-  -- don't. The reason we add 'Right' here and not in those handlers is that
-  -- it makes the signatures of those handlers better reflect their
-  -- properties (i.e. whether they can fail or not).
-  _getCategories = getCategories db        & fmap Right,
-  _getCategory   = getCategory db
+apiServer db = Site
+  { _getCategories = getCategories db
+  , _getCategory   = getCategory db
   }
 
 type FullApi =

src/Guide/Api/Types.hs

@@ -6,9 +6,12 @@
 {-# LANGUAGE TypeOperators         #-}
 {-# LANGUAGE OverloadedStrings     #-}
 
+
+{-# OPTIONS_GHC -fno-warn-orphans #-}
+
+
 module Guide.Api.Types
   ( Api
-  , ApiError(..)
   , CategoryInfo(..)
   , CCategoryDetail(..)
   , CItem(..)
@@ -30,9 +33,10 @@ import Servant
 import Servant.Generic
 import Data.Swagger as S
 
-import Guide.Types.Core (Category(..), CategoryStatus(..), Item(..), ItemKind
-  , Trait, content, uid
-  )
+import Guide.Api.Error
+import Guide.Types.Core
+         ( Category(..), CategoryStatus(..), Item(..), ItemKind
+         , Trait, content, uid )
 import Guide.Utils (Uid(..), Url)
 import Guide.Markdown (MarkdownBlock, MarkdownInline, MarkdownTree, mdHtml, mdSource)
 
@@ -45,13 +49,14 @@ data Site route = Site
   { _getCategories :: route :-
       Summary "Get all categories"
       :> "categories"
-      :> Get '[JSON] (Either ApiError [CategoryInfo])
+      :> Get '[JSON] [CategoryInfo]
 
   , _getCategory :: route :-
       Summary "Get details of a category, and its full contents"
+      :> ErrorResponse 404 "Category not found"
       :> "category"
       :> Capture "id" (Uid Category)
-      :> Get '[JSON] (Either ApiError CCategoryDetail)
+      :> Get '[JSON] CCategoryDetail
   }
   deriving (Generic)
 
@@ -67,14 +72,6 @@ type Api = ToServant (Site AsApi)
 -- we might not need on front-end.
 ----------------------------------------------------------------------------
 
--- | Client-side API error
-newtype ApiError = ApiError Text
-  deriving (Generic)
-
-instance A.FromJSON ApiError
-instance A.ToJSON ApiError
-instance ToSchema ApiError
-
 -- | A "light-weight" client type of `Category`, which describes a category info
 data CategoryInfo = CategoryInfo
   { categoryInfoUid     :: Uid Category
@@ -224,7 +221,9 @@ instance ToParamSchema (Uid a) where
     & S.type_ .~ SwaggerString
     & S.format ?~ "Text-based ID"
 
-instance ToSchema (Uid a)
+instance ToSchema (Uid a) where
+  declareNamedSchema _ = pure $ NamedSchema (Just "Uid") $ mempty
+    & S.type_ .~ SwaggerString
 
 instance ToSchema CategoryStatus