content: -- | This module provides a 'HasRequest' class that Interprets
  -- a 'ReqContent' type level list into 'Request' data
  --
  {-# LANGUAGE PatternSynonyms      #-}
  module Hreq.Core.Client.HasRequest where
  
  import Prelude ()
  import Prelude.Compat
  
  import Data.Kind
  import Data.Hlist
  import Data.Proxy
  import Data.Singletons
  import GHC.TypeLits
  import Data.String (fromString)
  import Data.String.Conversions (cs)
  import Data.List (intersperse)
  import qualified Data.Text as T (concat)
  
  import Hreq.Core.API
  import Hreq.Core.Client.Request
  import Hreq.Core.Client.BasicAuth
  import Network.HTTP.Types (QueryItem)
  
  pattern Empty :: Hlist '[]
  pattern Empty = Nil
  
  -- | 'HasRequest' is used to create a Request from a 'ReqContent' type level list
  -- and a 'Verb'.
  --
  -- @verb@ is requited for obtaining Request method and 'MediaType' value
  --
  -- @reqComponents@ is a usually a 'ReqContent Type' type level list.
  -- It can be something else.
  class HasRequest (reqComponents :: k) (verb :: Type) where
     type HttpInput reqComponents :: Type
  
     httpReq
       :: Proxy verb
       -> Proxy reqComponents
       -> HttpInput reqComponents
       -> Request
       -> Request
  
  instance
     ( HttpReqConstraints ts
     , ReflectMethod method
     , SingI ('Req ts)
     , SingI ('Res rs)
     , HttpResConstraints rs
    )
    => HasRequest (ts :: [ReqContent Type]) (Verb method rs) where
    type HttpInput ts = Hlist (HttpReq ts)
  
    httpReq _ _ input req =
      let method'      = reflectMethod (Proxy @method)
          acceptHeader = case sing @('Res rs) of
                           SRes ys -> getAcceptHeader ys
          req'         = case sing @('Req ts) of
                           SReq xs -> encodeHlistAsReq xs input req
  
      in appendMethod method' $ req' { reqAccept = acceptHeader }
  
  getAcceptHeader
    :: forall (rs :: [ResContent Type]) . HttpResConstraints rs
    => Sing rs -> Maybe MediaType
  getAcceptHeader = \case
    SNil -> Nothing
    SCons (SResBody sctyp _a) _rs -> Just $ mediaType sctyp
    SCons (SRaw _) rs -> getAcceptHeader rs
    SCons (SResHeaders _) rs -> getAcceptHeader rs
    SCons (SResStatus _ _) rs -> getAcceptHeader rs
    SCons (SResStream sctyp _) _rs -> Just $ mediaType sctyp
  
  -- | Transform a 'Hlist' of inputs into a 'Request'
  encodeHlistAsReq
    :: forall (ts :: [ReqContent Type]). (HttpReqConstraints ts)
    => Sing ts
    -> Hlist (HttpReq ts)
    -> Request
    -> Request
  encodeHlistAsReq xs input req = case (xs, input) of
    (SNil, _)                                                    ->
      req
  
    (SCons (SPath _ spath) sxs, ys) ->
      let path = withKnownSymbol spath (cs . symbolVal $ spath)
          req' = appendToPath path req
      in encodeHlistAsReq sxs ys req'
  
    (SCons (SBasicAuth _ _) sxs, y :. ys)                        ->
      let req' = basicAuthReq y req
      in encodeHlistAsReq sxs ys req'
  
    (SCons (SReqHeaders (SCons (STuple2 s _x) hs)) sxs, y :. ys) ->
      let headerName = fromString $ withKnownSymbol s (symbolVal s)
          req' = addHeader headerName y req
      in encodeHlistAsReq (SCons (SReqHeaders hs) sxs) ys req'
  
    (SCons (SReqHeaders SNil) sxs, ys)                           ->
      encodeHlistAsReq sxs ys req
  
    (SCons (SCaptureAll _a) sxs, captureList :. ys)              ->
      let captureFragments =
             T.concat $ intersperse "/" $ toUrlPiece <$> captureList
  
          req' = appendToPath captureFragments req
      in encodeHlistAsReq sxs ys req'
  
    (SCons (SCaptures SNil) sxs, ys)                             ->
      encodeHlistAsReq sxs ys req
  
    (SCons (SCaptures (SCons _z zs)) sxs, y :. ys)  ->
      let req' = appendToPath (cs $ toUrlPiece y) req
      in encodeHlistAsReq (SCons (SCaptures zs) sxs) ys req'
  
    (SCons (SParams SNil) sxs, ys)                               ->
      encodeHlistAsReq sxs ys req
  
    (SCons (SParams (SCons (STuple2 s _x) ps)) sxs, y :. ys)     ->
      let req' = appendToQueryString (createParam s y) req
      in encodeHlistAsReq (SCons (SParams ps) sxs) ys req'
  
    (SCons (SQueryFlags _a sflags) SNil, _)                      ->
      appendQueryFlags (toQueryFlags sflags) req
  
    (SCons (SQueryFlags _a sflags) sxs, ys)                      ->
       encodeHlistAsReq sxs ys
         $ appendQueryFlags (toQueryFlags sflags) req
  
    (SCons (SReqBody sctyp _sa) sxs, y :. ys)                    ->
       let body = RequestBodyLBS $ mediaEncode sctyp y
           req' = setReqBody body (mediaType sctyp) req
       in encodeHlistAsReq sxs ys req'
  
    (SCons (SStreamBody sctyp _sa) sxs, y :. ys)                 ->
       let body = RequestBodyStream $ givePopper y
           req' = setReqBody body (mediaType sctyp) req
       in encodeHlistAsReq sxs ys req'
  
  {-------------------------------------------------------------------------------
    Helper functions
  -------------------------------------------------------------------------------}
  
  createParam
    :: (KnownSymbol p, ToHttpApiData a) => Sing p -> a -> QueryItem
  createParam sname val =
    let pname = withKnownSymbol sname (symbolVal sname)
        value = toQueryParam val
    in (cs pname, Just $ cs value)
  
  appendQueryFlags :: [String] -> Request -> Request
  appendQueryFlags xs req =
    let queryflags = (\ x -> (cs x, Nothing)) <$> xs
    in foldr appendToQueryString req queryflags
  
  toQueryFlags
    :: forall (fs :: [Symbol]) . All KnownSymbol fs
    => Sing fs
    -> [String]
  toQueryFlags  = \case
    SNil -> []
    SCons x xs -> withKnownSymbol x (symbolVal x) : toQueryFlags xs
  