content: {-# LANGUAGE CPP                 #-}
  {-# LANGUAGE DeriveFunctor       #-}
  {-# LANGUAGE FlexibleContexts    #-}
  {-# LANGUAGE GADTs               #-}
  {-# LANGUAGE OverloadedStrings   #-}
  {-# LANGUAGE LambdaCase          #-}
  {-# LANGUAGE RankNTypes          #-}
  {-# LANGUAGE ScopedTypeVariables #-}
  {-# LANGUAGE TupleSections       #-}
  
  module Servant.Common.Req where
  
  -------------------------------------------------------------------------------
  import           Control.Applicative        (liftA2, liftA3)
  import           Control.Arrow              ((&&&))
  import           Control.Concurrent
  import           Control.Monad              (join)
  import           Control.Monad.IO.Class     (MonadIO, liftIO)
  import           Data.Bifunctor             (first)
  import qualified Data.ByteString.Builder    as Builder
  import qualified Data.ByteString.Lazy.Char8 as BL
  import           Data.ByteString            (ByteString)
  import qualified Data.Map                   as Map
  import           Data.Maybe                 (catMaybes, fromMaybe)
  import           Data.Functor.Compose
  import           Data.Monoid                ((<>))
  import           Data.Proxy                 (Proxy(..))
  import           Data.Text                  (Text)
  import qualified Data.Text                  as T
  import qualified Data.Text.Encoding         as TE
  import           Data.Traversable           (forM)
  import           Language.Javascript.JSaddle.Monad (JSM, MonadJSM, liftJSM)
  import qualified Network.URI                as N
  import           Reflex.Dom.Core                 hiding (tag)
  import           Servant.Common.BaseUrl     (BaseUrl, showBaseUrl,
                                               SupportsServantReflex)
  import           Servant.API.ContentTypes   (MimeUnrender(..), NoContent(..))
  import           Web.HttpApiData            (ToHttpApiData(..))
  -------------------------------------------------------------------------------
  import           Servant.API.BasicAuth
  
  
  ------------------------------------------------------------------------------
  -- | The result of a request event
  data ReqResult tag a
      = ResponseSuccess tag a XhrResponse
        -- ^ The succesfully decoded response from a request tagged with 'tag'
      | ResponseFailure tag Text XhrResponse
        -- ^ The failure response, which may have failed decoding or had
        --   a non-successful response code
      | RequestFailure  tag Text
        -- ^ A failure to construct the request tagged with 'tag' at trigger time
    deriving (Functor)
  
  data ClientOptions = ClientOptions
      { optsRequestFixup :: forall a. Show a => XhrRequest a -> JSM (XhrRequest a)
        -- ^ Aribtrarily modify requests just before they are sent.
        -- Warning: This escape hatch opens the possibility for your
        -- requests to diverge from what the server expects, when the
        -- server is also derived from a servant API
      }
  
  defaultClientOptions :: ClientOptions
  defaultClientOptions = ClientOptions { optsRequestFixup = return }
  
  -- withCredentials :: Lens' (XhrRequest a) Bool
  withCredentials :: (Show a, Functor f) => (Bool -> f Bool) -> XhrRequest a -> f (XhrRequest a)
  withCredentials inj r@(XhrRequest _ _ cfg) =
      let cfg' = (\b -> cfg { _xhrRequestConfig_withCredentials = b}) <$>
                 inj (_xhrRequestConfig_withCredentials cfg)
      in (\c' -> r {_xhrRequest_config = c' }) <$> cfg'
  
  ------------------------------------------------------------------------------
  -- | Simple filter/accessor for successful responses, when you want to
  -- ignore the error case. For example:
  -- >> goodResponses <- fmapMaybe reqSuccess <$> clientFun triggers
  reqSuccess :: ReqResult tag a -> Maybe a
  reqSuccess (ResponseSuccess _ x _) = Just x
  reqSuccess _                       = Nothing
  
  
  ------------------------------------------------------------------------------
  -- | Simple filter/accessor like 'reqSuccess', but keeping the request tag
  reqSuccess' :: ReqResult tag a -> Maybe (tag,a)
  reqSuccess' (ResponseSuccess tag x _) = Just (tag,x)
  reqSuccess' _                         = Nothing
  
  
  ------------------------------------------------------------------------------
  -- | Simple filter/accessor for any failure case
  reqFailure :: ReqResult tag a -> Maybe Text
  reqFailure (ResponseFailure _ s _) = Just s
  reqFailure (RequestFailure  _ s)   = Just s
  reqFailure _                       = Nothing
  
  ------------------------------------------------------------------------------
  -- | Simple filter/accessor like 'reqFailure', but keeping the request tag
  reqFailure' :: ReqResult tag a -> Maybe (tag,Text)
  reqFailure' (ResponseFailure tag s _) = Just (tag,s)
  reqFailure' (RequestFailure  tag s)   = Just (tag,s)
  reqFailure' _                         = Nothing
  
  
  ------------------------------------------------------------------------------
  -- | Simple filter/accessor for the raw XHR response
  response :: ReqResult tag a -> Maybe XhrResponse
  response (ResponseSuccess _ _ x) = Just x
  response (ResponseFailure _ _ x) = Just x
  response _                       = Nothing
  
  ------------------------------------------------------------------------------
  -- | Retrieve response tag
  reqTag :: ReqResult tag a -> tag
  reqTag (ResponseSuccess tag _ _) = tag
  reqTag (ResponseFailure tag _ _) = tag
  reqTag (RequestFailure  tag _  ) = tag
  
  -------------------------------------------------------------------------------
  -- | You must wrap the parameter of a QueryParam endpoint with 'QParam' to
  -- indicate whether the parameter is valid and present, validly absent, or
  -- invalid
  data QParam a = QParamSome a
                -- ^ A valid query parameter
                | QNone
                -- ^ Indication that the parameter is intentionally absent (the request is valid)
                | QParamInvalid Text
                -- ^ Indication that your validation failed (the request isn't valid)
  
  
  qParamToQueryPart :: ToHttpApiData a => QParam a -> Either Text (Maybe Text)
  qParamToQueryPart (QParamSome a)    = Right (Just $ toQueryParam a)
  qParamToQueryPart QNone             = Right Nothing
  qParamToQueryPart (QParamInvalid e) = Left e
  
  
  data QueryPart t = QueryPartParam  (Dynamic t (Either Text (Maybe Text)))
                   | QueryPartParams (Dynamic t [Text])
                   | QueryPartFlag   (Dynamic t Bool)
  
  
  -------------------------------------------------------------------------------
  -- The data structure used to build up request information while traversing
  -- the shape of a servant API
  data Req t = Req
    { reqMethod    :: Text
    , reqPathParts :: [Dynamic t (Either Text Text)]
    , qParams      :: [(Text, QueryPart t)]
    , reqBody      :: Maybe (Dynamic t (Either Text (BL.ByteString, Text)))
    , headers      :: [(Text, Dynamic t (Either Text Text))]
    , respHeaders  :: XhrResponseHeaders
    , authData     :: Maybe (Dynamic t (Maybe BasicAuthData))
    }
  
  defReq :: Req t
  defReq = Req "GET" [] [] Nothing [] def Nothing
  
  prependToPathParts :: Dynamic t (Either Text Text) -> Req t -> Req t
  prependToPathParts p req =
    req { reqPathParts = p : reqPathParts req }
  
  addHeader :: (ToHttpApiData a, Reflex t) => Text -> Dynamic t (Either Text a) -> Req t -> Req t
  addHeader name val req = req { headers = (name, (fmap . fmap) (TE.decodeUtf8 . toHeader) val) : headers req }
  
  
  reqToReflexRequest
      :: forall t. Reflex t
      => Text
      -> Dynamic t BaseUrl
      -> Req t
      -> Dynamic t (Either Text (XhrRequest XhrPayload))
  reqToReflexRequest reqMeth reqHost req =
    let t :: Dynamic t [Either Text Text]
        t = sequence $ reverse $ reqPathParts req
  
        baseUrl :: Dynamic t (Either Text Text)
        baseUrl = Right . showBaseUrl <$> reqHost
  
        urlParts :: Dynamic t (Either Text [Text])
        urlParts = fmap sequence t
  
        urlPath :: Dynamic t (Either Text Text)
        urlPath = (fmap.fmap)
                  (T.intercalate "/" . fmap escape)
                  urlParts
  
        queryPartString :: (Text, QueryPart t) -> Dynamic t (Maybe (Either Text Text))
        queryPartString (pName, qp) = case qp of
          QueryPartParam p -> ffor p $ \case
            Left e         -> Just (Left e)
            Right (Just a) -> Just (Right $ pName <> "=" <> escape a)
            Right Nothing  -> Nothing
          QueryPartParams ps -> ffor ps $ \pStrings ->
            if null pStrings
            then Nothing
            else Just . Right
                 . T.intercalate "&"
                 $ fmap (\p -> pName <> "=" <> escape p) pStrings
          QueryPartFlag fl -> ffor fl $ \case
            True ->  Just $ Right pName
            False -> Nothing
  
  
        queryPartStrings :: [Dynamic t (Maybe (Either Text Text))]
        queryPartStrings = map queryPartString (qParams req)
        queryPartStrings' = fmap (sequence . catMaybes) $ sequence queryPartStrings :: Dynamic t (Either Text [Text])
        queryString :: Dynamic t (Either Text Text) =
          ffor queryPartStrings' $ \qs -> fmap (T.intercalate "&") qs
        xhrUrl =  (liftA3 . liftA3) (\a p q -> a </> if T.null q then p else p <> "?" <> q)
            baseUrl urlPath queryString
          where
            (</>) :: Text -> Text -> Text
            x </> y | ("/" `T.isSuffixOf` x) || ("/" `T.isPrefixOf` y) = x <> y
                    | otherwise = x <> "/" <> y
  
  
        xhrHeaders :: Dynamic t (Either Text [(Text, Text)])
        xhrHeaders = (fmap sequence . sequence . fmap f . headers) req
          where
            f = \(headerName, dynam) ->
                  fmap (fmap (\rightVal -> (headerName, rightVal))) dynam
  
        mkConfigBody :: Either Text [(Text,Text)]
                     -> (Either Text (BL.ByteString, Text))
                     -> Either Text (XhrRequestConfig XhrPayload)
        mkConfigBody ehs rb = case (ehs, rb) of
                    (_, Left e)                     -> Left e
                    (Left e, _)                     -> Left e
                    (Right hs, Right (bBytes, bCT)) ->
                      Right $ XhrRequestConfig
                        { _xhrRequestConfig_sendData = bytesToPayload bBytes
                        , _xhrRequestConfig_headers  =
                          Map.insert "Content-Type" bCT (Map.fromList hs)
                        , _xhrRequestConfig_user = Nothing
                        , _xhrRequestConfig_password = Nothing
                        , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
                        , _xhrRequestConfig_withCredentials = False
                        , _xhrRequestConfig_responseHeaders = def
                        }
  
        xhrOpts :: Dynamic t (Either Text (XhrRequestConfig XhrPayload))
        xhrOpts = case reqBody req of
          Nothing    -> ffor xhrHeaders $ \case
                                 Left e -> Left e
                                 Right hs -> Right $ def { _xhrRequestConfig_headers = Map.fromList hs
                                                         , _xhrRequestConfig_user = Nothing
                                                         , _xhrRequestConfig_password = Nothing
                                                         , _xhrRequestConfig_responseType = Just XhrResponseType_ArrayBuffer
                                                         , _xhrRequestConfig_sendData = mempty
                                                         , _xhrRequestConfig_withCredentials = False
                                                         }
          Just rBody -> liftA2 mkConfigBody xhrHeaders rBody
  
        mkAuth :: Maybe BasicAuthData -> Either Text (XhrRequestConfig x) -> Either Text (XhrRequestConfig x)
        mkAuth _ (Left e) = Left e
        mkAuth Nothing r  = r
        mkAuth (Just (BasicAuthData u p)) (Right config) = Right $ config
          { _xhrRequestConfig_user     = Just $ TE.decodeUtf8 u
          , _xhrRequestConfig_password = Just $ TE.decodeUtf8 p}
  
        addAuth :: Dynamic t (Either Text (XhrRequestConfig x))
                -> Dynamic t (Either Text (XhrRequestConfig x))
        addAuth xhr = case authData req of
          Nothing -> xhr
          Just auth -> liftA2 mkAuth auth xhr
  
        xhrReq = (liftA2 . liftA2) (\p opt -> XhrRequest reqMeth p opt) xhrUrl (addAuth xhrOpts)
  
    in xhrReq
  
  -- * performing requests
  
  displayHttpRequest :: Text -> Text
  displayHttpRequest httpmethod = "HTTP " <> httpmethod <> " request"
  
  -- | This function performs the request
  performRequests :: forall t m f tag.(SupportsServantReflex t m, Traversable f)
                  => Text
                  -> Dynamic t (f (Req t))
                  -> Dynamic t BaseUrl
                  -> ClientOptions
                  -> Event t tag
                  -> m (Event t (tag, f (Either Text XhrResponse)))
  performRequests reqMeth rs reqHost opts trigger = do
    let xhrReqs =
            join $ (\(fxhr :: f (Req t)) -> sequence $
                       reqToReflexRequest reqMeth reqHost <$> fxhr) <$> rs
  
        -- xhrReqs = fmap snd <$> xhrReqsAndDebugs
        reqs    = attachPromptlyDynWith
                  (\fxhr t -> Compose (t, fxhr)) xhrReqs trigger
  
    resps <- performSomeRequestsAsync opts reqs
    return $ getCompose <$> resps
  
  -- | Issues a collection of requests when the supplied Event fires.
  -- When ALL requests from a given firing complete, the results are
  -- collected and returned via the return Event.
  performSomeRequestsAsync
      :: (MonadIO (Performable m),
          MonadJSM (Performable m),
          PerformEvent t m,
          TriggerEvent t m,
          Traversable f,
          IsXhrPayload a,
          Show a
         )
      => ClientOptions
      -> Event t (f (Either Text (XhrRequest a)))
      -> m (Event t (f (Either Text XhrResponse)))
  performSomeRequestsAsync opts =
      performSomeRequestsAsync' opts newXMLHttpRequest . fmap return
  
  
  ------------------------------------------------------------------------------
  -- | A modified version or Reflex.Dom.Xhr.performRequestsAsync
  -- that accepts 'f (Either e (XhrRequestb))' events
  performSomeRequestsAsync'
      :: (MonadJSM (Performable m), PerformEvent t m, TriggerEvent t m, Traversable f, Show b)
      => ClientOptions
      -> (XhrRequest b -> (a -> JSM ()) -> Performable m XMLHttpRequest)
      -> Event t (Performable m (f (Either Text (XhrRequest b)))) -> m (Event t (f (Either Text a)))
  performSomeRequestsAsync' opts newXhr req = performEventAsync $ ffor req $ \hrs cb -> do
    rs <- hrs
    resps <- forM rs $ \r -> case r of
        Left e -> do
            resp <- liftIO $ newMVar (Left e)
            return resp
        Right r' -> do
            resp <- liftIO newEmptyMVar
            r'' <- liftJSM $ (optsRequestFixup opts) r'
            _ <- newXhr r'' $ liftIO . putMVar resp . Right
            return resp
    _ <- liftIO $ forkIO $ cb =<< forM resps takeMVar
    return ()
  
  
  
  type XhrPayload = ByteString
  bytesToPayload :: BL.ByteString -> XhrPayload
  bytesToPayload = BL.toStrict
  
  
  performRequestsCT
      :: (SupportsServantReflex t m,
          MimeUnrender ct a, Traversable f)
      => Proxy ct
      -> Text
      -> Dynamic t (f (Req t))
      -> Dynamic t BaseUrl
      -> ClientOptions
      -> Event t tag
      -> m (Event t (f (ReqResult tag a)))
  performRequestsCT ct reqMeth reqs reqHost opts trigger = do
    resps <- performRequests reqMeth reqs reqHost opts trigger
    let decodeResp (Just (XhrResponseBody_ArrayBuffer x)) =
                       first T.pack .
                       mimeUnrender ct $
                       BL.fromStrict x
        decodeResp _ = Left "No body"
    return $ fmap
        (\(t,rs) -> ffor rs $ \r -> case r of
                Left e  -> RequestFailure t e
                Right g -> evalResponse (decodeResp . _xhrResponse_response) (t,g)
        )
        resps
  
  
  performRequestsNoBody
      :: (SupportsServantReflex t m,
          Traversable f)
      => Text
      -> Dynamic t (f (Req t))
      -> Dynamic t BaseUrl
      -> ClientOptions
      -> Event t tag
      -> m (Event t (f (ReqResult tag NoContent)))
  performRequestsNoBody reqMeth reqs reqHost opts trigger = do
    resps <- performRequests reqMeth reqs reqHost opts trigger
    let decodeResp = const $ Right NoContent
    return $ ffor resps $ \(tag,rs) -> ffor rs $ \r -> case r of
        Left e  -> RequestFailure tag e
        Right g -> evalResponse decodeResp (tag,g)
  
  
  ------------------------------------------------------------------------------
  evalResponse
      :: (XhrResponse -> Either Text a)
      -> (tag, XhrResponse)
      -> ReqResult tag a
  evalResponse decode (tag, xhr) =
      let status = _xhrResponse_status xhr
          okStatus = status >= 200 && status < 400
          errMsg = fromMaybe
              ("Empty response with error code " <>
                  T.pack (show $ _xhrResponse_status xhr))
              (_xhrResponse_responseText xhr)
          respPayld  = if okStatus
                       then either
                            (\e -> ResponseFailure tag e xhr)
                            (\v -> ResponseSuccess tag v xhr)
                            (decode xhr)
                       else ResponseFailure tag errMsg xhr
      in respPayld
  
  ------------------------------------------------------------------------------
  -- | Utility for simultaneously accessing/filtering Success and Failure
  -- response 'Event's,
  fanReqResult :: Reflex t => Event t (ReqResult tag a) -> (Event t Text, Event t a)
  fanReqResult = fmapMaybe reqFailure &&& fmapMaybe reqSuccess
  
  ------------------------------------------------------------------------------
  -- | Utility for simultaneously accessing/filtering Success and Failure
  -- response 'Event's, but keeping the request tag
  fanReqResult' :: Reflex t => Event t (ReqResult tag a) -> (Event t (tag, Text), Event t (tag, a))
  fanReqResult' = fmapMaybe reqFailure' &&& fmapMaybe reqSuccess'
  
  
  note :: e -> Maybe a -> Either e a
  note e = maybe (Left e) Right
  
  fmapL :: (e -> e') -> Either e a -> Either e' a
  fmapL _ (Right a) = Right a
  fmapL f (Left e)  = Left (f e)
  
  builderToText :: Builder.Builder -> T.Text
  builderToText = TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString
  
  escape :: T.Text -> T.Text
  escape = T.pack . N.escapeURIString (not . N.isReserved) . T.unpack . TE.decodeUtf8 . BL.toStrict . Builder.toLazyByteString . toEncodedUrlPiece
  