Hastodon 0.3.2 → 0.4.0
raw patch · 3 files changed
+20/−581 lines, 3 filesdep +attoparsecdep +conduitdep +exceptionssetup-changed
Dependencies added: attoparsec, conduit, exceptions, resourcet, transformers
Files
- Hastodon.cabal +7/−2
- Setup.hs +0/−2
- Web/Hastodon.hs +13/−577
Hastodon.cabal view
@@ -1,5 +1,5 @@ Name: Hastodon-Version: 0.3.2+Version: 0.4.0 Synopsis: mastodon client module for Haskell Category: Web Description: mastodon client module for Haskell@@ -21,13 +21,18 @@ default-language: Haskell2010 Build-Depends: base >= 4.5 && < 5, aeson,+ attoparsec, bytestring,+ conduit >= 1.3.0,+ exceptions, mime-types, http-types, http-client, http-conduit, MissingH,- text+ resourcet,+ text,+ transformers Exposed-Modules: Web.Hastodon Other-Modules:
− Setup.hs
@@ -1,2 +0,0 @@-import Distribution.Simple-main = defaultMain
Web/Hastodon.hs view
@@ -1,7 +1,5 @@ module Web.Hastodon- (- HastodonClient(..)-+ ( HastodonClient(..) , Account(..) , Application(..) , Attachment(..)@@ -15,6 +13,8 @@ , Report(..) , Results(..) , Status(..)+ , StreamingPayload(..)+ , StreamingResponse , Tag(..) , mkHastodonClient@@ -59,580 +59,16 @@ , getHomeTimeline , getPublicTimeline , getTaggedTimeline++ , streamUser+ , streamPublic+ , streamLocal+ , streamHashtag+ , streamList ) where -import Control.Applicative-import Data.Aeson-import qualified Data.ByteString.Char8 as Char8-import qualified Data.ByteString.Lazy.Char8 as LChar8-import qualified Data.Text as T-import qualified Data.Text.Encoding as T-import Data.String.Utils-import Network.HTTP.Simple-import Network.HTTP.Types.Header-import Network.HTTP.Client.MultipartFormData-import Network.Mime ------ Utility----utf8ToChar8 :: String -> Char8.ByteString-utf8ToChar8 = T.encodeUtf8 . T.pack------- Mastodon API endpoints----pAccountById = "/api/v1/accounts/:id"-pCurrentAccounts = "/api/v1/accounts/verify_credentials"-pFollowers = "/api/v1/accounts/:id/followers"-pFollowing = "/api/v1/accounts/:id/following"-pAccountStatuses = "/api/v1/accounts/:id/statuses"-pFollow = "/api/v1/accounts/:id/follow"-pUnfollow = "/api/v1/accounts/:id/unfollow"-pBlock = "/api/v1/accounts/:id/block"-pUnblock = "/api/v1/accounts/:id/unblock"-pMute = "/api/v1/accounts/:id/mute"-pUnmute = "/api/v1/accounts/:id/unmute"-pRelationships = "/api/v1/accounts/relationships"-pSearchAccounts = "/api/v1/accounts/search"-pApps = "/api/v1/apps"-pBlocks = "/api/v1/blocks"-pFavorites = "/api/v1/favourites"-pFollowRequests = "/api/v1/follow_requests"-pAuthorizeRequest = "/api/v1/follow_requests/:id/authorize"-pRejectRequest = "/api/v1/follow_requests/:id/reject"-pInstance = "/api/v1/instance"-pMedia = "/api/v1/media"-pMutes = "/api/v1/mutes"-pNotifications = "/api/v1/notifications"-pNotificationById = "/api/v1/notifications/:id"-pNotificationClear = "/api/v1/notifications/clear"-pReports = "/api/v1/reports"-pSearch = "/api/v1/search"-pStatus = "/api/v1/statuses/:id"-pContext = "/api/v1/statuses/:id/context"-pCard = "/api/v1/statuses/:id/card"-pRebloggedBy = "/api/v1/statuses/:id/reblogged_by"-pFavoritedBy = "/api/v1/statuses/:id/favourited_by"-pStatuses = "/api/v1/statuses"-pDeleteStatus = "/api/v1/statuses/:id"-pHomeTimeline = "/api/v1/timelines/home"-pPublicTimeline = "/api/v1/timelines/public"-pReblog = "/api/v1/statuses/:id/reblog"-pUnreblog = "/api/v1/statuses/:id/unreblog"-pFavorite = "/api/v1/statuses/:id/favourite"-pUnfavorite = "/api/v1/statuses/:id/unfavourite"-pTaggedTimeline = "/api/v1/timelines/tag/:hashtag"--type HastodonId = String--data HastodonClient = HastodonClient {- host :: String,- token :: String-}--data OAuthResponse = OAuthResponse {- accessToken :: String- -- NOTE currently ignore other fields.-} deriving (Show)-instance FromJSON OAuthResponse where- parseJSON (Object v) =- OAuthResponse <$> (v .: T.pack "access_token")--data Account = Account {- accountId :: HastodonId,- accountUsername :: String,- accountAcct :: String,- accountDisplayName :: String,- accountLocked :: Bool,- accountCreatedAt :: String,- accountFollowersCount :: Int,- accountFollowingCount :: Int,- accountStatusesCount :: Int,- accountNote :: String,- accountUrl :: String,- accountAvatar :: String,- accountAvatarStatic :: String,- accountHeader :: String,- accountHeaderStatic :: String-} deriving (Show)-instance FromJSON Account where- parseJSON (Object v) =- Account <$> (v .: T.pack "id")- <*> (v .: T.pack "username")- <*> (v .: T.pack "acct")- <*> (v .: T.pack "display_name")- <*> (v .: T.pack "locked")- <*> (v .: T.pack "created_at")- <*> (v .: T.pack "followers_count")- <*> (v .: T.pack "following_count")- <*> (v .: T.pack "statuses_count")- <*> (v .: T.pack "note")- <*> (v .: T.pack "url")- <*> (v .: T.pack "avatar")- <*> (v .: T.pack "avatar_static")- <*> (v .: T.pack "header")- <*> (v .: T.pack "header_static")--data Application = Application {- applicationName :: String,- applicationWebsite :: Maybe String-} deriving (Show)-instance FromJSON Application where- parseJSON (Object v) =- Application <$> (v .: T.pack "name")- <*> (v .:? T.pack "website")--data Attachment = Attachment {- attachmentId :: HastodonId,- attachmentType :: String,- attachmentUrl :: String,- attachmentRemoteUrl :: Maybe String,- attachmentPreviewUrl :: String,- attachmentTextUrl :: Maybe String-} deriving (Show)-instance FromJSON Attachment where- parseJSON (Object v) =- Attachment <$> (v .: T.pack "id")- <*> (v .: T.pack "type")- <*> (v .: T.pack "url")- <*> (v .:? T.pack "remote_url")- <*> (v .: T.pack "preview_url")- <*> (v .:? T.pack "text_url")--data Card = Card {- cardUrl :: String,- cardTitle :: String,- cardDescription :: String,- cardImage :: String-} deriving (Show)-instance FromJSON Card where- parseJSON (Object v) =- Card <$> (v .: T.pack "url")- <*> (v .: T.pack "title")- <*> (v .: T.pack "description")- <*> (v .: T.pack "image")--data Context = Context {- contextAncestors :: [Status],- contextDescendants :: [Status]-} deriving (Show)-instance FromJSON Context where- parseJSON (Object v) =- Context <$> (v .: T.pack "ancestors")- <*> (v .: T.pack "descendants")--data Instance = Instance {- instanceUri :: String,- instanceTitle :: String,- instanceDescription :: String,- instanceEmail :: String-} deriving (Show)-instance FromJSON Instance where- parseJSON (Object v) =- Instance <$> (v .: T.pack "uri")- <*> (v .: T.pack "title")- <*> (v .: T.pack "description")- <*> (v .: T.pack "email")--data Mention = Mention {- mentionUrl :: String,- mentionUsername :: String,- mentionAcct :: String,- mentionId :: HastodonId-} deriving (Show)-instance FromJSON Mention where- parseJSON (Object v) =- Mention <$> (v .: T.pack "url")- <*> (v .: T.pack "username")- <*> (v .: T.pack "acct")- <*> (v .: T.pack "id")--data Notification = Notification {- notificationId :: HastodonId,- notificationType :: String,- notificationCreatedAt :: String,- notificationAccount :: Account,- notificationStatus :: Maybe Status-} deriving (Show)-instance FromJSON Notification where- parseJSON (Object v) =- Notification <$> (v .: T.pack "id")- <*> (v .: T.pack "type")- <*> (v .: T.pack "created_at")- <*> (v .: T.pack "account")- <*> (v .:? T.pack "status")--data OAuthClient = OAuthClient {- oauthClientId :: HastodonId,- oauthClientRedirectUri :: String,- oauthClientClientId :: String,- oauthClientClientSecret :: String-} deriving (Show)-instance FromJSON OAuthClient where- parseJSON (Object v) =- OAuthClient <$> (v .: T.pack "id")- <*> (v .: T.pack "redirect_uri")- <*> (v .: T.pack "client_id")- <*> (v .: T.pack "client_secret")--data Relationship = Relationship {- relationshipId :: HastodonId,- relationshipFollowing :: Bool,- relationshipFollowed_by :: Bool,- relationshipBlocking :: Bool,- relationshipMuting :: Bool,- relationshipRequested :: Bool-} deriving (Show)-instance FromJSON Relationship where- parseJSON (Object v) =- Relationship <$> (v .: T.pack "id")- <*> (v .: T.pack "following")- <*> (v .: T.pack "followed_by")- <*> (v .: T.pack "blocking")- <*> (v .: T.pack "muting")- <*> (v .: T.pack "requested")--data Report = Report {- reportId :: HastodonId,- reportActionToken :: String-} deriving (Show)-instance FromJSON Report where- parseJSON (Object v) =- Report <$> (v .: T.pack "id")- <*> (v .: T.pack "action_taken")--data Results = Results {- resultAccounts :: [Account],- resultStatus :: [Status],- resultHashtags :: [String]-} deriving (Show)-instance FromJSON Results where- parseJSON (Object v) =- Results <$> (v .: T.pack "accounts")- <*> (v .: T.pack "statuses")- <*> (v .: T.pack "hashtags")--data Status = Status {- statusId :: HastodonId,- statusUri :: String,- statusUrl :: String,- statusAccount :: Account,- statusInReplyToId :: Maybe Int,- statusInReplyToAccountId :: Maybe Int,- statusReblog :: Maybe Status,- statusContent :: String,- statusCreatedAt :: String,- statusReblogsCount :: Int,- statusFavouritesCount :: Int,- statusReblogged :: Maybe Bool,- statusFavourited :: Maybe Bool,- statusSensitive :: Maybe Bool,- statusSpoilerText :: String,- statusVisibility :: String,- statusMediaAttachments :: [Attachment],- statusMentions :: [Mention],- statusTags :: [Tag],- statusApplication :: Maybe Application-} deriving (Show)-instance FromJSON Status where- parseJSON (Object v) =- Status <$> (v .: T.pack "id")- <*> (v .: T.pack "uri")- <*> (maybe "" id <$> (v .:? T.pack "url"))- <*> (v .: T.pack "account")- <*> (v .:? T.pack "in_reply_to_id")- <*> (v .:? T.pack "in_reply_to_account_id")- <*> (v .:? T.pack "reblog")- <*> (v .: T.pack "content")- <*> (v .: T.pack "created_at")- <*> (v .: T.pack "reblogs_count")- <*> (v .: T.pack "favourites_count")- <*> (v .:? T.pack "reblogged")- <*> (v .:? T.pack "favourited")- <*> (v .:? T.pack "sensitive")- <*> (v .: T.pack "spoiler_text")- <*> (v .: T.pack "visibility")- <*> (v .: T.pack "media_attachments")- <*> (v .: T.pack "mentions")- <*> (v .: T.pack "tags")- <*> (v .:? T.pack "application")--data Tag = Tag {- name :: String,- url :: String-} deriving (Show)-instance FromJSON Tag where- parseJSON (Object v) =- Tag <$> (v .: T.pack "name")- <*> (v .: T.pack "url")--- --- helpers--- --getOAuthToken :: String -> String -> String -> String -> String -> IO (Either JSONException OAuthResponse)-getOAuthToken clientId clientSecret username password host = do- initReq <- parseRequest $ "https://" ++ host ++ "/oauth/token"- let reqBody = [(Char8.pack "client_id", utf8ToChar8 clientId),- (Char8.pack "client_secret", utf8ToChar8 clientSecret),- (Char8.pack "username", utf8ToChar8 username),- (Char8.pack "password", utf8ToChar8 password),- (Char8.pack "grant_type", Char8.pack "password"),- (Char8.pack "scope", Char8.pack "read write follow")]- let req = setRequestBodyURLEncoded reqBody $ initReq- res <- httpJSONEither req- return $ (getResponseBody res :: Either JSONException OAuthResponse)--mkHastodonHeader :: String -> Request -> Request-mkHastodonHeader token =- addRequestHeader hAuthorization $ utf8ToChar8 $ "Bearer " ++ token--mkHastodonRequest :: String -> HastodonClient -> IO Request-mkHastodonRequest path client = do- initReq <- parseRequest $ "https://" ++ (host client) ++ path- return $ mkHastodonHeader (token client) $ initReq--getHastodonResponseBody :: String -> HastodonClient -> IO LChar8.ByteString-getHastodonResponseBody path client = do- req <- mkHastodonRequest path client- res <- httpLBS req- return $ getResponseBody res--getHastodonResponseJSON path client = mkHastodonRequest path client >>= httpJSONEither--postAndGetHastodonResult path body client = do- initReq <- mkHastodonRequest path client- let req = setRequestBodyURLEncoded body $ initReq- res <- httpNoBody req- return $ (getResponseStatusCode res) == 200--postAndGetHastodonResponseJSON path body client = do- initReq <- mkHastodonRequest path client- let req = setRequestBodyURLEncoded body $ initReq- httpJSONEither req---- --- exported functions--- --mkHastodonClient :: String -> String -> String -> String -> String -> IO (Maybe HastodonClient)-mkHastodonClient clientId clientSecret username password host = do- oauthRes <- getOAuthToken clientId clientSecret username password host- case oauthRes of- Left err -> return $ Nothing- Right oauthData -> return $ Just $ HastodonClient host (accessToken oauthData)--getAccountById :: HastodonClient -> Int -> IO (Either JSONException Account)-getAccountById client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pAccountById) client- return (getResponseBody res :: Either JSONException Account)--getCurrentAccount :: HastodonClient -> IO (Either JSONException Account)-getCurrentAccount client = do- res <- getHastodonResponseJSON pCurrentAccounts client- return (getResponseBody res :: Either JSONException Account)---- TODO support options-getFollowers :: HastodonClient -> Int -> IO (Either JSONException [Account])-getFollowers client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pFollowers) client- return (getResponseBody res :: Either JSONException [Account])--getFollowing :: HastodonClient -> Int -> IO (Either JSONException [Account])-getFollowing client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pFollowing) client- return (getResponseBody res :: Either JSONException [Account])--getAccountStatuses :: HastodonClient -> Int -> IO (Either JSONException [Status])-getAccountStatuses client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pAccountStatuses) client- return (getResponseBody res :: Either JSONException [Status])--getRelationships :: HastodonClient -> [Int] -> IO (Either JSONException [Relationship])-getRelationships client ids = do- let intIds = map (show) ids- let params = foldl (\x y -> x ++ (if x == "" then "?" else "&") ++ "id%5b%5d=" ++ y) "" intIds- res <- getHastodonResponseJSON (pRelationships ++ params) client- return (getResponseBody res :: Either JSONException [Relationship])--getSearchedAccounts :: HastodonClient -> String -> IO (Either JSONException [Account])-getSearchedAccounts client query = do- res <- getHastodonResponseJSON (pSearchAccounts ++ "?q=" ++ query) client- return (getResponseBody res :: Either JSONException [Account])--postFollow :: HastodonClient -> Int -> IO (Either JSONException Relationship)-postFollow client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pFollow) [] client- return (getResponseBody res :: Either JSONException Relationship)--postUnfollow :: HastodonClient -> Int -> IO (Either JSONException Relationship)-postUnfollow client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnfollow) [] client- return (getResponseBody res :: Either JSONException Relationship)--postBlock :: HastodonClient -> Int -> IO (Either JSONException Relationship)-postBlock client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pBlock) [] client- return (getResponseBody res :: Either JSONException Relationship)--postUnblock :: HastodonClient -> Int -> IO (Either JSONException Relationship)-postUnblock client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnblock) [] client- return (getResponseBody res :: Either JSONException Relationship)--postMute :: HastodonClient -> Int -> IO (Either JSONException Relationship)-postMute client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pMute) [] client- return (getResponseBody res :: Either JSONException Relationship)--postUnmute :: HastodonClient -> Int -> IO (Either JSONException Relationship)-postUnmute client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnmute) [] client- return (getResponseBody res :: Either JSONException Relationship)--postApps :: String -> String -> IO (Either JSONException OAuthClient)-postApps host clientName = do- let reqBody = [(Char8.pack "client_name", utf8ToChar8 clientName),- (Char8.pack "redirect_uris", Char8.pack "urn:ietf:wg:oauth:2.0:oob"),- (Char8.pack "scopes", Char8.pack "read write follow")]- initReq <- parseRequest $ "https://" ++ host ++ pApps- let req = setRequestBodyURLEncoded reqBody $ initReq- res <- httpJSONEither req- return (getResponseBody res :: Either JSONException OAuthClient)--getBlocks :: HastodonClient -> IO (Either JSONException [Account])-getBlocks client = do- res <- getHastodonResponseJSON pBlocks client- return (getResponseBody res :: Either JSONException [Account])--getFavorites :: HastodonClient -> IO (Either JSONException [Status])-getFavorites client = do- res <- getHastodonResponseJSON pFavorites client- return (getResponseBody res :: Either JSONException [Status])--getFollowRequests :: HastodonClient -> IO (Either JSONException [Account])-getFollowRequests client = do- res <- getHastodonResponseJSON pFollowRequests client- return (getResponseBody res :: Either JSONException [Account])--postAuthorizeRequest :: HastodonClient -> Int -> IO Bool-postAuthorizeRequest client id = postAndGetHastodonResult (replace ":id" (show id) pAuthorizeRequest) [] client--postRejectRequest :: HastodonClient -> Int -> IO Bool-postRejectRequest client id = postAndGetHastodonResult (replace ":id" (show id) pRejectRequest) [] client--getInstance :: HastodonClient -> IO (Either JSONException Instance)-getInstance client = do- res <- getHastodonResponseJSON pInstance client- return (getResponseBody res :: Either JSONException Instance)--postMediaFile :: HastodonClient -> String -> String -> IO (Either JSONException Attachment)-postMediaFile client filename description = do- initReq <- mkHastodonRequest pMedia client- let file = partFileSource (T.pack "file") filename- let mimetype = defaultMimeLookup (T.pack filename)- req <- formDataBody [file { partContentType = Just mimetype },- partBS (T.pack "description") (utf8ToChar8 description)- ] initReq- res <- httpJSONEither req- return (getResponseBody res :: Either JSONException Attachment)--getMutes :: HastodonClient -> IO (Either JSONException [Account])-getMutes client = do- res <- getHastodonResponseJSON pMutes client- return (getResponseBody res :: Either JSONException [Account])--getNotifications :: HastodonClient -> IO (Either JSONException [Notification])-getNotifications client = do- res <- getHastodonResponseJSON pNotifications client- return (getResponseBody res :: Either JSONException [Notification])--getNotificationById :: HastodonClient -> Int -> IO (Either JSONException Notification)-getNotificationById client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pNotificationById) client- return (getResponseBody res :: Either JSONException Notification)--postNotificationsClear :: HastodonClient -> IO Bool-postNotificationsClear = postAndGetHastodonResult pNotificationClear []--getReports :: HastodonClient -> IO (Either JSONException [Report])-getReports client = do- res <- getHastodonResponseJSON pReports client- return (getResponseBody res :: Either JSONException [Report])--getSearchedResults :: HastodonClient -> String -> IO (Either JSONException [Results])-getSearchedResults client query = do- res <- getHastodonResponseJSON (pSearch ++ "?q=" ++ query) client- return (getResponseBody res :: Either JSONException [Results])--getStatus :: HastodonClient -> Int -> IO (Either JSONException Status)-getStatus client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pStatus) client- return (getResponseBody res :: Either JSONException Status)--getCard :: HastodonClient -> Int -> IO (Either JSONException Card)-getCard client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pCard) client- return (getResponseBody res :: Either JSONException Card)--getContext :: HastodonClient -> Int -> IO (Either JSONException Context)-getContext client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pContext) client- return (getResponseBody res :: Either JSONException Context)--getRebloggedBy :: HastodonClient -> Int -> IO (Either JSONException [Account])-getRebloggedBy client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pRebloggedBy) client- return (getResponseBody res :: Either JSONException [Account])--getFavoritedBy :: HastodonClient -> Int -> IO (Either JSONException [Account])-getFavoritedBy client id = do- res <- getHastodonResponseJSON (replace ":id" (show id) pFavoritedBy) client- return (getResponseBody res :: Either JSONException [Account])--postStatus :: HastodonClient -> String -> IO (Either JSONException Status)-postStatus client status = do- res <- postAndGetHastodonResponseJSON pStatuses [(Char8.pack "status", utf8ToChar8 status)] client- return (getResponseBody res :: Either JSONException Status)--postStatusWithMediaIds :: HastodonClient -> String -> [HastodonId] -> IO (Either JSONException Status)-postStatusWithMediaIds client status mediaIds = do- let unpackedMediaIds = [(Char8.pack "media_ids[]",utf8ToChar8 media)|media <- mediaIds] -- Rails array parameter convention?- let body = (Char8.pack "status",utf8ToChar8 status):unpackedMediaIds- res <- postAndGetHastodonResponseJSON pStatuses body client- return (getResponseBody res :: Either JSONException Status)--postReblog :: HastodonClient -> Int -> IO (Either JSONException Status)-postReblog client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pReblog) [] client- return (getResponseBody res :: Either JSONException Status)--postUnreblog :: HastodonClient -> Int -> IO (Either JSONException Status)-postUnreblog client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnreblog) [] client- return (getResponseBody res :: Either JSONException Status)--postFavorite :: HastodonClient -> Int -> IO (Either JSONException Status)-postFavorite client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pFavorite) [] client- return (getResponseBody res :: Either JSONException Status)--postUnfavorite :: HastodonClient -> Int -> IO (Either JSONException Status)-postUnfavorite client id = do- res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnfavorite) [] client- return (getResponseBody res :: Either JSONException Status)--getHomeTimeline :: HastodonClient -> IO (Either JSONException [Status])-getHomeTimeline client = do- res <- getHastodonResponseJSON pHomeTimeline client- return (getResponseBody res :: Either JSONException [Status])--getPublicTimeline :: HastodonClient -> IO (Either JSONException [Status])-getPublicTimeline client = do- res <- getHastodonResponseJSON pPublicTimeline client- return (getResponseBody res :: Either JSONException [Status])--getTaggedTimeline :: HastodonClient -> String -> IO (Either JSONException [Status])-getTaggedTimeline client hashtag = do- res <- getHastodonResponseJSON (replace ":hashtag" hashtag pTaggedTimeline) client- return (getResponseBody res :: Either JSONException [Status])+import Web.Hastodon.API+import Web.Hastodon.Streaming+import Web.Hastodon.Types+import Web.Hastodon.Util