{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# OPTIONS_GHC -Wall -Werror -Wno-unticked-promoted-constructors #-}
module Main where

import Data.Kind (Type)
import GHC.Generics hiding (Meta)
import Data.Bifunctor (Bifunctor(..))
import qualified Data.HashMap.Strict as H
import qualified Data.Text as T
import Data.Aeson
  (Value(..),FromJSON(..),ToJSON(..),encode,eitherDecode'
  ,object,withObject,(.:),(.=))
import Net.Types (IPv4)
import qualified Net.IPv4.String as IPv4
import Control.Exception (catch,SomeException)
import System.Exit (exitFailure)
import qualified Network.HTTP.Types.Status as N
import qualified Network.HTTP.Client as N
import Trasa.Core
import qualified Trasa.Method as M
import Trasa.Client

data Ip = Ip
  { origin :: IPv4
  } deriving (Generic,FromJSON,ToJSON)

instance Show Ip where
  show (Ip ipv4) = "{ origin: " ++ IPv4.encode ipv4 ++ " }"

data Args = Args
  { args :: H.HashMap T.Text Value
  } deriving Show

instance FromJSON Args where
  parseJSON = withObject "Args" $ \o -> Args <$> o .: "args"

instance ToJSON Args where
  toJSON (Args as) = object [ "args" .= as ]

bodyAeson :: (FromJSON a, ToJSON a) => BodyCodec a
bodyAeson = BodyCodec (pure "application/json") encode (first T.pack . eitherDecode')

int :: CaptureCodec Int
int = showReadCaptureCodec

bodyUnit :: BodyCodec ()
bodyUnit = BodyCodec (pure "text/html") (const "") (const (Right ()))

data Route :: [Type] -> [Param] -> Bodiedness -> Type -> Type where
  RouteHome :: Route '[] '[] Bodyless ()
  RouteIp :: Route '[] '[] Bodyless Ip
  RouteStatus :: Route '[Int] '[] Bodyless ()
  RouteQuery :: Route '[] '[Optional Int] Bodyless Args

data Meta caps qrys req resp = Meta
  { metaPath :: Path CaptureCodec caps
  , metaQuery :: Rec (Query CaptureCodec) qrys
  , metaRequestBody :: RequestBody BodyCodec req
  , metaResponseBody :: ResponseBody BodyCodec resp
  , metaMethod :: Method }

meta :: Route caps qrys req resp -> Meta caps qrys req resp
meta = \case
  RouteHome -> Meta end qend bodyless (resp bodyUnit) M.get
  RouteIp -> Meta (match "ip" ./ end) qend bodyless (resp bodyAeson) M.get
  RouteStatus -> Meta (match "status" ./ capture int ./ end) qend bodyless (resp bodyUnit) M.get
  RouteQuery -> Meta (match "anything" ./ end) (optional "int" int .& qend) bodyless (resp bodyAeson) M.get

prepare :: Route caps qrys req resp -> Arguments caps qrys req (Prepared Route resp)
prepare = prepareWith (metaPath . meta) (metaQuery . meta) (metaRequestBody . meta)

link :: Prepared Route resp -> Url
link = linkWith
  (mapPath captureCodecToCaptureEncoding . metaPath . meta)
  (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)

client :: Config -> Prepared Route resp -> IO (Either TrasaErr resp)
client = clientWith
  (metaMethod . meta)
  (mapPath captureCodecToCaptureEncoding . metaPath . meta)
  (mapQuery captureCodecToCaptureEncoding . metaQuery . meta)
  (mapRequestBody (Many . pure . bodyCodecToBodyEncoding) . metaRequestBody . meta)
  (mapResponseBody (Many . pure . bodyCodecToBodyDecoding) . metaResponseBody . meta)

shouldRight :: Show resp => Config -> Prepared Route resp -> IO ()
shouldRight conf route = do
  putStr $ show (link route) ++ ": "
  client conf route >>= \case
    Left err -> do
      print err
      exitFailure
    Right val -> print val

main :: IO ()
main = do
  manager <- N.newManager N.defaultManagerSettings
  let conf = Config (Authority Http "httpbin.org" Nothing) manager
  res <- catch (client conf (prepare RouteHome)) $ \(_ :: SomeException) -> return (Left (status N.status400))
  case res of
    Left err  -> do
      putStrLn "Could not connect to httpbin.org, not running test suite"
      putStrLn ("Could not connect because: " ++ show err)
    Right _ -> do
      putStrLn "Connected to httpbin.org, actually testing routes now..."
      shouldRight conf (prepare RouteIp)
      shouldRight conf (prepare RouteStatus 200)
      shouldRight conf (prepare RouteQuery (Just 1))