{-# options_haddock prune #-}

-- |Description: Request Combinators, Internal
module Polysemy.Http.Request where

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

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

invalidScheme ::
  Text ->
  Text ->
  Either Text a
invalidScheme :: forall a. Text -> Text -> Either Text a
invalidScheme Text
scheme Text
url =
  forall a b. a -> Either a b
Left [exon|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, forall a. Maybe a
Nothing)
    (Text
a, Text
b) -> (Text
a, 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) -> forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
True, Text
full)
  (Text
"https", Just Text
rest) -> forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
True, Text
rest)
  (Text
"http", Just Text
rest) -> forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
False, Text
rest)
  (Text
scheme, Maybe 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) -> forall a b. b -> Either a b
Right (Text -> Host
Host Text
host, forall a. Maybe a
Nothing)
  (Text
host, Just (forall a. Read a => String -> Maybe a
readMaybe forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ToString a => a -> String
toString -> Just Int
port)) -> forall a b. b -> Either a b
Right (Text -> Host
Host Text
host, forall a. a -> Maybe a
Just (Int -> Port
Port Int
port))
  (Text
_, Just Text
port) -> forall a b. a -> Either a b
Left [exon|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)
  forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tls
tls, Host
host, Maybe Port
port, Text -> Path
Path (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 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
  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 (Year -> Int -> Int -> Day
fromGregorian Year
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 (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
name) (forall a b. ConvertUtf8 a b => a -> b
encodeUtf8 Text
value) UTCTime
neverExpire (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 =
  #cookies %~ update
  where
    update :: CookieJar -> CookieJar
update =
      [Cookie] -> CookieJar
CJ forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Cookie]
cookies <>) 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure (Text -> Text -> Text -> Cookie
cookie Text
domain Text
name Text
value))