HasResponse.hs

-- | This module provides a 'HasResponse' class that Interprets
-- 'Verb' content into a particular api endpoint query result.
--
-- For instance @Verb GET '[]@ gets interpreted as an empty response of type Unit i.e @()@
--
module Hreq.Core.Client.HasResponse where

import Control.Monad.Except
import Data.Kind
import Data.Hlist
import Data.Proxy
import Data.Singletons
import qualified Data.List.NonEmpty as NE
import GHC.TypeLits
import Network.HTTP.Types (hContentType)

import Hreq.Core.API
import Hreq.Core.Client.ClientError
import Hreq.Core.Client.Response

class MonadError ClientError m => HasResponse (a :: k) m where
   type HttpOutput a :: Type

   httpRes :: sing a -> Response -> m (HttpOutput a)

instance
  ( UniqMembers rs "Response"
  , HasResponse rs m
  )
  => HasResponse (Verb method rs ) m where

  type HttpOutput (Verb method rs) = HttpOutput rs

  httpRes _ = httpRes (Proxy @rs)

instance (MonadError ClientError m) => HasResponse '[] m where
  type HttpOutput '[] = ()

  httpRes _ _ = return ()

instance {-# OVERLAPPING #-} (MonadError ClientError m)
  => HasResponse '[ 'Raw a ] m where
  type HttpOutput '[ 'Raw a ] = Response

  httpRes _ = return

instance MonadError ClientError m => HasResponse ('ResStream ': rs) m where

  type HttpOutput ('ResStream ': rs) =
    TypeError ('Text "ResStream shouldn't be an instance of HasResponse class")

  httpRes _ _ =  error "GHC Error"

instance {-# OVERLAPPING #-}
  MonadError ClientError m
  => HasResponse ('Raw a : r : rs) m where

  type HttpOutput ('Raw a : r : rs) =
    TypeError ('Text "Raw should be used only in a singleton list")

  httpRes _ _ =  error "GHC Error"

-- | Expected status code much match received code
instance {-# OVERLAPPING #-}
  ( MonadError ClientError m
  , KnownNat n
  )
  => HasResponse '[ ResStatus n ] m where
  type HttpOutput '[ ResStatus n ] = Response

  httpRes _ res = do
    let expectedCode = fromIntegral @Integer @Int $ natVal (Proxy @n)
        rcode = resStatusCode res
    when (expectedCode /= rcode) $ throwError (InvalidStatusCode res)

    return res

-- | Expected status code much match received code in a response code list
instance {-# OVERLAPPING #-}
  ( MonadError ClientError m
  , KnownNat n
  , SingI ('Res (r ': rs))
  , HttpResConstraints (r ': rs)
  )
  => HasResponse (ResStatus n : r : rs) m where
  type HttpOutput (ResStatus n : r : rs) =  Hlist (HttpRes (r ': rs))

  httpRes _ response = do
    let expectedCode = fromIntegral @Integer @Int $ natVal (Proxy @n)
        rcode = resStatusCode response
    when (expectedCode /= rcode) $ throwError (InvalidStatusCode response)

    case sing @('Res (r ': rs)) of
      SRes xs -> decodeAsHlist xs response

instance {-# OVERLAPPING #-}
  ( MediaDecode ctyp a
  , MonadError ClientError m
  )
  => HasResponse '[ 'ResBody ctyp a ] m where
  type HttpOutput '[ 'ResBody ctyp a ] = a

  httpRes _ = decodeAsBody (Proxy @ctyp)

-- | The following type instance is overly restrictive to avoid
-- overlapping type family instance error.
instance {-# OVERLAPPING #-}
  ( MediaDecode ctyp a
  , MonadError ClientError m
  , SingI ('Res (r ': rs))
  , HttpResConstraints (r ': rs)
  ) => HasResponse ( 'ResBody ctyp a ': r ': rs ) m where
  type HttpOutput  ( 'ResBody ctyp a ': r ': rs) = Hlist ( a ': HttpRes (r ': rs))
  httpRes _ response = case sing @('Res (r ': rs)) of
    SRes xs -> do
      body <- decodeAsBody (Proxy @ctyp) response
      reset <- decodeAsHlist xs response
      return $ body :. reset


instance {-# OVERLAPPING #-}
  ( MonadError ClientError m
  , SingI ('Res ('ResHeaders hs ': rs))
  , HttpResConstraints ('ResHeaders hs ': rs)
  ) => HasResponse ('ResHeaders hs ': rs) m where
  type HttpOutput ('ResHeaders hs : rs) = Hlist (HttpRes ('ResHeaders hs ': rs))

  httpRes _ response = case sing @('Res ('ResHeaders hs ': rs)) of
    SRes xs -> decodeAsHlist xs response

decodeAsBody
  :: forall ctyp a m sing
  . (MonadError ClientError m, MediaDecode ctyp a)
  => sing ctyp
  -> Response
  -> m a
decodeAsBody _ response = do
  responseContentType <- checkContentType

  unless (any (responseContentType `matches`) accepts)
    . throwError $ UnsupportedContentType (NE.head accepts) response

  case mediaDecode ctypProxy (resBody response) of
     Left err -> throwError $ DecodeFailure (unDecodeError err) response
     Right val -> pure val
  where
    ctypProxy :: Proxy ctyp
    ctypProxy = Proxy

    accepts :: NE.NonEmpty MediaType
    accepts = mediaTypes ctypProxy

    checkContentType :: m MediaType
    checkContentType  = case lookup hContentType $ resHeaders response of
      Nothing -> return $ mediaType (Proxy @PlainText) -- fall back to plain text
      Just t  -> maybe (throwError $ InvalidContentTypeHeader response) return $ parseAccept t

-- | Turn a Response into a 'Hlist' of outputs
decodeAsHlist
  :: (MonadError ClientError m, HttpResConstraints rs)
  => Sing rs
  -> Response
  -> m (Hlist (HttpRes rs))
decodeAsHlist srs response = case srs of
  SNil -> return Nil

  SCons (SResBody ctyp _a) xs -> do
    body <- decodeAsBody ctyp response
    rest <- decodeAsHlist xs response
    return $ body :. rest

  SCons (SResHeaders (SCons _h _hs)) xs -> do
    let headers = resHeaders response

    rest <- decodeAsHlist xs response
    return $ headers :. rest

  SCons (SResHeaders SNil) xs ->
    decodeAsHlist xs response

  SCons (SResStatus _ snat) xs -> do
    let rcode = resStatusCode response
        expectedCode = withKnownNat snat (fromIntegral @Integer @Int $ natVal snat)

    when (rcode /= expectedCode) $ throwError (InvalidStatusCode response)

    decodeAsHlist xs response
 
  -- Should never match because we have a class instance
  -- that triggers a type error when 'Raw' is in a non-singleton
  -- type level list
  (SCons (SRaw _) _xs)-> error "GHC Error"

  -- Should never match because we have a class instance
  -- that triggers a type error when 'ResStream' is in a instance of
  -- HasResponse class
  (SCons (SResStream _ _) _xs)-> error "GHC Error"