Add linear types to ResponderHeaders DSL

okapi.cabal

@@ -34,6 +34,7 @@ library
       Okapi.Endpoint.Headers
       Okapi.Endpoint.Body
       Okapi.Endpoint.Responder
+      Okapi.Endpoint.ResponderHeaders
       Okapi.Params
       Okapi.Response
       Okapi.Controller
@@ -53,6 +54,7 @@ library
     , extra
     , http-api-data
     , http-types
+    , linear-base
     , memory
     , mmorph
     , mtl
@@ -93,6 +95,7 @@ test-suite okapi-test
     , hspec
     , http-api-data
     , http-types
+    , linear-base
     , memory
     , mmorph
     , mtl

src/Okapi/Endpoint/Responder.hs

@@ -74,3 +74,12 @@ eval op state = case op of
                 }
        in (Right f, state)
     (left, _) -> (Left ResponderHeadersError, state)
+
+json ::
+  Aeson.ToJSON a =>
+  HTTP.Status ->
+  ResponseHeaders.ResponderHeaders h ->
+  (h %1 -> ResponseHeaders.Response -> ResponseHeaders.Response) ->
+  Responder
+    (a -> ResponseHeaders.Response)
+json = JSON

src/Okapi/Endpoint/ResponderHeaders.hs

@@ -37,7 +37,17 @@ data ResponderHeaders a where
   FMap :: (a -> b) -> ResponderHeaders a -> ResponderHeaders b
   Pure :: a -> ResponderHeaders a
   Apply :: ResponderHeaders (a -> b) -> ResponderHeaders a -> ResponderHeaders b
-  HasHeader :: Web.ToHttpApiData a => HTTP.HeaderName -> ResponderHeaders (a -> (Response -> Response))
+  Has :: Web.ToHttpApiData a => HTTP.HeaderName -> ResponderHeaders (a -> (Response -> Response))
+
+instance Functor ResponderHeaders where
+  fmap :: (a -> b) -> ResponderHeaders a -> ResponderHeaders b
+  fmap = FMap
+
+instance Applicative ResponderHeaders where
+  pure :: a -> ResponderHeaders a
+  pure = Pure
+  (<*>) :: ResponderHeaders (a -> b) -> ResponderHeaders a -> ResponderHeaders b
+  (<*>) = Apply
 
 eval ::
   ResponderHeaders a ->
@@ -54,6 +64,13 @@ eval op state = case op of
       (Right x, state'') -> (Right $ f x, state'')
       (Left e, state'') -> (Left e, state'')
     (Left e, state') -> (Left e, state')
-  HasHeader headerName ->
+  Has headerName ->
     let f value response = response {headers = headers response <> [ResponseHeader headerName $ Web.toHeader value]}
-     in (Right f, state)
+     in (Right f, state)
+
+has ::
+  Web.ToHttpApiData a =>
+  HTTP.HeaderName ->
+  ResponderHeaders
+    (a -> Response -> Response)
+has = Has

test/Spec.hs

@@ -1,15 +1,23 @@
 {-# LANGUAGE ApplicativeDo #-}
+{-# LANGUAGE BlockArguments #-}
 {-# LANGUAGE DuplicateRecordFields #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE LinearTypes #-}
+{-# LANGUAGE NamedFieldPuns #-}
 {-# LANGUAGE OverloadedRecordDot #-}
 {-# LANGUAGE OverloadedStrings #-}
 {-# LANGUAGE RecordWildCards #-}
 {-# LANGUAGE TypeApplications #-}
 
 import Control.Exception (evaluate)
+import qualified Data.Aeson as Aeson
 import qualified Data.Text as Text
+import qualified Network.HTTP.Types as HTTP
 import qualified Okapi.Endpoint.Path as Path
 import qualified Okapi.Endpoint.Query as Query
+import qualified Okapi.Endpoint.Responder as Responder
+import qualified Okapi.Endpoint.ResponderHeaders as ResponderHeaders
+import qualified Prelude.Linear as Linear
 import Test.Hspec
 import qualified Web.HttpApiData as Web
 
@@ -56,8 +64,53 @@ main = hspec $ do
     it "returns the first element of a list" $ do
       Query.eval query3 [("username", Just "Bob")] `shouldBe` (Right (Username "Anon", Nothing), [("username", Just "Bob")])
 
+{-
+  describe "Responder Operations" $ do
+    it "returns the first element of a list" $ do
+      Query.eval responder1 [("score", Just "5"), ("user", Just "Joe")] `shouldBe` (Right $ Filter 5 $ Username "Joe", [])
+
+    it "returns the first element of a list" $ do
+      Query.eval responder2 [("user", Just "Bob"), ("active", Nothing)] `shouldBe` (Right $ Username "Bob", [])
+
+    it "returns the first element of a list" $ do
+      Query.eval responder2 [("username", Just "Bob")] `shouldBe` (Right (Username "Anon", Nothing), [("username", Just "Bob")])
+-}
+
+data AddHeaders = AddHeaders
+  { addCookie :: Username -> ResponderHeaders.Response -> ResponderHeaders.Response,
+    addAnotherHeader :: Username -> ResponderHeaders.Response -> ResponderHeaders.Response
+  }
+
+responder1 ::
+  Responder.Responder
+    ( Aeson.Value -> ResponderHeaders.Response,
+      Aeson.Value -> ResponderHeaders.Response
+    )
+responder1 = do
+  itsOk <- Responder.json
+    @Aeson.Value
+    HTTP.status200
+    do
+      addCookie <- ResponderHeaders.has @Username "Cookie"
+      pure addCookie
+    \addCookie -> addCookie $ Username "Bob"
+  itsNotFound <- Responder.json
+    @Aeson.Value
+    HTTP.status404
+    do
+      addCookie <- ResponderHeaders.has @Username "Blob"
+      addAnotherHeader <- ResponderHeaders.has @Username "X-Some-Header"
+      pure $ AddHeaders {..}
+    \AddHeaders {..} response -> addAnotherHeader (Username "John") $ addCookie (Username "Bob") response
+  pure (itsOk, itsNotFound)
+
+-- f :: (Username -> ResponderHeaders.Response -> ResponderHeaders.Response, Username -> ResponderHeaders.Response -> ResponderHeaders.Response) %1 -> ResponderHeaders.Response -> ResponderHeaders.Response
+-- f (addCookie, addAnotherCookie) response = addAnotherHeader (Username "John") $ addCookie (Username "Bob") response
+
+responder2 = undefined
+
 newtype Username = Username {unwrap :: Text.Text}
-  deriving (Eq, Show, Web.FromHttpApiData)
+  deriving (Eq, Show, Web.FromHttpApiData, Web.ToHttpApiData)
 
 data Filter = Filter
   { score :: Int,