-- SPDX-FileCopyrightText: 2022 Gregor Kleen <gregor.kleen@ifi.lmu.de>,Sarah Vaupel <sarah.vaupel@ifi.lmu.de>,Steffen Jost <jost@tcs.ifi.lmu.de>
--
-- SPDX-License-Identifier: AGPL-3.0-or-later

{-# OPTIONS_GHC -fno-warn-deprecations #-}

module TestImport
    ( module TestImport
    , module X
    ) where

import Application           (makeFoundation, makeMiddleware, shutdownApp)
import ClassyPrelude         as X
  hiding ( delete, deleteBy
         , Handler, Index
         , (<.>), (<|)
         , index, uncons, unsnoc, cons, snoc
         , try, catches, handle, catch, bracket, bracketOnError, bracket_, catchJust, finally, handleJust, mask, mask_, onException, tryJust, uninterruptibleMask, uninterruptibleMask_
         )
import Database.Persist      as X hiding (get)
import Database.Persist.Sql  as X (SqlPersistM)
import Foundation            as X
import Model                 as X
import Test.Hspec            as X
import Yesod.Default.Config2 (useEnv, loadYamlSettings)
import Yesod.Auth            as X
import Yesod.Test            as X
import Yesod.Core.Unsafe     (fakeHandlerGetLogger)
import Test.QuickCheck       as X
import Test.Hspec.QuickCheck as X hiding (prop)
import Test.QuickCheck.Gen   as X
import Data.Default          as X
import Test.QuickCheck.Instances as X ()
import Test.QuickCheck.Arbitrary.Generic as X
import Test.QuickCheck.Classes as X hiding (jsonLaws)
import Test.QuickCheck.Classes.PathPiece as X
import Test.QuickCheck.Classes.PersistField as X
import Test.QuickCheck.Classes.Hashable as X
import Test.QuickCheck.Classes.JSON as X
import Test.QuickCheck.Classes.HttpApiData as X
import Test.QuickCheck.Classes.Universe as X
import Test.QuickCheck.Classes.Binary as X
import Test.QuickCheck.Classes.Csv as X
import Test.QuickCheck.IO as X
import Control.Lens.Properties as X
import Data.Proxy as X
import Data.UUID as X (UUID)
import System.IO as X (hPrint, hPutStrLn)
import Jobs (handleJobs)
import Numeric.Natural as X
import Network.URI.Arbitrary as X ()

import qualified Network.Wai as Wai
import qualified Network.Wai.Test as Wai
import qualified Network.Wai.Test.Internal as Wai (ClientState)
import Network.HTTP.Types (Status(..), hContentType, hAccept)
import Network.HTTP.Types.Header (hHost)
import qualified Network.HTTP.Types as Wai

import Control.Monad.Trans.Except (ExceptT)
import qualified Servant.Client.Core as Servant
import Servant.Client.Core.ClientError
import Servant.Client.Core.RunClient
import Control.Monad.Except (MonadError(..))
import Control.Monad.State.Class (MonadState(..))
import qualified Control.Monad.State.Class as State
import qualified Servant.Types.SourceT as S
import Servant.API (SourceIO)

import Utils (throwExceptT)

import Yesod.Servant (ServantApi, servantApiBaseUrl)

import qualified Data.ByteString as BS
import qualified Data.ByteString.Lazy as Lazy (ByteString)
import qualified Data.ByteString.Lazy as LBS hiding (ByteString)
import qualified Data.Binary.Builder as B
import Network.HTTP.Media (renderHeader)
import Control.Monad.Fail

import Control.Lens as X hiding ((<.), elements)

import Network.IP.Addr as X (IP)

import Database (truncateDb)
import Database as X (fillDb)
import User as X (fakeUser)

import Control.Monad.Catch as X hiding (Handler(..))

import Control.Monad.Trans.Resource (runResourceT)

import Settings.WellKnownFiles as X

import Data.CaseInsensitive as X (CI)
import qualified Data.CaseInsensitive as CI

import Data.Typeable

import Handler.Utils (runAppLoggingT)

import Web.PathPieces (toPathPiece)
import Utils.Parameters (GlobalPostParam(PostLoginDummy))

import Control.Monad.Morph as X (generalize)

import Control.Monad.Logger (runNoLoggingT)
import Utils.DB (customRunSqlPool)


runDB :: SqlPersistM a -> YesodExample UniWorX a
runDB query = do
  app <- getTestYesod
  liftIO $ runDBWithApp app query

runDBWithApp :: MonadIO m => UniWorX -> SqlPersistM a -> m a
runDBWithApp app query = liftIO . runResourceT . runNoLoggingT . customRunSqlPool query $ appConnPool app

runHandler :: Handler a -> YesodExample UniWorX a
runHandler handler = do
  app <- getTestYesod
  logger <- liftIO . readTVarIO . snd $ appLogger app
  fakeHandlerGetLogger (const logger) app handler


withApp :: YSpec UniWorX -> Spec
withApp = around $ \act -> runResourceT $ do
    settings <- liftIO $ loadYamlSettings
      ["config/test-settings.yml", "config/settings.yml"]
      []
      useEnv
    foundation <- makeFoundation settings
    wipeDB foundation
    runAppLoggingT foundation $ handleJobs foundation
    logWare <- makeMiddleware foundation
    lift $ act (foundation, logWare) `finally` shutdownApp foundation

-- This function will truncate all of the tables in your database.
-- 'withApp' calls it before each test, creating a clean environment for each
-- spec to run in.
wipeDB :: MonadUnliftIO m => UniWorX -> m ()
wipeDB app = runDBWithApp app Database.truncateDb

-- | Authenticate as a user. This relies on the `auth-dummy-login: true` flag
-- being set in test-settings.yaml, which enables dummy authentication in
-- Foundation.hs
authenticateAs :: Entity User -> YesodExample UniWorX ()
authenticateAs (Entity _ User{..}) = do
  request $ do
    setMethod "GET"
    addRequestHeader ("Accept-Language", "de")
    setUrl $ AuthR LoginR

  request $ do
    setMethod "POST"
    addToken_ "#login--dummy"
    addPostParam (toPathPiece PostLoginDummy) $ CI.original userIdent
    setUrl $ AuthR $ PluginR "dummy" []

-- | Create a user.  The dummy email entry helps to confirm that foreign-key
-- checking is switched off in wipeDB for those database backends which need it.
createUser :: (User -> User) -> YesodExample UniWorX (Entity User)
createUser = runDB . insertEntity . fakeUser

lawsCheckHspec :: Typeable a => Proxy a -> [Proxy a -> Laws] -> Spec
lawsCheckHspec p = parallel . describe (show $ typeRep p) . mapM_ (checkHspec . ($ p))
  where
    checkHspec (Laws className properties) = describe className $
      forM_ properties $ \(name, prop) -> it name $ property prop


newtype ServantExample a = ServantExample
  { unServantExample :: ReaderT ServantExampleEnv (ExceptT ClientError Wai.Session) a
  } deriving stock (Generic)
    deriving newtype (Functor, Applicative, Monad, MonadIO, MonadReader ServantExampleEnv, MonadError ClientError, MonadThrow, MonadCatch, MonadState Wai.ClientState)

data ServantExampleEnv = ServantExampleEnv
  { yseBaseUrl :: BaseUrl
  , yseMakeClientRequest :: BaseUrl -> Servant.Request -> IO Wai.Request
  } deriving (Generic)

runServantExample :: (Route (ServantApi proxy) -> Route UniWorX) -> ServantExample a -> YesodExample UniWorX a
runServantExample apiR (ServantExample act) = do
  yseBaseUrl <- runHandler $ servantApiBaseUrl apiR
  let yseMakeClientRequest burl Servant.Request{..} = do
        ((body, bodyLength), contentTypeHdr) <- case requestBody of
            Nothing           -> return ((return BS.empty, Wai.KnownLength 0), Nothing)
            Just (body', typ) -> let (mkBody, bLength) = convertBody body'
                                  in (, Just (hContentType, renderHeader typ)) . (, bLength) <$> mkBody

        return $ Wai.defaultRequest
          { Wai.requestMethod = requestMethod
          , Wai.requestHeaders = maybeToList acceptHdr ++ maybeToList contentTypeHdr ++ headers
          , Wai.requestHeaderHost =
              let BaseUrl{..} = yseBaseUrl
               in Just . encodeUtf8 . pack $ baseUrlHost <> bool (":" <> show baseUrlPort) mempty (baseUrlPort == 80)
          , Wai.requestBody = body, Wai.requestBodyLength = bodyLength
          , Wai.isSecure = isSecure
          }
          & flip Wai.setPath (encodeUtf8 (pack $ baseUrlPath burl) <> toStrict (B.toLazyByteString requestPath) <> Wai.renderQuery True (toList requestQueryString))
        where
          headers = filter (\(h, _) -> h `notElem` [hAccept, hContentType, hHost]) $ toList requestHeaders

          acceptHdr
              | null hs   = Nothing
              | otherwise = Just (hAccept, renderHeader hs)
            where
              hs = toList requestAccept

          convertBody :: Servant.RequestBody -> (IO (IO ByteString), Wai.RequestBodyLength)
          convertBody bd = case bd of
              Servant.RequestBodyLBS body'       -> ( givesPopper . S.source . map fromStrict $ LBS.toChunks body'
                                                    , Wai.KnownLength . fromIntegral $ LBS.length body'
                                                    )
              Servant.RequestBodyBS body'        -> ( return $ return body'
                                                    , Wai.KnownLength . fromIntegral $ BS.length body'
                                                    )
              Servant.RequestBodySource sourceIO -> ( givesPopper sourceIO
                                                    , Wai.ChunkedBody
                                                    )
            where
              givesPopper :: SourceIO Lazy.ByteString -> IO (IO ByteString)
              givesPopper sourceIO = S.unSourceT sourceIO $ \step0 -> do
                  ref <- newMVar step0
                  return $ modifyMVar ref nextBs

              nextBs S.Stop          = return (S.Stop, BS.empty)
              nextBs (S.Error err)   = fail err
              nextBs (S.Skip s)      = nextBs s
              nextBs (S.Effect ms)   = ms >>= nextBs
              nextBs (S.Yield lbs s) = case LBS.toChunks lbs of
                  []     -> nextBs s
                  (x:xs) | BS.null x -> nextBs step'
                         | otherwise -> return (step', x)
                      where
                        step' = S.Yield (LBS.fromChunks xs) s

          isSecure = case baseUrlScheme burl of
              Servant.Http -> False
              Servant.Https -> True
  YesodExampleData waiApp _ _ _ <- State.get
  liftIO . flip Wai.runSession waiApp . throwExceptT $ runReaderT act ServantExampleEnv{..}

instance RunClient ServantExample where
  runRequestAcceptStatus acceptStatus req = do
    ServantExampleEnv{..} <- ask
    waiRequest <- liftIO $ yseMakeClientRequest yseBaseUrl req
    waiResponse@Wai.SResponse{..} <- ServantExample . lift . lift $ Wai.request waiRequest
    let Status{..} = simpleStatus
        statusOk = case acceptStatus of
          Nothing -> 200 <= statusCode && statusCode < 300
          Just good -> simpleStatus `elem` good
        response = (waiResponseToResponse waiResponse) { Servant.responseHttpVersion = Wai.httpVersion waiRequest }
    unless statusOk $
      throwError $ mkFailureResponse yseBaseUrl req response
    return response
    where
      mkFailureResponse :: BaseUrl -> Servant.Request -> Servant.ResponseF Lazy.ByteString -> ClientError
      mkFailureResponse burl request' =
          FailureResponse (bimap (const ()) f request')
        where
          f b = (burl, LBS.toStrict $ B.toLazyByteString b)

      waiResponseToResponse :: Wai.SResponse -> Servant.Response
      waiResponseToResponse Wai.SResponse{..} = Servant.Response
          { responseStatusCode  = simpleStatus
          , responseBody        = simpleBody
          , responseHeaders     = fromList simpleHeaders
          , responseHttpVersion = error "WAI Response does not carry http version information"
          }
  throwClientError = throwError