{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE UndecidableInstances #-}

-- | Provides instances from server-related types to jordan API combinators.
--
-- Sadly, this does mean that this module has a bunch of orphan instances.
-- Please, *please* use these instead of any others.
-- Please.
module Jordan.Servant.Server where

import Control.Monad.IO.Class
import Data.ByteString as SBS
import qualified Data.ByteString.Lazy as LBS
import Data.List.NonEmpty (toList)
import Data.Maybe (fromMaybe)
import Data.Proxy
import qualified Data.Text as T
import GHC.TypeLits
import Jordan
import Jordan.Servant
import Jordan.Servant.Query
import Jordan.Servant.Query.Parse
import Jordan.Types.JSONError
import Network.HTTP.Media (matchContent)
import Network.HTTP.Types.Header (hContentType)
import Network.Wai (Request (..), lazyRequestBody, queryString)
import Servant.API
import Servant.API.Modifiers
import Servant.Server
import Servant.Server.Internal
import Servant.Server.Internal.ServerError
import Servant.Server.UVerb

-- | Parse a request body.
-- On parse errors where a valid but wrong-for-the-type JSON is given, we return back an error report.
instance forall a rest context. (HasServer rest context, FromJSON a) => HasServer (ReportingRequestBody a :> rest) context where
  type ServerT (ReportingRequestBody a :> rest) m = a -> ServerT rest m
  hoistServerWithContext :: Proxy (ReportingRequestBody a :> rest)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (ReportingRequestBody a :> rest) m
-> ServerT (ReportingRequestBody a :> rest) n
hoistServerWithContext Proxy (ReportingRequestBody a :> rest)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (ReportingRequestBody a :> rest) m
s = Proxy rest
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT rest m
-> ServerT rest n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest) Proxy context
pc forall x. m x -> n x
nt (ServerT rest m -> ServerT rest n)
-> (a -> ServerT rest m) -> a -> ServerT rest n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (ReportingRequestBody a :> rest) m
a -> ServerT rest m
s
  route :: Proxy (ReportingRequestBody a :> rest)
-> Context context
-> Delayed env (Server (ReportingRequestBody a :> rest))
-> Router env
route (Proxy (ReportingRequestBody a :> rest)
Proxy :: Proxy (ReportingRequestBody a :> rest)) Context context
context Delayed env (Server (ReportingRequestBody a :> rest))
subserver =
    Proxy rest
-> Context context -> Delayed env (Server rest) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest) Context context
context (Delayed env (Server rest) -> Router env)
-> Delayed env (Server rest) -> Router env
forall a b. (a -> b) -> a -> b
$ Delayed env (a -> Server rest)
-> DelayedIO (ByteString -> Either JSONError a)
-> ((ByteString -> Either JSONError a) -> DelayedIO a)
-> Delayed env (Server rest)
forall env a b c.
Delayed env (a -> b)
-> DelayedIO c -> (c -> DelayedIO a) -> Delayed env b
addBodyCheck Delayed env (Server (ReportingRequestBody a :> rest))
Delayed env (a -> Server rest)
subserver DelayedIO (ByteString -> Either JSONError a)
checkContent (ByteString -> Either JSONError a) -> DelayedIO a
forall a a. ToJSON a => (ByteString -> Either a a) -> DelayedIO a
checkBody
    where
      checkContent :: DelayedIO (ByteString -> Either JSONError a)
checkContent = (Request -> DelayedIO (ByteString -> Either JSONError a))
-> DelayedIO (ByteString -> Either JSONError a)
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO (ByteString -> Either JSONError a))
 -> DelayedIO (ByteString -> Either JSONError a))
-> (Request -> DelayedIO (ByteString -> Either JSONError a))
-> DelayedIO (ByteString -> Either JSONError a)
forall a b. (a -> b) -> a -> b
$ \Request
request -> do
        let contentType :: ByteString
contentType = ByteString -> Maybe ByteString -> ByteString
forall a. a -> Maybe a -> a
fromMaybe ByteString
"application/octect-stream" (Maybe ByteString -> ByteString) -> Maybe ByteString -> ByteString
forall a b. (a -> b) -> a -> b
$ HeaderName -> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup HeaderName
hContentType ([(HeaderName, ByteString)] -> Maybe ByteString)
-> [(HeaderName, ByteString)] -> Maybe ByteString
forall a b. (a -> b) -> a -> b
$ Request -> [(HeaderName, ByteString)]
requestHeaders Request
request
        case [MediaType] -> ByteString -> Maybe MediaType
