-- SPDX-FileCopyrightText: 2022 Sarah Vaupel <sarah.vaupel@ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-unused-foralls #-}
{-# LANGUAGE UndecidableInstances #-}

module Yesod.Servant
  ( ServantApiUnproxy, ServantApiUnproxy', ServantApiDirect
  , HasRoute(..)
  , ServantApi(..), getServantApi
  , ServantApiDispatch(..)
  , servantApiLink
  , ServantHandlerFor(..)
  , HasServantHandlerContext(..), getServantContext, getsServantContext, getYesodApproot, renderRouteAbsolute, servantApiBaseUrl
  , MonadServantHandler(..), MonadHandler(..), MonadSite(..), MonadRequest(..)
  , ServantDBFor, ServantPersist(..), defaultRunDB
  , ServantLog(..), ServantLogYesod(..)
  , mkYesodApi
  , PathPieceHttpApiData(..)
  , BearerAuth, SessionAuth
  , ServantErrorResponse, getServantErrorResponse
  , module Yesod.Servant.HttpApiDataInjective
  ) where

import ClassyPrelude hiding (Handler, fromList, link)
import Control.Lens hiding (Context)
import Control.Lens.Extras

import Foundation.Servant.Types

import Utils hiding (HasRoute)
import Model.Types.Security

import Yesod.Core ( Yesod
                  , RenderRoute(..), ParseRoute(..)
                  , YesodSubDispatch(..)
                  , PathPiece(..)
                  )
import Yesod.Core.Types ( YesodRunnerEnv(..)
                        , YesodSubRunnerEnv(..)
                        )
import qualified Yesod.Core as Yesod
import qualified Yesod.Core.Types as Yesod
import qualified Yesod.Persist.Core as Yesod

import Servant.Links
import Servant.API
import Servant.Server hiding (route)
import Servant.Server.Instances ()

import Servant.Client.Core.BaseUrl

import Data.Proxy

import Network.Wai (Request, Middleware)
import qualified Network.Wai as W

import Language.Haskell.TH hiding (Type)
import qualified Language.Haskell.TH as TH (Type)
import Language.Haskell.Meta.Parse (parseType)
import Yesod.Routes.TH.Types

import Control.Monad.Fail (MonadFail(..))

import Data.Data (Data)
import Data.Kind (Type)
import GHC.Exts (Constraint)
  
import Data.Swagger

import qualified Data.Set as Set

import Network.HTTP.Types.Status
import Network.HTTP.Types.URI

import Control.Monad.Trans.Class (MonadTrans)
import Control.Monad.Catch (MonadThrow(..), MonadCatch, MonadMask)
import Control.Monad.Base (MonadBase)
import Control.Monad.Trans.Control (MonadBaseControl)
import Control.Monad.Error.Class (MonadError)

import qualified Data.Text as Text
import qualified Data.Text.Encoding as Text
import Data.Text.Lens (packed)

import Data.Typeable (eqT, typeRep)

import Network.URI
import Network.URI.Lens
import GHC.TypeLits (KnownSymbol, symbolVal, KnownNat)

import Text.Read (Read(readPrec), readP_to_Prec, readPrec_to_P)
import Text.Show (showParen, showString)
import qualified Text.ParserCombinators.ReadP as R
import qualified Data.Char as Char

import Yesod.Servant.HttpApiDataInjective
  
import qualified Data.ByteString.Base64.URL as Base64 (encode)
import qualified Data.Binary.Builder as Builder

import Database.Persist

import Data.CryptoID.Class.ImplicitNamespace

import Control.Monad.Logger


renderServantRoute :: Link -> ([Text], [(Text, Text)])
renderServantRoute link
  = ( linkSegments    link <&> pack . unEscapeString
    , linkQueryParams link <&> paramToPair
    )
  where paramToPair (FlagParam      str    ) = (pack $ unEscapeString str, Text.empty)
        paramToPair (ArrayElemParam str val) = (pack $ unEscapeString str, val       )
        paramToPair (SingleParam    str val) = (pack $ unEscapeString str, val       )


escapedSymbol :: forall sym. KnownSymbol sym => Proxy sym -> Text
escapedSymbol _ = pack . escapeURIString isUnreserved . symbolVal $ Proxy @sym

class HasLink api => HasRoute api where
  parseServantRoute :: forall proxy. ServantApiUnproxy' proxy ~ api => ([Text], [(Text, Text)]) -> Maybe (Route (ServantApi proxy))

instance HasRoute EmptyAPI where
  parseServantRoute _ = Nothing

instance (Typeable m, Typeable k) => HasRoute (NoContentVerb (m :: k)) where
  parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(NoContentVerb m)) id mempty mempty
  parseServantRoute  _      = Nothing

