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))
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 []) []
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
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
host path :: Path
path =
Method -> Host -> Path -> Body -> Request
simple Method
Get Host
host Path
path ""
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
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
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 ""
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)
getUrl ::
Text ->
Either Text Request
getUrl :: Text -> Either Text Request
getUrl =
Method -> Body -> Text -> Either Text Request
fromUrl Method
Get ""
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 ""
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
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
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
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))