packages feed

Hastodon 0.4.0 → 0.4.1

raw patch · 5 files changed

+817/−2 lines, 5 files

Files

Hastodon.cabal view
@@ -1,5 +1,5 @@ Name: Hastodon-Version: 0.4.0+Version: 0.4.1 Synopsis: mastodon client module for Haskell Category: Web Description: mastodon client module for Haskell@@ -35,4 +35,8 @@                  transformers    Exposed-Modules: Web.Hastodon-  Other-Modules:+  Other-Modules: Web.Hastodon.API,+                 Web.Hastodon.Streaming,+                 Web.Hastodon.Types,+                 Web.Hastodon.Util+
+ Web/Hastodon/API.hs view
@@ -0,0 +1,368 @@+module Web.Hastodon.API+  ( mkHastodonClient+  , getAccountById+  , getCurrentAccount+  , getFollowers+  , getFollowing+  , getAccountStatuses+  , postFollow+  , postUnfollow+  , postBlock+  , postUnblock+  , postMute+  , postUnmute+  , getRelationships+  , getSearchedAccounts+  , postApps+  , getBlocks+  , getFavorites+  , getFollowRequests+  , postAuthorizeRequest+  , postRejectRequest+  , getInstance+  , postMediaFile+  , getMutes+  , getNotifications+  , getNotificationById+  , postNotificationsClear+  , getReports+  , getSearchedResults+  , getStatus+  , getCard+  , getContext+  , getRebloggedBy+  , getFavoritedBy+  , postStatus+  , postStatusWithMediaIds+  , 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 qualified Data.Text.Encoding as T+import Data.String.Utils+import Network.HTTP.Simple+import Network.HTTP.Client.MultipartFormData+import Network.Mime++import Web.Hastodon.Types+import Web.Hastodon.Util+++--+-- 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"+++--+-- 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)++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])+
+ Web/Hastodon/Streaming.hs view
@@ -0,0 +1,130 @@+{-# LANGUAGE OverloadedStrings #-}+{-# LANGUAGE RankNTypes #-}++module Web.Hastodon.Streaming+  ( StreamingPayload(..)+  , StreamingResponse+  , streamUser+  , streamPublic+  , streamLocal+  , streamHashtag+  , streamList+  ) where++import           Prelude hiding (takeWhile)+import           Control.Applicative ((<|>), many, some)+import           Data.Aeson+import           Data.Attoparsec.ByteString as A+import           Data.Attoparsec.ByteString.Char8 as C8+import qualified Data.ByteString as BS+import           Data.ByteString (ByteString)+import qualified Data.ByteString.Char8 as B8+import           Data.Maybe (maybeToList)+import           Conduit+import           Network.HTTP.Simple+import           Web.Hastodon.Util+import           Web.Hastodon.Types+++----+-- Public API+----++pStreamUser        = "/api/v1/streaming/user"+pStreamPublic      = "/api/v1/streaming/public"+pStreamLocal       = "/api/v1/streaming/public/local"+pStreamHashtag     = "/api/v1/streaming/hashtag"+pStreamList        = "/api/v1/streaming/list"++type StreamingResponse m =+  forall m. MonadResource m => ConduitT () StreamingPayload m ()++data StreamingPayload = SUpdate Status             |+                        SNotification Notification |+                        SDelete HastodonId         |+                        Thump+                        deriving (Show)++data EventType = EUpdate | ENotification | EDelete+++streamUser :: HastodonClient -> StreamingResponse m+streamUser client = getStreamingResponse pStreamUser client++streamPublic :: HastodonClient -> StreamingResponse m+streamPublic client = getStreamingResponse pStreamPublic client++streamLocal :: HastodonClient -> StreamingResponse m+streamLocal client = getStreamingResponse pStreamLocal client++streamHashtag :: HastodonClient -> String -> StreamingResponse m+streamHashtag client hashtag = getStreamingResponse ph client where+  ph = pStreamHashtag ++ "?hashtag=" ++ hashtag++streamList :: HastodonClient -> String -> StreamingResponse m+streamList client list = getStreamingResponse l client where+  l = pStreamList ++ "?list=" ++ list+++----+-- Private stuff+----++stream :: ByteString -> ByteString -> (ByteString, [StreamingPayload])+stream i a | isThump i = ("", [Thump])+           | isEvent i = (i, [])+           | otherwise = parseE a i+  where parseE et d =+          case parseET et of+            (Just EDelete) -> ("", p parseDelete d)+            (Just ENotification) -> ("", p parseNotification d)+            (Just EUpdate) -> ("",p parseUpdate d)+            Nothing -> ("", [])+        p r s = maybeToList $ maybeResult $ parse r s+        isThump = (":thump" `B8.isPrefixOf`)+        isEvent = ("event: " `B8.isPrefixOf`)+        parseET s = maybeResult $ parse parseEvent s++parseEvent :: Parser EventType+parseEvent = do+  string "event: "+  try ("delete" *> return EDelete)   <|>+    try ("update" *> return EUpdate) <|>+    try ("notification" *> return ENotification)++pd = string "data: "++parseDelete :: Parser StreamingPayload+parseDelete = do+  pd+  i <- many C8.digit+  return $ SDelete i+++eoc :: String -> Char -> Maybe String+eoc "\n" '\n' = Nothing+eoc acc c = Just (c:acc)++parseNotification :: Parser StreamingPayload+parseNotification = do+  pd+  s <- C8.takeTill (== '\n')+  case (decodeStrict' s :: Maybe Notification) of+    Nothing -> fail $ "decode error"+    (Just n) -> return $ SNotification n++parseUpdate :: Parser StreamingPayload+parseUpdate = do+  pd+  s <- C8.takeTill (== '\n')+  case (decodeStrict' s :: Maybe Status) of+    Nothing -> fail $ "decode error"+    (Just s) -> return $ SUpdate s++parseStream :: forall m. MonadResource m =>+  ConduitT ByteString StreamingPayload m ()+parseStream = concatMapAccumC stream ""++getStreamingResponse path client = do+  req <- liftIO $ mkHastodonRequest path client+  httpSource req getResponseBody .| parseStream
+ Web/Hastodon/Types.hs view
@@ -0,0 +1,279 @@+{-# LANGUAGE OverloadedStrings #-}+module Web.Hastodon.Types+  ( HastodonId+  , OAuthResponse(..)+  , Account(..)+  , Application(..)+  , Attachment(..)+  , Card(..)+  , Context(..)+  , Instance(..)+  , Mention(..)+  , Notification(..)+  , OAuthClient(..)+  , Relationship(..)+  , Report(..)+  , Results(..)+  , Status(..)+  , Tag(..)+  ) where++import Data.Aeson+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+++type HastodonId = String++data OAuthResponse = OAuthResponse {+  accessToken :: String+  -- NOTE currently ignore other fields.+} deriving (Show)+instance FromJSON OAuthResponse where+  parseJSON (Object v) =+    OAuthResponse <$> (v .: "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 .: "id")+            <*> (v .: "username")+            <*> (v .: "acct")+            <*> (v .: "display_name")+            <*> (v .: "locked")+            <*> (v .: "created_at")+            <*> (v .: "followers_count")+            <*> (v .: "following_count")+            <*> (v .: "statuses_count")+            <*> (v .: "note")+            <*> (v .: "url")+            <*> (v .: "avatar")+            <*> (v .: "avatar_static")+            <*> (v .: "header")+            <*> (v .: "header_static")++data Application = Application {+  applicationName :: String,+  applicationWebsite :: Maybe String+} deriving (Show)+instance FromJSON Application where+  parseJSON (Object v) =+    Application <$> (v .:  "name")+                <*> (v .:? "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 .:  "id")+               <*> (v .:  "type")+               <*> (v .:  "url")+               <*> (v .:? "remote_url")+               <*> (v .:  "preview_url")+               <*> (v .:? "text_url")++data Card = Card {+  cardUrl :: String,+  cardTitle :: String,+  cardDescription :: String,+  cardImage :: String+} deriving (Show)+instance FromJSON Card where+  parseJSON (Object v) =+    Card <$> (v .: "url")+         <*> (v .: "title")+         <*> (v .: "description")+         <*> (v .: "image")++data Context = Context {+  contextAncestors :: [Status],+  contextDescendants :: [Status]+} deriving (Show)+instance FromJSON Context where+  parseJSON (Object v) =+    Context <$> (v .: "ancestors")+            <*> (v .: "descendants")++data Instance = Instance {+  instanceUri :: String,+  instanceTitle :: String,+  instanceDescription :: String,+  instanceEmail :: String+} deriving (Show)+instance FromJSON Instance where+  parseJSON (Object v) =+    Instance <$> (v .: "uri")+             <*> (v .: "title")+             <*> (v .: "description")+             <*> (v .: "email")++data Mention = Mention {+  mentionUrl :: String,+  mentionUsername :: String,+  mentionAcct :: String,+  mentionId :: HastodonId+} deriving (Show)+instance FromJSON Mention where+  parseJSON (Object v) =+    Mention <$> (v .: "url")+            <*> (v .: "username")+            <*> (v .: "acct")+            <*> (v .: "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 .:  "id")+                 <*> (v .:  "type")+                 <*> (v .:  "created_at")+                 <*> (v .:  "account")+                 <*> (v .:? "status")++data OAuthClient = OAuthClient {+  oauthClientId :: HastodonId,+  oauthClientRedirectUri :: String,+  oauthClientClientId :: String,+  oauthClientClientSecret :: String+} deriving (Show)+instance FromJSON OAuthClient where+  parseJSON (Object v) =+    OAuthClient <$> (v .: "id")+                <*> (v .: "redirect_uri")+                <*> (v .: "client_id")+                <*> (v .: "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 .: "id")+                 <*> (v .: "following")+                 <*> (v .: "followed_by")+                 <*> (v .: "blocking")+                 <*> (v .: "muting")+                 <*> (v .: "requested")++data Report = Report {+  reportId :: HastodonId,+  reportActionToken :: String+} deriving (Show)+instance FromJSON Report where+  parseJSON (Object v) =+    Report <$> (v .: "id")+           <*> (v .: "action_taken")++data Results = Results {+  resultAccounts :: [Account],+  resultStatus :: [Status],+  resultHashtags :: [String]+} deriving (Show)+instance FromJSON Results where+  parseJSON (Object v) =+    Results <$> (v .: "accounts")+            <*> (v .: "statuses")+            <*> (v .: "hashtags")++data Emoji = Emoji {+  emojiShortcode :: String,+  emojiStaticUrl :: String,+  emojiUrl :: String+} deriving (Show)+instance FromJSON Emoji where+ parseJSON (Object v) =+   Emoji <$> (v .: "shortcode")+         <*> (v .: "static_url")+         <*> (v .: "url")++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,+  statusMuted :: Maybe Bool,+  statusSensitive :: Maybe Bool,+  statusSpoilerText :: String,+  statusVisibility :: String,+  statusMediaAttachments :: [Attachment],+  statusMentions :: [Mention],+  statusTags :: [Tag],+  statusApplication :: Maybe Application,+  statusEmojis :: [Emoji],+  statusLanguage :: Maybe String+} deriving (Show)+instance FromJSON Status where+  parseJSON (Object v) =+    Status <$> (v .:  "id")+           <*> (v .:  "uri")+           <*> (v .:  "url")+           <*> (v .:  "account")+           <*> (v .:? "in_reply_to_id")+           <*> (v .:? "in_reply_to_account_id")+           <*> (v .:? "reblog")+           <*> (v .:  "content")+           <*> (v .:  "created_at")+           <*> (v .:  "reblogs_count")+           <*> (v .:  "favourites_count")+           <*> (v .:? "reblogged")+           <*> (v .:? "favourited")+           <*> (v .:? "muted")+           <*> (v .:? "sensitive")+           <*> (v .:  "spoiler_text")+           <*> (v .:  "visibility")+           <*> (v .:  "media_attachments")+           <*> (v .:  "mentions")+           <*> (v .:  "tags")+           <*> (v .:? "application")+           <*> (v .: "emojis")+           <*> (v .:? "language")++data Tag = Tag {+  name :: String,+  url :: String+} deriving (Show)+instance FromJSON Tag where+  parseJSON (Object v) =+    Tag <$> (v .: "name")+        <*> (v .: "url")
+ Web/Hastodon/Util.hs view
@@ -0,0 +1,34 @@+module Web.Hastodon.Util+  ( HastodonClient(..)+  , mkHastodonHeader+  , mkHastodonRequest+  , utf8ToChar8+  ) where+++import qualified Data.ByteString.Char8 as Char8+import qualified Data.Text as T+import qualified Data.Text.Encoding as T+import Network.HTTP.Simple+import Network.HTTP.Types.Header+++data HastodonClient = HastodonClient {+  host :: String,+  token :: String+}+++mkHastodonRequest :: String -> HastodonClient -> IO Request+mkHastodonRequest path client = do+  initReq <- parseRequest $ "https://" ++ (host client) ++ path+  return $ mkHastodonHeader (token client) $ initReq+++mkHastodonHeader :: String -> Request -> Request+mkHastodonHeader token =+  addRequestHeader hAuthorization $ utf8ToChar8 $ "Bearer " ++ token+++utf8ToChar8 :: String -> Char8.ByteString+utf8ToChar8 = T.encodeUtf8 . T.pack