telegraph (empty) → 0.1.0
raw patch · 7 files changed
+688/−0 lines, 7 filesdep +aesondep +basedep +bytestring
Dependencies added: aeson, base, bytestring, conduit, deriving-aeson, exceptions, generic-data-surgery, http-client, http-client-tls, http-conduit, monad-control, mtl, telegraph, text, transformers-base
Files
- CHANGELOG.md +5/−0
- LICENSE +11/−0
- README.md +5/−0
- src/Web/Telegraph/API.hs +396/−0
- src/Web/Telegraph/Types.hs +159/−0
- telegraph.cabal +88/−0
- test/Spec.hs +24/−0
+ CHANGELOG.md view
@@ -0,0 +1,5 @@+# telegraph++## 0.1.0++Initial release
+ LICENSE view
@@ -0,0 +1,11 @@+Copyright (c) 2021 Poscat++Redistribution and use in source and binary forms, with or without modification, are permitted provided that the following conditions are met:++ 1. Redistributions of source code must retain the above copyright notice, this list of conditions and the following disclaimer.++ 2. Redistributions in binary form must reproduce the above copyright notice, this list of conditions and the following disclaimer in the documentation and/or other materials provided with the distribution.++ 3. Neither the name of the copyright holder nor the names of its contributors may be used to endorse or promote products derived from this software without specific prior written permission.++THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT HOLDER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
+ README.md view
@@ -0,0 +1,5 @@+# telegraph++[](http://hackage.haskell.org/package/telegraph)++Haskell binding to the [Telegraph API](https://telegra.ph/api)
+ src/Web/Telegraph/API.hs view
@@ -0,0 +1,396 @@+{-# 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+ Telegraph (..),+ MonadTelegraph (..),+ AccountInfo (..),++ -- ** Interpreting 'MonadTelegraph'+ TelegraphT (..),+ runTelegraph,+ runTelegraph',++ -- ** Type Synonyms+ HasHttpCap,++ -- ** 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,+ )+where++import Conduit+ ( ConduitT,+ sourceHandle,+ )+import Control.Concurrent+import Control.Exception (throwIO)+import Control.Monad.Base+import Control.Monad.Catch+import Control.Monad.Cont+import Control.Monad.Reader+import Control.Monad.Trans.Control+import Data.Aeson (eitherDecode, encode, object, (.=))+import Data.ByteString (ByteString)+import Data.Function ((&))+import Data.Maybe+import Data.Text (Text, pack, unpack)+import Deriving.Aeson+import Deriving.Aeson.Stock+import Network.HTTP.Client.Conduit+import Network.HTTP.Client.MultipartFormData+import System.IO+import Web.Telegraph.Types+import Prelude as P++type HasHttpCap env m = (MonadIO m, HasHttpManager env, MonadReader env m)++class MonadThrow m => MonadTelegraph m where+ takeTelegraph :: m Telegraph+ readTelegraph :: m Telegraph+ putTelegraph :: Telegraph -> m ()++newtype TelegraphT m a = TelegraphT {runTelegraphT :: ReaderT (MVar Telegraph) m a}+ deriving newtype+ ( Functor,+ Applicative,+ Monad,+ MonadTrans,+ MonadIO,+ MonadThrow,+ MonadCatch,+ MonadMask,+ MonadBase b,+ MonadBaseControl b+ )++instance MonadReader r m => MonadReader r (TelegraphT m) where+ ask = lift ask+ local f m = do+ ref <- TelegraphT ask+ lift $ local f $ flip runReaderT ref $ runTelegraphT m++instance (MonadThrow m, MonadIO m) => MonadTelegraph (TelegraphT m) where+ takeTelegraph = TelegraphT ask >>= liftIO . takeMVar+ readTelegraph = TelegraphT ask >>= liftIO . readMVar+ putTelegraph t = TelegraphT ask >>= \ref -> liftIO $ putMVar ref t++instance+ {-# OVERLAPPABLE #-}+ ( MonadTelegraph m,+ MonadTrans f,+ MonadThrow (f m)+ ) =>+ MonadTelegraph (f m)+ where+ takeTelegraph = lift takeTelegraph+ readTelegraph = lift readTelegraph+ putTelegraph = lift . putTelegraph++data Telegraph = Telegraph+ { accessToken :: Text,+ shortName :: Text,+ authorName :: Text,+ authorUrl :: Text+ }+ deriving (Show, Eq, Generic)++data AccountInfo = AccountInfo+ { shortName :: Text,+ authorName :: Text,+ authorUrl :: Text+ }+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via Snake AccountInfo++-- | Use this method to create a new Telegraph account+createAccount :: HasHttpCap env m => AccountInfo -> m (Result Account)+createAccount !a = postAeson "https://api.telegra.ph/createAccount" a++-- | Use this method to update information about this Telegraph account+editAccountInfo :: (HasHttpCap env m, MonadTelegraph m, MonadMask m) => AccountInfo -> m ()+editAccountInfo AccountInfo {..} =+ bracketOnError+ takeTelegraph+ putTelegraph+ $ \t@Telegraph {accessToken} -> do+ let o =+ object+ [ "access_token" .= accessToken,+ "short_name" .= shortName,+ "author_name" .= authorName,+ "author_url" .= authorUrl+ ]+ r <- postAeson "https://api.telegra.ph/editAccountInfo" o+ case r of+ Error e -> do+ putTelegraph t+ throwM $ APICallFailure e+ Result Account {} -> do+ let t' = Telegraph {..}+ putTelegraph t'++-- | Use this method to get information about this Telegraph account+getAccountInfo :: (HasHttpCap env m, MonadTelegraph m) => m Account+getAccountInfo = do+ Telegraph {accessToken} <- readTelegraph+ r <- getAccountInfo' accessToken+ case r of+ Error e -> throwM $ APICallFailure e+ Result a -> pure a++getAccountInfo' :: HasHttpCap env m => Text -> m (Result Account)+getAccountInfo' accessToken = postAeson "https://api.telegra.ph/getAccountInfo" o+ where+ fields :: [Text]+ fields = ["short_name", "author_name", "author_url", "auth_url", "page_count"]+ o =+ object+ [ "access_token" .= accessToken,+ "fields" .= fields+ ]++-- | Use this method to revoke access_token and generate a new one+revokeAccessToken :: (HasHttpCap env m, MonadTelegraph m, MonadMask m) => m Account+revokeAccessToken =+ bracketOnError+ takeTelegraph+ putTelegraph+ $ \Telegraph {..} -> do+ let o = object ["access_token" .= accessToken]+ r <- postAeson "https://api.telegra.ph/revokeAccessToken" o+ case r of+ Error e -> throwM $ APICallFailure e+ Result a@Account {accessToken = accessToken'} -> do+ let t' = Telegraph {accessToken = fromJust accessToken', ..}+ putTelegraph t'+ pure a++data CreatePage = CreatePage+ { accessToken :: Text,+ title :: Text,+ authorName :: Maybe Text,+ authorUrl :: Maybe Text,+ content :: [Node],+ returnContent :: Bool+ }+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via Snake CreatePage++-- | Use this method to create a new Telegraph page+createPage ::+ (HasHttpCap env m, MonadTelegraph m) =>+ -- | title+ Text ->+ -- | content+ [Node] ->+ m Page+createPage title content = do+ Telegraph {..} <- readTelegraph+ let o =+ object+ [ "access_token" .= accessToken,+ "title" .= title,+ "author_name" .= authorName,+ "author_url" .= authorUrl,+ "content" .= content+ ]+ r <- postAeson "https://api.telegra.ph/createPage" o+ case r of+ Error e -> throwM $ APICallFailure e+ Result p -> pure p++-- | Use this method to edit an existing Telegraph page+editPage ::+ (HasHttpCap env m, MonadTelegraph m) =>+ -- | path+ Text ->+ -- | title+ Text ->+ -- | content+ [Node] ->+ m Page+editPage path title content = do+ Telegraph {..} <- readTelegraph+ let o =+ object+ [ "access_token" .= accessToken,+ "path" .= path,+ "title" .= title,+ "author_name" .= authorName,+ "author_url" .= authorUrl,+ "content" .= content+ ]+ r <- postAeson "https://api.telegra.ph/editPage" o+ case r of+ Error e -> throwM $ APICallFailure e+ Result p -> pure p++-- | Use this method to get a Telegraph page+getPage :: HasHttpCap env m => Text -> m (Result Page)+getPage path = do+ let o =+ object+ [ "path" .= path,+ "return_content" .= True+ ]+ postAeson "https://api.telegra.ph/getPage" o++-- | Use this method to get a list of pages belonging to this Telegraph account+getPageList ::+ (HasHttpCap env m, MonadTelegraph m) =>+ -- | offset+ Int ->+ -- | limit (0 - 200)+ Int ->+ m PageList+getPageList offset limit = do+ Telegraph {..} <- readTelegraph+ let o =+ object+ [ "access_token" .= accessToken,+ "offset" .= offset,+ "limit" .= limit+ ]+ r <- postAeson "https://api.telegra.ph/getPageList" o+ case r of+ Error e -> throwM $ APICallFailure e+ Result p -> pure p++-- | Use this method to get the total number of views for a Telegraph article+getTotalViews :: HasHttpCap env m => Text -> m (Result PageViews)+getTotalViews path = postAeson "https://api.telegra.ph/getViews" o+ where+ o = object ["path" .= path]++--------------------------------------------------+-- Upload API++uploadParts :: HasHttpCap env m => [PartM m] -> m UploadResult+uploadParts parts = do+ let initReq = parseRequest_ "POST https://telegra.ph/upload"+ boundary <- liftIO webkitBoundary+ req <- formDataBodyWithBoundary boundary parts initReq+ resp <- httpLbs req+ case eitherDecode (responseBody resp) of+ Left e -> P.error ("impossible: json decode failure: " ++ e)+ Right r -> pure r++-- | Upload a image from a filepath to Telegraph+uploadImageFromFile :: (HasHttpCap env m, MonadMask m) => FilePath -> m UploadResult+uploadImageFromFile fp =+ evalContT $ do+ src <- withSourceFile fp+ let body = requestBodySourceChunked src+ part = partFileRequestBody "file" fp body+ lift $ uploadParts [part]++-- | Upload a list of images to Telegraph. The resulting list of images will be in the same order+uploadImageFromFiles :: (HasHttpCap env m, MonadMask m) => [FilePath] -> m UploadResult+uploadImageFromFiles fps =+ evalContT $ do+ srcs <- traverse withSourceFile fps+ let bodies = map requestBodySourceChunked srcs+ parts = zipWith (\fp -> partFileRequestBody (pack fp) fp) fps bodies+ lift $ uploadParts parts++data ImgStream = ImgStream+ { -- | an image stream needs a filename+ name :: Text,+ stream :: forall i n. MonadIO n => ConduitT i ByteString n ()+ }++imgStream2Part :: Applicative m => ImgStream -> PartM m+imgStream2Part ImgStream {..} = partFileRequestBody name (unpack name) body+ where+ body = requestBodySourceChunked stream++-- | Upload a image stream to Telegraph+uploadImageStreaming :: HasHttpCap env m => ImgStream -> m UploadResult+uploadImageStreaming imgs = uploadParts [imgStream2Part imgs]++-- | Upload a list of image streams to Telegraph. The resulting list of images+uploadImagesStreaming :: HasHttpCap env m => [ImgStream] -> m UploadResult+uploadImagesStreaming imgss = uploadParts $ map imgStream2Part imgss++--------------------------------------------------+-- Utils+postAeson :: (ToJSON a, FromJSON b, HasHttpCap env m) => String -> a -> m b+postAeson url c = do+ let req =+ (parseRequest_ url)+ { method = "POST",+ requestBody = RequestBodyLBS $ encode c,+ requestHeaders =+ [ ("content-type", "application/json"),+ ("accept", "application/json")+ ]+ }+ resp <- httpLbs req+ case eitherDecode (responseBody resp) of+ Left e -> P.error ("impossible: json decode failure: " ++ e)+ Right r -> pure r++-- | interprets 'TelegraphT' using the access token of an existing account+runTelegraph :: HasHttpCap env m => Text -> TelegraphT m a -> m a+runTelegraph accessToken m = do+ r <- getAccountInfo' accessToken+ case r of+ Error e -> liftIO $ throwIO $ APICallFailure e+ Result Account {shortName, authorName, authorUrl} -> do+ let t = Telegraph {..}+ ref <- liftIO $ newMVar t+ m+ & runTelegraphT+ & flip runReaderT ref++-- | Create a new account and interprets 'TelegraphT' using that account+runTelegraph' :: HasHttpCap env m => AccountInfo -> TelegraphT m a -> m a+runTelegraph' acc m = do+ r <- createAccount acc+ case r of+ Error e -> liftIO $ throwIO $ APICallFailure e+ Result Account {shortName, authorName, authorUrl, accessToken = accessToken'} -> do+ let t = Telegraph {accessToken = fromJust accessToken', ..}+ ref <- liftIO $ newMVar t+ m+ & runTelegraphT+ & flip runReaderT ref++evalContT :: Applicative m => ContT r m r -> m r+evalContT m = runContT m pure+{-# INLINE evalContT #-}++withSourceFile :: (MonadMask m, MonadIO m, MonadIO n) => FilePath -> ContT r m (ConduitT i ByteString n ())+withSourceFile fp = ContT $ \k ->+ bracket+ (liftIO $ openBinaryFile fp ReadMode)+ (liftIO . hClose)+ (k . sourceHandle)
+ src/Web/Telegraph/Types.hs view
@@ -0,0 +1,159 @@+{-# LANGUAGE DeriveAnyClass #-}+{-# LANGUAGE DerivingStrategies #-}+{-# LANGUAGE DerivingVia #-}+{-# LANGUAGE GeneralizedNewtypeDeriving #-}+{-# LANGUAGE StrictData #-}++-- | Type definitions, note that all fields are strict+module Web.Telegraph.Types where++import Control.Exception+import Data.Aeson hiding (Result (..))+import Data.Maybe+import Data.Text (Text, unpack)+import Deriving.Aeson+import Deriving.Aeson.Stock+import Generic.Data.Surgery++-- | A Telegraph account+data Account = Account+ { -- | Account name, helps users with several accounts remember which they are currently using+ --+ -- Displayed to the user above the "Edit/Publish" button on Telegra.ph, other users don't see this name+ shortName :: {-# UNPACK #-} Text,+ -- | Default author name used when creating new articles+ authorName :: {-# UNPACK #-} Text,+ -- | Profile link, opened when users click on the author's name below the title+ --+ -- Can be any link, not necessarily to a Telegram profile or channel+ authorUrl :: {-# UNPACK #-} Text,+ -- | Access token of the Telegraph account+ accessToken :: Maybe Text,+ -- | URL to authorize a browser on telegra.ph and connect it to a Telegraph account+ --+ -- This URL is valid for only one use and for 5 minutes only+ authUrl :: Maybe Text,+ -- | Number of pages belonging to the Telegraph account+ pageCount :: Maybe Int+ }+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier CamelToSnake, OmitNothingFields] Account++-- | A list of Telegraph articles belonging to an account+--+-- Most recently created articles first+data PageList = PageList+ { -- | Total number of pages belonging to the target Telegraph account+ totalCount :: {-# UNPACK #-} Int,+ -- | Requested pages of the target Telegraph account+ pages :: [Page]+ }+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via Snake PageList++-- | A page on Telegraph+data Page = Page+ { -- | Path to the page+ path :: {-# UNPACK #-} Text,+ -- | URL of the page+ url :: {-# UNPACK #-} Text,+ -- | Title of the page+ title :: {-# UNPACK #-} Text,+ -- | Description of the page+ description :: {-# UNPACK #-} Text,+ -- | Name of the author, displayed below the title+ authorName :: Maybe Text,+ -- | rofile link, opened when users click on the author's name below the title+ --+ -- Can be any link, not necessarily to a Telegram profile or channel+ authorUrl :: Maybe Text,+ -- | Image URL of the page+ imageUrl :: Maybe Text,+ -- | Content of the page+ content :: Maybe [Node],+ -- | Number of page views for the page+ views :: {-# UNPACK #-} Int,+ -- | True, if the target Telegraph account can edit the page+ canEdit :: Maybe Bool+ }+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via CustomJSON '[FieldLabelModifier CamelToSnake, OmitNothingFields] Page++-- | The number of page views for a Telegraph article+newtype PageViews = PageViews {views :: Int}+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via Vanilla PageViews++-- | A DOM Node+data Node+ = Content {-# UNPACK #-} Text+ | Element {-# UNPACK #-} NodeElement+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via CustomJSON '[SumUntaggedValue] Node++-- | A DOM elemen node+data NodeElement = NodeElement+ { -- | Name of the DOM element+ --+ -- Available tags: @a@, @aside@, @b@, @blockquote@, @br@, @code@, @em@, @figcaption@, @figure@,+ -- @h3@, @h4@, @hr@, @i@, @iframe@, @img@, @li@, @ol@, @p@, @pre@, @s@, @strong@, @u@, @ul@, @video@+ tag :: {-# UNPACK #-} Text,+ -- | Attributes of the DOM element+ --+ -- Key of object represents name of attribute, value represents value of attribute+ --+ -- Available attributes: @href@, @src@+ attrs :: [(Text, [Text])],+ -- | List of child nodes for the DOM element+ children :: [Node]+ }+ deriving (Show, Eq, Generic)+ deriving (ToJSON) via Vanilla NodeElement++instance FromJSON NodeElement where+ parseJSON =+ fmap+ ( fromORLazy+ . modifyRField @"attrs" (fromMaybe [])+ . modifyRField @"children" (fromMaybe [])+ . toOR'+ )+ . genericParseJSON defaultOptions++-- | The result of an API call+data Result a+ = Error {-# UNPACK #-} Text+ | Result a+ deriving (Show, Eq, Generic)++instance FromJSON a => FromJSON (Result a) where+ parseJSON = withObject "telegra.ph api call result" $ \o -> do+ ok <- o .: "ok"+ if ok+ then Result <$> o .: "result"+ else Error <$> o .: "error"++-- | An image uploaded to Telegraph+newtype Image = Image+ { -- | The path to the image+ src :: Text+ }+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via Vanilla Image++-- | The result of an image upload+data UploadResult+ = UploadError {error :: {-# UNPACK #-} Text}+ | Sources [Image]+ deriving (Show, Eq, Generic)+ deriving (FromJSON, ToJSON) via CustomJSON '[SumUntaggedValue] UploadResult++newtype TelegraphError+ = -- | An api call has failed, we cannot distinguish between minor errors (such as illformed author urls)+ -- and much serious errors, such as invalid accessTokens, so we always throw exceptions+ APICallFailure Text+ deriving newtype (Eq)+ deriving anyclass (Exception)++instance Show TelegraphError where+ show (APICallFailure e) = "API call failed with error: " ++ unpack e
+ telegraph.cabal view
@@ -0,0 +1,88 @@+cabal-version: 3.0+name: telegraph+version: 0.1.0+synopsis: Binding to the telegraph API+description: Binding to the telegraph API+category: Web+license: BSD-3-Clause+license-file: LICENSE+author: Poscat+maintainer: Poscat <poscat@mail.poscat.moe>+copyright: Copyright (c) Poscat 2021+stability: alpha+homepage: https://github.com/poscat0x04/telegraph+bug-reports: https://github.com/poscat0x04/telegraph/issues+extra-doc-files:+ CHANGELOG.md+ README.md++common common-attrs+ build-depends:+ , aeson ^>=1.5.4+ , base >=4.10 && <5+ , bytestring >=0.10.12 && <0.12+ , conduit ^>=1.3.4+ , deriving-aeson ^>=0.2.6+ , exceptions ^>=0.10.4+ , generic-data-surgery ^>=0.3.0+ , http-client >=0.6.4 && <=0.8+ , http-conduit ^>=2.3.7+ , monad-control ^>=1.0.2+ , mtl ^>=2.2.2+ , text ^>=1.2.4+ , transformers-base ^>=0.4.5++ default-language: Haskell2010+ default-extensions:+ NoStarIsType+ BangPatterns+ ConstraintKinds+ DataKinds+ DeriveFoldable+ DeriveFunctor+ DeriveGeneric+ DeriveTraversable+ DuplicateRecordFields+ EmptyCase+ FlexibleContexts+ FlexibleInstances+ FunctionalDependencies+ InstanceSigs+ KindSignatures+ LambdaCase+ MultiWayIf+ OverloadedStrings+ PartialTypeSignatures+ PatternSynonyms+ RecordWildCards+ ScopedTypeVariables+ TupleSections+ TypeApplications+ TypeFamilies+ TypeOperators+ UnicodeSyntax+ ViewPatterns++library+ import: common-attrs+ build-depends:+ exposed-modules:+ Web.Telegraph.API+ Web.Telegraph.Types++ other-modules:+ hs-source-dirs: src++test-suite telegraph-test+ import: common-attrs+ type: exitcode-stdio-1.0+ build-depends:+ , http-client-tls+ , telegraph++ hs-source-dirs: test+ main-is: Spec.hs++source-repository head+ type: git+ location: https://github.com/poscat0x04/telegraph
+ test/Spec.hs view
@@ -0,0 +1,24 @@+{-# LANGUAGE NamedFieldPuns #-}++module Main where++import Control.Monad.Reader+import Network.HTTP.Client.TLS+import Web.Telegraph.API+import Web.Telegraph.Types++main :: IO ()+main = do+ manager <- newTlsManager+ flip runReaderT manager $+ runTelegraph "b968da509bb76866c35425099bc0989a5ec3b32997d55286c657e6994bbb" $ do+ pl <- getPageList 0 3+ liftIO $ print pl+ Page {path} <- createPage "test" $ pure $ Element $ NodeElement "p" [] [Content "Hello"]+ p <- getPage path+ liftIO $ print p+ _ <- editPage path "test" $ pure $ Element $ NodeElement "p" [] [Content "Bye"]+ p' <- getPage path+ liftIO $ print p'+ a <- getAccountInfo+ liftIO $ print a