diff --git a/Hastodon.cabal b/Hastodon.cabal new file mode 100644 --- /dev/null +++ b/Hastodon.cabal @@ -0,0 +1,31 @@ +Name: Hastodon +Version: 0.0.1 +Synopsis: mastodon client module for Haskell +Category: Web +Description: mastodon client module for Haskell +Author: Ryo Okubo +Maintainer: syucream1031@gmail.com +Homepage: https://github.com/syucream/hastodon +cabal-version: >= 1.10 + +License: MIT +license-file: LICENSE +Stability: experimental +build-type: Simple + +Source-repository head + type: git + location: https://github.com/syucream/hastodon.git + +Library + default-language: Haskell2010 + Build-Depends: base >= 4.5 && < 5, + aeson, + bytestring, + http-types, + http-conduit, + MissingH, + text + + Exposed-Modules: Web.Hastodon + Other-Modules: diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,21 @@ +MIT License + +Copyright (c) 2017 Ryo Okubo + +Permission is hereby granted, free of charge, to any person obtaining a copy +of this software and associated documentation files (the "Software"), to deal +in the Software without restriction, including without limitation the rights +to use, copy, modify, merge, publish, distribute, sublicense, and/or sell +copies of the Software, and to permit persons to whom the Software is +furnished to do so, subject to the following conditions: + +The above copyright notice and this permission notice shall be included in all +copies or substantial portions of the Software. + +THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR +IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, +FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE +AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER +LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, +OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE +SOFTWARE. diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/Web/Hastodon.hs b/Web/Hastodon.hs new file mode 100644 --- /dev/null +++ b/Web/Hastodon.hs @@ -0,0 +1,564 @@ +module Web.Hastodon + ( + mkHastodonClient + + , getAccountById + , getCurrentAccount + , getFollowers + , getFollowing + , getAccountStatuses + , postFollow + , postUnfollow + , postBlock + , postUnblock + , postMute + , postUnmute + , getRelationships + , getSearchedAccounts + , postApps + , getBlocks + , getFavorites + , getFollowRequests + , postAuthorizeRequest + , postRejectRequest + , getInstance + , getMutes + , getNotifications + , getNotificationById + , postNotificationsClear + , getReports + , getSearchedResults + , getStatus + , getCard + , getContext + , getRebloggedBy + , getFavoritedBy + , postStatus + , postReblog + , postUnreblog + , postFavorite + , postUnfavorite + , getHomeTimeline + , getPublicTimeline + , getTaggedTimeline + ) 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 Data.String.Utils +import Network.HTTP.Simple +import Network.HTTP.Types.Header + +-- +-- 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" +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" + +data HastodonClient = HastodonClient { + host :: String, + token :: String +} + +data Account = Account { + accountId :: Int, + 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 :: Int, + attachmentType :: String, + attachmentUrl :: String, + attachmentRemoteUrl :: 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 :: Int +} 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 :: Int, + 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 :: Int, + 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 :: Int, + 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 :: Int, + 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 :: Int, + 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") + <*> (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 +-- + +mkHastodonHeader :: String -> Request -> Request +mkHastodonHeader token = + addRequestHeader hAuthorization $ Char8.pack $ "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 -> HastodonClient +mkHastodonClient host token = HastodonClient host token + +getAccountById :: Int -> HastodonClient -> IO (Either JSONException Account) +getAccountById id client = 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 :: Int -> HastodonClient -> IO (Either JSONException [Account]) +getFollowers id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pFollowers) client + return (getResponseBody res :: Either JSONException [Account]) + +getFollowing :: Int -> HastodonClient -> IO (Either JSONException [Account]) +getFollowing id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pFollowing) client + return (getResponseBody res :: Either JSONException [Account]) + +getAccountStatuses :: Int -> HastodonClient -> IO (Either JSONException [Status]) +getAccountStatuses id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pAccountStatuses) client + return (getResponseBody res :: Either JSONException [Status]) + +getRelationships :: [Int] -> HastodonClient -> IO (Either JSONException [Relationship]) +getRelationships ids client = 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 :: String -> HastodonClient -> IO (Either JSONException [Account]) +getSearchedAccounts query client = do + res <- getHastodonResponseJSON (pSearchAccounts ++ "?q=" ++ query) client + return (getResponseBody res :: Either JSONException [Account]) + +postFollow :: Int -> HastodonClient -> IO (Either JSONException Relationship) +postFollow id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pFollow) [] client + return (getResponseBody res :: Either JSONException Relationship) + +postUnfollow :: Int -> HastodonClient -> IO (Either JSONException Relationship) +postUnfollow id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnfollow) [] client + return (getResponseBody res :: Either JSONException Relationship) + +postBlock :: Int -> HastodonClient -> IO (Either JSONException Relationship) +postBlock id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pBlock) [] client + return (getResponseBody res :: Either JSONException Relationship) + +postUnblock :: Int -> HastodonClient -> IO (Either JSONException Relationship) +postUnblock id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnblock) [] client + return (getResponseBody res :: Either JSONException Relationship) + +postMute :: Int -> HastodonClient -> IO (Either JSONException Relationship) +postMute id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pMute) [] client + return (getResponseBody res :: Either JSONException Relationship) + +postUnmute :: Int -> HastodonClient -> IO (Either JSONException Relationship) +postUnmute id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnmute) [] client + return (getResponseBody res :: Either JSONException Relationship) + +postApps :: String -> HastodonClient -> IO (Either JSONException OAuthClient) +postApps clientName client = do + let reqBody = [(Char8.pack "client_name", Char8.pack clientName), + (Char8.pack "redirect_uris", Char8.pack "urn:ietf:wg:oauth:2.0:oob"), + (Char8.pack "scopes", Char8.pack "read write follow")] + res <- postAndGetHastodonResponseJSON pApps reqBody client + 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 :: Int -> HastodonClient -> IO Bool +postAuthorizeRequest id = postAndGetHastodonResult (replace ":id" (show id) pAuthorizeRequest) [] + +postRejectRequest :: Int -> HastodonClient -> IO Bool +postRejectRequest id = postAndGetHastodonResult (replace ":id" (show id) pRejectRequest) [] + +getInstance :: HastodonClient -> IO (Either JSONException Instance) +getInstance client = do + res <- getHastodonResponseJSON pInstance client + return (getResponseBody res :: Either JSONException Instance) + +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 :: Int -> HastodonClient -> IO (Either JSONException Notification) +getNotificationById id client = 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 :: String -> HastodonClient -> IO (Either JSONException [Results]) +getSearchedResults query client = do + res <- getHastodonResponseJSON (pSearch ++ "?q=" ++ query) client + return (getResponseBody res :: Either JSONException [Results]) + +getStatus :: Int -> HastodonClient -> IO (Either JSONException Status) +getStatus id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pStatus) client + return (getResponseBody res :: Either JSONException Status) + +getCard :: Int -> HastodonClient -> IO (Either JSONException Card) +getCard id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pCard) client + return (getResponseBody res :: Either JSONException Card) + +getContext :: Int -> HastodonClient -> IO (Either JSONException Context) +getContext id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pContext) client + return (getResponseBody res :: Either JSONException Context) + +getRebloggedBy :: Int -> HastodonClient -> IO (Either JSONException [Account]) +getRebloggedBy id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pRebloggedBy) client + return (getResponseBody res :: Either JSONException [Account]) + +getFavoritedBy :: Int -> HastodonClient -> IO (Either JSONException [Account]) +getFavoritedBy id client = do + res <- getHastodonResponseJSON (replace ":id" (show id) pFavoritedBy) client + return (getResponseBody res :: Either JSONException [Account]) + +postStatus :: String -> HastodonClient -> IO (Either JSONException Status) +postStatus status client = do + res <- postAndGetHastodonResponseJSON pStatuses [(Char8.pack "status", Char8.pack status)] client + return (getResponseBody res :: Either JSONException Status) + +postReblog :: Int -> HastodonClient -> IO (Either JSONException Status) +postReblog id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pReblog) [] client + return (getResponseBody res :: Either JSONException Status) + +postUnreblog :: Int -> HastodonClient -> IO (Either JSONException Status) +postUnreblog id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnreblog) [] client + return (getResponseBody res :: Either JSONException Status) + +postFavorite :: Int -> HastodonClient -> IO (Either JSONException Status) +postFavorite id client = do + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pFavorite) [] client + return (getResponseBody res :: Either JSONException Status) + +postUnfavorite :: Int -> HastodonClient -> IO (Either JSONException Status) +postUnfavorite id client = 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 :: String -> HastodonClient -> IO (Either JSONException [Status]) +getTaggedTimeline hashtag client = do + res <- getHastodonResponseJSON (replace ":hashtag" hashtag pTaggedTimeline) client + return (getResponseBody res :: Either JSONException [Status])