{-# OPTIONS_GHC -Wno-orphans #-}

-- | Server implementation of the `Status` trait.
module WebGear.Server.Trait.Status where

import Control.Arrow (returnA)
import qualified Network.HTTP.Types.Status as HTTP
import WebGear.Core.Response (Response (..))
import WebGear.Core.Trait (Set, With, setTrait, unwitness)
import WebGear.Core.Trait.Status (Status (..))
import WebGear.Server.Handler (ServerHandler)

instance (Monad m) => Set (ServerHandler m) Status Response where
  {-# INLINE setTrait #-}
  setTrait ::
    Status ->
    (Response `With` ts -> Response -> HTTP.Status -> Response `With` (Status : ts)) ->
    ServerHandler m (Response `With` ts, HTTP.Status) (Response `With` (Status : ts))
  setTrait :: forall (ts :: [*]).
Status
-> (With Response ts
    -> Response -> Status -> With Response (Status : ts))
-> ServerHandler
     m (With Response ts, Status) (With Response (Status : ts))
setTrait (Status Status
status) With Response ts
-> Response -> Status -> With Response (Status : ts)
f = proc (With Response ts
wResponse, Status
_) -> do
    let response' :: Response
response' =
          case With Response ts -> Response
forall a (ts :: [*]). With a ts -> a
unwitness With Response ts
wResponse of
            Response Status
_ ResponseHeaders
hdrs ResponseBody
body -> Status -> ResponseHeaders -> ResponseBody -> Response
Response Status
status ResponseHeaders
hdrs ResponseBody
body
            Response
response -> Response
response
    ServerHandler
  m (With Response (Status : ts)) (With Response (Status : ts))
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< With Response ts
-> Response -> Status -> With Response (Status : ts)
f With Response ts
wResponse Response
response' Status
status