{-# LANGUAGE DataKinds         #-}
{-# LANGUAGE FlexibleContexts  #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE OverloadedStrings #-}
module Network.HTTP.ApiMaker.Ops
  ( mkReq
  , runRequests
  , runStRequests
  , runReqM
  , runReqWithParamsM
  , runSessReqM
  , runSessReqWithParamsM
  ) where

import           Control.Lens
import           Control.Monad.Except
import           Control.Monad.Trans.State
import qualified Data.ByteString.Char8       as B
import           Data.List                   (find)
import qualified Network.HTTP.Client         as C
import           Network.HTTP.Req

import           Network.HTTP.ApiMaker.Class


-- | Prepare to run requests.
runReqM :: (MonadIO m) => SafeReqM () a -> m (Either HttpException a)
runReqM :: SafeReqM () a -> m (Either HttpException a)
runReqM = Config () -> SafeReqM () a -> m (Either HttpException a)
forall (m :: Type -> Type) cfg a.
MonadIO m =>
Config cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSafeReqM (HttpConfig -> [Option 'Https] -> () -> Config ()
forall cfg. HttpConfig -> [Option 'Https] -> cfg -> Config cfg
Config HttpConfig
defaultHttpConfig [] ())

-- | Prepare to run requests with addional header options.
runReqWithParamsM :: (MonadIO m) => [Option 'Https] -> SafeReqM () a -> m (Either HttpException a)
runReqWithParamsM :: [Option 'Https] -> SafeReqM () a -> m (Either HttpException a)
runReqWithParamsM [Option 'Https]
params = Config () -> SafeReqM () a -> m (Either HttpException a)
forall (m :: Type -> Type) cfg a.
MonadIO m =>
Config cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSafeReqM (HttpConfig -> [Option 'Https] -> () -> Config ()
forall cfg. HttpConfig -> [Option 'Https] -> cfg -> Config cfg
Config HttpConfig
defaultHttpConfig [Option 'Https]
params ())

-- | Prepare to run request with config.
runSessReqM :: (MonadIO m) => cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSessReqM :: cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSessReqM cfg
cfg = Config cfg -> SafeReqM cfg a -> m (Either HttpException a)
forall (m :: Type -> Type) cfg a.
MonadIO m =>
Config cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSafeReqM (HttpConfig -> [Option 'Https] -> cfg -> Config cfg
forall cfg. HttpConfig -> [Option 'Https] -> cfg -> Config cfg
Config HttpConfig
defaultHttpConfig [] cfg
cfg)

-- | Prepare to run request with config and additional header options.
runSessReqWithParamsM :: (MonadIO m) => [Option 'Https] -> cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSessReqWithParamsM :: [Option 'Https]
-> cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSessReqWithParamsM [Option 'Https]
params cfg
cfg = Config cfg -> SafeReqM cfg a -> m (Either HttpException a)
forall (m :: Type -> Type) cfg a.
MonadIO m =>
Config cfg -> SafeReqM cfg a -> m (Either HttpException a)
runSafeReqM (HttpConfig -> [Option 'Https] -> cfg -> Config cfg
forall cfg. HttpConfig -> [Option 'Https] -> cfg -> Config cfg
Config HttpConfig
defaultHttpConfig [Option 'Https]
params cfg
cfg)


-- | Run a normal session based request state monad.
runRequests :: StateT Session (SafeReqM cfg) a -> SafeReqM cfg a
runRequests :: StateT Session (SafeReqM cfg) a -> SafeReqM cfg a
runRequests = (StateT Session (SafeReqM cfg) a -> Session -> SafeReqM cfg a)
-> Session -> StateT Session (SafeReqM cfg) a -> SafeReqM cfg a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT Session (SafeReqM cfg) a -> Session -> SafeReqM cfg a
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT (Maybe ByteString -> Maybe ByteString -> Maybe CookieJar -> Session
Session Maybe ByteString
forall a. Maybe a
Nothing Maybe ByteString
forall a. Maybe a
Nothing Maybe CookieJar
forall a. Maybe a
Nothing)


-- | Run a user defined session request state monad.
runStRequests :: st -> StateT st (SafeReqM cfg) a -> SafeReqM cfg a
runStRequests :: st -> StateT st (SafeReqM cfg) a -> SafeReqM cfg a
runStRequests = (StateT st (SafeReqM cfg) a -> st -> SafeReqM cfg a)
-> st -> StateT st (SafeReqM cfg) a -> SafeReqM cfg a
forall a b c. (a -> b -> c) -> b -> a -> c
flip StateT st (SafeReqM cfg) a -> st -> SafeReqM cfg a
forall (m :: Type -> Type) s a. Monad m => StateT s m a -> s -> m a
evalStateT


-- | Call a single request. See 'runRequest' and 'runStRequests' to build and execute a set of requests that share the
-- same state, session and configuration.
mkReq :: (Request cfg request, SessionState st) => request -> SafeReqSt st cfg (Output request)
mkReq :: request -> SafeReqSt st cfg (Output request)
mkReq request
r = do
  st
session <- StateT st (SafeReqM cfg) st
forall (m :: Type -> Type) s. Monad m => StateT s m s
get
  Config cfg
cfg <- SafeReqM cfg (Config cfg) -> StateT st (SafeReqM cfg) (Config cfg)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift SafeReqM cfg (Config cfg)
forall cfg. SafeReqM cfg (Config cfg)
askConfig
  cfg
apiCfg <- SafeReqM cfg cfg -> StateT st (SafeReqM cfg) cfg
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift SafeReqM cfg cfg
forall cfg. SafeReqM cfg cfg
askApiConfig

  let ops :: Option 'Https
ops = cfg -> request -> Option 'Https
forall cfg r. Request cfg r => cfg -> r -> Option 'Https
option cfg
apiCfg request
r Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> st -> Option 'Https
forall st (scheme :: Scheme).
SessionState st =>
st -> Option scheme
mkSessionOps st
session Option 'Https -> Option 'Https -> Option 'Https
forall a. Semigroup a => a -> a -> a
<> [Option 'Https] -> Option 'Https
forall a. Monoid a => [a] -> a
mconcat (Config cfg -> [Option 'Https]
forall cfg. Config cfg -> [Option 'Https]
apiDefaultParameters Config cfg
cfg)
  -- liftIO $ putStrLn $ "Running a request to " <> show (url r)
  Response request
resp <- SafeReqM cfg (Response request)
-> StateT st (SafeReqM cfg) (Response request)
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (SafeReqM cfg (Response request)
 -> StateT st (SafeReqM cfg) (Response request))
-> SafeReqM cfg (Response request)
-> StateT st (SafeReqM cfg) (Response request)
forall a b. (a -> b) -> a -> b
$ Method request
-> Url 'Https
-> Body request
-> Proxy (Response request)
-> Option 'Https
-> SafeReqM cfg (Response request)
forall (m :: Type -> Type) method body response (scheme :: Scheme).
(MonadHttp m, HttpMethod method, HttpBody body,
 HttpResponse response,
 HttpBodyAllowed (AllowsBody method) (ProvidesBody body)) =>
method
-> Url scheme
-> body
-> Proxy response
-> Option scheme
-> m response
req (cfg -> request -> Method request
forall cfg r. Request cfg r => cfg -> r -> Method r
method cfg
apiCfg request
r) (cfg -> request -> Url 'Https
forall cfg r. Request cfg r => cfg -> r -> Url 'Https
url cfg
apiCfg request
r) (cfg -> request -> Body request
forall cfg r. Request cfg r => cfg -> r -> Body r
body cfg
apiCfg request
r) (cfg -> request -> Proxy (Response request)
forall cfg r. Request cfg r => cfg -> r -> Proxy (Response r)
response cfg
apiCfg request
r) Option 'Https
ops
  request -> Response request -> SafeReqSt st cfg ()
forall cfg request st.
(Request cfg request, SessionState st) =>
request -> Response request -> SafeReqSt st cfg ()
updateSession request
r Response request
resp
  cfg
-> request -> Response request -> SafeReqSt st cfg (Output request)
forall cfg r (m :: Type -> Type) st.
(Request cfg r, MonadHttp m, SessionState st) =>
cfg -> r -> Response r -> StateT st m (Output r)
process cfg
apiCfg request
r Response request
resp
  where
    mkSessionOps :: st -> Option scheme
mkSessionOps st
session =
      Option scheme
-> (CookieJar -> Option scheme) -> Maybe CookieJar -> Option scheme
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Option scheme
forall a. Monoid a => a
mempty CookieJar -> Option scheme
forall (scheme :: Scheme). CookieJar -> Option scheme
cookieJar (st
session st
-> Getting (Maybe CookieJar) st (Maybe CookieJar)
-> Maybe CookieJar
forall s a. s -> Getting a s a -> a
^. Getting (Maybe CookieJar) st (Maybe CookieJar)
forall st. SessionState st => Lens' st (Maybe CookieJar)
cookieJarData) Option scheme -> Option scheme -> Option scheme
forall a. Semigroup a => a -> a -> a
<> ByteString -> ByteString -> Option scheme
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"Cookie" (ByteString -> [ByteString] -> ByteString
B.intercalate ByteString
";" (st -> [ByteString]
forall st. SessionState st => st -> [ByteString]
mkSessionCookie st
session [ByteString] -> [ByteString] -> [ByteString]
forall a. [a] -> [a] -> [a]
++ st -> [ByteString]
forall st. SessionState st => st -> [ByteString]
mkCsrfCookie st
session)) Option scheme -> Option scheme -> Option scheme
forall a. Semigroup a => a -> a -> a
<> st -> Option scheme
forall st (scheme :: Scheme).
SessionState st =>
st -> Option scheme
mkCsrfHeader st
session

updateSession :: (Request cfg request, SessionState st) => request -> Response request -> SafeReqSt st cfg ()
updateSession :: request -> Response request -> SafeReqSt st cfg ()
updateSession request
_ Response request
resp =
  let cookies :: [Cookie]
cookies = CookieJar -> [Cookie]
C.destroyCookieJar (CookieJar -> [Cookie]) -> CookieJar -> [Cookie]
forall a b. (a -> b) -> a -> b
$ Response request -> CookieJar
forall response. HttpResponse response => response -> CookieJar
responseCookieJar Response request
resp
      sessData :: Maybe ByteString
sessData = Cookie -> ByteString
C.cookie_value (Cookie -> ByteString) -> Maybe Cookie -> Maybe ByteString
forall (f :: Type -> Type) a b. Functor f => (a -> b) -> f a -> f b
<$> (Cookie -> Bool) -> [Cookie] -> Maybe Cookie
forall (t :: Type -> Type) a.
Foldable t =>
(a -> Bool) -> t a -> Maybe a
find ((ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"_SESSION") (ByteString -> Bool) -> (Cookie -> ByteString) -> Cookie -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Cookie -> ByteString
C.cookie_name) [Cookie]
cookies
   in (Maybe ByteString -> Identity (Maybe ByteString))
-> st -> Identity st
forall st. SessionState st => Lens' st (Maybe ByteString)
sessionData ((Maybe ByteString -> Identity (Maybe ByteString))
 -> st -> Identity st)
-> Maybe ByteString -> SafeReqSt st cfg ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a b -> b -> m ()
.= Maybe ByteString
sessData SafeReqSt st cfg () -> SafeReqSt st cfg () -> SafeReqSt st cfg ()
forall (m :: Type -> Type) a b. Monad m => m a -> m b -> m b
>> (Maybe CookieJar -> Identity (Maybe CookieJar))
-> st -> Identity st
forall st. SessionState st => Lens' st (Maybe CookieJar)
cookieJarData ((Maybe CookieJar -> Identity (Maybe CookieJar))
 -> st -> Identity st)
-> CookieJar -> SafeReqSt st cfg ()
forall s (m :: Type -> Type) a b.
MonadState s m =>
ASetter s s a (Maybe b) -> b -> m ()
?= Response request -> CookieJar
forall response. HttpResponse response => response -> CookieJar
responseCookieJar Response request
resp


-- Note: Server does not check/receive cookie!
mkSessionCookie :: (SessionState st) => st -> [B.ByteString]
mkSessionCookie :: st -> [ByteString]
mkSessionCookie st
st =
  case st
st st
-> Getting (Maybe ByteString) st (Maybe ByteString)
-> Maybe ByteString
forall s a. s -> Getting a s a -> a
^. Getting (Maybe ByteString) st (Maybe ByteString)
forall st. SessionState st => Lens' st (Maybe ByteString)
sessionData of
    Maybe ByteString
Nothing   -> [ByteString]
forall a. Monoid a => a
mempty
    Just ByteString
sess -> [ByteString
"_SESSION=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
sess]

mkCsrfCookie :: (SessionState st) => st -> [B.ByteString]
mkCsrfCookie :: st -> [ByteString]
mkCsrfCookie st
st =
  case st
st st
-> Getting (Maybe ByteString) st (Maybe ByteString)
-> Maybe ByteString
forall s a. s -> Getting a s a -> a
^. Getting (Maybe ByteString) st (Maybe ByteString)
forall st. SessionState st => Lens' st (Maybe ByteString)
csrfToken of
    Maybe ByteString
Nothing   -> [ByteString]
forall a. Monoid a => a
mempty
    Just ByteString
csrf -> [ByteString
"XSRF-TOKEN=" ByteString -> ByteString -> ByteString
forall a. Semigroup a => a -> a -> a
<> ByteString
csrf]

mkCsrfHeader :: (SessionState st) => st -> Option scheme
mkCsrfHeader :: st -> Option scheme
mkCsrfHeader st
st =
  case st
st st
-> Getting (Maybe ByteString) st (Maybe ByteString)
-> Maybe ByteString
forall s a. s -> Getting a s a -> a
^. Getting (Maybe ByteString) st (Maybe ByteString)
forall st. SessionState st => Lens' st (Maybe ByteString)
csrfToken of
    Maybe ByteString
Nothing   -> Option scheme
forall a. Monoid a => a
mempty
    Just ByteString
csrf -> ByteString -> ByteString -> Option scheme
forall (scheme :: Scheme).
ByteString -> ByteString -> Option scheme
header ByteString
"X-XSRF-TOKEN" ByteString
csrf