{-# LANGUAGE FlexibleInstances     #-}
{-# LANGUAGE KindSignatures        #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings     #-}

module Web.Eved.Options
    where

import qualified Data.ByteString    as B
import           Data.Coerce        (coerce)
import           Data.Text          (Text)
import           Network.HTTP.Types
import           Network.Wai
import           Web.Eved.Internal

provideOptions :: EvedOptions m a -> Middleware
provideOptions :: EvedOptions m a -> Middleware
provideOptions EvedOptions m a
api Application
app Request
req Response -> IO ResponseReceived
respond
  | Request -> Method
requestMethod Request
req Method -> Method -> Bool
forall a. Eq a => a -> a -> Bool
== Method
"OPTIONS" = Response -> IO ResponseReceived
respond (EvedOptions m a -> Request -> Response
forall (m :: * -> *) a. EvedOptions m a -> Request -> Response
getOptionsResponse EvedOptions m a
api Request
req)
  | Bool
otherwise = Application
app Request
req Response -> IO ResponseReceived
respond

getOptionsResponse :: EvedOptions m a -> Request -> Response
getOptionsResponse :: EvedOptions m a -> Request -> Response
getOptionsResponse EvedOptions m a
api Request
req =
    let methods :: [Method]
methods = (StdMethod -> Method) -> [StdMethod] -> [Method]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap StdMethod -> Method
renderStdMethod ([StdMethod] -> [Method]) -> [StdMethod] -> [Method]
forall a b. (a -> b) -> a -> b
$ EvedOptions m a -> [Text] -> [StdMethod]
forall (m :: * -> *) a. EvedOptions m a -> [Text] -> [StdMethod]
getAvailableMethods EvedOptions m a
api (Request -> [Text]
pathInfo Request
req)
        headers :: [(HeaderName, Method)]
headers = [ (HeaderName
"Allow", Method -> [Method] -> Method
B.intercalate Method
", " ([Method] -> Method) -> [Method] -> Method
forall a b. (a -> b) -> a -> b
$ Method
"OPTIONS"Method -> [Method] -> [Method]
forall a. a -> [a] -> [a]
:[Method]
methods) ]
    in Status -> [(HeaderName, Method)] -> Builder -> Response
responseBuilder Status
status200 [(HeaderName, Method)]
headers Builder
forall a. Monoid a => a
mempty

newtype EvedOptions (m :: * -> *) a = EvedOptions
    { EvedOptions m a -> [Text] -> [StdMethod]
getAvailableMethods :: [Text] -> [StdMethod]
    }

passthrough :: EvedOptions m a -> EvedOptions m b
passthrough :: EvedOptions m a -> EvedOptions m b
passthrough = EvedOptions m a -> EvedOptions m b
coerce

instance Eved (EvedOptions m) m where
    EvedOptions m a
left .<|> :: EvedOptions m a -> EvedOptions m b -> EvedOptions m (a :<|> b)
.<|> EvedOptions m b
right = ([Text] -> [StdMethod]) -> EvedOptions m (a :<|> b)
forall (m :: * -> *) a. ([Text] -> [StdMethod]) -> EvedOptions m a
EvedOptions (([Text] -> [StdMethod]) -> EvedOptions m (a :<|> b))
-> ([Text] -> [StdMethod]) -> EvedOptions m (a :<|> b)
forall a b. (a -> b) -> a -> b
$ \[Text]
path ->
        EvedOptions m a -> [Text] -> [StdMethod]
forall (m :: * -> *) a. EvedOptions m a -> [Text] -> [StdMethod]
getAvailableMethods EvedOptions m a
left [Text]
path [StdMethod] -> [StdMethod] -> [StdMethod]
forall a. Semigroup a => a -> a -> a
<> EvedOptions m b -> [Text] -> [StdMethod]
forall (m :: * -> *) a. EvedOptions m a -> [Text] -> [StdMethod]
getAvailableMethods EvedOptions m b
right [Text]
path

    lit :: Text -> EvedOptions m a -> EvedOptions m a
lit Text
t EvedOptions m a
next = ([Text] -> [StdMethod]) -> EvedOptions m a
forall (m :: * -> *) a. ([Text] -> [StdMethod]) -> EvedOptions m a
EvedOptions (([Text] -> [StdMethod]) -> EvedOptions m a)
-> ([Text] -> [StdMethod]) -> EvedOptions m a
forall a b. (a -> b) -> a -> b
$ \[Text]
path ->
        case [Text]
path of
          Text
p:[Text]
rest | Text
p Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== Text
t -> EvedOptions m a -> [Text] -> [StdMethod]
forall (m :: * -> *) a. EvedOptions m a -> [Text] -> [StdMethod]
getAvailableMethods EvedOptions m a
next [Text]
rest
          [Text]
_               -> [StdMethod]
forall a. Monoid a => a
mempty

    capture :: Text -> UrlElement a -> EvedOptions m b -> EvedOptions m (a -> b)
capture Text
_ UrlElement a
_ EvedOptions m b
next = ([Text] -> [StdMethod]) -> EvedOptions m (a -> b)
forall (m :: * -> *) a. ([Text] -> [StdMethod]) -> EvedOptions m a
EvedOptions (([Text] -> [StdMethod]) -> EvedOptions m (a -> b))
-> ([Text] -> [StdMethod]) -> EvedOptions m (a -> b)
forall a b. (a -> b) -> a -> b
$ \[Text]
path ->
        case [Text]
path of
          Text
_:[Text]
rest -> EvedOptions m b -> [Text] -> [StdMethod]
forall (m :: * -> *) a. EvedOptions m a -> [Text] -> [StdMethod]
getAvailableMethods EvedOptions m b
next [Text]
rest
          [Text]
_      -> [StdMethod]
forall a. Monoid a => a
mempty

    reqBody :: NonEmpty (ContentType a)
-> EvedOptions m b -> EvedOptions m (a -> b)
reqBody NonEmpty (ContentType a)
_ = EvedOptions m b -> EvedOptions m (a -> b)
forall (m :: * -> *) a b. EvedOptions m a -> EvedOptions m b
passthrough
    queryParam :: Text -> QueryParam a -> EvedOptions m b -> EvedOptions m (a -> b)
queryParam Text
_ QueryParam a
_ = EvedOptions m b -> EvedOptions m (a -> b)
forall (m :: * -> *) a b. EvedOptions m a -> EvedOptions m b
passthrough
    verb :: StdMethod
-> Status -> NonEmpty (ContentType a) -> EvedOptions m (m a)
verb StdMethod
method Status
_ NonEmpty (ContentType a)
_ = ([Text] -> [StdMethod]) -> EvedOptions m (m a)
forall (m :: * -> *) a. ([Text] -> [StdMethod]) -> EvedOptions m a
EvedOptions (([Text] -> [StdMethod]) -> EvedOptions m (m a))
-> ([Text] -> [StdMethod]) -> EvedOptions m (m a)
forall a b. (a -> b) -> a -> b
$ \[Text]
path ->
        case [Text]
path of
          [] -> [StdMethod
method]
          [Text]
_  -> [StdMethod]
forall a. Monoid a => a
mempty