{-# LANGUAGE QuasiQuotes #-}
{-# OPTIONS_GHC -Wno-incomplete-record-updates #-}

module Servant.Client.TypeScriptSpec
  ( main
  , spec
  ) where

import           Control.Concurrent.Async (mapConcurrently_)
import           Control.Monad (when)
import           Data.Aeson (FromJSON, ToJSON, encode)
import           Data.Aeson.Generics.TypeScript
  ( FieldTypeName
  , TypeScriptDefinition
  , printTS
  )
import qualified Data.Aeson.Generics.TypeScript as GGT (gen)
import           Data.Char (isAscii, isDigit, isLetter, toLower)
import qualified Data.Conduit.List as CL
import           Data.Kind (Type)
import           Data.List.Split (splitOn)
import           Data.Proxy (Proxy (Proxy))
import           Data.String (IsString)
import           Data.String.Interpolate (i)
import           Data.Time.Clock.POSIX (getPOSIXTime)
import           GHC.Generics (Generic)
import           Network.Wai.Handler.Warp (testWithApplication)
import           Servant (serveDirectoryFileServer)
import           Servant.API
  ( Capture
  , Description
  , Fragment
  , Get
  , Header
  , JSON
  , Post
  , QueryFlag
  , QueryParam
  , QueryParams
  , Raw
  , ReqBody
  , Summary
  , type (:<|>) (..)
  , type (:>)
  )
import           Servant.API.WebSocketConduit (WebSocketConduit)
import qualified Servant.Client.TypeScript as SCT (gen)
import           Servant.Client.TypeScript (GenAll)
import           Servant.Server (HasServer, Server, serve)
import           System.Directory
  ( doesFileExist
  , getTemporaryDirectory
  , removeFile
  )
import           System.Exit (ExitCode (ExitFailure))
import           System.FilePath ((<.>), (</>))
import           System.Process (readProcessWithExitCode)
import           System.Random (randomIO)
import           Test.Hspec (Spec, describe, hspec, it, parallel, shouldBe)
import           Test.QuickCheck (generate, resize, suchThat)
import           Test.QuickCheck.Arbitrary (Arbitrary (arbitrary))
import           Test.WebDriver
  ( Browser (chromeOptions)
  , asyncJS
  , chrome
  , closeSession
  , defaultConfig
  , openPage
  , runSession
  , useBrowser
  )

-- | TEST SETTINGS
showLineNumbers :: Bool
showLineNumbers = True
parRuns :: Int
parRuns = 5
isHeadless :: Bool
isHeadless = True
--

type User :: Type
data User = User
  { names   :: [AlphaNumAscii]
  , age     :: Int
  , isAdmin :: Bool
  }
  deriving stock (Eq, Generic, Ord, Show)
  deriving anyclass (FromJSON, ToJSON, TypeScriptDefinition)

newtype AlphaNumAscii = AlphaNumAscii { unAlphaNumAscii :: String }
  deriving newtype (Eq, FieldTypeName, FromJSON, IsString, Ord, Show, ToJSON)

instance Arbitrary AlphaNumAscii where
  arbitrary = AlphaNumAscii <$> arbitrary `suchThat` all (\x -> (isDigit x || isLetter x) && isAscii x)

instance Arbitrary User where
  arbitrary = User <$> arbitrary <*> arbitrary <*> arbitrary

type CaptureAPI :: Type
type CaptureAPI
  = Description "This is the description of this route" :>
  "foo" :> "bar"
  :> Capture "Frog Splat" Int
  :> Capture "wat" String
  :> "Zap"
  :> Capture "zazzy" Bool
  :> Get '[JSON] User

type QueryAPI :: Type
type QueryAPI
  = Summary "This is the summary of this route"
  :> "foo" :> "bar"
  :> QueryParam "Frog Splat" Int
  :> QueryParam "wat" Bool
  :> "Zap"
  :> QueryParams "zazzy" String
  :> Post '[JSON] User

type HeaderAPI :: Type
type HeaderAPI
  = "foo" :> "bar"
  :> Header "Frog-Splat" Int
  :> Header "wat" String
  :> "Zap"
  :> Header "zazzy" Bool
  :> Post '[JSON] User

type BodyAPI :: Type
type BodyAPI
  = "foo" :> "bar"
  :> ReqBody '[JSON] User
  :> Post '[JSON] User

type FragmentAPI :: Type
type FragmentAPI
  = "foo" :> "bar"
  :> Fragment String
  :> Post '[JSON] String

type MixedCaptureQueryAPI :: Type
type MixedCaptureQueryAPI
  = "foo" :> "bar"
  :> Capture "Frog Splat" Int
  :> QueryParam "wat" String
  :> Header "bip" String
  :> Header "wip" Int
  :> "Zap"
  :> QueryFlag "rump"
  :> Capture "zazzy" Bool
  :> QueryParam "hu hu" String
  :> Get '[JSON] User

type WebSocketAPI :: Type
type WebSocketAPI
  = "foo" :> "bar"
  :> WebSocketConduit User User

type WebSocketSecureAPI :: Type
type WebSocketSecureAPI
  = "foo" :> "bar"
  :> Header "Dunno" String
  :> WebSocketConduit User User

main :: IO ()
main = hspec spec

spec :: Spec
spec = do
  describe "Printing" printSpec
  describe "Round Trips" $ parallel roundTrips

printSpec :: Spec
printSpec = do
  it "Should be a trusting type casting WebSocket" $ SCT.gen @WebSocketAPI `shouldBe` [i|const API = {
  base: "",
  "/foo/bar": ():
    Promise<{ send : (input: User) => void
            , receive : (cb: (output: User) => void) => void
            , raw : WebSocket
    }> => {
      const pr = window.location.protocol === "http:" ? "ws:" : "wss:";
      const ws = new WebSocket(`${pr}//${window.location.host}${API.base}/foo/bar`);
      return Promise.resolve({
        send: (input: User) => ws.send(JSON.stringify(input)),
        receive: (cb: ((output: User) => void)) =>
          ws.onmessage = (message: MessageEvent<string>) => cb(JSON.parse(message.data)),
        raw: ws
      });
  }
};|]

  it "Should allow for the WebSocket SEC header" $ SCT.gen @WebSocketSecureAPI `shouldBe` [i|const API = {
  base: "",
  "/foo/bar{Dunno}": (Dunno:string):
    Promise<{ send : (input: User) => void
            , receive : (cb: (output: User) => void) => void
            , raw : WebSocket
    }> => {
      const pr = window.location.protocol === "http:" ? "ws:" : "wss:";
      const ws = new WebSocket(`${pr}//${window.location.host}${API.base}/foo/bar`, [Dunno]);
      return Promise.resolve({
        send: (input: User) => ws.send(JSON.stringify(input)),
        receive: (cb: ((output: User) => void)) =>
          ws.onmessage = (message: MessageEvent<string>) => cb(JSON.parse(message.data)),
        raw: ws
      });
  }
};|]

  it "Should interpolate variables into the url for Capture" $
    let open = '/' : "*"; close = '*' : "/"
    in SCT.gen @CaptureAPI `shouldBe` [i|const API = {
  base: "",
  #{open}
   * This is the description of this route
   #{close}
  "/foo/bar/:Frog%20Splat/:wat/Zap/:zazzy": async (Frog_Splat:number,wat:string,zazzy:boolean): Promise<User> => {
    const uri = `${API.base}/foo/bar/${Frog_Splat}/${wat}/Zap/${zazzy}`;
    return fetch(uri, {
      method: "GET"
    }).then(res => res.json());
  }
};|]

  it "Should interpolate variables into the url for Query" $ SCT.gen @QueryAPI `shouldBe` [i|const API = {
  base: "",
  // This is the summary of this route
  "/foo/bar/Zap?Frog%20Splat&wat&zazzy": async (Frog_Splat:number,wat:boolean,zazzy:Array<string>): Promise<User> => {
    const uri = `${API.base}/foo/bar/Zap?Frog%20Splat=${Frog_Splat}&wat=${wat}&${zazzy.reduceRight((acc,x) => "zazzy=" + x + (acc ? "&" + acc : ""), "")}`;
    return fetch(uri, {
      method: "POST"
    }).then(res => res.json());
  }
};|]

  it "Should interpolate variables into the url for Header" $ SCT.gen @HeaderAPI `shouldBe` [i|const API = {
  base: "",
  "/foo/bar/Zap{Frog-Splat,wat,zazzy}": async (Frog_Splat:number,wat:string,zazzy:boolean): Promise<User> => {
    const uri = `${API.base}/foo/bar/Zap`;
    return fetch(uri, {
      method: "POST",
      headers: {
        "Frog-Splat": "" + Frog_Splat,
        "wat": wat,
        "zazzy": "" + zazzy
      }
    }).then(res => res.json());
  }
};|]

  it "Should interpolate variables into the url for Fragment" $ SCT.gen @FragmentAPI `shouldBe` [i|const API = {
  base: "",
  "/foo/bar\#fragment": async (): Promise<string> => {
    const uri = `${API.base}/foo/bar`;
    return fetch(uri, {
      method: "POST"
    }).then(res => res.json());
  }
};|]

  it "Should interpolate variables into the url for Request Body" $ SCT.gen @BodyAPI `shouldBe` [i|const API = {
  base: "",
  "/foo/bar(User)": async (User:User): Promise<User> => {
    const uri = `${API.base}/foo/bar`;
    return fetch(uri, {
      method: "POST",
      headers: {
        'Content-Type': 'application/json'
      },
      body: JSON.stringify(User)
    }).then(res => res.json());
  }
};|]

  it "Should interpolate variables into the url for Mixed" $ SCT.gen @MixedCaptureQueryAPI `shouldBe` [i|const API = {
  base: "",
  "/foo/bar/:Frog%20Splat/Zap/:zazzy?wat&rump&hu%20hu{bip,wip}": async (Frog_Splat:number,wat:string,bip:string,wip:number,rump:boolean,zazzy:boolean,hu_hu:string): Promise<User> => {
    const uri = `${API.base}/foo/bar/${Frog_Splat}/Zap/${zazzy}?wat=${wat}&rump=${rump}&hu%20hu=${hu_hu}`;
    return fetch(uri, {
      method: "GET",
      headers: {
        "bip": bip,
        "wip": "" + wip
      }
    }).then(res => res.json());
  }
};|]

toJSBool :: Bool -> String
toJSBool = fmap toLower . show

echoMaybe :: Applicative m => Maybe a -> m a
echoMaybe = \case
  Just b -> pure b
  _ -> error "Bool was not parsed from the frontend"

pprop :: forall a. Arbitrary a => String -> Int -> (a -> IO ()) -> Spec
pprop m runs p = it m $ do
  randos <- generate (sequence [ resize n (arbitrary @a) | n <- [1..runs] ])
  mapConcurrently_ p randos

roundTrips :: Spec
roundTrips = do
  pprop "Should round trip for WebSocket health" parRuns \((age,toJSBool -> isAdmin',encode -> names) :: (Int,Bool,[AlphaNumAscii])) ->
   shouldRoundTrip @WebSocketAPI
    (CL.map id)
    ( "/foo/bar"
    , ""
    , [i|
    const msg = { names: #{names}, age: #{age}, isAdmin: #{isAdmin'} };
    res.receive(msg_ => {
      if(JSON.stringify(msg_.names) === JSON.stringify(msg.names)
         && msg_.age === msg.age
         && msg_.isAdmin === msg.isAdmin){
        return #{resolveSuccess}
      }
      return resolve('msg did not echo, got this instead: ' + JSON.stringify(msg_));
    })
    res.raw.onopen = () => res.send(msg);
    |])

  pprop "Should round trip for Query" parRuns \((age,toJSBool -> isAdmin',encode -> names) :: (Int,Bool,[AlphaNumAscii])) ->
   shouldRoundTrip @QueryAPI
    (\ns g a -> User (AlphaNumAscii <$> a) <$> echoMaybe ns <*> echoMaybe g)
    ( "/foo/bar/Zap?Frog%20Splat&wat&zazzy"
    , [i|#{age},#{isAdmin'},#{names}|]
    , [i|
    if(JSON.stringify(res.names) !== JSON.stringify(#{names})
       || res.age !== #{age}
       || res.isAdmin !== #{isAdmin'}){
      return resolve('responded with ' + JSON.stringify(res) + "\\n" + JSON.stringify(#{names}));
    }
    return #{resolveSuccess};|])

  pprop "Should round trip for Capture" parRuns \((age,name,toJSBool -> isAdmin') :: (Int,AlphaNumAscii,Bool)) ->
   let names' = [encode name] in
   shouldRoundTrip @CaptureAPI
    (\ns a g -> pure $ User (pure $ AlphaNumAscii a) ns g)
    ( "/foo/bar/:Frog%20Splat/:wat/Zap/:zazzy"
    , [i|#{age},`#{name}`,#{isAdmin'}|]
    , [i|
    if(JSON.stringify(res.names) !== JSON.stringify(#{names'})
       || res.age !== #{age}
       || res.isAdmin !== #{isAdmin'}){
      return resolve('responded with ' + JSON.stringify(res) + "\\n" + JSON.stringify(#{names'}));
    }
    return #{resolveSuccess};|])

  pprop "Should round trip for Header" parRuns \((age,name,toJSBool -> isAdmin') :: (Int,AlphaNumAscii,Bool)) ->
   let names = encode [name] in shouldRoundTrip @HeaderAPI
    (\ns a g -> User <$> (pure . AlphaNumAscii <$> echoMaybe a) <*> echoMaybe ns <*> echoMaybe g)
    ( "/foo/bar/Zap{Frog-Splat,wat,zazzy}"
    , [i|#{age},#{name},#{isAdmin'}|]
    , [i|
    if(JSON.stringify(res.names) !== `#{names}`
      || res.age !== #{age}
      || res.isAdmin !== #{isAdmin'}){
      return resolve('should respond with ' + JSON.stringify(res));
    }
    return #{resolveSuccess};|])

  pprop "Should round trip for Fragment" parRuns \(frag :: AlphaNumAscii) -> shouldRoundTrip @FragmentAPI
    (pure $ unAlphaNumAscii frag)
    ( "/foo/bar#fragment"
    , mempty
    , [i|
    if(#{frag} !== res){
      return resolve('should respond with ' + JSON.stringify(res));
    }
    return #{resolveSuccess};|])

  pprop "Should round trip for Request Body" parRuns \User{..} ->
    let isAdmin' = toJSBool isAdmin
        names' = encode names
    in shouldRoundTrip @BodyAPI
    pure
    ( "/foo/bar(User)"
    , [i|{names:#{names},age:#{age},isAdmin:#{isAdmin'}}|]
    , [i|
    if(JSON.stringify(res.names) !== `#{names'}`
       || res.age !== #{age}
       || res.isAdmin !== #{isAdmin'}){
      return resolve("User was not as expected");
    }
    return #{resolveSuccess};|])

  it "Should round trip for Mixed" $ shouldRoundTrip @MixedCaptureQueryAPI
    (\_ _ _ _ _ _ _ -> pure $ User ["jack"] 22 True)
    ( "/foo/bar/:Frog%20Splat/Zap/:zazzy?wat&rump&hu%20hu{bip,wip}"
    , "3,'wazzy','zammy',4,false,true,'grim'"
    , [i|
    if(res.names[0] === "jack"
       && res.age === 22
       && res.isAdmin){
      return #{resolveSuccess};
    }
    return resolve("User was not as expected");
    |])

srid :: String -> String
srid script = [i|<html>
<head>
  <script src="/#{script <.> "js"}"></script>
</head>
<body></body>
</html>|]

resolveSuccess :: String
resolveSuccess = [i|resolve("success")|]

shouldRoundTrip :: forall (api :: Type).
  ( HasServer api '[]
  , GenAll api
  ) => Server api -> (String, String, String) -> IO ()
shouldRoundTrip app (path, args, test)
 = getTemporaryDirectory >>= \tmpDir ->
 testWithApplication (pure $ serve (Proxy @(api :<|> Raw)) (app :<|> serveDirectoryFileServer tmpDir)) $ \port -> do
  rand :: Int <- randomIO
  now <- getPOSIXTime

  let
    tsFilePath, localhost, ts :: String
    localhost = "http://127.0.0.1:" <> show port
    tsFilePath = show now <> show (rand * 1000000) <.> "ts"
    ts = [i|#{printTS $ GGT.gen @User}
#{SCT.gen @api}
window["test"] = resolve => {
  API["#{path}"](#{args}).then(res => {
    #{test}
  });
};|]

    death = do
      removeFileIfExists $ tmpDir </> tsFilePath
      removeFileIfExists $ tmpDir </> tsFilePath <.> "js"
      removeFileIfExists $ tmpDir </> tsFilePath <.> "html"

    handleFailure :: forall a. (ExitCode, String, String) -> String -> IO a -> IO a
    handleFailure res mes continue = case res of
      (ExitFailure ef, out, err) -> do
        death
        putStrLn "━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"
        putStrLn $ addLineNumbers ts
        putStrLn "┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈┈"
        putStrLn out
        when (not (null err)) $ putStrLn err
        putStrLn "━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━━"
        error $ mes <> " " <> show ef
      _ -> continue

  writeFile (tmpDir </> tsFilePath) ts
  writeFile (tmpDir </> tsFilePath <.> "html") (srid tsFilePath)

  tscres <- readProcessWithExitCode "tsc"
    [ tmpDir </> tsFilePath
    , "--lib", "ES2021,DOM"
    , "--module", "system"
    , "--outFile", tmpDir </> tsFilePath <.> "js"
    ] ""
  handleFailure tscres "TSC exited with" do
    res <- runSession
      (useBrowser chrome { chromeOptions = if isHeadless then
        [ "--headless"
        , "--disable-gpu"
        ] else [] } defaultConfig)
      do
        openPage $ localhost </> tsFilePath <.> "html"
        res <- asyncJS [] [i|test(arguments[0])|]
        closeSession
        return res
    case res of
      Just "success" -> pure ()
      Just x         -> death >> error x
      Nothing        -> death >> error "TIMEOUT"

removeFileIfExists :: FilePath -> IO ()
removeFileIfExists fp = do
  exists <- doesFileExist fp
  when exists $ removeFile fp

addLineNumbers :: String -> String
addLineNumbers ts =
  if showLineNumbers then foldMap (\(x,ln) ->
    let lnf = show (ln :: Int) in "\n " <> lnf <> replicate (4 - length lnf) ' ' <> "| " <> x)
      $ zip (splitOn "\n" ts) [1..]
  else ts