{-# options_haddock prune #-}
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))
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 []) []
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
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)
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
""
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
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
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
""
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)
getUrl ::
Text ->
Either Text Request
getUrl :: Text -> Either Text Request
getUrl =
Method -> Body -> Text -> Either Text Request
fromUrl Method
Get Body
""
postUrl ::
Body ->
Text ->
Either Text Request
postUrl :: Body -> Text -> Either Text Request
postUrl =
Method -> Body -> Text -> Either Text Request
fromUrl Method
Post
putUrl ::
Body ->
Text ->
Either Text Request
putUrl :: Body -> Text -> Either Text Request
putUrl =
Method -> Body -> Text -> Either Text Request
fromUrl Method
Put
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
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
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
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))