instance (Typeable m, Typeable k, Typeable s, Typeable ct, Typeable a, IsSubList ct ct ~ (() :: Constraint)) => HasRoute (Verb (m :: k) s ct a) where
  parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Verb m s ct a)) id mempty mempty
  parseServantRoute  _      = Nothing

instance (Typeable m, Typeable k, Typeable status, Typeable fr, Typeable ct, Typeable a) => HasRoute (Stream (m :: k) status fr ct a) where
  parseServantRoute ([], _) = Just $ ServantApiRoute (Proxy @(Stream m status fr ct a)) id mempty mempty
  parseServantRoute  _      = Nothing

instance HasRoute sub => HasRoute (HttpVersion :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(HttpVersion :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute
  
instance HasRoute sub => HasRoute (Vault :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Vault :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance (HasRoute sub, KnownSymbol realm, Typeable a) => HasRoute (BasicAuth realm a :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(BasicAuth realm a :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute
  
instance (HasRoute sub, KnownSymbol s) => HasRoute (Description s :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Description s :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute
  
instance (HasRoute sub, KnownSymbol s) => HasRoute (Summary s :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Summary s :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute
  
instance (HasRoute sub, Typeable tag, Typeable k) => HasRoute (AuthProtect (tag :: k) :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(AuthProtect tag :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance HasRoute sub => HasRoute (IsSecure :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(IsSecure :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance HasRoute sub => HasRoute (RemoteHost :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(RemoteHost :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance (HasRoute sub, Typeable mods, Typeable restr) => HasRoute (CaptureBearerRestriction' mods restr :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerRestriction' mods restr :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance (HasRoute sub, Typeable mods) => HasRoute (CaptureBearerToken' mods :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(CaptureBearerToken' mods :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance (KnownSymbol sym, HasRoute sub, HasLink sub) => HasRoute (sym :> sub) where
  parseServantRoute (p : ps, qs)
    | p == escapedSymbol (Proxy @sym)
    = parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
        ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(sym :> endpoint)) f (escapedSymbol (Proxy @sym) : ps') qs'
        ServantApiBaseRoute -> ServantApiBaseRoute
  parseServantRoute _ = Nothing

instance (HasRoute a, HasRoute b) => HasRoute (a :<|> b) where
  parseServantRoute args = asum
    [ parseServantRoute @a @(ServantApiDirect a) args <&> \case
        ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
        ServantApiBaseRoute -> ServantApiBaseRoute
    , parseServantRoute @b @(ServantApiDirect b) args <&> \case
        ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @endpoint) f ps qs
        ServantApiBaseRoute -> ServantApiBaseRoute
    ]

instance (HasRoute sub, Typeable mods, Typeable ct, Typeable a) => HasRoute (ReqBody' mods ct a :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ReqBody' mods ct a :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute
  
instance (HasRoute sub, Typeable mods, Typeable framing, Typeable ct, Typeable a) => HasRoute (StreamBody' mods framing ct a :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(StreamBody' mods framing ct a :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance (HasRoute sub, KnownSymbol sym, Typeable mods, Typeable a) => HasRoute (Header' mods sym (a :: Type) :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(Header' mods sym a :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute

instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable v, ToHttpApiDataInjective v, FromHttpApiData v) => HasRoute (Capture' mods sym (v :: Type) :> sub) where
  parseServantRoute (p : ps, qs)
    | Right v <- parseUrlPiece @v p
    = parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
        ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(Capture' mods sym v :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
        ServantApiBaseRoute -> ServantApiBaseRoute
  parseServantRoute _ = Nothing

instance (HasRoute sub, Typeable mods, KnownSymbol sym, Typeable plaintext, ToHttpApiDataInjective ciphertext, FromHttpApiData ciphertext, Typeable ciphertext) => HasRoute (CaptureCryptoID' mods ciphertext sym plaintext :> sub) where
  parseServantRoute (p : ps, qs)
    | Right v <- parseUrlPiece @(CryptoID ciphertext plaintext) p
    = parseServantRoute @sub @(ServantApiDirect sub) (ps, qs) <&> \case
        ServantApiRoute (_ :: Proxy endpoint) f ps' qs' -> ServantApiRoute (Proxy @(CaptureCryptoID' mods ciphertext sym plaintext :> endpoint)) (f . ($ v)) (toUrlPieceInjective v : ps') qs'
        ServantApiBaseRoute -> ServantApiBaseRoute
  parseServantRoute _ = Nothing

instance (HasRoute sub, KnownNat major, KnownNat minor, KnownNat patch) => HasRoute (ApiVersion major minor patch :> sub) where
  parseServantRoute args = parseServantRoute @sub @(ServantApiDirect sub) args <&> \case
    ServantApiRoute (_ :: Proxy endpoint) f ps qs -> ServantApiRoute (Proxy @(ApiVersion major minor patch :> endpoint)) f ps qs
    ServantApiBaseRoute -> ServantApiBaseRoute


data ServantApi (proxy :: k) = ServantApi
  deriving (Eq, Ord, Read, Show, Generic)
  deriving anyclass (Hashable)

getServantApi :: forall master proxy. master -> ServantApi proxy
getServantApi _ = ServantApi

type family ServantApiUnproxy (proxy :: k) :: Type

type ServantApiUnproxy' :: forall k. forall (proxy :: k) -> Type
type family ServantApiUnproxy' proxy where
  ServantApiUnproxy' @Type (ServantApiDirect api) = api
  ServantApiUnproxy' @k' proxy = ServantApiUnproxy proxy

data ServantApiDirect (api :: Type)
type instance ServantApiUnproxy (ServantApiDirect api) = api
  
instance HasRoute (ServantApiUnproxy' proxy) => RenderRoute (ServantApi proxy) where
  data Route (ServantApi proxy)
    = forall endpoint.
      ( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint)
      , HasRoute endpoint
      , Typeable endpoint
      )
   => ServantApiRoute
      (Proxy endpoint)
      (forall a. MkLink endpoint a -> a)
      [Text] (HashMap Text [Text])
    | ServantApiBaseRoute
  renderRoute (ServantApiRoute (_ :: Proxy endpoint) f _ _) = f $ safeLink' renderServantRoute (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
  renderRoute ServantApiBaseRoute = mempty

instance HasRoute (ServantApiUnproxy' proxy) => Eq (Route (ServantApi proxy)) where
  (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) == (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
    = case eqT @endpoint @endpoint' of
        Just Refl -> ps == ps' && qs == qs'
        Nothing   -> False
  ServantApiBaseRoute == ServantApiBaseRoute = True
  _ == _ = False

instance HasRoute (ServantApiUnproxy' proxy) => Ord (Route (ServantApi proxy)) where
  compare (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) (ServantApiRoute (_ :: Proxy endpoint') _ ps' qs')
    = case eqT @endpoint @endpoint' of
        Just Refl -> compare ps ps' <> compare qs qs'
        Nothing   -> typeRep (Proxy @endpoint) `compare` typeRep (Proxy @endpoint')
  compare ServantApiBaseRoute ServantApiBaseRoute = EQ
  compare ServantApiBaseRoute _ = LT
  compare _ ServantApiBaseRoute = GT

instance HasRoute (ServantApiUnproxy' proxy) => Hashable (Route (ServantApi proxy)) where
  hashWithSalt salt (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = salt `hashWithSalt` (0 :: Int) `hashWithSalt` typeRep (Proxy @endpoint) `hashWithSalt` ps `hashWithSalt` qs
  hashWithSalt salt ServantApiBaseRoute = salt `hashWithSalt` (1 :: Int)

instance HasRoute (ServantApiUnproxy' proxy) => Read (Route (ServantApi proxy)) where
  readPrec = readP_to_Prec $ \d -> asum
    [ ServantApiBaseRoute <$ R.string "ServantApiBaseRoute"
    , do
        when (d > 10) . void $ R.char '('
        R.skipSpaces
        void $ R.string "ServantApiRoute "
        R.skipSpaces
        void $ R.string "_ "
        R.skipSpaces
        asum [ do
                 void $ R.char '('
                 R.skipMany . R.manyTill (R.satisfy $ const True) $ R.char ')'
                 void $ R.char ' '
             , R.skipMany . R.manyTill (R.satisfy $ not . Char.isSpace) $ R.satisfy Char.isSpace
             ]
        R.skipSpaces
        ps <- readPrec_to_P readPrec 11
        void $ R.char ' '
        R.skipSpaces
        qs <- readPrec_to_P readPrec 11 :: R.ReadP (HashMap Text [Text])
        R.skipSpaces
        when (d > 10) . void $ R.char ')'
        maybe (fail "Could not parse servant route") return $ parseServantRoute (ps, ifoldMap (fmap . (,)) qs)
    ]
instance HasRoute (ServantApiUnproxy' proxy) => Show (Route (ServantApi proxy)) where
  showsPrec d (ServantApiRoute (_ :: Proxy endpoint) _ ps qs) = showParen (d > 10)
    $ showString "ServantApiRoute "
    . showsPrec 11 (typeRep $ Proxy @endpoint)
    . showString " _ "
    . showsPrec 11 ps
    . showString " "
    . showsPrec 11 qs
  showsPrec _ ServantApiBaseRoute = showString "ServantApiBaseRoute"

instance HasRoute (ServantApiUnproxy' proxy) => ParseRoute (ServantApi proxy) where
  parseRoute = parseServantRoute

newtype ServantErrorResponse
  = ServantErrorResponse { getServantErrorResponse :: W.Response }

class (HasServer (ServantApiUnproxy' proxy) context, HasRoute (ServantApiUnproxy' proxy), HasContextEntry (context .++ DefaultErrorFormatters) ErrorFormatters) => ServantApiDispatch context m master proxy | master proxy -> context m where
  servantContext         :: ServantApi proxy -> master -> Request -> Yesod.HandlerFor master (Context context)
  servantHoist           :: ServantApi proxy -> master -> Request -> Context context -> (forall a. m a -> Handler a)
  servantMiddleware      :: ServantApi proxy -> master -> Context context -> Middleware
  servantYesodMiddleware :: ServantApi proxy -> master -> Yesod.HandlerFor master Middleware
  servantServer          :: ServantApi proxy -> master -> ServerT (ServantApiUnproxy' proxy) m

instance ServantApiDispatch context m master proxy => YesodSubDispatch (ServantApi proxy) master where
  yesodSubDispatch YesodSubRunnerEnv{..} req
    = ysreParentRunner handlerT ysreParentEnv (ysreToParentRoute <$> route) req
    where
      master :: master
      master = yreSite ysreParentEnv
      proxy :: ServantApi proxy
      proxy = ysreGetSub master
      
      route = parseRoute ( W.pathInfo req
                         , over (traverse . _2) (fromMaybe Text.empty) . queryToQueryText $ W.queryString req
                         )
  
      handlerT :: Yesod.HandlerFor master Yesod.TypedContent
      handlerT = do
        yesodMiddleware <- servantYesodMiddleware proxy master
        ctx <- servantContext proxy master req

        let server' = hoistServerWithContext (Proxy @(ServantApiUnproxy' proxy)) (Proxy @context) (servantHoist proxy master req ctx) (servantServer proxy master)
            toTypedContent = error "Servant handler did not shortcircuit"
            sendResponse res = case yesodError of
              Just err -> do
                Yesod.cacheSet $ ServantErrorResponse res
                throwM . Yesod.HCError =<< liftIO (err <$> resText)
              Nothing -> do
                when (is _Nothing route) $
                  $(Yesod.logErrorS) "Servant" "Could not parse route even though servant responded successfully"

                Yesod.sendWaiResponse res
              where
                status = W.responseStatus res
                resText = toText <$> getResBS
                  where
                    toText bs = case Text.decodeUtf8' bs of
                      Right t -> t
                      Left  _ -> Text.decodeUtf8 $ Base64.encode bs
                    
                    (_, _, resStream) = W.responseToStream res
                    getResBS = resStream $ \runStream -> do
                      resVar <- newTVarIO Builder.empty
                      runStream (\chunk -> atomically $ modifyTVar' resVar (<> chunk)) (return ())
                      toStrict . Builder.toLazyByteString <$> readTVarIO resVar
                
                yesodError :: Maybe (Text -> Yesod.ErrorResponse)
                yesodError
                  | status == notFound404
                  = Just $ const Yesod.NotFound
                  | status == internalServerError500
                  = Just   Yesod.InternalError
                  | status == badRequest400
                  = Just $ Yesod.InvalidArgs . pure
                  | status == unauthorized401
                  = Just $ const Yesod.NotAuthenticated
                  | status == forbidden403
                  = Just   Yesod.PermissionDenied
                  | status == methodNotAllowed405
                  = Just . const . Yesod.BadMethod $ W.requestMethod req
                  | otherwise = Nothing
  
        fmap toTypedContent . withUnliftIO $ \UnliftIO{..} ->
          (yesodMiddleware . servantMiddleware proxy master ctx $ serveWithContext (Proxy @(ServantApiUnproxy' proxy)) ctx server') req $ unliftIO . sendResponse

servantApiLink :: forall p1 p2 proxy endpoint.
                  ( IsElem endpoint (ServantApiUnproxy' proxy) ~ (() :: Constraint), HasRoute (ServantApiUnproxy' proxy), HasLink endpoint, Typeable endpoint )
               => p1 proxy
               -> p2 endpoint
               -> MkLink endpoint (Route (ServantApi proxy))
servantApiLink _ _ = safeLink' (fromMaybe (error "Could not parse result of safeLink'") . guardEndpoint . parseServantRoute @(ServantApiUnproxy' proxy) . renderServantRoute) (Proxy @(ServantApiUnproxy' proxy)) (Proxy @endpoint)
  where
    guardEndpoint :: Maybe (Route (ServantApi proxy)) -> Maybe (Route (ServantApi proxy))
    guardEndpoint x@(Just (ServantApiRoute (_ :: Proxy endpoint') _ _ _))
      | Just Refl <- eqT @endpoint @endpoint' = x
    guardEndpoint _ = Nothing

  
class HasServantHandlerContext site where
  data ServantHandlerContextFor site :: Type
  getSCtxSite :: ServantHandlerContextFor site -> site
  getSCtxRequest :: ServantHandlerContextFor site -> Request
  
newtype ServantHandlerFor site a = ServantHandlerFor { unServantHandlerFor :: ServantHandlerContextFor site -> Handler a }
  deriving (Generic)
  deriving (Monad, Functor, Applicative, MonadIO, MonadThrow, MonadCatch, MonadMask, MonadBase IO, MonadBaseControl IO, MonadError ServerError) via (ReaderT (ServantHandlerContextFor site) Handler)

instance MonadUnliftIO (ServantHandlerFor site) where
  withRunInIO cont
    = ServantHandlerFor $ \app -> withRunInIO $ \unliftHandler -> cont (unliftHandler . flip unServantHandlerFor app)

getServantContext :: (site ~ site', MonadServantHandler site m) => m (ServantHandlerContextFor site')
getServantContext = liftServantHandler $ ServantHandlerFor return
  
getsServantContext :: (site ~ site', MonadServantHandler site m) => (ServantHandlerContextFor site' -> a) -> m a 
getsServantContext = liftServantHandler . ServantHandlerFor . (return .)

getYesodApproot :: (Yesod site, MonadSite site m, MonadRequest m) => m Text
getYesodApproot = Yesod.getApprootText Yesod.approot <$> getSite <*> getRequest

renderRouteAbsolute :: (Yesod site, MonadSite site m, MonadRequest m) => Route site -> m URI
renderRouteAbsolute (renderRoute -> (ps, qs)) = addRoute . unpack <$> getYesodApproot 
  where addRoute root = case parseURI root of
          Just root' -> root' & uriPathLens . packed %~ addPath
                              & uriQueryLens . packed %~ addQuery
          Nothing -> error "Could not parse approot as URI"
        addPath p = p <> "/" <> Text.intercalate "/" ps
        addQuery q | null qs = q
        addQuery "" = "?" <> Text.intercalate "&" (map (\(q, v) -> q <> "=" <> v) qs)
        addQuery "?" = addQuery ""
        addQuery q = q <> "&" <> tailEx (addQuery "")

servantApiBaseUrl :: (Yesod site, MonadSite site m, MonadRequest m, MonadThrow m) => (Route (ServantApi proxy) -> Route site) -> m BaseUrl
servantApiBaseUrl = parseBaseUrl . ($ mempty). uriToString (const "") <=< renderRouteAbsolute . ($ ServantApiBaseRoute)

class (MonadIO m, HasServantHandlerContext site) => MonadServantHandler site m | m -> site where
  liftServantHandler :: forall a. ServantHandlerFor site a -> m a

instance HasServantHandlerContext site => MonadServantHandler site (ServantHandlerFor site) where
  liftServantHandler = id

instance (MonadTrans t, MonadIO (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadServantHandler site (t (ServantHandlerFor site)) where
  liftServantHandler = lift

class MonadIO m => MonadHandler m where
  liftHandler :: forall a. Handler a -> m a

instance MonadHandler (ServantHandlerFor site) where
  liftHandler = ServantHandlerFor . const
  
instance (MonadTrans t, MonadIO (t (ServantHandlerFor site))) => MonadHandler (t (ServantHandlerFor site)) where
  liftHandler = lift . ServantHandlerFor . const

class Monad m => MonadSite site m | m -> site where
  getSite :: m site

  getsSite :: (site -> a) -> m a
  getsSite f = f <$> getSite

instance HasServantHandlerContext site => MonadSite site (ServantHandlerFor site) where
  getSite = liftServantHandler . ServantHandlerFor $ return . getSCtxSite

instance MonadSite site (Reader site) where
  getSite = ask
  getsSite = asks

instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, site ~ Yesod.HandlerSite m) => MonadSite site m where
  getSite = Yesod.getYesod
  getsSite = Yesod.getsYesod

instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadSite site (t (ServantHandlerFor site)) where
  getSite = lift getSite
  getsSite = lift . getsSite

class Monad m => MonadRequest m where
  getRequest :: m Request

instance HasServantHandlerContext site => MonadRequest (ServantHandlerFor site) where
  getRequest = liftServantHandler . ServantHandlerFor $ return . getSCtxRequest

instance {-# OVERLAPPABLE #-} (Yesod.MonadHandler m, Monad m) => MonadRequest m where
  getRequest = Yesod.waiRequest

instance {-# OVERLAPPING #-} (MonadTrans t, Monad (t (ServantHandlerFor site)), HasServantHandlerContext site) => MonadRequest (t (ServantHandlerFor site)) where
  getRequest = lift getRequest

  
type ServantDBFor site = ReaderT (Yesod.YesodPersistBackend site) (ServantHandlerFor site)

class Yesod.YesodPersist site => ServantPersist site where
  runDB :: forall a. ServantDBFor site a -> ServantHandlerFor site a

defaultRunDB :: ( PersistConfig c
                , ServantDBFor site a ~ PersistConfigBackend c (ServantHandlerFor site) a
                , HasServantHandlerContext site
                )
             => Getting c site c
             -> Getting (PersistConfigPool c) site (PersistConfigPool c)
             -> ServantDBFor site a -> ServantHandlerFor site a
defaultRunDB confL poolL f = do
  app <- getSite
  runPool (app ^. confL) f (app ^. poolL)


class ServantLog site where
  servantLogLog :: (MonadIO m, ToLogStr msg) => site -> Loc -> LogSource -> LogLevel -> msg -> m ()

newtype ServantLogYesod site = ServantLogYesod { unServantLogYesod :: site }

instance Yesod site => ServantLog (ServantLogYesod site) where
  servantLogLog (ServantLogYesod app) a b c (toLogStr -> d) = liftIO $ do
    logger <- Yesod.makeLogger app
    Yesod.messageLoggerSource app logger a b c d

instance (ServantLog site, HasServantHandlerContext site) => MonadLogger (ServantHandlerFor site) where
  monadLoggerLog a b c d = do
    app <- getSite
    servantLogLog app a b c d

instance (ServantLog site, HasServantHandlerContext site) => MonadLoggerIO (ServantHandlerFor site) where
  askLoggerIO = servantLogLog <$> getSite


newtype PathPieceHttpApiData a = PathPieceHttpApiData { unPathPieceHttpApiData :: a }
  deriving (Eq, Ord, Read, Show, Generic, Data)
  deriving newtype (PathPiece, ToParamSchema)
instance PathPiece a => FromHttpApiData (PathPieceHttpApiData a) where
  parseUrlPiece = maybe (Left "Could not convert from HttpApiData via PathPiece") Right . fromPathPiece
instance PathPiece a => ToHttpApiData (PathPieceHttpApiData a) where
  toUrlPiece = toPathPiece
  

mkYesodApi :: Name -> [ResourceTree String] -> DecsQ
mkYesodApi (nameBase -> masterN) ress = do
  let toPiecesApi :: [Piece String]
                  -> ResourceTree String
                  -> MaybeT Q [([Piece String], TH.Type, [Text])]
      toPiecesApi ps (ResourceLeaf Resource{..}) = do
        Subsite{..} <- pure resourceDispatch
        Just tn <- lift $ lookupTypeName subsiteType
        TyConI (TySynD _ [] (ConT conN `AppT` apiT)) <- lift $ reify tn
        guard $ conN == ''ServantApi
        return $ pure (ps <> resourcePieces, ConT ''ServantApiUnproxy' `AppT` apiT, map pack resourceAttrs)
      toPiecesApi ps (ResourceParent _ _ ps' cs)
        = lift . fmap concat $ mapMaybeM (toPiecesApi (ps <> ps')) cs
  apiRess <- concat <$> mapMaybeM (toPiecesApi []) ress

  let apiType
        | Just apiRess' <- fromNullable $ map apiEndpoint apiRess
        = ofoldr1 (\e acc -> conT ''(:<|>) `appT` e `appT` acc) apiRess'
        | otherwise
        = conT ''EmptyAPI

      apiEndpoint (pieces, apiT, attrs) = withAuth attrs $
        foldr (\p acc -> conT ''(:>) `appT` apiPiece p `appT` acc) (return apiT) pieces

      withAuth attrs typ = case authDNF of
        Left t
          -> fail $ "Invalid auth tag: " <> unpack t
        Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthFree) `Set.member` dnfTerms
          -> typ
        Right PredDNF{..} | (impureNonNull . Set.singleton $ PLVariable AuthToken) `Set.member` dnfTerms
          -> conT ''(:>) `appT` conT ''BearerAuth `appT` typ
        Right _
          -> conT ''(:>) `appT` conT ''SessionAuth `appT` typ
        where authDNF = parsePredDNF defaultAuthDNF attrs

      apiPiece (Static str) = litT $ strTyLit str
      apiPiece (Dynamic str) = conT ''PathPieceHttpApiData `appT` either fail return (parseType str)

  sequence
    [ tySynD (mkName $ masterN <> "Api") [] apiType
    ]