diff --git a/Hastodon.cabal b/Hastodon.cabal --- a/Hastodon.cabal +++ b/Hastodon.cabal @@ -1,5 +1,5 @@ Name: Hastodon -Version: 0.4.1 +Version: 0.5.0 Synopsis: mastodon client module for Haskell Category: Web Description: mastodon client module for Haskell @@ -32,9 +32,12 @@ MissingH, resourcet, text, - transformers + transformers, + containers - Exposed-Modules: Web.Hastodon + Exposed-Modules: Web.Hastodon, + Web.Hastodon.Option + Other-Modules: Web.Hastodon.API, Web.Hastodon.Streaming, Web.Hastodon.Types, diff --git a/Web/Hastodon.hs b/Web/Hastodon.hs --- a/Web/Hastodon.hs +++ b/Web/Hastodon.hs @@ -1,5 +1,7 @@ module Web.Hastodon - ( HastodonClient(..) + ( module Web.Hastodon.Option + + , HastodonClient(..) , Account(..) , Application(..) , Attachment(..) @@ -21,44 +23,61 @@ , getAccountById , getCurrentAccount , getFollowers + , getFollowersWithOption , getFollowing + , getFollowingWithOption , getAccountStatuses + , getAccountStatusesWithOption , postFollow , postUnfollow , postBlock , postUnblock , postMute + , postMuteWithOption , postUnmute , getRelationships , getSearchedAccounts + , getSearchedAccountsWithOption , postApps , getBlocks + , getBlocksWithOption , getFavorites + , getFavoritesWithOption , getFollowRequests + , getFollowRequestsWithOption , postAuthorizeRequest , postRejectRequest , getInstance , postMediaFile , getMutes + , getMutesWithOption , getNotifications + , getNotificationsWithOption , getNotificationById , postNotificationsClear , getReports , getSearchedResults + , getSearchedResultsWithOption , getStatus , getCard , getContext , getRebloggedBy + , getRebloggedByWithOption , getFavoritedBy + , getFavoritedByWithOption , postStatus + , postStatusWithOption , postStatusWithMediaIds , postReblog , postUnreblog , postFavorite , postUnfavorite , getHomeTimeline + , getHomeTimelineWithOption , getPublicTimeline + , getPublicTimelineWithOption , getTaggedTimeline + , getTaggedTimelineWithOption , streamUser , streamPublic @@ -69,6 +88,7 @@ import Web.Hastodon.API +import Web.Hastodon.Option import Web.Hastodon.Streaming import Web.Hastodon.Types import Web.Hastodon.Util diff --git a/Web/Hastodon/API.hs b/Web/Hastodon/API.hs --- a/Web/Hastodon/API.hs +++ b/Web/Hastodon/API.hs @@ -3,44 +3,61 @@ , getAccountById , getCurrentAccount , getFollowers + , getFollowersWithOption , getFollowing + , getFollowingWithOption , getAccountStatuses + , getAccountStatusesWithOption , postFollow , postUnfollow , postBlock , postUnblock , postMute + , postMuteWithOption , postUnmute , getRelationships , getSearchedAccounts + , getSearchedAccountsWithOption , postApps , getBlocks + , getBlocksWithOption , getFavorites + , getFavoritesWithOption , getFollowRequests + , getFollowRequestsWithOption , postAuthorizeRequest , postRejectRequest , getInstance , postMediaFile , getMutes + , getMutesWithOption , getNotifications + , getNotificationsWithOption , getNotificationById , postNotificationsClear , getReports , getSearchedResults + , getSearchedResultsWithOption , getStatus , getCard , getContext , getRebloggedBy + , getRebloggedByWithOption , getFavoritedBy + , getFavoritedByWithOption , postStatus + , postStatusWithOption , postStatusWithMediaIds , postReblog , postUnreblog , postFavorite , postUnfavorite , getHomeTimeline + , getHomeTimelineWithOption , getPublicTimeline + , getPublicTimelineWithOption , getTaggedTimeline + , getTaggedTimelineWithOption ) where import Control.Applicative @@ -56,6 +73,7 @@ import Web.Hastodon.Types import Web.Hastodon.Util +import Web.Hastodon.Option -- @@ -127,6 +145,9 @@ res <- httpLBS req return $ getResponseBody res +getHastodonResponseJSONWithOption opt path client = + mkHastodonRequestWithQuery opt path client >>= httpJSONEither + getHastodonResponseJSON path client = mkHastodonRequest path client >>= httpJSONEither postAndGetHastodonResult path body client = do @@ -161,22 +182,39 @@ 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 +getFollowers client = getFollowersWithOption client mempty + +getFollowersWithOption :: HastodonClient -> RangeOption -> Int -> IO (Either JSONException [Account]) +getFollowersWithOption client opt id = do + res <- getHastodonResponseJSONWithOption + (optionAsQuery opt) + (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 +getFollowing client = getFollowingWithOption client mempty + +getFollowingWithOption :: HastodonClient -> RangeOption -> Int -> IO (Either JSONException [Account]) +getFollowingWithOption client opt id = do + res <- getHastodonResponseJSONWithOption + (optionAsQuery opt) + (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 +getAccountStatusesWithOption :: HastodonClient -> GetAccountStatusesOption -> Int -> IO (Either JSONException [Status]) +getAccountStatusesWithOption client opt id = do + res <- getHastodonResponseJSONWithOption + (optionAsQuery opt) + (replace ":id" (show id) pAccountStatuses) + client return (getResponseBody res :: Either JSONException [Status]) +getAccountStatuses :: HastodonClient -> Int -> IO (Either JSONException [Status]) +getAccountStatuses client = getAccountStatusesWithOption client mempty + getRelationships :: HastodonClient -> [Int] -> IO (Either JSONException [Relationship]) getRelationships client ids = do let intIds = map (show) ids @@ -184,11 +222,15 @@ 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 +getSearchedAccountsWithOption :: + HastodonClient -> AccountSearchOption -> String -> IO (Either JSONException [Account]) +getSearchedAccountsWithOption client opt query = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) (pSearchAccounts ++ "?q=" ++ query) client return (getResponseBody res :: Either JSONException [Account]) +getSearchedAccounts :: HastodonClient -> String -> IO (Either JSONException [Account]) +getSearchedAccounts client = getSearchedAccountsWithOption client mempty + postFollow :: HastodonClient -> Int -> IO (Either JSONException Relationship) postFollow client id = do res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pFollow) [] client @@ -209,11 +251,16 @@ 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 +postMuteWithOption :: + HastodonClient -> PostMuteOption -> Int -> IO (Either JSONException Relationship) +postMuteWithOption client opt id = do + let prms = optionAsForm opt + res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pMute) prms client return (getResponseBody res :: Either JSONException Relationship) +postMute :: HastodonClient -> Int -> IO (Either JSONException Relationship) +postMute client = postMuteWithOption client mempty + postUnmute :: HastodonClient -> Int -> IO (Either JSONException Relationship) postUnmute client id = do res <- postAndGetHastodonResponseJSON (replace ":id" (show id) pUnmute) [] client @@ -229,21 +276,30 @@ res <- httpJSONEither req return (getResponseBody res :: Either JSONException OAuthClient) -getBlocks :: HastodonClient -> IO (Either JSONException [Account]) -getBlocks client = do - res <- getHastodonResponseJSON pBlocks client +getBlocksWithOption :: HastodonClient -> RangeOption -> IO (Either JSONException [Account]) +getBlocksWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pBlocks client return (getResponseBody res :: Either JSONException [Account]) -getFavorites :: HastodonClient -> IO (Either JSONException [Status]) -getFavorites client = do - res <- getHastodonResponseJSON pFavorites client +getBlocks :: HastodonClient -> IO (Either JSONException [Account]) +getBlocks client = getBlocksWithOption client mempty + +getFavoritesWithOption :: HastodonClient -> RangeOption -> IO (Either JSONException [Status]) +getFavoritesWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pFavorites client return (getResponseBody res :: Either JSONException [Status]) -getFollowRequests :: HastodonClient -> IO (Either JSONException [Account]) -getFollowRequests client = do - res <- getHastodonResponseJSON pFollowRequests client +getFavorites :: HastodonClient -> IO (Either JSONException [Status]) +getFavorites client = getFavoritesWithOption client mempty + +getFollowRequestsWithOption :: HastodonClient -> RangeOption -> IO (Either JSONException [Account]) +getFollowRequestsWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pFollowRequests client return (getResponseBody res :: Either JSONException [Account]) +getFollowRequests :: HastodonClient -> IO (Either JSONException [Account]) +getFollowRequests client = getFollowRequestsWithOption client mempty + postAuthorizeRequest :: HastodonClient -> Int -> IO Bool postAuthorizeRequest client id = postAndGetHastodonResult (replace ":id" (show id) pAuthorizeRequest) [] client @@ -266,14 +322,20 @@ res <- httpJSONEither req return (getResponseBody res :: Either JSONException Attachment) -getMutes :: HastodonClient -> IO (Either JSONException [Account]) -getMutes client = do - res <- getHastodonResponseJSON pMutes client +getMutesWithOption :: HastodonClient -> RangeOption -> IO (Either JSONException [Account]) +getMutesWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pMutes client return (getResponseBody res :: Either JSONException [Account]) +getMutes :: HastodonClient -> IO (Either JSONException [Account]) +getMutes client = getMutesWithOption client mempty + getNotifications :: HastodonClient -> IO (Either JSONException [Notification]) -getNotifications client = do - res <- getHastodonResponseJSON pNotifications client +getNotifications client = getNotificationsWithOption client mempty + +getNotificationsWithOption :: HastodonClient -> GetNotificationsOption -> IO (Either JSONException [Notification]) +getNotificationsWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pNotifications client return (getResponseBody res :: Either JSONException [Notification]) getNotificationById :: HastodonClient -> Int -> IO (Either JSONException Notification) @@ -290,8 +352,12 @@ return (getResponseBody res :: Either JSONException [Report]) getSearchedResults :: HastodonClient -> String -> IO (Either JSONException [Results]) -getSearchedResults client query = do - res <- getHastodonResponseJSON (pSearch ++ "?q=" ++ query) client +getSearchedResults client = getSearchedResultsWithOption client mempty + +getSearchedResultsWithOption :: + HastodonClient -> StatusSearchOption -> String -> IO (Either JSONException [Results]) +getSearchedResultsWithOption client opt query = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) (pSearch ++ "?q=" ++ query) client return (getResponseBody res :: Either JSONException [Results]) getStatus :: HastodonClient -> Int -> IO (Either JSONException Status) @@ -309,19 +375,30 @@ 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 +getRebloggedByWithOption :: HastodonClient -> RangeOption -> Int -> IO (Either JSONException [Account]) +getRebloggedByWithOption client opt id = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) (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 +getRebloggedBy :: HastodonClient -> Int -> IO (Either JSONException [Account]) +getRebloggedBy client = getRebloggedByWithOption client mempty + +getFavoritedByWithOption :: HastodonClient -> RangeOption -> Int -> IO (Either JSONException [Account]) +getFavoritedByWithOption client opt id = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) (replace ":id" (show id) pFavoritedBy) client return (getResponseBody res :: Either JSONException [Account]) +getFavoritedBy :: HastodonClient -> Int -> IO (Either JSONException [Account]) +getFavoritedBy client = getFavoritedByWithOption client mempty + postStatus :: HastodonClient -> String -> IO (Either JSONException Status) -postStatus client status = do - res <- postAndGetHastodonResponseJSON pStatuses [(Char8.pack "status", utf8ToChar8 status)] client +postStatus client = postStatusWithOption client mempty + +postStatusWithOption :: + HastodonClient -> PostStatusOption -> String -> IO (Either JSONException Status) +postStatusWithOption client opt status = do + let prms = [(Char8.pack "status", utf8ToChar8 status)] ++ optionAsForm opt + res <- postAndGetHastodonResponseJSON pStatuses prms client return (getResponseBody res :: Either JSONException Status) postStatusWithMediaIds :: HastodonClient -> String -> [HastodonId] -> IO (Either JSONException Status) @@ -352,13 +429,20 @@ return (getResponseBody res :: Either JSONException Status) getHomeTimeline :: HastodonClient -> IO (Either JSONException [Status]) -getHomeTimeline client = do - res <- getHastodonResponseJSON pHomeTimeline client +getHomeTimeline client = getHomeTimelineWithOption client mempty + +getHomeTimelineWithOption :: HastodonClient -> TimelineOption -> IO (Either JSONException [Status]) +getHomeTimelineWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pHomeTimeline client return (getResponseBody res :: Either JSONException [Status]) + getPublicTimeline :: HastodonClient -> IO (Either JSONException [Status]) -getPublicTimeline client = do - res <- getHastodonResponseJSON pPublicTimeline client +getPublicTimeline client = getPublicTimelineWithOption client mempty + +getPublicTimelineWithOption :: HastodonClient -> TimelineOption -> IO (Either JSONException [Status]) +getPublicTimelineWithOption client opt = do + res <- getHastodonResponseJSONWithOption (optionAsQuery opt) pPublicTimeline client return (getResponseBody res :: Either JSONException [Status]) getTaggedTimeline :: HastodonClient -> String -> IO (Either JSONException [Status]) @@ -366,3 +450,11 @@ res <- getHastodonResponseJSON (replace ":hashtag" hashtag pTaggedTimeline) client return (getResponseBody res :: Either JSONException [Status]) +getTaggedTimelineWithOption :: + HastodonClient -> TimelineOption -> String -> IO (Either JSONException [Status]) +getTaggedTimelineWithOption client opt hashtag = do + res <- getHastodonResponseJSONWithOption + (optionAsQuery opt) + (replace ":hashtag" hashtag pTaggedTimeline) + client + return (getResponseBody res :: Either JSONException [Status]) diff --git a/Web/Hastodon/Option.hs b/Web/Hastodon/Option.hs new file mode 100644 --- /dev/null +++ b/Web/Hastodon/Option.hs @@ -0,0 +1,323 @@ +module Web.Hastodon.Option + ( + -- * Limit Options + IsLimitOption + , limit + + -- * Range Options + , RangeOption () + , IsRangeOption + , maxId + , sinceId + + -- * Timeline Options + , TimelineOption () + , IsTimelineOption + , instanceLocal + + -- * Status search Options + , StatusSearchOption () + , IsStatusSearchOption + , resolve + + -- * Account search Options + , AccountSearchOption () + , IsAccountSearchOption + , following + + -- * Status getting options + , IsGetStatusesOption + , onlyMedia + + -- * Account status getting options + , GetAccountStatusesOption () + , IsGetAccountStatusesOption + , pinned + , excludeReplies + + -- * Notification getting options + , GetNotificationsOption () + , IsGetNotificationsOption + , NotificationType + , excludeTypes + + -- * Status posting options + , PostStatusOption () + , IsPostStatusOption + , Visibility (..) + , inReplyToId + , mediaIds + , sensitive + , spoilerText + , visibility + + -- * Mute options + , PostMuteOption () + , IsPostMuteOption + , muteNotifications + ) +where + +import Data.Semigroup +import Data.Monoid hiding ((<>)) +import Control.Applicative +import qualified Data.Map as Map + +import Web.Hastodon.Types +import Web.Hastodon.Util + + +-- +-- Limit option +-- +class IsOption a => IsLimitOption a where {} + +limit :: IsLimitOption a => Int -> a +limit i = mkOption "limit" $ Just (show i) + + +-- +-- Range options +-- +newtype RangeOption = RangeOption { unRangeOption :: OptionImpl } deriving Show + +instance IsOption RangeOption where + fromOptionImpl = RangeOption + toOptionImpl = unRangeOption + +instance Semigroup RangeOption where + (<>) = optionMappend + +instance Monoid RangeOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsRangeOption a where {} + +instance IsLimitOption RangeOption where {} +instance IsRangeOption RangeOption where {} + +sinceId :: IsRangeOption a => String -> a +sinceId i = mkOption "since_id" $ Just i + +maxId :: IsRangeOption a => String -> a +maxId i = mkOption "max_id" $ Just i + +-- +-- Timeline options +-- +newtype TimelineOption = TimelineOption { unTimelineOption :: OptionImpl } deriving Show + +instance IsOption TimelineOption where + fromOptionImpl = TimelineOption + toOptionImpl = unTimelineOption + +instance Semigroup TimelineOption where + (<>) = optionMappend + +instance Monoid TimelineOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsTimelineOption a where {} + +instance IsLimitOption TimelineOption where {} +instance IsRangeOption TimelineOption where {} +instance IsGetStatusesOption TimelineOption where {} +instance IsTimelineOption TimelineOption where {} + +instanceLocal :: IsTimelineOption a => a +instanceLocal = mkOption "local" $ Nothing + +-- +-- Status getting options +-- +class IsOption a => IsGetStatusesOption a where {} + +onlyMedia :: IsGetStatusesOption a => a +onlyMedia = mkOption "only_media" Nothing + +-- +-- AccountStatus getting options +-- +newtype GetAccountStatusesOption = GetAccountStatusesOption { unGetAccountStatusesOption :: OptionImpl } deriving Show + +instance IsOption GetAccountStatusesOption where + fromOptionImpl = GetAccountStatusesOption + toOptionImpl = unGetAccountStatusesOption + +instance Semigroup GetAccountStatusesOption where + (<>) = optionMappend + +instance Monoid GetAccountStatusesOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsGetAccountStatusesOption a where {} + +instance IsLimitOption GetAccountStatusesOption where {} +instance IsRangeOption GetAccountStatusesOption where {} +instance IsGetStatusesOption GetAccountStatusesOption where {} +instance IsGetAccountStatusesOption GetAccountStatusesOption where {} + +pinned :: IsGetAccountStatusesOption a => a +pinned = mkOption "pinned" Nothing + +excludeReplies :: IsGetAccountStatusesOption a => a +excludeReplies = mkOption "exclude_replies" Nothing + +-- +-- Notification getting options +-- +newtype GetNotificationsOption = GetNotificationsOption { + unGetNotificationsOption :: OptionImpl + } deriving Show + +instance IsOption GetNotificationsOption where + fromOptionImpl = GetNotificationsOption + toOptionImpl = unGetNotificationsOption + +instance Semigroup GetNotificationsOption where + (<>) = optionMappend + +instance Monoid GetNotificationsOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsGetNotificationsOption a where {} + +instance IsLimitOption GetNotificationsOption where {} +instance IsRangeOption GetNotificationsOption where {} +instance IsGetNotificationsOption GetNotificationsOption where {} + +data NotificationType = + NotificationFollow | NotificationFavourite | NotificationReblog | NotificationMention + deriving (Eq, Show, Ord,Enum, Bounded) + +formatNt :: NotificationType -> String +formatNt NotificationFollow = "follow" +formatNt NotificationFavourite = "favourite" +formatNt NotificationReblog = "reblog" +formatNt NotificationMention = "mention" + +excludeTypes :: IsGetNotificationsOption a => [NotificationType] -> a +excludeTypes ts = mkArrayOption "exclude_types" $ map formatNt ts + +-- +-- AccountSearch options +-- +newtype AccountSearchOption = AccountSearchOption { unAccountSearchOption :: OptionImpl } deriving Show + +instance IsOption AccountSearchOption where + fromOptionImpl = AccountSearchOption + toOptionImpl = unAccountSearchOption + +instance Semigroup AccountSearchOption where + (<>) = optionMappend + +instance Monoid AccountSearchOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsAccountSearchOption a where {} + +instance IsAccountSearchOption AccountSearchOption where {} + +following :: IsAccountSearchOption a => a +following = mkOption "following" $ Nothing + +-- +-- StatusSearch options +-- +newtype StatusSearchOption = StatusSearchOption { unStatusSearchOption :: OptionImpl } deriving Show + +instance IsOption StatusSearchOption where + fromOptionImpl = StatusSearchOption + toOptionImpl = unStatusSearchOption + +instance Semigroup StatusSearchOption where + (<>) = optionMappend + +instance Monoid StatusSearchOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsStatusSearchOption a where {} + +instance IsLimitOption StatusSearchOption where {} +instance IsStatusSearchOption StatusSearchOption where {} + +resolve :: IsStatusSearchOption a => a +resolve = mkOption "resolve" $ Nothing + +-- +-- Status posting options +-- +newtype PostStatusOption = PostStatusOption { unPostStatusOption :: OptionImpl } deriving Show + +instance IsOption PostStatusOption where + fromOptionImpl = PostStatusOption + toOptionImpl = unPostStatusOption + +instance Semigroup PostStatusOption where + (<>) = optionMappend + +instance Monoid PostStatusOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsPostStatusOption a where {} + +instance IsPostStatusOption PostStatusOption where {} + +data Visibility = + VisibilityDirect | VisibilityPrivate | VisibilityUnlisted | VisibilityPublic + deriving (Eq, Show, Ord, Enum, Bounded) + +formatVis :: Visibility -> String +formatVis VisibilityDirect = "direct" +formatVis VisibilityPrivate = "private" +formatVis VisibilityUnlisted = "unlisted" +formatVis VisibilityPublic = "public" + +inReplyToId :: IsPostStatusOption a => Int -> a +inReplyToId i = mkOption "in_reply_to_id" (Just $ show i) + +mediaIds :: IsPostStatusOption a => [Int] -> a +mediaIds l = mkArrayOption "media_ids" $ show <$> l + +sensitive :: IsPostStatusOption a => a +sensitive = mkOption "sensitive" Nothing + +spoilerText :: IsPostStatusOption a => String -> a +spoilerText str = mkOption "spoiler_text" (Just str) + +visibility :: IsPostStatusOption a => Visibility -> a +visibility vis = mkOption "visibility" (Just $ formatVis vis) + +-- +-- PostMute options +-- +newtype PostMuteOption = PostMuteOption { unPostMuteOption :: OptionImpl } deriving Show + +instance IsOption PostMuteOption where + fromOptionImpl = PostMuteOption + toOptionImpl = unPostMuteOption + +instance Semigroup PostMuteOption where + (<>) = optionMappend + +instance Monoid PostMuteOption where + mempty = optionMempty + mappend = (<>) + +class IsOption a => IsPostMuteOption a where {} + +instance IsLimitOption PostMuteOption where {} +instance IsPostMuteOption PostMuteOption where {} + +muteNotifications :: IsPostMuteOption a => a +muteNotifications = mkOption "notifications" $ Nothing + + + diff --git a/Web/Hastodon/Types.hs b/Web/Hastodon/Types.hs --- a/Web/Hastodon/Types.hs +++ b/Web/Hastodon/Types.hs @@ -16,12 +16,16 @@ , Results(..) , Status(..) , Tag(..) + , OptionVal + , OptionImpl + , IsOption(..) ) where import Data.Aeson import qualified Data.Text as T import qualified Data.Text.Encoding as T - +import qualified Data.ByteString.Char8 as Char8 +import qualified Data.Map as Map type HastodonId = String @@ -277,3 +281,13 @@ parseJSON (Object v) = Tag <$> (v .: "name") <*> (v .: "url") + +-- Left : Array parameter, Right : Single parameter +type OptionVal = Either [Char8.ByteString] (Maybe Char8.ByteString) + +type OptionImpl = Map.Map Char8.ByteString OptionVal + +class IsOption a where + fromOptionImpl :: OptionImpl -> a + toOptionImpl :: a -> OptionImpl + diff --git a/Web/Hastodon/Util.hs b/Web/Hastodon/Util.hs --- a/Web/Hastodon/Util.hs +++ b/Web/Hastodon/Util.hs @@ -1,17 +1,27 @@ module Web.Hastodon.Util ( HastodonClient(..) , mkHastodonHeader + , mkHastodonRequestWithQuery , mkHastodonRequest + , mkOption + , mkArrayOption + , optionMempty + , optionMappend + , optionAsQuery + , optionAsForm , utf8ToChar8 ) where +import Data.Maybe (fromMaybe) import qualified Data.ByteString.Char8 as Char8 import qualified Data.Text as T import qualified Data.Text.Encoding as T +import qualified Data.Map as Map import Network.HTTP.Simple import Network.HTTP.Types.Header +import Web.Hastodon.Types data HastodonClient = HastodonClient { host :: String, @@ -19,11 +29,16 @@ } -mkHastodonRequest :: String -> HastodonClient -> IO Request -mkHastodonRequest path client = do +mkHastodonRequestWithQuery :: + [(Char8.ByteString, Maybe Char8.ByteString)] -> String -> HastodonClient -> IO Request +mkHastodonRequestWithQuery opt path client = do initReq <- parseRequest $ "https://" ++ (host client) ++ path - return $ mkHastodonHeader (token client) $ initReq + return $ + mkHastodonHeader (token client) $ + setRequestQueryString opt $ initReq +mkHastodonRequest :: String -> HastodonClient -> IO Request +mkHastodonRequest = mkHastodonRequestWithQuery [] mkHastodonHeader :: String -> Request -> Request mkHastodonHeader token = @@ -32,3 +47,33 @@ utf8ToChar8 :: String -> Char8.ByteString utf8ToChar8 = T.encodeUtf8 . T.pack + + +mkOption :: IsOption a => String -> Maybe String -> a +mkOption key val = fromOptionImpl $ Map.singleton (utf8ToChar8 key) (Right $ utf8ToChar8 <$> val) + + +mkArrayOption :: IsOption a => String -> [String] -> a +mkArrayOption key val = fromOptionImpl $ Map.singleton (utf8ToChar8 key) (Left $ utf8ToChar8 <$> val) + + +optionMempty :: IsOption a => a +optionMempty = fromOptionImpl Map.empty + + +optionMappend :: IsOption a => a -> a -> a +optionMappend x y = fromOptionImpl $ Map.union (toOptionImpl x) (toOptionImpl y) + + +optionAsQuery :: IsOption a => a -> [(Char8.ByteString, Maybe Char8.ByteString)] +optionAsQuery x = do + (k, v) <- Map.toList $ toOptionImpl x + let k' = k `mappend` Char8.pack "[]" -- The Rails convention of list query parameter + case v of + Left l -> [(k, Just x) | x <- l] + Right r -> [(k, r)] + + +optionAsForm :: IsOption a => a -> [(Char8.ByteString, Char8.ByteString)] +optionAsForm opt = fmap cnv $ optionAsQuery opt + where cnv (x, y) = (x, fromMaybe (Char8.pack "true") y)