Hastodon 0.4.1 → 0.5.0

raw patch · 6 files changed

+547/−50 lines, 6 filesdep +containersPVP ok

version bump matches the API change (PVP)

Dependencies added: containers

API changes (from Hackage documentation)

Files

• Hastodon.cabal +6/−3
• Web/Hastodon.hs +21/−1
• Web/Hastodon/API.hs +134/−42
• Web/Hastodon/Option.hs +323/−0
• Web/Hastodon/Types.hs +15/−1
• Web/Hastodon/Util.hs +48/−3

@@ -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,

@@ -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

@@ -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])

@@ -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+++

@@ -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+

@@ -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)