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

-- | The telegraph API.
-- Note that the @'Error' 'HttpException'@ effect should be interpreted using
-- either 'errorToIOAsExc' or 'errorToErrorIOAsExc' or otherwise it won't get
-- caught.
module Web.Telegraph.API
  ( -- ** Types
    AccountInfo (..),
    TS (..),

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

    -- ** Interpreters
    runTelegraph,
    runTelegraph',

    -- ** 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 (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)

-- | 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
{-# INLINEABLE createAccount #-}

-- | 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'
{-# INLINEABLE editAccountInfo #-}

-- | 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
{-# 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' #-}

-- | 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
{-# 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)

-- | 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
{-# INLINEABLE createPage #-}

-- | 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
{-# INLINEABLE editPage #-}

-- | 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
{-# INLINEABLE getPage #-}

-- | 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
{-# INLINEABLE getPageList #-}

-- | 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]
{-# INLINEABLE getTotalViews #-}

--------------------------------------------------
-- 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
{-# INLINEABLE uploadParts #-}

-- | 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]
{-# INLINEABLE uploadImageFromFile #-}

-- | 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
{-# INLINEABLE uploadImageFromFiles #-}

data ImgStream = ImgStream
  { -- | filename
    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

-- | 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]
{-# INLINEABLE uploadImageStreaming #-}

-- | 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
{-# INLINEABLE uploadImagesStreaming #-}

--------------------------------------------------
-- 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
{-# INLINE postAeson #-}

type TelegraphToIOC =
  CompositionC
    '[ TelegraphC,
       ReaderC (MVar TS),
       HttpC
     ]

-- | Interpret a 'Http' effect together with a 'Telegraph' effect with a supplied access token
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 #-}

-- | Interpret a 'Http' effect together with a 'Telegraph' effect with account info
-- that will be used to create a new account
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