CompoundParam.hs

{-# LANGUAGE AllowAmbiguousTypes #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE PolyKinds #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
{-# LANGUAGE TypeFamilies #-}
{-# LANGUAGE TypeOperators #-}

module Web.Telegram.API.CompoundParam
  ( CompoundParam,
    ArgType (..),
  )
where

import Data.Aeson
import qualified Data.ByteString.Lazy as LBS
import Data.Kind
import Data.Maybe
import Data.Proxy
import Data.Proxy
import Data.Text (Text, pack, intercalate)
import GHC.TypeLits
import Network.HTTP.Media.MediaType ((//), (/:))
import Servant.API hiding (Optional, Required)
import Servant.Client
import Servant.Client.Core (Request, appendToQueryString, setRequestBody)
import Servant.Multipart
import Web.Telegram.Types

data ArgType
  = Optional
  | Required
  | Multiple
  deriving (Show, Eq, Ord)

data ArgTyppy (a :: ArgType) where
  Oy :: ArgTyppy 'Optional
  Ry :: ArgTyppy 'Required
  My :: ArgTyppy 'Multiple

class Typpy (b :: ArgType) where typpy :: ArgTyppy b

instance Typpy 'Optional where typpy = Oy

instance Typpy 'Required where typpy = Ry

instance Typpy 'Multiple where typpy = My

data CompoundParam (argType :: ArgType) (tag :: *) (sym :: Symbol) (a :: *)

type family GenType (argType :: ArgType) (a :: *) :: *

type instance GenType Optional a = Maybe a

type instance GenType Required a = a

type instance GenType Multiple a = [a]

foldArg ::
  forall at a r.
  Typpy at =>
  GenType at a ->
  (Maybe a -> r) ->
  (a -> r) ->
  ([a] -> r) ->
  r
foldArg x f g h =
  case (typpy :: ArgTyppy at) of
    Oy -> f x
    Ry -> g x
    My -> h x

instance Semigroup (MultipartData tag) where
  d1 <> d2 = MultipartData (inputs d1 <> inputs d2) (files d1 <> files d2)

instance Monoid (MultipartData tag) where
  mempty = MultipartData [] []

foldMultipart :: (ToMultipart tag a, Traversable f) => f a -> MultipartData tag
foldMultipart = foldMap toMultipart

appendTo :: ToHttpApiData a => Text -> Request -> a -> Request
appendTo p r a = appendToQueryString p (Just $ toQueryParam a) r

instance
  (KnownSymbol sym, ToHttpApiData a, HasClient m api, ToMultipart tag a, MultipartBackend tag, Typpy argType) =>
  HasClient m (CompoundParam argType tag sym a :> api)
  where
  type
    Client m (CompoundParam argType tag sym a :> api) =
      (LBS.ByteString, GenType argType a) -> Client m api
  clientWithRoute pm _ req (boundary, param) =
    clientWithRoute pm (Proxy @api) $ foldArg @argType param (maybe req add) add add'
    where
      add :: (ToHttpApiData a, ToMultipart tag a) => a -> Request
      add a =
        let newBody = multipartToBody boundary $ toMultipart @tag a
            newMedia = "multipart" // "form-data" /: ("boundary", LBS.toStrict boundary)
         in setRequestBody newBody newMedia $ appendTo pname req a
      add' :: (ToHttpApiData a, ToMultipart tag a) => [a] -> Request
      add' a =
        let newBody = multipartToBody boundary $ foldMultipart @tag a
            newMedia = "multipart" // "form-data" /: ("boundary", LBS.toStrict boundary)
         in setRequestBody newBody newMedia $ appendTo pname req a
      pname :: Text
      pname = pack $ symbolVal @sym Proxy
  hoistClientMonad pm _ f cl arg =
    hoistClientMonad pm (Proxy @api) f (cl arg)

instance ToHttpApiData a => ToHttpApiData [a] where
  toQueryParam xs = "[" <>
    (intercalate "," $ fmap toQueryParam xs) <> "]"