{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.Wai.Middleware.Servant.Options (provideOptions) where
import Servant
import Servant.Foreign
import Network.Wai
import Data.Text hiding (null, zipWith, length)
import Network.HTTP.Types.Method
import Data.Maybe
import Data.List (nub)
import Network.HTTP.Types
import qualified Data.ByteString as B
provideOptions :: (GenerateList NoContent (Foreign NoContent api), HasForeign NoTypes NoContent api)
=> Proxy api -> Middleware
provideOptions :: forall api.
(GenerateList NoContent (Foreign NoContent api),
HasForeign NoTypes NoContent api) =>
Proxy api -> Middleware
provideOptions Proxy api
apiproxy Application
app Request
req Response -> IO ResponseReceived
cb
| Method
rmeth forall a. Eq a => a -> a -> Bool
== Method
"OPTIONS" = forall r. (Response -> r) -> r -> [Text] -> [Req NoContent] -> r
optional Response -> IO ResponseReceived
cb IO ResponseReceived
prior [Text]
pinfo [Req NoContent]
mlist
| Bool
otherwise = IO ResponseReceived
prior
where
rmeth :: Method
rmeth = Request -> Method
requestMethod Request
req :: Method
pinfo :: [Text]
pinfo = Request -> [Text]
pathInfo Request
req :: [ Text ]
mlist :: [Req NoContent]
mlist = forall {k} (lang :: k) ftype api.
(HasForeign lang ftype api,
GenerateList ftype (Foreign ftype api)) =>
Proxy lang -> Proxy ftype -> Proxy api -> [Req ftype]
listFromAPI (forall {k} (t :: k). Proxy t
Proxy :: Proxy NoTypes) (forall {k} (t :: k). Proxy t
Proxy :: Proxy NoContent) Proxy api
apiproxy
prior :: IO ResponseReceived
prior = Application
app Request
req Response -> IO ResponseReceived
cb
optional :: (Response -> r) -> r -> [Text] -> [Req NoContent] -> r
optional :: forall r. (Response -> r) -> r -> [Text] -> [Req NoContent] -> r
optional Response -> r
cb r
prior [Text]
ts [Req NoContent]
rs
| forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Method]
methods = r
prior
| Bool
otherwise = Response -> r
cb ([Method] -> Response
buildResponse [Method]
methods)
where
methods :: [Method]
methods = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ([Text] -> Req NoContent -> Maybe Method
getMethod [Text]
ts) [Req NoContent]
rs
getMethod :: [Text] -> Req NoContent -> Maybe Method
getMethod :: [Text] -> Req NoContent -> Maybe Method
getMethod [Text]
rs Req NoContent
ps
| Bool
sameLength Bool -> Bool -> Bool
&& Bool
matchingSegments = forall a. a -> Maybe a
Just (forall ftype. Req ftype -> Method
_reqMethod Req NoContent
ps)
| Bool
otherwise = forall a. Maybe a
Nothing
where
pattern :: Path NoContent
pattern = forall ftype. Url ftype -> Path ftype
_path forall a b. (a -> b) -> a -> b
$ forall ftype. Req ftype -> Url ftype
_reqUrl Req NoContent
ps
sameLength :: Bool
sameLength = forall (t :: * -> *) a. Foldable t => t a -> Int
length [Text]
rs forall a. Eq a => a -> a -> Bool
== forall (t :: * -> *) a. Foldable t => t a -> Int
length Path NoContent
pattern
matchingSegments :: Bool
matchingSegments = forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Text -> Segment NoContent -> Bool
matchSegment [Text]
rs Path NoContent
pattern
matchSegment :: Text -> Segment NoContent -> Bool
matchSegment :: Text -> Segment NoContent -> Bool
matchSegment Text
a (Segment (Static (PathSegment Text
b)) ) | Text
a forall a. Eq a => a -> a -> Bool
/= Text
b = Bool
False
matchSegment Text
_ Segment NoContent
_ = Bool
True
buildResponse :: [Method] -> Response
buildResponse :: [Method] -> Response
buildResponse [Method]
ms = Status -> ResponseHeaders -> Builder -> Response
responseBuilder Status
s ResponseHeaders
h forall a. Monoid a => a
mempty
where
s :: Status
s = Int -> Method -> Status
Status Int
200 Method
"OK"
m :: Method
m = Method -> [Method] -> Method
B.intercalate Method
", " (Method
"OPTIONS" forall a. a -> [a] -> [a]
: forall a. Eq a => [a] -> [a]
nub [Method]
ms)
h :: ResponseHeaders
h = [ (HeaderName
"Allow", Method
m) ]