module Polysemy.Http.Request where

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

import Data.Time.Calendar (fromGregorian)
import Data.Time.Clock.POSIX (posixSecondsToUTCTime)
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 scheme :: Text
scheme url :: 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 target :: Text
target t :: Text
t =
  case Text -> Text -> (Text, Text)
Text.breakOn Text
target Text
t of
    (a :: Text
a, "") -> (Text
a, Maybe Text
forall a. Maybe a
Nothing)
    (a :: Text
a, b :: 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 url :: Text
url = \case
  (full :: Text
full, Nothing) -> (Tls, Text) -> Either Text (Tls, Text)
forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
True, Text
full)
  ("https", Just rest :: Text
rest) -> (Tls, Text) -> Either Text (Tls, Text)
forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
True, Text
rest)
  ("http", Just rest :: Text
rest) -> (Tls, Text) -> Either Text (Tls, Text)
forall a b. b -> Either a b
Right (Bool -> Tls
Tls Bool
False, Text
rest)
  (scheme :: Text
scheme, _) -> 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 url :: Text
url = \case
  (host :: Text
host, 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)
  (host :: 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 port :: 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))
  (_, Just port :: 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 url :: Text
url = do
  (tls :: Tls
tls, Text -> Text -> (Text, Maybe Text)
split "/" -> (hostPort :: Text
hostPort, path :: Maybe Text
path)) <- Text -> (Text, Maybe Text) -> Either Text (Tls, Text)
parseScheme Text
url (Text -> Text -> (Text, Maybe Text)
split "://" Text
url)
  (host :: Host
host, port :: Maybe Port
port) <- Text -> (Text, Maybe Text) -> Either Text (Host, Maybe Port)
parseHostPort Text
url (Text -> Text -> (Text, Maybe Text)
split ":" 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 "" 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 port :: Maybe Port
port tls :: Tls
tls method :: Method
method host :: Host
host path :: 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
host path :: Path
path =
  Method -> Host -> Path -> Body -> Request
simple Method
Get Host
host Path
path ""

-- |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
host path :: 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
host path :: 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
host path :: Path
path =
  Method -> Host -> Path -> Body -> Request
simple Method
Delete Host
host Path
path ""

-- |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
method body :: Body
body url :: Text
url = do
  (tls :: Tls
tls, host :: Host
host, port :: Maybe Port
port, path :: 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 ""

-- |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 ""

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

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

-- |Create a cookie with default values.
cookie ::
  Text ->
  Text ->
  Text ->
  Cookie
cookie :: Text -> Text -> Text -> Cookie
cookie domain :: Text
domain name :: Text
name value :: 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) "/" 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 cookies :: [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 domain :: Text
domain name :: Text
name value :: 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))