{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}
module Web.Telegraph.API
(
AccountInfo (..),
TS (..),
Telegraph (..),
Http (..),
Telegraph',
Http',
runTelegraph,
runTelegraph',
errorToIO',
errorToErrorIO',
errorToIOThrowing,
errorToErrorIOThrowing,
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 (eitherDecode, encode, object, (.=))
import Data.ByteString (ByteString)
import Data.Maybe
import Data.Text (Text, pack, unpack)
import Deriving.Aeson
import Deriving.Aeson.Stock
import Network.HTTP.Client (HttpException, Manager, Request (..), RequestBody (..), Response (..), parseRequest_)
import Network.HTTP.Client.Conduit (requestBodySourceChunked)
import Network.HTTP.Client.MultipartFormData
import System.IO
import Web.Telegraph.Types hiding (error)
data AccountInfo = AccountInfo
{ AccountInfo -> Text
shortName :: Text,
AccountInfo -> Text
authorName :: Text,
AccountInfo -> Text
authorUrl :: 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, (forall x. AccountInfo -> Rep AccountInfo x)
-> (forall x. Rep AccountInfo x -> AccountInfo)
-> Generic AccountInfo
forall x. Rep AccountInfo x -> AccountInfo
forall x. AccountInfo -> Rep AccountInfo x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep AccountInfo x -> AccountInfo
$cfrom :: forall x. AccountInfo -> Rep AccountInfo x
Generic)
deriving (Value -> Parser [AccountInfo]
Value -> Parser AccountInfo
(Value -> Parser AccountInfo)
-> (Value -> Parser [AccountInfo]) -> FromJSON AccountInfo
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [AccountInfo]
$cparseJSONList :: Value -> Parser [AccountInfo]
parseJSON :: Value -> Parser AccountInfo
$cparseJSON :: Value -> Parser AccountInfo
FromJSON, [AccountInfo] -> Encoding
[AccountInfo] -> Value
AccountInfo -> Encoding
AccountInfo -> Value
(AccountInfo -> Value)
-> (AccountInfo -> Encoding)
-> ([AccountInfo] -> Value)
-> ([AccountInfo] -> Encoding)
-> ToJSON AccountInfo
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [AccountInfo] -> Encoding
$ctoEncodingList :: [AccountInfo] -> Encoding
toJSONList :: [AccountInfo] -> Value
$ctoJSONList :: [AccountInfo] -> Value
toEncoding :: AccountInfo -> Encoding
$ctoEncoding :: AccountInfo -> Encoding
toJSON :: AccountInfo -> Value
$ctoJSON :: AccountInfo -> Value
ToJSON) via Snake AccountInfo
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
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'
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
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
]
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
data CreatePage = CreatePage
{ CreatePage -> Text
accessToken :: Text,
CreatePage -> Text
title :: 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, (forall x. CreatePage -> Rep CreatePage x)
-> (forall x. Rep CreatePage x -> CreatePage) -> Generic CreatePage
forall x. Rep CreatePage x -> CreatePage
forall x. CreatePage -> Rep CreatePage x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cto :: forall x. Rep CreatePage x -> CreatePage
$cfrom :: forall x. CreatePage -> Rep CreatePage x
Generic)
deriving (Value -> Parser [CreatePage]
Value -> Parser CreatePage
(Value -> Parser CreatePage)
-> (Value -> Parser [CreatePage]) -> FromJSON CreatePage
forall a.
(Value -> Parser a) -> (Value -> Parser [a]) -> FromJSON a
parseJSONList :: Value -> Parser [CreatePage]
$cparseJSONList :: Value -> Parser [CreatePage]
parseJSON :: Value -> Parser CreatePage
$cparseJSON :: Value -> Parser CreatePage
FromJSON, [CreatePage] -> Encoding
[CreatePage] -> Value
CreatePage -> Encoding
CreatePage -> Value
(CreatePage -> Value)
-> (CreatePage -> Encoding)
-> ([CreatePage] -> Value)
-> ([CreatePage] -> Encoding)
-> ToJSON CreatePage
forall a.
(a -> Value)
-> (a -> Encoding)
-> ([a] -> Value)
-> ([a] -> Encoding)
-> ToJSON a
toEncodingList :: [CreatePage] -> Encoding
$ctoEncodingList :: [CreatePage] -> Encoding
toJSONList :: [CreatePage] -> Value
$ctoJSONList :: [CreatePage] -> Value
toEncoding :: CreatePage -> Encoding
$ctoEncoding :: CreatePage -> Encoding
toJSON :: CreatePage -> Value
$ctoJSON :: CreatePage -> Value
ToJSON) via Snake CreatePage
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
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
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
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
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]
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
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]
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
data ImgStream = ImgStream
{
ImgStream -> Text
name :: 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]
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
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
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
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
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
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)