forall a. Accept a => [a] -> ByteString -> Maybe a
matchContent (NonEmpty MediaType -> [MediaType]
forall a. NonEmpty a -> [a]
toList (NonEmpty MediaType -> [MediaType])
-> NonEmpty MediaType -> [MediaType]
forall a b. (a -> b) -> a -> b
$ Proxy JordanJSON -> NonEmpty MediaType
forall k (ctype :: k).
Accept ctype =>
Proxy ctype -> NonEmpty MediaType
contentTypes (Proxy JordanJSON
forall k (t :: k). Proxy t
Proxy :: Proxy JordanJSON)) ByteString
contentType of
          Maybe MediaType
Nothing -> ServerError -> DelayedIO (ByteString -> Either JSONError a)
forall a. ServerError -> DelayedIO a
delayedFail ServerError
err415
          Just MediaType
_ -> (ByteString -> Either JSONError a)
-> DelayedIO (ByteString -> Either JSONError a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (FromJSON a => ByteString -> Either JSONError a
forall a. FromJSON a => ByteString -> Either JSONError a
parseOrReport @a)
      checkBody :: (ByteString -> Either a a) -> DelayedIO a
checkBody ByteString -> Either a a
parser = (Request -> DelayedIO a) -> DelayedIO a
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest ((Request -> DelayedIO a) -> DelayedIO a)
-> (Request -> DelayedIO a) -> DelayedIO a
forall a b. (a -> b) -> a -> b
$ \Request
request -> do
        ByteString
body <- IO ByteString -> DelayedIO ByteString
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO ByteString -> DelayedIO ByteString)
-> IO ByteString -> DelayedIO ByteString
forall a b. (a -> b) -> a -> b
$ Request -> IO ByteString
lazyRequestBody Request
request
        case ByteString -> Either a a
parser (ByteString -> ByteString
LBS.toStrict ByteString
body) of
          Left a
je ->
            ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError -> DelayedIO a) -> ServerError -> DelayedIO a
forall a b. (a -> b) -> a -> b
$
              ServerError :: Int
-> String
-> ByteString
-> [(HeaderName, ByteString)]
-> ServerError
ServerError
                { errHTTPCode :: Int
errHTTPCode = Int
400,
                  errReasonPhrase :: String
errReasonPhrase = String
"Bad Request",
                  errBody :: ByteString
errBody = a -> ByteString
forall a. ToJSON a => a -> ByteString
toJSONViaBuilder a
je,
                  errHeaders :: [(HeaderName, ByteString)]
errHeaders = [(HeaderName
"Content-Type", ByteString
"application/json+haskell-servant-body-error")]
                }
          Right a
a -> a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure a
a

-- | If the query was required, no maybe.
-- Otherwise, wrap the query in a maybe.
type QueryArgument mods a = If (FoldRequired mods) a (Maybe a)

