Merge remote-tracking branch 'origin/main' into tools

docs/src/02-request-anatomy.md

@@ -144,7 +144,7 @@ Other wrappers look very similar:
 * `Optional name value` - for optional queries
 * `QueryFlag` - for boolean query that can be missing in the path (and then it is `false`)
 * `Body media value` - for request body
-
+* `Cookie` - for cookie (set in the header)
 
 ### Using custom types as query parameters
 
@@ -498,6 +498,7 @@ We can query
 * `Optional name value` - for optional queries
 * `Header name value` - for required headers
 * `OptionalHeader name value` - for optional headers
+* `Cookie value` - for cookies (set in the header)
 * `Capture name value` - for path captures
 * `QueryFlag` - for boolean query that can be missing in the path (and then it is `false`)
 

docs/src/03-response-anatomy.md

@@ -195,6 +195,23 @@ setStatus :: IsResp a => Status -> a -> a
 Although we rarely need this function as `ok` sets the right status 
 for successful response and all functions that need the status take it as argument.
 
+Also we have functions to set cookies that are form url-encoded:
+
+```haskell
+setCookie :: (ToForm val, IsResp a) => SetCookie val -> a -> a
+
+-- sets cookie params
+data SetCookie 
+
+-- | Cookie setter with default params (only value)
+defCookie :: val -> SetCookie val
+defCookie = ...
+```
+
+For great explanation on how cookies work in HTTP you can read [an article](https://web.archive.org/web/20170122122852/https://www.nczonline.net/blog/2009/05/05/http-cookies-explained/).
+Under the hood it is just a http-header with name `SetCookie`.
+To read the cookie value use input request `newtype`-wrapper `Cookie`.
+
 ### How it works with server definition
 
 How can we use both of the types as responses: `Resp` and `RespOr`?

docs/src/09-reference.md

@@ -70,6 +70,9 @@ newtype Capture name value = Capture value
 -- boolean query flag parameter
 newtype QueryFlag name = QueryFlag Bool
 
+-- optional cookies (set in the header)
+newtype Cookie value = Cookie (Maybe value)
+
 -- Is connection made over SSL
 newtype IsSecure = IsSecure Bool
 
@@ -135,6 +138,21 @@ class IsResp a where
 
 setHeader :: (IsResp a, ToHttpApiData h) => HeaderName -> h -> a -> a
 
+-- | Set cookie as http header from form url encoded value
+setCookie :: (ToForm cookie, IsResp resp) => SetCookie cookie -> resp -> resp
+
+data SetCookie a = SetCookie
+  { cookie :: a
+  , expires :: Maybe UTCTime
+  , domain :: Maybe Text
+  , path :: Maybe Text
+  , secure :: Bool
+  , httpOnly :: Bool
+  }
+
+-- | Default cookie which sets only the cookie itself.
+defCookie :: a -> SetCookie a
+
 -- | Bad request. The @bad@ response with 400 status.
 badReq :: (IsResp a) => RespError a -> a
 

mig-extra/src/Mig/Extra/Server/Common.hs

@@ -25,6 +25,9 @@ module Mig.Extra.Server.Common (
   notImplemented,
   redirect,
   setHeader,
+  setCookie,
+  SetCookie (..),
+  defCookie,
 
   -- ** methods
   Send (..),
@@ -48,6 +51,8 @@ module Mig.Extra.Server.Common (
   QueryFlag (..),
   Optional (..),
   Header (..),
+  OptionalHeader (..),
+  Cookie (..),
   PathInfo (..),
   FullPathInfo (..),
   RawRequest (..),

mig-server/src/Mig.hs

@@ -46,6 +46,9 @@ module Mig (
   notImplemented,
   redirect,
   setHeader,
+  setCookie,
+  SetCookie (..),
+  defCookie,
 
   -- ** methods
   Send (..),
@@ -77,6 +80,8 @@ module Mig (
   QueryFlag (..),
   Optional (..),
   Body (..),
+  OptionalHeader (..),
+  Cookie (..),
   Header (..),
   PathInfo (..),
   FullPathInfo (..),

mig/mig.cabal

@@ -90,6 +90,7 @@ library
     , openapi3
     , safe
     , text
+    , time
     , transformers
   default-language: GHC2021
 

mig/package.yaml

@@ -80,6 +80,7 @@ library:
   - lens
   - lrucache
   - transformers
+  - time
 
 tests:
   mig-test:

mig/src/Mig/Core/Class/Plugin.hs

@@ -53,7 +53,9 @@ import Control.Monad.IO.Class
 import Data.OpenApi (ToParamSchema (..), ToSchema (..))
 import Data.Proxy
 import Data.String
+import Data.Text (Text)
 import GHC.TypeLits
+import Web.FormUrlEncoded (FromForm)
 import Web.HttpApiData
 
 import Mig.Core.Class.MediaType
@@ -158,6 +160,11 @@ instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => To
   toPluginInfo = addOptionalHeaderInfo @sym @a . toPluginInfo @b
   toPluginFun f = \fun -> withOptionalHeader (getName @sym) (\a -> toPluginFun (f (OptionalHeader a)) fun)
 
+-- cookie
+instance (FromForm a, ToPlugin b) => ToPlugin (Cookie a -> b) where
+  toPluginInfo = addOptionalHeaderInfo @"Cookie" @Text . toPluginInfo @b
+  toPluginFun f = \fun -> withCookie (\a -> toPluginFun (f (Cookie a)) fun)
+
 -- query
 instance (FromHttpApiData a, ToParamSchema a, ToPlugin b, KnownSymbol sym) => ToPlugin (Query sym a -> b) where
   toPluginInfo = addQueryInfo @sym @a . toPluginInfo @b

mig/src/Mig/Core/Class/Response.hs

@@ -8,17 +8,26 @@ module Mig.Core.Class.Response (
   notImplemented,
   redirect,
   setHeader,
+  SetCookie (..),
+  defCookie,
+  setCookie,
 ) where
 
 import Data.Bifunctor
+import Data.ByteString (ByteString)
 import Data.ByteString.Lazy qualified as BL
 import Data.Kind
+import Data.List qualified as List
+import Data.Maybe
 import Data.Text (Text)
+import Data.Text qualified as Text
 import Data.Text.Encoding qualified as Text
+import Data.Time
 import Network.HTTP.Media.RenderHeader (RenderHeader (..))
-import Network.HTTP.Types.Header (HeaderName, ResponseHeaders)
+import Network.HTTP.Types.Header (HeaderName, ResponseHeaders, hSetCookie)
 import Network.HTTP.Types.Status (Status, internalServerError500, notImplemented501, ok200, status302, status400)
 import Web.HttpApiData
+import Web.Internal.FormUrlEncoded
 
 import Mig.Core.Class.MediaType (AnyMedia, MediaType, ToMediaType (..), ToRespBody (..))
 import Mig.Core.Types.Http (Response, ResponseBody (..), noContentResponse)
@@ -191,3 +200,62 @@ notImplemented = bad notImplemented501
 -- | Redirect to url. It is @bad@ response with 302 status and set header of "Location" to a given URL.
 redirect :: (IsResp a) => Text -> a
 redirect url = addHeaders [("Location", Text.encodeUtf8 url)] $ noContent status302
+
+-- | Set cookie as http header from form url encoded value
+setCookie :: (ToForm cookie, IsResp resp) => SetCookie cookie -> resp -> resp
+setCookie cookie = addHeaders [(hSetCookie, renderSetCookie cookie)]
+
+{-| Set cookie params. For explanation see an article
+<https://web.archive.org/web/20170122122852/https://www.nczonline.net/blog/2009/05/05/http-cookies-explained/>
+-}
+data SetCookie a = SetCookie
+  { cookie :: a
+  , expires :: Maybe UTCTime
+  , domain :: Maybe Text
+  , path :: Maybe Text
+  , secure :: Bool
+  , httpOnly :: Bool
+  }
+  deriving (Show, Eq)
+
+renderSetCookie :: (ToForm a) => SetCookie a -> ByteString
+renderSetCookie value =
+  mconcat $
+    (BL.toStrict $ urlEncodeForm $ toForm value.cookie)
+      : addColons
+        ( catMaybes
+            [ param "expires" . fmtTime <$> value.expires
+            , param "domain" <$> value.domain
+            , param "path" <$> value.path
+            , flag "secure" value.secure
+            , flag "httpOnly" value.httpOnly
+            ]
+        )
+  where
+    addColons xs
+      | null xs = []
+      | otherwise = ";" : List.intersperse ";" xs
+
+    param name v = Text.encodeUtf8 $ name <> v
+
+    flag name = \case
+      True -> Just name
+      False -> Nothing
+
+    fmtTime :: UTCTime -> Text
+    fmtTime = Text.pack . formatTime defaultTimeLocale expiresFormat
+
+    expiresFormat :: String
+    expiresFormat = "%a, %d-%b-%Y %X GMT"
+
+-- | Default cookie which sets only the cookie itself.
+defCookie :: a -> SetCookie a
+defCookie val =
+  SetCookie
+    { cookie = val
+    , expires = Nothing
+    , domain = Nothing
+    , path = Nothing
+    , secure = False
+    , httpOnly = False
+    }

mig/src/Mig/Core/Class/Route.hs

@@ -13,12 +13,14 @@ import Control.Monad.IO.Class
 import Data.OpenApi (ToParamSchema (..), ToSchema (..))
 import Data.Proxy
 import Data.String
+import Data.Text (Text)
 import GHC.TypeLits
 import Mig.Core.Class.MediaType
 import Mig.Core.Class.Monad
 import Mig.Core.Class.Response (IsResp (..))
 import Mig.Core.ServerFun
 import Mig.Core.Types
+import Web.FormUrlEncoded (FromForm)
 import Web.HttpApiData
 
 {-| Values that represent routes.
@@ -88,6 +90,10 @@ instance (FromHttpApiData a, ToParamSchema a, ToRoute b, KnownSymbol sym) => ToR
   toRouteInfo = addOptionalHeaderInfo @sym @a . toRouteInfo @b
   toRouteFun f = withOptionalHeader (getName @sym) (toRouteFun . f . OptionalHeader)
 
+instance (FromForm a, ToRoute b) => ToRoute (Cookie a -> b) where
+  toRouteInfo = addOptionalHeaderInfo @"Cookie" @Text . toRouteInfo @b
+  toRouteFun f = withCookie (toRouteFun . f . Cookie)
+
 instance (ToRoute b) => ToRoute (PathInfo -> b) where
   toRouteInfo = toRouteInfo @b
   toRouteFun f = withPathInfo (toRouteFun . f . PathInfo)

mig/src/Mig/Core/ServerFun.hs

@@ -19,6 +19,7 @@ module Mig.Core.ServerFun (
   withCapture,
   withHeader,
   withOptionalHeader,
+  withCookie,
   withPathInfo,
   withFullPathInfo,
   handleServerError,
@@ -39,6 +40,7 @@ import Mig.Core.Class.MediaType
 import Mig.Core.Types
 import Network.HTTP.Types.Header (HeaderName)
 import Network.HTTP.Types.Status (status500)
+import Web.FormUrlEncoded (FromForm (..), urlDecodeForm)
 import Web.HttpApiData
 
 {-| Low-level representation of the server.
@@ -144,6 +146,14 @@ withOptionalHeader name act = withQueryBy getVal act
   where
     getVal req = eitherToMaybe . parseHeader =<< Map.lookup name req.headers
 
+withCookie :: forall a m. (FromForm a) => (Maybe a -> ServerFun m) -> ServerFun m
+withCookie act = withOptionalHeader @Text "Cookie" (act . (parseCookie =<<))
+  where
+    parseCookie :: Text -> Maybe a
+    parseCookie txt = do
+      form <- eitherToMaybe $ urlDecodeForm $ BL.fromStrict $ Text.encodeUtf8 txt
+      eitherToMaybe $ fromForm form
+
 -- | Reads full path (without qury parameters)
 withPathInfo :: ([Text] -> ServerFun m) -> ServerFun m
 withPathInfo act = \req -> act req.path req

mig/src/Mig/Core/Types/Route.hs

@@ -8,6 +8,7 @@ module Mig.Core.Types.Route (
   Capture (..),
   Header (..),
   OptionalHeader (..),
+  Cookie (..),
   PathInfo (..),
   FullPathInfo (..),
   RawRequest (..),
@@ -94,6 +95,21 @@ It reads the value:
 -}
 newtype OptionalHeader (sym :: Symbol) a = OptionalHeader (Maybe a)
 
+{-| Reads a cookie. It's an optional header with name "Cookie".
+The cookie is URL-encoded and read with instnace of FromForm class.
+
+> data MyCookie = MyCookie
+>   { secret :: Text
+>   , count :: Int
+>   }
+>   deriving (Generic, FromForm)
+>
+> > "secret=lolkek&count=101"
+>
+> (Cookie (Just (MyCookie { secret = "lolkek", count = 101 }))) :: Cookie MyCookie
+-}
+newtype Cookie a = Cookie (Maybe a)
+
 {-| Reads current path info.
 
 > "api/foo/bar" ==> PathInfo ["foo", "bar"]

mig/test/Test/Server/Counter.hs

@@ -6,6 +6,7 @@ import Data.IORef
 import Data.Maybe
 import Data.Text qualified as Text
 import Mig.Core
+import Mig.Core qualified as Request (Request (..))
 import Network.HTTP.Types.Method (methodPost)
 import Test.Hspec
 import Test.Server.Common
@@ -82,8 +83,8 @@ script f inputs = do
     putReq increment =
       emptyReq
         { method = methodPost
-        , path = ["counter", "put", Text.pack (show increment)]
+        , Request.path = ["counter", "put", Text.pack (show increment)]
         }
 
     getReq :: Request
-    getReq = emptyReq{path = ["counter", "get"]}
+    getReq = emptyReq{Request.path = ["counter", "get"]}

mig/test/Test/Server/Hello.hs

@@ -55,10 +55,10 @@ specBy finder = do
         it "wrong output media type" $ do
           serverFun (helloReq{Request.headers = Map.fromList [("Accept", "text/html")]}) `shouldReturn` Nothing
 
-    helloReq = emptyReq{path = ["api", "v1", "hello"]}
+    helloReq = emptyReq{Request.path = ["api", "v1", "hello"]}
     helloResp = Just $ jsonResp @Text "hello"
 
-    byeReq = emptyReq{path = ["api", "v1", "bye"]}
+    byeReq = emptyReq{Request.path = ["api", "v1", "bye"]}
     byeResp = Just $ jsonResp @Text "bye"
 
-    wrongPathReq = emptyReq{path = ["api", "v2", "hello"]}
+    wrongPathReq = emptyReq{Request.path = ["api", "v2", "hello"]}