telegraph 0.1.0 → 1.0.0
raw patch · 5 files changed
+276/−179 lines, 5 filesdep +in-other-wordsdep −exceptionsdep −monad-controldep −transformers-base
Dependencies added: in-other-words
Dependencies removed: exceptions, monad-control, transformers-base
Files
- CHANGELOG.md +4/−0
- src/Control/Effect/Telegraph.hs +134/−0
- src/Web/Telegraph/API.hs +105/−150
- telegraph.cabal +15/−16
- test/Spec.hs +18/−13
CHANGELOG.md view
@@ -3,3 +3,7 @@ ## 0.1.0 Initial release++## 1.0.0++- Rewrite using in-other-words
+ src/Control/Effect/Telegraph.hs view
@@ -0,0 +1,134 @@+{-# LANGUAGE GADTs #-}+{-# LANGUAGE RankNTypes #-}+{-# LANGUAGE UndecidableInstances #-}++module Control.Effect.Telegraph where++import Control.Concurrent+import Control.Effect+import Control.Effect.Error+import Control.Effect.ErrorIO+import Control.Effect.Reader+import Data.ByteString (ByteString)+import qualified Data.ByteString.Lazy as LBS+import Data.Text (Text)+import GHC.Generics+import Network.HTTP.Client+import qualified Network.HTTP.Client as C+import Network.HTTP.Client.MultipartFormData++data Http :: Effect where+ HttpLbs :: Request -> Http m (Response LBS.ByteString)+ GenBoundary :: Http m ByteString++data Telegraph :: Effect where+ TakeTS :: Telegraph m TS+ ReadTS :: Telegraph m TS+ PutTS :: TS -> Telegraph m ()++type Telegraph' = Bundle '[Telegraph, Http, Error HttpException]++type Http' = Bundle '[Http, Error HttpException]++data TelegraphH++instance+ Effs '[Embed IO, Reader (MVar TS)] m =>+ Handler TelegraphH Telegraph m+ where+ effHandler = \case+ TakeTS -> ask >>= embed . takeMVar+ ReadTS -> ask >>= embed . readMVar+ PutTS ts -> do+ ref <- ask+ embed $ putMVar ref ts++type TelegraphC = InterpretC TelegraphH Telegraph++telegraph ::+ Effs '[Embed IO, Reader (MVar TS)] m =>+ TelegraphC m a ->+ m a+telegraph = interpretViaHandler++data HttpH++instance+ Effs '[Embed IO, Reader Manager] m =>+ Handler HttpH Http m+ where+ effHandler = \case+ HttpLbs req -> ask >>= embed . C.httpLbs req+ GenBoundary -> embed webkitBoundary++type HttpC = InterpretC HttpH Http++http ::+ Effs '[Embed IO, Reader Manager] m =>+ HttpC m a ->+ m a+http = interpretViaHandler++errorToErrorIO' ::+ (Exception e, Effs '[ErrorIO, Embed IO] m) =>+ InterpretErrorC e m a ->+ m (Either e a)+errorToErrorIO' main = fmap Right main' `catchIO` (pure . Left)+ where+ main' =+ interpret (\(Throw e) -> throwIO e) $+ interpret (\(Catch m h) -> m `catchIO` h) $+ runComposition main++errorToErrorIOThrowing ::+ (Exception e, Effs '[ErrorIO, Embed IO] m) =>+ InterpretErrorC e m a ->+ m a+errorToErrorIOThrowing main =+ interpret (\(Throw e) -> throwIO e) $+ interpret (\(Catch m h) -> m `catchIO` h) $+ runComposition main++errorToIO' ::+ (Exception e, Eff (Embed IO) m, MonadCatch m) =>+ ErrorToIOC e m a ->+ m (Either e a)+errorToIO' m =+ errorIOToIO $+ errorToErrorIO' $+ introUnderMany $+ runComposition m++errorToIOThrowing ::+ (Exception e, Eff (Embed IO) m, MonadCatch m) =>+ ErrorToIOC e m a ->+ m a+errorToIOThrowing m =+ errorIOToIO $+ errorToErrorIOThrowing $+ introUnderMany $+ runComposition m++takeTS :: Eff Telegraph m => m TS+takeTS = send TakeTS++readTS :: Eff Telegraph m => m TS+readTS = send ReadTS++putTS :: Eff Telegraph m => TS -> m ()+putTS !s = send (PutTS s)++httpLbs :: Effs '[Http, Error HttpException] m => Request -> m (Response LBS.ByteString)+httpLbs !r = send (HttpLbs r)++genBoundary :: Eff Http m => m ByteString+genBoundary = send GenBoundary++-- | Telegraph state+data TS = TS+ { accessToken :: Text,+ shortName :: Text,+ authorName :: Text,+ authorUrl :: Text+ }+ deriving (Show, Eq, Generic)
src/Web/Telegraph/API.hs view
@@ -10,17 +10,24 @@ -- Every function that runs in 'MonadTelegraph' might throw a 'TelegraphError'. module Web.Telegraph.API ( -- ** Types- Telegraph (..),- MonadTelegraph (..), AccountInfo (..),+ TS (..), - -- ** Interpreting 'MonadTelegraph'- TelegraphT (..),+ -- ** Effects+ Telegraph (..),+ Http (..),+ Telegraph',+ Http',++ -- ** Interpreters runTelegraph, runTelegraph', - -- ** Type Synonyms- HasHttpCap,+ -- *** Error Interpreters+ errorToIO',+ errorToErrorIO',+ errorToIOThrowing,+ errorToErrorIOThrowing, -- ** Account related APIs editAccountInfo,@@ -43,6 +50,15 @@ uploadImageStreaming, uploadImagesStreaming, uploadParts,++ -- ** Interpreter primitives+ TelegraphToIOC,+ TelegraphC,+ HttpC,+ TelegraphH,+ HttpH,+ telegraph,+ http, ) where @@ -51,76 +67,23 @@ sourceHandle, ) import Control.Concurrent-import Control.Exception (throwIO)-import Control.Monad.Base-import Control.Monad.Catch+import Control.Effect+import Control.Effect.Bracket+import Control.Effect.Error+import Control.Effect.Reader+import Control.Effect.Telegraph 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 (HttpException, Manager, Request (..), RequestBody (..), Response (..), parseRequest_)+import Network.HTTP.Client.Conduit (requestBodySourceChunked) 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)+import Web.Telegraph.Types hiding (error) data AccountInfo = AccountInfo { shortName :: Text,@@ -131,16 +94,16 @@ deriving (FromJSON, ToJSON) via Snake AccountInfo -- | Use this method to create a new Telegraph account-createAccount :: HasHttpCap env m => AccountInfo -> m (Result Account)+createAccount :: Eff Http' 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 :: (Effs '[Telegraph', Bracket, Throw TelegraphError] m) => AccountInfo -> m () editAccountInfo AccountInfo {..} = bracketOnError- takeTelegraph- putTelegraph- $ \t@Telegraph {accessToken} -> do+ takeTS+ putTS+ $ \t@TS {accessToken} -> do let o = object [ "access_token" .= accessToken,@@ -151,22 +114,19 @@ r <- postAeson "https://api.telegra.ph/editAccountInfo" o case r of Error e -> do- putTelegraph t- throwM $ APICallFailure e+ putTS t+ throw $ APICallFailure e Result Account {} -> do- let t' = Telegraph {..}- putTelegraph t'+ let t' = TS {..}+ putTS t' -- | Use this method to get information about this Telegraph account-getAccountInfo :: (HasHttpCap env m, MonadTelegraph m) => m Account+getAccountInfo :: Effs '[Telegraph', Throw TelegraphError] m => m Account getAccountInfo = do- Telegraph {accessToken} <- readTelegraph- r <- getAccountInfo' accessToken- case r of- Error e -> throwM $ APICallFailure e- Result a -> pure a+ TS {accessToken} <- readTS+ processResult =<< getAccountInfo' accessToken -getAccountInfo' :: HasHttpCap env m => Text -> m (Result Account)+getAccountInfo' :: Eff Http' m => Text -> m (Result Account) getAccountInfo' accessToken = postAeson "https://api.telegra.ph/getAccountInfo" o where fields :: [Text]@@ -178,20 +138,17 @@ ] -- | Use this method to revoke access_token and generate a new one-revokeAccessToken :: (HasHttpCap env m, MonadTelegraph m, MonadMask m) => m Account+revokeAccessToken :: (Effs '[Telegraph', Bracket, Error TelegraphError] m) => m Account revokeAccessToken = bracketOnError- takeTelegraph- putTelegraph- $ \Telegraph {..} -> do+ takeTS+ putTS+ $ \TS {..} -> 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+ a@Account {accessToken = accessToken'} <- processResult =<< postAeson "https://api.telegra.ph/revokeAccessToken" o+ let t' = TS {accessToken = fromJust accessToken', ..}+ putTS t'+ pure a data CreatePage = CreatePage { accessToken :: Text,@@ -206,14 +163,14 @@ -- | Use this method to create a new Telegraph page createPage ::- (HasHttpCap env m, MonadTelegraph m) =>+ (Effs '[Telegraph', Error TelegraphError] m) => -- | title Text -> -- | content [Node] -> m Page createPage title content = do- Telegraph {..} <- readTelegraph+ TS {..} <- readTS let o = object [ "access_token" .= accessToken,@@ -222,14 +179,11 @@ "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+ processResult =<< postAeson "https://api.telegra.ph/createPage" o -- | Use this method to edit an existing Telegraph page editPage ::- (HasHttpCap env m, MonadTelegraph m) =>+ (Effs '[Telegraph', Throw TelegraphError] m) => -- | path Text -> -- | title@@ -238,7 +192,7 @@ [Node] -> m Page editPage path title content = do- Telegraph {..} <- readTelegraph+ TS {..} <- readTS let o = object [ "access_token" .= accessToken,@@ -248,13 +202,10 @@ "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+ processResult =<< postAeson "https://api.telegra.ph/editPage" o -- | Use this method to get a Telegraph page-getPage :: HasHttpCap env m => Text -> m (Result Page)+getPage :: Eff Http' m => Text -> m (Result Page) getPage path = do let o = object@@ -265,27 +216,24 @@ -- | Use this method to get a list of pages belonging to this Telegraph account getPageList ::- (HasHttpCap env m, MonadTelegraph m) =>+ (Effs '[Telegraph', Throw TelegraphError] m) => -- | offset Int -> -- | limit (0 - 200) Int -> m PageList getPageList offset limit = do- Telegraph {..} <- readTelegraph+ TS {..} <- readTS 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+ processResult =<< postAeson "https://api.telegra.ph/getPageList" o -- | Use this method to get the total number of views for a Telegraph article-getTotalViews :: HasHttpCap env m => Text -> m (Result PageViews)+getTotalViews :: Eff Http' m => Text -> m (Result PageViews) getTotalViews path = postAeson "https://api.telegra.ph/getViews" o where o = object ["path" .= path]@@ -293,18 +241,18 @@ -------------------------------------------------- -- Upload API -uploadParts :: HasHttpCap env m => [PartM m] -> m UploadResult+uploadParts :: Eff Telegraph' m => [PartM m] -> m UploadResult uploadParts parts = do let initReq = parseRequest_ "POST https://telegra.ph/upload"- boundary <- liftIO webkitBoundary+ boundary <- genBoundary req <- formDataBodyWithBoundary boundary parts initReq resp <- httpLbs req case eitherDecode (responseBody resp) of- Left e -> P.error ("impossible: json decode failure: " ++ e)+ Left e -> 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 :: (Effs '[Telegraph', Bracket, Embed IO] m) => FilePath -> m UploadResult uploadImageFromFile fp = evalContT $ do src <- withSourceFile fp@@ -313,7 +261,7 @@ 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 :: (Effs '[Telegraph', Bracket, Embed IO] m) => [FilePath] -> m UploadResult uploadImageFromFiles fps = evalContT $ do srcs <- traverse withSourceFile fps@@ -333,16 +281,16 @@ body = requestBodySourceChunked stream -- | Upload a image stream to Telegraph-uploadImageStreaming :: HasHttpCap env m => ImgStream -> m UploadResult+uploadImageStreaming :: Eff Telegraph' 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 :: Eff Telegraph' m => [ImgStream] -> m UploadResult uploadImagesStreaming imgss = uploadParts $ map imgStream2Part imgss -------------------------------------------------- -- Utils-postAeson :: (ToJSON a, FromJSON b, HasHttpCap env m) => String -> a -> m b+postAeson :: (ToJSON a, FromJSON b, Eff Http' m) => String -> a -> m b postAeson url c = do let req = (parseRequest_ url)@@ -355,42 +303,49 @@ } resp <- httpLbs req case eitherDecode (responseBody resp) of- Left e -> P.error ("impossible: json decode failure: " ++ e)+ Left e -> 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+type TelegraphToIOC =+ CompositionC+ '[ TelegraphC,+ ReaderC (MVar TS),+ HttpC+ ] --- | 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+runTelegraph ::+ (Effs '[Embed IO, Reader Manager, Error HttpException, Throw TelegraphError] m, Threaders '[ReaderThreads] m p) =>+ Text ->+ TelegraphToIOC m a ->+ m a+runTelegraph accessToken m =+ http $ do+ Account {shortName, authorName, authorUrl} <- processResult =<< getAccountInfo' accessToken+ ref <- embed $ newMVar TS {..}+ runReader ref $ telegraph $ runComposition m +runTelegraph' ::+ (Effs '[Embed IO, Reader Manager, Error HttpException, Throw TelegraphError] m, Threaders '[ReaderThreads] m p) =>+ AccountInfo ->+ TelegraphToIOC m a ->+ m a+runTelegraph' acc m =+ http $ do+ Account {shortName, authorName, authorUrl, accessToken = accessToken'} <- processResult =<< createAccount acc+ ref <- embed $ newMVar TS {accessToken = fromJust accessToken', ..}+ runReader ref $ telegraph $ runComposition m++processResult :: Eff (Throw TelegraphError) m => Result a -> m a+processResult (Error e) = throw $ APICallFailure e+processResult (Result r) = pure r+ 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 :: (Effs '[Embed IO, Bracket] m, MonadIO n) => FilePath -> ContT r m (ConduitT i ByteString n ()) withSourceFile fp = ContT $ \k -> bracket- (liftIO $ openBinaryFile fp ReadMode)- (liftIO . hClose)+ (embed $ openBinaryFile fp ReadMode)+ (embed . hClose) (k . sourceHandle)
telegraph.cabal view
@@ -1,6 +1,6 @@ cabal-version: 3.0 name: telegraph-version: 0.1.0+version: 1.0.0 synopsis: Binding to the telegraph API description: Binding to the telegraph API category: Web@@ -9,7 +9,7 @@ author: Poscat maintainer: Poscat <poscat@mail.poscat.moe> copyright: Copyright (c) Poscat 2021-stability: alpha+stability: experimental homepage: https://github.com/poscat0x04/telegraph bug-reports: https://github.com/poscat0x04/telegraph/issues extra-doc-files:@@ -18,19 +18,9 @@ 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+ , base >=4.10 && <5+ , http-client >=0.6.4 && <=0.8+ , in-other-words ^>=0.1.0 default-language: Haskell2010 default-extensions:@@ -66,11 +56,20 @@ library import: common-attrs build-depends:+ , aeson >=1.4.7 && <1.6+ , bytestring >=0.10.12 && <0.12+ , conduit ^>=1.3.4+ , deriving-aeson ^>=0.2.6+ , generic-data-surgery ^>=0.3.0+ , http-conduit ^>=2.3.7+ , mtl ^>=2.2.2+ , text ^>=1.2.4+ exposed-modules: Web.Telegraph.API Web.Telegraph.Types - other-modules:+ other-modules: Control.Effect.Telegraph hs-source-dirs: src test-suite telegraph-test
test/Spec.hs view
@@ -2,7 +2,9 @@ module Main where -import Control.Monad.Reader+import Control.Effect+import Control.Effect.Reader+import Network.HTTP.Client (HttpException) import Network.HTTP.Client.TLS import Web.Telegraph.API import Web.Telegraph.Types@@ -10,15 +12,18 @@ 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+ runM $+ errorToIOThrowing @TelegraphError $+ errorToIOThrowing @HttpException $+ runReader manager $+ runTelegraph "b968da509bb76866c35425099bc0989a5ec3b32997d55286c657e6994bbb" $ do+ pl <- getPageList 0 3+ embed $ print pl+ Page {path} <- createPage "test" $ pure $ Element $ NodeElement "p" [] [Content "Hello"]+ p <- getPage path+ embed $ print p+ _ <- editPage path "test" $ pure $ Element $ NodeElement "p" [] [Content "Bye"]+ p' <- getPage path+ embed $ print p'+ a <- getAccountInfo+ embed $ print a