instance
  forall a rest context baseKey mods.
  ( HasServer rest context,
    FromJSON a,
    KnownSymbol baseKey,
    SBoolI (FoldRequired mods)
  ) =>
  HasServer (JordanQuery' baseKey mods a :> rest) context
  where
  type ServerT (JordanQuery' baseKey mods a :> rest) m = QueryArgument mods a -> ServerT rest m
  hoistServerWithContext :: Proxy (JordanQuery' baseKey mods a :> rest)
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT (JordanQuery' baseKey mods a :> rest) m
-> ServerT (JordanQuery' baseKey mods a :> rest) n
hoistServerWithContext Proxy (JordanQuery' baseKey mods a :> rest)
_ Proxy context
pc forall x. m x -> n x
nt ServerT (JordanQuery' baseKey mods a :> rest) m
s = Proxy rest
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT rest m
-> ServerT rest n
forall k (api :: k) (context :: [*]) (m :: * -> *) (n :: * -> *).
HasServer api context =>
Proxy api
-> Proxy context
-> (forall x. m x -> n x)
-> ServerT api m
-> ServerT api n
hoistServerWithContext (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest) Proxy context
pc forall x. m x -> n x
nt (ServerT rest m -> ServerT rest n)
-> (If (FoldRequired mods) a (Maybe a) -> ServerT rest m)
-> If (FoldRequired mods) a (Maybe a)
-> ServerT rest n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ServerT (JordanQuery' baseKey mods a :> rest) m
If (FoldRequired mods) a (Maybe a) -> ServerT rest m
s
  route :: Proxy (JordanQuery' baseKey mods a :> rest)
-> Context context
-> Delayed env (Server (JordanQuery' baseKey mods a :> rest))
-> Router env
route (Proxy (JordanQuery' baseKey mods a :> rest)
Proxy :: Proxy (JordanQuery' baseKey mods a :> rest)) Context context
context Delayed env (Server (JordanQuery' baseKey mods a :> rest))
subserver =
    Proxy rest
-> Context context -> Delayed env (Server rest) -> Router env
forall k (api :: k) (context :: [*]) env.
HasServer api context =>
Proxy api
-> Context context -> Delayed env (Server api) -> Router env
route (Proxy rest
forall k (t :: k). Proxy t
Proxy :: Proxy rest) Context context
context (Delayed env (Server rest) -> Router env)
-> Delayed env (Server rest) -> Router env
forall a b. (a -> b) -> a -> b
$ Delayed env (Server (JordanQuery' baseKey mods a :> rest))
Delayed env (If (FoldRequired mods) a (Maybe a) -> Server rest)
subserver Delayed env (If (FoldRequired mods) a (Maybe a) -> Server rest)
-> DelayedIO (If (FoldRequired mods) a (Maybe a))
-> Delayed env (Server rest)
forall env a b.
Delayed env (a -> b) -> DelayedIO a -> Delayed env b
`addParameterCheck` (Request -> DelayedIO (If (FoldRequired mods) a (Maybe a)))
-> DelayedIO (If (FoldRequired mods) a (Maybe a))
forall a. (Request -> DelayedIO a) -> DelayedIO a
withRequest Request -> DelayedIO (If (FoldRequired mods) a (Maybe a))
paramsCheck
    where
      keyName :: Text
keyName = String -> Text
T.pack (String -> Text) -> String -> Text
forall a b. (a -> b) -> a -> b
$ Proxy baseKey -> String
forall (n :: Symbol) (proxy :: Symbol -> *).
KnownSymbol n =>
proxy n -> String
symbolVal (Proxy baseKey
forall k (t :: k). Proxy t
Proxy :: Proxy baseKey)
      parseQ :: Request -> Either String a
      parseQ :: Request -> Either String a
parseQ = Text -> Query -> Either String a
forall a. FromJSON a => Text -> Query -> Either String a
parseQueryAtKey Text
keyName (Query -> Either String a)
-> (Request -> Query) -> Request -> Either String a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
      hasQuery :: Request -> Bool
hasQuery = Text -> Query -> Bool
hasQueryAtKey Text
keyName (Query -> Bool) -> (Request -> Query) -> Request -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Request -> Query
queryString
      failWithError :: a -> DelayedIO a
failWithError a
s =
        ServerError -> DelayedIO a
forall a. ServerError -> DelayedIO a
delayedFailFatal (ServerError -> DelayedIO a) -> ServerError -> DelayedIO a
forall a b. (a -> b) -> a -> b
$
          ServerError
err400
            { errBody :: ByteString
errBody = a -> ByteString
forall a. ToJSON a => a -> ByteString
toJSONViaBuilder a
s,
              errHeaders :: [(HeaderName, ByteString)]
errHeaders = [(HeaderName
"Content-Type", ByteString
"application/json+haskell-jordan-query-error")]
            }
      paramsCheck :: Request -> DelayedIO (If (FoldRequired mods) a (Maybe a))
paramsCheck Request
req =
        let parsed :: Either String a
parsed = Request -> Either String a
parseQ Request
req
            hasKeys :: Bool
hasKeys = Request -> Bool
hasQuery Request
req
         in case SBoolI (FoldRequired mods) => SBool (FoldRequired mods)
forall (b :: Bool). SBoolI b => SBool b
sbool @(FoldRequired mods) of
              SBool (FoldRequired mods)
STrue -> (String -> DelayedIO a)
-> (a -> DelayedIO a) -> Either String a -> DelayedIO a
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> DelayedIO a
forall a a. ToJSON a => a -> DelayedIO a
failWithError a -> DelayedIO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either String a
parsed
              SBool (FoldRequired mods)
SFalse
                | Bool -> Bool
not Bool
hasKeys -> Maybe a -> DelayedIO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
                | Bool
otherwise -> (String -> DelayedIO (Maybe a))
-> (a -> DelayedIO (Maybe a))
-> Either String a
-> DelayedIO (Maybe a)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either String -> DelayedIO (Maybe a)
forall a a. ToJSON a => a -> DelayedIO a
failWithError (Maybe a -> DelayedIO (Maybe a)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe a -> DelayedIO (Maybe a))
-> (a -> Maybe a) -> a -> DelayedIO (Maybe a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Maybe a
forall a. a -> Maybe a
Just) Either String a
parsed