Status.hs

{-# LANGUAGE CPP #-}
{-# OPTIONS_GHC -Wno-orphans #-}

-- | Swagger implementation of 'Status' trait.
module WebGear.Swagger.Trait.Status where

import Control.Applicative ((<|>))
import Control.Lens (at, mapped, (%~), (&), (.~), (?~), (^.))
import Data.Maybe (fromMaybe)
import Data.Swagger (
  Operation,
  PathItem,
  Referenced (..),
  Response,
  delete,
  description,
  get,
  head_,
  options,
  patch,
  paths,
  post,
  put,
  responses,
 )
import qualified Network.HTTP.Types as HTTP
import WebGear.Core.Handler (Description (..))
import qualified WebGear.Core.Response as WG
import WebGear.Core.Trait (Set, With, setTrait)
import WebGear.Core.Trait.Status (Status (..))
import WebGear.Swagger.Handler (SwaggerHandler (..), addRootPath, consumeDescription)

#if MIN_VERSION_swagger2(2,9,0)
import qualified Data.HashMap.Strict.InsOrd.Compat as Map
#else
import qualified Data.HashMap.Strict.InsOrd as Map
#endif

instance Set (SwaggerHandler m) Status where
  {-# INLINE setTrait #-}
  setTrait ::
    Status ->
    (WG.Response `With` ts -> WG.Response -> HTTP.Status -> WG.Response `With` (Status : ts)) ->
    SwaggerHandler m (WG.Response `With` ts, HTTP.Status) (WG.Response `With` (Status : ts))
  setTrait status _ = SwaggerHandler $ \doc -> do
    desc <- consumeDescription
    let doc' = if Map.null (doc ^. paths) then addRootPath doc else doc
    pure $ doc' & paths . mapped %~ setOperation desc status

setOperation :: Maybe Description -> Status -> PathItem -> PathItem
setOperation desc (Status status) item =
  item
    & delete %~ updateOperation
    & get %~ updateOperation
    & head_ %~ updateOperation
    & options %~ updateOperation
    & patch %~ updateOperation
    & post %~ updateOperation
    & put %~ updateOperation
  where
    httpCode = HTTP.statusCode status

    updateOperation :: Maybe Operation -> Maybe Operation
    updateOperation Nothing = Just $ mempty @Operation & at httpCode ?~ addDescription emptyResp
    updateOperation (Just op) =
      let resp = addDescription $ fromMaybe emptyResp $ (op ^. at httpCode) <|> (op ^. at 0)
       in Just $ op & responses . responses %~ Map.insert httpCode resp . Map.delete 0

    emptyResp :: Referenced Response
    emptyResp = Inline mempty

    addDescription :: Referenced Response -> Referenced Response
    addDescription (Ref r) = Ref r
    addDescription (Inline r) =
      case desc of
        Nothing -> Inline r
        Just (Description d) -> Inline (r & description .~ d)