{-# options_haddock prune #-}
-- |Description: Request Combinators, Internal
module Polysemy.Http.Request where

import Control.Lens ((%~))
import qualified Data.Text as Text
import Data.Time (UTCTime (UTCTime))
import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
import Network.HTTP.Client (Cookie (Cookie))
import Network.HTTP.Client.Internal (CookieJar (CJ, expose))
import Prelude hiding (get, put)

import qualified Polysemy.Http.Data.Request as Request
import Polysemy.Http.Data.Request (Body, Host (Host), Method (..), Path (Path), Port (Port), Request (Request), Tls (Tls))

invalidScheme ::
  Text ->
  Text ->
  Either Text a
invalidScheme :: Text -> Text -> Either Text a
invalidScheme Text
scheme Text
url =
  Text -> Either Text a
forall a b. a -> Either a b
Left [qt|invalid scheme `#{scheme}` in url: #{url}|]

split ::
  Text ->
  Text ->
  (Text, Maybe Text)
split :: Text -> Text -> (Text, Maybe Text)
split Text
target Text
t =
  case Text -> Text -> (Text, Text)
Text.breakOn Text
target Text
t of
    (Text
a, Text
"") -> (Text
a, Maybe Text
forall a. Maybe a
Nothing)
    (Text
a, Text
b) -> (Text
a, Text -> Maybe Text
forall a. a -> Maybe a
Just (Int -> Text -> Text
Text.drop (Text -> Int
Text.length Text
target) Text
b))

parseScheme ::
  Text ->
  (Text, Maybe Text) ->
  Either Text (Tls, Text)
parseScheme :: Text -> (Text, Maybe Text) -> Either Text (Tls, Text)
parseScheme Text
url = \case
  (Text
full, Maybe Text
Nothing) -> (Tls, Text) -> Either Text (Tls, Text)
forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
True, Text
full)
  (Text
"https", Just Text
rest) -> (Tls, Text) -> Either Text (Tls, Text)
forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
True, Text
rest)
  (Text
"http", Just Text
rest) -> (Tls, Text) -> Either Text (Tls, Text)
forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
False, Text
rest)
  (Text
scheme, Maybe Text
_) -> Text -> Text -> Either Text (Tls, Text)
forall a. Text -> Text -> Either Text a
invalidScheme Text
scheme Text
url

parseHostPort ::
  Text ->
  (Text, Maybe Text) ->
  Either Text (Host, Maybe Port)
parseHostPort :: Text -> (Text, Maybe Text) -> Either Text (Host, Maybe Port)
parseHostPort Text
url = \case
  (Text
host, Maybe Text
Nothing) -> (Host, Maybe Port) -> Either Text (Host, Maybe Port)
forall a b. b -> Either a b
Right (Text -> Host
Host Text
host, Maybe Port
forall a. Maybe a
Nothing)
  (Text
host, Just (String -> Maybe Int
forall a. Read a => String -> Maybe a
readMaybe (String -> Maybe Int) -> (Text -> String) -> Text -> Maybe Int
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Text -> String
forall a. ToString a => a -> String
toString -> Just Int
port)) -> (Host, Maybe Port) -> Either Text (Host, Maybe Port)
forall a b. b -> Either a b
Right (Text -> Host
Host Text
host, Port -> Maybe Port
forall a. a -> Maybe a
Just (Int -> Port
Port Int
port))
  (Text
_, Just Text
port) -> Text -> Either Text (Host, Maybe Port)
forall a b. a -> Either a b
Left [qt|invalid port `#{port}` in url: #{url}|]

parseUrl ::
  Text ->
  Either Text (Tls, Host, Maybe Port, Path)
parseUrl :: Text -> Either Text (Tls, Host, Maybe Port, Path)
parseUrl Text
url = do
  (Tls
tls, Text -> Text -> (Text, Maybe Text)
split Text
"/" -> (Text
hostPort, Maybe Text
path)) <- Text -> (Text, Maybe Text) -> Either Text (Tls, Text)
parseScheme Text
url (Text -> Text -> (Text, Maybe Text)
split Text
"://" Text
url)
  (Host
host, Maybe Port
port) <- Text -> (Text, Maybe Text) -> Either Text (Host, Maybe Port)
parseHostPort Text
url (Text -> Text -> (Text, Maybe Text)
split Text
":" Text
hostPort)
  (Tls, Host, Maybe Port, Path)
-> Either Text (Tls, Host, Maybe Port, Path)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tls
tls, Host
host, Maybe Port
port, Text -> Path
Path (Text -> Maybe Text -> Text
forall a. a -> Maybe a -> a
fromMaybe Text
"" Maybe Text
path))

-- |Create a request with empty headers, query and cookies.
withPort ::
  Maybe Port ->
  Tls ->
  Method ->
  Host ->
  Path ->
  Body ->
  Request
withPort :: Maybe Port -> Tls -> Method -> Host -> Path -> Body -> Request
withPort Maybe Port
port Tls
tls Method
method Host
host Path
path =
  Method
-> Host
-> Maybe Port
-> Tls
-> Path
-> [(HeaderName, HeaderValue)]
-> CookieJar
-> [(QueryKey, Maybe QueryValue)]
-> Body
-> Request
Request Method
method Host
host Maybe Port
port Tls
tls Path
path [] ([Cookie] -> CookieJar
CJ []) []

-- |Create a request with default port and empty headers, query and cookies.
withTls ::
  Tls ->
  Method ->
  Host ->
  Path ->
  Body ->
  Request
withTls :: Tls -> Method -> Host -> Path -> Body -> Request
withTls =
  Maybe Port -> Tls -> Method -> Host -> Path -> Body -> Request
