{-# 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 (responseStatus))
import WebGear.Core.Trait (Linked, Set, setTrait, unlink)
import WebGear.Core.Trait.Status (Status (..))
import WebGear.Server.Handler (ServerHandler)

instance Monad m => Set (ServerHandler m) Status Response where
  {-# INLINEABLE setTrait #-}
  setTrait ::
    Status ->
    (Linked ts Response -> Response -> HTTP.Status -> Linked (Status : ts) Response) ->
    ServerHandler m (Linked ts Response, HTTP.Status) (Linked (Status : ts) Response)
  setTrait :: Status
-> (Linked ts Response
    -> Response -> Status -> Linked (Status : ts) Response)
-> ServerHandler
     m (Linked ts Response, Status) (Linked (Status : ts) Response)
setTrait (Status Status
status) Linked ts Response
-> Response -> Status -> Linked (Status : ts) Response
f = proc (Linked ts Response
linkedResponse, Status
_) -> do
    let response :: Response
response = Linked ts Response -> Response
forall (ts :: [*]) a. Linked ts a -> a
unlink Linked ts Response
linkedResponse
        response' :: Response
response' = Response
response{responseStatus :: Status
responseStatus = Status
status}
    ServerHandler
  m (Linked (Status : ts) Response) (Linked (Status : ts) Response)
forall (a :: * -> * -> *) b. Arrow a => a b b
returnA -< Linked ts Response
-> Response -> Status -> Linked (Status : ts) Response
f Linked ts Response
linkedResponse Response
response' Status
status