{-# LANGUAGE DerivingStrategies #-}
{-# LANGUAGE DerivingVia #-}
{-# LANGUAGE ExistentialQuantification #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RankNTypes #-}
{-# LANGUAGE UndecidableInstances #-}

-- | The telegraph API.
-- Every function that runs in 'MonadTelegraph' might throw a 'TelegraphError'.
module Web.Telegraph.API
  ( -- ** Types
    AccountInfo (..),
    TS (..),

    -- ** Effects
    Telegraph (..),
    Http (..),
    Telegraph',
    Http',

    -- ** Interpreters
    runTelegraph,
    runTelegraph',

    -- *** Error Interpreters
    errorToIO',
    errorToErrorIO',
    errorToIOThrowing,
    errorToErrorIOThrowing,

    -- ** Account related APIs
    editAccountInfo,
    getAccountInfo,
    revokeAccessToken,
    createPage,
    editPage,
    getPageList,

    -- ** Account independent APIs
    createAccount,
    getAccountInfo',
    getPage,
    getTotalViews,

    -- ** Image uploading API
    uploadImageFromFile,
    uploadImageFromFiles,
    ImgStream (..),
    uploadImageStreaming,
    uploadImagesStreaming,
    uploadParts,

    -- ** Interpreter primitives
    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

-- | Use this method to create a new Telegraph account
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

-- | Use this method to update information about this Telegraph account
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'

-- | Use this method to get information about this Telegraph account
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
        ]

-- | Use this method to revoke access_token and generate a new one
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

-- | Use this method to create a new Telegraph page
createPage ::
  (Effs '[Telegraph', Error TelegraphError] m) =>
  -- | title
  Text ->
  -- | content
  [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

-- | Use this method to edit an existing Telegraph page
editPage ::
  (Effs '[Telegraph', Throw TelegraphError] m) =>
  -- | path
  Text ->
  -- | title
  Text ->
  -- | content
  [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

-- | Use this method to get a Telegraph page
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

-- | Use this method to get a list of pages belonging to this Telegraph account
getPageList ::
  (Effs '[Telegraph', Throw TelegraphError] m) =>
  -- | offset
  Int ->
  -- | limit (0 - 200)
  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

-- | Use this method to get the total number of views for a Telegraph article
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]

--------------------------------------------------
-- Upload API

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

-- | Upload a image from a filepath to Telegraph
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]

-- | Upload a list of images to Telegraph. The resulting list of images will be in the same order
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
  { -- | an image stream needs a filename
    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

-- | Upload a image stream to Telegraph
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]

-- | Upload a list of image streams to Telegraph. The resulting list of images
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

--------------------------------------------------
-- Utils
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)