withPort Maybe Port
forall a. Maybe a
Nothing

-- |Create a TLS request with default port and empty headers, query and cookies.
simple ::
  Method ->
  Host ->
  Path ->
  Body ->
  Request
simple :: Method -> Host -> Path -> Body -> Request
simple =
  Tls -> Method -> Host -> Path -> Body -> Request
withTls (Bool -> Tls
Tls Bool
True)

-- |Create a TLS GET request with default port and empty headers, query and cookies.
get ::
  Host ->
  Path ->
  Request
get :: Host -> Path -> Request
get Host
host Path
path =
  Method -> Host -> Path -> Body -> Request
simple Method
Get Host
host Path
path Body
""

-- |Create a TLS POST request with default port and empty headers, query and cookies.
post ::
  Host ->
  Path ->
  Body ->
  Request
post :: Host -> Path -> Body -> Request
post Host
host Path
path =
  Method -> Host -> Path -> Body -> Request
simple Method
Post Host
host Path
path

-- |Create a TLS PUT request with default port and empty headers, query and cookies.
put ::
  Host ->
  Path ->
  Body ->
  Request
put :: Host -> Path -> Body -> Request
put Host
host Path
path =
  Method -> Host -> Path -> Body -> Request
simple Method
Put Host
host Path
path

-- |Create a TLS DELETE request with default port and empty headers, query and cookies.
delete ::
  Host ->
  Path ->
  Request
delete :: Host -> Path -> Request
delete Host
host Path
path =
  Method -> Host -> Path -> Body -> Request
simple Method
Delete Host
host Path
path Body
""

-- |Parse the URL and create a request or return a parse error.
fromUrl ::
  Method ->
  Body ->
  Text ->
  Either Text Request
fromUrl :: Method -> Body -> Text -> Either Text Request
fromUrl Method
method Body
body Text
url = do
  (Tls
tls, Host
host, Maybe Port
port, Path
path) <- Text -> Either Text (Tls, Host, Maybe Port, Path)
parseUrl Text
url
  Request -> Either Text Request
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe Port -> Tls -> Method -> Host -> Path -> Body -> Request
withPort Maybe Port
port Tls
tls Method
method Host
host Path
path Body
body)

-- |Parse URL for a GET.
getUrl ::
  Text ->
  Either Text Request
getUrl :: Text -> Either Text Request
getUrl =
  Method -> Body -> Text -> Either Text Request
fromUrl Method
Get Body
""

-- |Parse URL for a POST.
postUrl ::
  Body ->
  Text ->
  Either Text Request
postUrl :: Body -> Text -> Either Text Request
postUrl =
  Method -> Body -> Text -> Either Text Request
fromUrl Method
Post

-- |Parse URL for a PUT.
putUrl ::
  Body ->
  Text ->
  Either Text Request
putUrl :: Body -> Text -> Either Text Request
putUrl =
  Method -> Body -> Text -> Either Text Request
fromUrl Method
Put

-- |Parse URL for a DELETE.
deleteUrl ::
  Text ->
  Either Text Request
deleteUrl :: Text -> Either Text Request
deleteUrl =
  Method -> Body -> Text -> Either Text Request
fromUrl Method
Delete Body
""

neverExpire :: UTCTime
neverExpire :: UTCTime
neverExpire =
  Day -> DiffTime -> UTCTime
UTCTime (Integer -> Int -> Int -> Day
fromGregorian Integer
9999 Int
1 Int
1) DiffTime
0

epoch :: UTCTime
epoch :: UTCTime
epoch =
  POSIXTime -> UTCTime
posixSecondsToUTCTime POSIXTime
0

-- |Create a cookie with default values.
cookie ::
  Text ->
  Text ->
  Text ->
  Cookie
cookie :: Text -> Text -> Text -> Cookie
cookie Text
domain Text
name Text
value =
  ByteString
-> ByteString
-> UTCTime
-> ByteString
-> ByteString
-> UTCTime
-> UTCTime
-> Bool
-> Bool
-> Bool
-> Bool
-> Cookie
Cookie (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
name) (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
value) UTCTime
neverExpire (Text -> ByteString
forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
domain) ByteString
"/" UTCTime
epoch UTCTime
epoch Bool
False Bool
False Bool
False Bool
False

-- |Add multiple cookies to a request.
addCookies ::
  [Cookie] ->
  Request ->
  Request
addCookies :: [Cookie] -> Request -> Request
addCookies [Cookie]
cookies =
  (CookieJar -> Identity CookieJar) -> Request -> Identity Request
forall c. HasRequest c => Lens' c CookieJar
Request.cookies ((CookieJar -> Identity CookieJar) -> Request -> Identity Request)
-> (CookieJar -> CookieJar) -> Request -> Request
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
%~ CookieJar -> CookieJar
update
  where
    update :: CookieJar -> CookieJar
update =
      [Cookie] -> CookieJar
CJ ([Cookie] -> CookieJar)
-> (CookieJar -> [Cookie]) -> CookieJar -> CookieJar
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Cookie]
cookies [Cookie] -> [Cookie] -> [Cookie]
forall a. Semigroup a => a -> a -> a
<>) ([Cookie] -> [Cookie])
-> (CookieJar -> [Cookie]) -> CookieJar -> [Cookie]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CookieJar -> [Cookie]
expose

-- |Add a cookie to a request, using default values.
addCookie ::
  Text ->
  Text ->
  Text ->
  Request ->
  Request
addCookie :: Text -> Text -> Text -> Request -> Request
addCookie Text
domain Text
name Text
value =
  [Cookie] -> Request -> Request
addCookies (Cookie -> [Cookie]
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Text -> Cookie
cookie Text
domain Text
name Text
value))