{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE StrictData #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UndecidableInstances #-}
module Web.Telegraph.API
(
AccountInfo (..),
TS (..),
Telegraph (..),
Http (..),
Telegraph',
Http',
runTelegraph,
runTelegraph',
editAccountInfo,
getAccountInfo,
revokeAccessToken,
createPage,
editPage,
getPageList,
createAccount,
getAccountInfo',
getPage,
getTotalViews,
uploadImageFromFile,
uploadImageFromFiles,
ImgStream (..),
uploadImageStreaming,
uploadImagesStreaming,
uploadParts,
TelegraphToIOC,
TelegraphC,
HttpC,
TelegraphH,
HttpH,
telegraph,
http,
)
where
import Conduit
( ConduitT,
sourceHandle,
)
import Control.Concurrent
import Control.Effect
import Control.Effect.Bracket
import Control.Effect.Error
import Control.Effect.Reader
import Control.Effect.Telegraph
import Control.Monad.Cont
import Data.Aeson (FromJSON, ToJSON, eitherDecode, encode, object, (.=))
import Data.Aeson.TH
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text, pack, unpack)
import Network.HTTP.Client (HttpException, Manager, Request (..), RequestBody (..), Response (..), parseRequest_)
import Network.HTTP.Client.Conduit (requestBodySourceChunked)
import Network.HTTP.Client.MultipartFormData
import Optics.TH
import System.IO
import Web.Telegraph.Types hiding (error)
import Web.Telegraph.Utils
data AccountInfo = AccountInfo
{ AccountInfo -> Text
shortName :: {-# UNPACK #-} Text,
AccountInfo -> Text
authorName :: {-# UNPACK #-} Text,
AccountInfo -> Text
authorUrl :: {-# UNPACK #-} Text
}
deriving (Int -> AccountInfo -> ShowS
[AccountInfo] -> ShowS
AccountInfo -> String
(Int -> AccountInfo -> ShowS)
-> (AccountInfo -> String)
-> ([AccountInfo] -> ShowS)
-> Show AccountInfo
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [AccountInfo] -> ShowS
$cshowList :: [AccountInfo] -> ShowS
show :: AccountInfo -> String
$cshow :: AccountInfo -> String
showsPrec :: Int -> AccountInfo -> ShowS
$cshowsPrec :: Int -> AccountInfo -> ShowS
Show, AccountInfo -> AccountInfo -> Bool
(AccountInfo -> AccountInfo -> Bool)
-> (AccountInfo -> AccountInfo -> Bool) -> Eq AccountInfo
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AccountInfo -> AccountInfo -> Bool
$c/= :: AccountInfo -> AccountInfo -> Bool
== :: AccountInfo -> AccountInfo -> Bool
$c== :: AccountInfo -> AccountInfo -> Bool
Eq)
createAccount :: Eff Http' m => AccountInfo -> m (Result Account)
createAccount :: AccountInfo -> m (Result Account)
createAccount !AccountInfo
a = String -> AccountInfo -> m (Result Account)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/createAccount" AccountInfo
a
{-# INLINEABLE createAccount #-}
editAccountInfo :: (Effs '[Telegraph', Bracket, Throw TelegraphError] m) => AccountInfo -> m ()
editAccountInfo :: AccountInfo -> m ()
editAccountInfo AccountInfo {Text
authorUrl :: Text
authorName :: Text
shortName :: Text
$sel:authorUrl:AccountInfo :: AccountInfo -> Text
$sel:authorName:AccountInfo :: AccountInfo -> Text
$sel:shortName:AccountInfo :: AccountInfo -> Text
..} =
m TS -> (TS -> m ()) -> (TS -> m ()) -> m ()
forall (m :: Type -> Type) a c b.
Eff Bracket m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracketOnError
m TS
forall (m :: Type -> Type). Eff Telegraph m => m TS
takeTS
TS -> m ()
forall (m :: Type -> Type). Eff Telegraph m => TS -> m ()
putTS
((TS -> m ()) -> m ()) -> (TS -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \t :: TS
t@TS {Text
$sel:accessToken:TS :: TS -> Text
accessToken :: Text
accessToken} -> do
let o :: Value
o =
[Pair] -> Value
object
[ Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
accessToken,
Text
"short_name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
shortName,
Text
"author_name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
authorName,
Text
"author_url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
authorUrl
]
Result Account
r <- String -> Value -> m (Result Account)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/editAccountInfo" Value
o
case Result Account
r of
Error Text
e -> do
TS -> m ()
forall (m :: Type -> Type). Eff Telegraph m => TS -> m ()
putTS TS
t
TelegraphError -> m ()
forall e (m :: Type -> Type) a. Eff (Throw e) m => e -> m a
throw (TelegraphError -> m ()) -> TelegraphError -> m ()
forall a b. (a -> b) -> a -> b
$ Text -> TelegraphError
APICallFailure Text
e
Result Account {} -> do
let t' :: TS
t' = TS :: Text -> Text -> Text -> Text -> TS
TS {Text
$sel:authorUrl:TS :: Text
$sel:authorName:TS :: Text
$sel:shortName:TS :: Text
$sel:accessToken:TS :: Text
accessToken :: Text
authorUrl :: Text
authorName :: Text
shortName :: Text
..}
TS -> m ()
forall (m :: Type -> Type). Eff Telegraph m => TS -> m ()
putTS TS
t'
{-# INLINEABLE editAccountInfo #-}
getAccountInfo :: Effs '[Telegraph', Throw TelegraphError] m => m Account
getAccountInfo :: m Account
getAccountInfo = do
TS {Text
accessToken :: Text
$sel:accessToken:TS :: TS -> Text
accessToken} <- m TS
forall (m :: Type -> Type). Eff Telegraph m => m TS
readTS
Result Account -> m Account
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result Account -> m Account) -> m (Result Account) -> m Account
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> m (Result Account)
forall (m :: Type -> Type).
Eff Http' m =>
Text -> m (Result Account)
getAccountInfo' Text
accessToken
{-# INLINEABLE getAccountInfo #-}
getAccountInfo' :: Eff Http' m => Text -> m (Result Account)
getAccountInfo' :: Text -> m (Result Account)
getAccountInfo' Text
accessToken = String -> Value -> m (Result Account)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/getAccountInfo" Value
o
where
fields :: [Text]
fields :: [Text]
fields = [Text
"short_name", Text
"author_name", Text
"author_url", Text
"auth_url", Text
"page_count"]
o :: Value
o =
[Pair] -> Value
object
[ Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
accessToken,
Text
"fields" Text -> [Text] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Text]
fields
]
{-# INLINEABLE getAccountInfo' #-}
revokeAccessToken :: (Effs '[Telegraph', Bracket, Error TelegraphError] m) => m Account
revokeAccessToken :: m Account
revokeAccessToken =
m TS -> (TS -> m ()) -> (TS -> m Account) -> m Account
forall (m :: Type -> Type) a c b.
Eff Bracket m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracketOnError
m TS
forall (m :: Type -> Type). Eff Telegraph m => m TS
takeTS
TS -> m ()
forall (m :: Type -> Type). Eff Telegraph m => TS -> m ()
putTS
((TS -> m Account) -> m Account) -> (TS -> m Account) -> m Account
forall a b. (a -> b) -> a -> b
$ \TS {Text
authorUrl :: Text
authorName :: Text
shortName :: Text
accessToken :: Text
$sel:authorUrl:TS :: TS -> Text
$sel:authorName:TS :: TS -> Text
$sel:shortName:TS :: TS -> Text
$sel:accessToken:TS :: TS -> Text
..} -> do
let o :: Value
o = [Pair] -> Value
object [Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
accessToken]
a :: Account
a@Account {$sel:accessToken:Account :: Account -> Maybe Text
accessToken = Maybe Text
accessToken'} <- Result Account -> m Account
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result Account -> m Account) -> m (Result Account) -> m Account
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Value -> m (Result Account)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/revokeAccessToken" Value
o
let t' :: TS
t' = TS :: Text -> Text -> Text -> Text -> TS
TS {$sel:accessToken:TS :: Text
accessToken = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
accessToken', Text
authorUrl :: Text
authorName :: Text
shortName :: Text
$sel:authorUrl:TS :: Text
$sel:authorName:TS :: Text
$sel:shortName:TS :: Text
..}
TS -> m ()
forall (m :: Type -> Type). Eff Telegraph m => TS -> m ()
putTS TS
t'
Account -> m Account
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure Account
a
{-# INLINEABLE revokeAccessToken #-}
data CreatePage = CreatePage
{ CreatePage -> Text
accessToken :: {-# UNPACK #-} Text,
CreatePage -> Text
title :: {-# UNPACK #-} Text,
CreatePage -> Maybe Text
authorName :: Maybe Text,
CreatePage -> Maybe Text
authorUrl :: Maybe Text,
CreatePage -> [Node]
content :: [Node],
CreatePage -> Bool
returnContent :: Bool
}
deriving (Int -> CreatePage -> ShowS
[CreatePage] -> ShowS
CreatePage -> String
(Int -> CreatePage -> ShowS)
-> (CreatePage -> String)
-> ([CreatePage] -> ShowS)
-> Show CreatePage
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [CreatePage] -> ShowS
$cshowList :: [CreatePage] -> ShowS
show :: CreatePage -> String
$cshow :: CreatePage -> String
showsPrec :: Int -> CreatePage -> ShowS
$cshowsPrec :: Int -> CreatePage -> ShowS
Show, CreatePage -> CreatePage -> Bool
(CreatePage -> CreatePage -> Bool)
-> (CreatePage -> CreatePage -> Bool) -> Eq CreatePage
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: CreatePage -> CreatePage -> Bool
$c/= :: CreatePage -> CreatePage -> Bool
== :: CreatePage -> CreatePage -> Bool
$c== :: CreatePage -> CreatePage -> Bool
Eq)
createPage ::
(Effs '[Telegraph', Error TelegraphError] m) =>
Text ->
[Node] ->
m Page
createPage :: Text -> [Node] -> m Page
createPage Text
title [Node]
content = do
TS {Text
authorUrl :: Text
authorName :: Text
shortName :: Text
accessToken :: Text
$sel:authorUrl:TS :: TS -> Text
$sel:authorName:TS :: TS -> Text
$sel:shortName:TS :: TS -> Text
$sel:accessToken:TS :: TS -> Text
..} <- m TS
forall (m :: Type -> Type). Eff Telegraph m => m TS
readTS
let o :: Value
o =
[Pair] -> Value
object
[ Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
accessToken,
Text
"title" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
title,
Text
"author_name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
authorName,
Text
"author_url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
authorUrl,
Text
"content" Text -> [Node] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Node]
content
]
Result Page -> m Page
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result Page -> m Page) -> m (Result Page) -> m Page
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Value -> m (Result Page)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/createPage" Value
o
{-# INLINEABLE createPage #-}
editPage ::
(Effs '[Telegraph', Throw TelegraphError] m) =>
Text ->
Text ->
[Node] ->
m Page
editPage :: Text -> Text -> [Node] -> m Page
editPage Text
path Text
title [Node]
content = do
TS {Text
authorUrl :: Text
authorName :: Text
shortName :: Text
accessToken :: Text
$sel:authorUrl:TS :: TS -> Text
$sel:authorName:TS :: TS -> Text
$sel:shortName:TS :: TS -> Text
$sel:accessToken:TS :: TS -> Text
..} <- m TS
forall (m :: Type -> Type). Eff Telegraph m => m TS
readTS
let o :: Value
o =
[Pair] -> Value
object
[ Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
accessToken,
Text
"path" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
path,
Text
"title" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
title,
Text
"author_name" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
authorName,
Text
"author_url" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
authorUrl,
Text
"content" Text -> [Node] -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= [Node]
content
]
Result Page -> m Page
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result Page -> m Page) -> m (Result Page) -> m Page
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Value -> m (Result Page)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/editPage" Value
o
{-# INLINEABLE editPage #-}
getPage :: Eff Http' m => Text -> m (Result Page)
getPage :: Text -> m (Result Page)
getPage Text
path = do
let o :: Value
o =
[Pair] -> Value
object
[ Text
"path" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
path,
Text
"return_content" Text -> Bool -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Bool
True
]
String -> Value -> m (Result Page)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/getPage" Value
o
{-# INLINEABLE getPage #-}
getPageList ::
(Effs '[Telegraph', Throw TelegraphError] m) =>
Int ->
Int ->
m PageList
getPageList :: Int -> Int -> m PageList
getPageList Int
offset Int
limit = do
TS {Text
authorUrl :: Text
authorName :: Text
shortName :: Text
accessToken :: Text
$sel:authorUrl:TS :: TS -> Text
$sel:authorName:TS :: TS -> Text
$sel:shortName:TS :: TS -> Text
$sel:accessToken:TS :: TS -> Text
..} <- m TS
forall (m :: Type -> Type). Eff Telegraph m => m TS
readTS
let o :: Value
o =
[Pair] -> Value
object
[ Text
"access_token" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
accessToken,
Text
"offset" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
offset,
Text
"limit" Text -> Int -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Int
limit
]
Result PageList -> m PageList
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result PageList -> m PageList)
-> m (Result PageList) -> m PageList
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< String -> Value -> m (Result PageList)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/getPageList" Value
o
{-# INLINEABLE getPageList #-}
getTotalViews :: Eff Http' m => Text -> m (Result PageViews)
getTotalViews :: Text -> m (Result PageViews)
getTotalViews Text
path = String -> Value -> m (Result PageViews)
forall a b (m :: Type -> Type).
(ToJSON a, FromJSON b, Eff Http' m) =>
String -> a -> m b
postAeson String
"https://api.telegra.ph/getViews" Value
o
where
o :: Value
o = [Pair] -> Value
object [Text
"path" Text -> Text -> Pair
forall kv v. (KeyValue kv, ToJSON v) => Text -> v -> kv
.= Text
path]
{-# INLINEABLE getTotalViews #-}
uploadParts :: Eff Telegraph' m => [PartM m] -> m UploadResult
uploadParts :: [PartM m] -> m UploadResult
uploadParts [PartM m]
parts = do
let initReq :: Request
initReq = String -> Request
parseRequest_ String
"POST https://telegra.ph/upload"
ByteString
boundary <- m ByteString
forall (m :: Type -> Type). Eff Http m => m ByteString
genBoundary
Request
req <- ByteString -> [PartM m] -> Request -> m Request
forall (m :: Type -> Type).
Applicative m =>
ByteString -> [PartM m] -> Request -> m Request
formDataBodyWithBoundary ByteString
boundary [PartM m]
parts Request
initReq
Response ByteString
resp <- Request -> m (Response ByteString)
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
Request -> m (Response ByteString)
httpLbs Request
req
case ByteString -> Either String UploadResult
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp) of
Left String
e -> String -> m UploadResult
forall a. HasCallStack => String -> a
error (String
"impossible: json decode failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
Right UploadResult
r -> UploadResult -> m UploadResult
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure UploadResult
r
{-# INLINEABLE uploadParts #-}
uploadImageFromFile :: (Effs '[Telegraph', Bracket, Embed IO] m) => FilePath -> m UploadResult
uploadImageFromFile :: String -> m UploadResult
uploadImageFromFile String
fp =
ContT UploadResult m UploadResult -> m UploadResult
forall (m :: Type -> Type) r. Applicative m => ContT r m r -> m r
evalContT (ContT UploadResult m UploadResult -> m UploadResult)
-> ContT UploadResult m UploadResult -> m UploadResult
forall a b. (a -> b) -> a -> b
$ do
ConduitT () ByteString IO ()
src <- String -> ContT UploadResult m (ConduitT () ByteString IO ())
forall (m :: Type -> Type) (n :: Type -> Type) r i.
(Effs '[Embed IO, Bracket] m, MonadIO n) =>
String -> ContT r m (ConduitT i ByteString n ())
withSourceFile String
fp
let body :: RequestBody
body = ConduitT () ByteString IO () -> RequestBody
requestBodySourceChunked ConduitT () ByteString IO ()
src
part :: PartM m
part = Text -> String -> RequestBody -> PartM m
forall (m :: Type -> Type).
Applicative m =>
Text -> String -> RequestBody -> PartM m
partFileRequestBody Text
"file" String
fp RequestBody
body
m UploadResult -> ContT UploadResult m UploadResult
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m UploadResult -> ContT UploadResult m UploadResult)
-> m UploadResult -> ContT UploadResult m UploadResult
forall a b. (a -> b) -> a -> b
$ [PartM m] -> m UploadResult
forall (m :: Type -> Type).
Eff Telegraph' m =>
[PartM m] -> m UploadResult
uploadParts [PartM m
part]
{-# INLINEABLE uploadImageFromFile #-}
uploadImageFromFiles :: (Effs '[Telegraph', Bracket, Embed IO] m) => [FilePath] -> m UploadResult
uploadImageFromFiles :: [String] -> m UploadResult
uploadImageFromFiles [String]
fps =
ContT UploadResult m UploadResult -> m UploadResult
forall (m :: Type -> Type) r. Applicative m => ContT r m r -> m r
evalContT (ContT UploadResult m UploadResult -> m UploadResult)
-> ContT UploadResult m UploadResult -> m UploadResult
forall a b. (a -> b) -> a -> b
$ do
[ConduitT () ByteString IO ()]
srcs <- (String -> ContT UploadResult m (ConduitT () ByteString IO ()))
-> [String] -> ContT UploadResult m [ConduitT () ByteString IO ()]
forall (t :: Type -> Type) (f :: Type -> Type) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse String -> ContT UploadResult m (ConduitT () ByteString IO ())
forall (m :: Type -> Type) (n :: Type -> Type) r i.
(Effs '[Embed IO, Bracket] m, MonadIO n) =>
String -> ContT r m (ConduitT i ByteString n ())
withSourceFile [String]
fps
let bodies :: [RequestBody]
bodies = (ConduitT () ByteString IO () -> RequestBody)
-> [ConduitT () ByteString IO ()] -> [RequestBody]
forall a b. (a -> b) -> [a] -> [b]
map ConduitT () ByteString IO () -> RequestBody
requestBodySourceChunked [ConduitT () ByteString IO ()]
srcs
parts :: [PartM m]
parts = (String -> RequestBody -> PartM m)
-> [String] -> [RequestBody] -> [PartM m]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\String
fp -> Text -> String -> RequestBody -> PartM m
forall (m :: Type -> Type).
Applicative m =>
Text -> String -> RequestBody -> PartM m
partFileRequestBody (String -> Text
pack String
fp) String
fp) [String]
fps [RequestBody]
bodies
m UploadResult -> ContT UploadResult m UploadResult
forall (t :: (Type -> Type) -> Type -> Type) (m :: Type -> Type) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m UploadResult -> ContT UploadResult m UploadResult)
-> m UploadResult -> ContT UploadResult m UploadResult
forall a b. (a -> b) -> a -> b
$ [PartM m] -> m UploadResult
forall (m :: Type -> Type).
Eff Telegraph' m =>
[PartM m] -> m UploadResult
uploadParts [PartM m]
parts
{-# INLINEABLE uploadImageFromFiles #-}
data ImgStream = ImgStream
{
ImgStream -> Text
name :: {-# UNPACK #-} Text,
ImgStream
-> forall i (n :: Type -> Type).
MonadIO n =>
ConduitT i ByteString n ()
stream :: forall i n. MonadIO n => ConduitT i ByteString n ()
}
imgStream2Part :: Applicative m => ImgStream -> PartM m
imgStream2Part :: ImgStream -> PartM m
imgStream2Part ImgStream {Text
forall i (n :: Type -> Type).
MonadIO n =>
ConduitT i ByteString n ()
stream :: forall i (n :: Type -> Type).
MonadIO n =>
ConduitT i ByteString n ()
name :: Text
$sel:stream:ImgStream :: ImgStream
-> forall i (n :: Type -> Type).
MonadIO n =>
ConduitT i ByteString n ()
$sel:name:ImgStream :: ImgStream -> Text
..} = Text -> String -> RequestBody -> PartM m
forall (m :: Type -> Type).
Applicative m =>
Text -> String -> RequestBody -> PartM m
partFileRequestBody Text
name (Text -> String
unpack Text
name) RequestBody
body
where
body :: RequestBody
body = ConduitT () ByteString IO () -> RequestBody
requestBodySourceChunked ConduitT () ByteString IO ()
forall i (n :: Type -> Type).
MonadIO n =>
ConduitT i ByteString n ()
stream
uploadImageStreaming :: Eff Telegraph' m => ImgStream -> m UploadResult
uploadImageStreaming :: ImgStream -> m UploadResult
uploadImageStreaming ImgStream
imgs = [PartM m] -> m UploadResult
forall (m :: Type -> Type).
Eff Telegraph' m =>
[PartM m] -> m UploadResult
uploadParts [ImgStream -> PartM m
forall (m :: Type -> Type). Applicative m => ImgStream -> PartM m
imgStream2Part ImgStream
imgs]
{-# INLINEABLE uploadImageStreaming #-}
uploadImagesStreaming :: Eff Telegraph' m => [ImgStream] -> m UploadResult
uploadImagesStreaming :: [ImgStream] -> m UploadResult
uploadImagesStreaming [ImgStream]
imgss = [PartM m] -> m UploadResult
forall (m :: Type -> Type).
Eff Telegraph' m =>
[PartM m] -> m UploadResult
uploadParts ([PartM m] -> m UploadResult) -> [PartM m] -> m UploadResult
forall a b. (a -> b) -> a -> b
$ (ImgStream -> PartM m) -> [ImgStream] -> [PartM m]
forall a b. (a -> b) -> [a] -> [b]
map ImgStream -> PartM m
forall (m :: Type -> Type). Applicative m => ImgStream -> PartM m
imgStream2Part [ImgStream]
imgss
{-# INLINEABLE uploadImagesStreaming #-}
postAeson :: (ToJSON a, FromJSON b, Eff Http' m) => String -> a -> m b
postAeson :: String -> a -> m b
postAeson String
url a
c = do
let req :: Request
req =
(String -> Request
parseRequest_ String
url)
{ method :: ByteString
method = ByteString
"POST",
requestBody :: RequestBody
requestBody = ByteString -> RequestBody
RequestBodyLBS (ByteString -> RequestBody) -> ByteString -> RequestBody
forall a b. (a -> b) -> a -> b
$ a -> ByteString
forall a. ToJSON a => a -> ByteString
encode a
c,
requestHeaders :: RequestHeaders
requestHeaders =
[ (HeaderName
"content-type", ByteString
"application/json"),
(HeaderName
"accept", ByteString
"application/json")
]
}
Response ByteString
resp <- Request -> m (Response ByteString)
forall (m :: Type -> Type).
Effs '[Http, Error HttpException] m =>
Request -> m (Response ByteString)
httpLbs Request
req
case ByteString -> Either String b
forall a. FromJSON a => ByteString -> Either String a
eitherDecode (Response ByteString -> ByteString
forall body. Response body -> body
responseBody Response ByteString
resp) of
Left String
e -> String -> m b
forall a. HasCallStack => String -> a
error (String
"impossible: json decode failure: " String -> ShowS
forall a. [a] -> [a] -> [a]
++ String
e)
Right b
r -> b -> m b
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure b
r
{-# INLINE postAeson #-}
type TelegraphToIOC =
CompositionC
'[ TelegraphC,
ReaderC (MVar TS),
HttpC
]
runTelegraph ::
(Effs '[Embed IO, Reader Manager, Error HttpException, Throw TelegraphError] m, Threaders '[ReaderThreads] m p) =>
Text ->
TelegraphToIOC m a ->
m a
runTelegraph :: Text -> TelegraphToIOC m a -> m a
runTelegraph Text
accessToken TelegraphToIOC m a
m =
HttpC m a -> m a
forall (m :: Type -> Type) a.
Effs '[Embed IO, Reader Manager] m =>
HttpC m a -> m a
http (HttpC m a -> m a) -> HttpC m a -> m a
forall a b. (a -> b) -> a -> b
$ do
Account {Text
$sel:shortName:Account :: Account -> Text
shortName :: Text
shortName, Text
$sel:authorName:Account :: Account -> Text
authorName :: Text
authorName, Text
$sel:authorUrl:Account :: Account -> Text
authorUrl :: Text
authorUrl} <- Result Account -> InterpretC HttpH Http m Account
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result Account -> InterpretC HttpH Http m Account)
-> InterpretC HttpH Http m (Result Account)
-> InterpretC HttpH Http m Account
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< Text -> InterpretC HttpH Http m (Result Account)
forall (m :: Type -> Type).
Eff Http' m =>
Text -> m (Result Account)
getAccountInfo' Text
accessToken
MVar TS
ref <- IO (MVar TS) -> InterpretC HttpH Http m (MVar TS)
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO (MVar TS) -> InterpretC HttpH Http m (MVar TS))
-> IO (MVar TS) -> InterpretC HttpH Http m (MVar TS)
forall a b. (a -> b) -> a -> b
$ TS -> IO (MVar TS)
forall a. a -> IO (MVar a)
newMVar TS :: Text -> Text -> Text -> Text -> TS
TS {Text
authorUrl :: Text
authorName :: Text
shortName :: Text
accessToken :: Text
$sel:authorUrl:TS :: Text
$sel:authorName:TS :: Text
$sel:shortName:TS :: Text
$sel:accessToken:TS :: Text
..}
MVar TS
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a -> HttpC m a
forall i (m :: Type -> Type) a
(p :: [(Type -> Type) -> Type -> Type]).
(Carrier m, Threaders '[ReaderThreads] m p) =>
i -> ReaderC i m a -> m a
runReader MVar TS
ref (ReaderC (MVar TS) (InterpretC HttpH Http m) a -> HttpC m a)
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a -> HttpC m a
forall a b. (a -> b) -> a -> b
$ TelegraphC (ReaderC (MVar TS) (InterpretC HttpH Http m)) a
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a
forall (m :: Type -> Type) a.
Effs '[Embed IO, Reader (MVar TS)] m =>
TelegraphC m a -> m a
telegraph (TelegraphC (ReaderC (MVar TS) (InterpretC HttpH Http m)) a
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a)
-> TelegraphC (ReaderC (MVar TS) (InterpretC HttpH Http m)) a
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a
forall a b. (a -> b) -> a -> b
$ TelegraphToIOC m a
-> CompositionBaseM '[TelegraphC, ReaderC (MVar TS), HttpC] m a
forall (ts :: [(Type -> Type) -> Type -> Type]) (m :: Type -> Type)
a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition TelegraphToIOC m a
m
{-# INLINE runTelegraph #-}
runTelegraph' ::
(Effs '[Embed IO, Reader Manager, Error HttpException, Throw TelegraphError] m, Threaders '[ReaderThreads] m p) =>
AccountInfo ->
TelegraphToIOC m a ->
m a
runTelegraph' :: AccountInfo -> TelegraphToIOC m a -> m a
runTelegraph' AccountInfo
acc TelegraphToIOC m a
m =
HttpC m a -> m a
forall (m :: Type -> Type) a.
Effs '[Embed IO, Reader Manager] m =>
HttpC m a -> m a
http (HttpC m a -> m a) -> HttpC m a -> m a
forall a b. (a -> b) -> a -> b
$ do
Account {Text
shortName :: Text
$sel:shortName:Account :: Account -> Text
shortName, Text
authorName :: Text
$sel:authorName:Account :: Account -> Text
authorName, Text
authorUrl :: Text
$sel:authorUrl:Account :: Account -> Text
authorUrl, $sel:accessToken:Account :: Account -> Maybe Text
accessToken = Maybe Text
accessToken'} <- Result Account -> InterpretC HttpH Http m Account
forall (m :: Type -> Type) a.
Eff (Throw TelegraphError) m =>
Result a -> m a
processResult (Result Account -> InterpretC HttpH Http m Account)
-> InterpretC HttpH Http m (Result Account)
-> InterpretC HttpH Http m Account
forall (m :: Type -> Type) a b. Monad m => (a -> m b) -> m a -> m b
=<< AccountInfo -> InterpretC HttpH Http m (Result Account)
forall (m :: Type -> Type).
Eff Http' m =>
AccountInfo -> m (Result Account)
createAccount AccountInfo
acc
MVar TS
ref <- IO (MVar TS) -> InterpretC HttpH Http m (MVar TS)
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO (MVar TS) -> InterpretC HttpH Http m (MVar TS))
-> IO (MVar TS) -> InterpretC HttpH Http m (MVar TS)
forall a b. (a -> b) -> a -> b
$ TS -> IO (MVar TS)
forall a. a -> IO (MVar a)
newMVar TS :: Text -> Text -> Text -> Text -> TS
TS {$sel:accessToken:TS :: Text
accessToken = Maybe Text -> Text
forall a. HasCallStack => Maybe a -> a
fromJust Maybe Text
accessToken', Text
authorUrl :: Text
authorName :: Text
shortName :: Text
$sel:authorUrl:TS :: Text
$sel:authorName:TS :: Text
$sel:shortName:TS :: Text
..}
MVar TS
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a -> HttpC m a
forall i (m :: Type -> Type) a
(p :: [(Type -> Type) -> Type -> Type]).
(Carrier m, Threaders '[ReaderThreads] m p) =>
i -> ReaderC i m a -> m a
runReader MVar TS
ref (ReaderC (MVar TS) (InterpretC HttpH Http m) a -> HttpC m a)
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a -> HttpC m a
forall a b. (a -> b) -> a -> b
$ TelegraphC (ReaderC (MVar TS) (InterpretC HttpH Http m)) a
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a
forall (m :: Type -> Type) a.
Effs '[Embed IO, Reader (MVar TS)] m =>
TelegraphC m a -> m a
telegraph (TelegraphC (ReaderC (MVar TS) (InterpretC HttpH Http m)) a
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a)
-> TelegraphC (ReaderC (MVar TS) (InterpretC HttpH Http m)) a
-> ReaderC (MVar TS) (InterpretC HttpH Http m) a
forall a b. (a -> b) -> a -> b
$ TelegraphToIOC m a
-> CompositionBaseM '[TelegraphC, ReaderC (MVar TS), HttpC] m a
forall (ts :: [(Type -> Type) -> Type -> Type]) (m :: Type -> Type)
a.
CompositionC ts m a -> CompositionBaseM ts m a
runComposition TelegraphToIOC m a
m
{-# INLINE runTelegraph' #-}
processResult :: Eff (Throw TelegraphError) m => Result a -> m a
processResult :: Result a -> m a
processResult (Error Text
e) = TelegraphError -> m a
forall e (m :: Type -> Type) a. Eff (Throw e) m => e -> m a
throw (TelegraphError -> m a) -> TelegraphError -> m a
forall a b. (a -> b) -> a -> b
$ Text -> TelegraphError
APICallFailure Text
e
processResult (Result a
r) = a -> m a
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure a
r
{-# INLINE processResult #-}
evalContT :: Applicative m => ContT r m r -> m r
evalContT :: ContT r m r -> m r
evalContT ContT r m r
m = ContT r m r -> (r -> m r) -> m r
forall k (r :: k) (m :: k -> Type) a.
ContT r m a -> (a -> m r) -> m r
runContT ContT r m r
m r -> m r
forall (f :: Type -> Type) a. Applicative f => a -> f a
pure
{-# INLINE evalContT #-}
withSourceFile :: (Effs '[Embed IO, Bracket] m, MonadIO n) => FilePath -> ContT r m (ConduitT i ByteString n ())
withSourceFile :: String -> ContT r m (ConduitT i ByteString n ())
withSourceFile String
fp = ((ConduitT i ByteString n () -> m r) -> m r)
-> ContT r m (ConduitT i ByteString n ())
forall k (r :: k) (m :: k -> Type) a.
((a -> m r) -> m r) -> ContT r m a
ContT (((ConduitT i ByteString n () -> m r) -> m r)
-> ContT r m (ConduitT i ByteString n ()))
-> ((ConduitT i ByteString n () -> m r) -> m r)
-> ContT r m (ConduitT i ByteString n ())
forall a b. (a -> b) -> a -> b
$ \ConduitT i ByteString n () -> m r
k ->
m Handle -> (Handle -> m ()) -> (Handle -> m r) -> m r
forall (m :: Type -> Type) a c b.
Eff Bracket m =>
m a -> (a -> m c) -> (a -> m b) -> m b
bracket
(IO Handle -> m Handle
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO Handle -> m Handle) -> IO Handle -> m Handle
forall a b. (a -> b) -> a -> b
$ String -> IOMode -> IO Handle
openBinaryFile String
fp IOMode
ReadMode)
(IO () -> m ()
forall (b :: Type -> Type) (m :: Type -> Type) a.
Eff (Embed b) m =>
b a -> m a
embed (IO () -> m ()) -> (Handle -> IO ()) -> Handle -> m ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> IO ()
hClose)
(ConduitT i ByteString n () -> m r
k (ConduitT i ByteString n () -> m r)
-> (Handle -> ConduitT i ByteString n ()) -> Handle -> m r
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Handle -> ConduitT i ByteString n ()
forall (m :: Type -> Type) i.
MonadIO m =>
Handle -> ConduitT i ByteString m ()
sourceHandle)
{-# INLINE withSourceFile #-}
deriveJSON snake ''AccountInfo
deriveJSON snake ''CreatePage
makeFieldLabelsWith noPrefixFieldLabels ''AccountInfo
makeFieldLabelsWith noPrefixFieldLabels ''CreatePage
makeFieldLabelsWith noPrefixFieldLabels ''ImgStream