{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}
module Network.Reddit.Utils
( bshow
, defaultAPIAction
, joinPathSegments
, writeUA
, emptyPaginator
, paginatorToFormData
, apiRequestLimit
, mkTextForm
, mkTextFormData
, submissionIDFromURL
, commentIDFromURL
, subAPIPath
, subAboutPath
, textObject
, textEncode
, joinPerms
, splitPath
, splitURL
, catchEmptyListing
) where
import Control.Monad.Catch ( MonadCatch(catch)
, MonadThrow(throwM)
)
import Data.Aeson ( eitherDecode )
import Data.ByteString ( ByteString )
import qualified Data.ByteString.Char8 as C8
import Data.Coerce ( coerce )
import Data.Containers.ListUtils ( nubOrd )
import qualified Data.Foldable as F
import Data.List ( (\\) )
import qualified Data.Text as T
import Data.Text ( Text )
import qualified Data.Text.Encoding as T
import Lens.Micro
import Network.Reddit.Types
import Network.Reddit.Types.Comment
import Network.Reddit.Types.Submission
import Network.Reddit.Types.Subreddit
import URI.ByteString
( Authority(..)
, URIRef(URI, uriPath, uriAuthority)
, hostBSL
, laxURIParserOptions
, parseURI
)
import Web.FormUrlEncoded ( ToForm(toForm) )
import Web.HttpApiData ( ToHttpApiData(..) )
defaultAPIAction :: APIAction a
defaultAPIAction :: APIAction a
defaultAPIAction = APIAction :: forall a.
Method
-> [PathSegment]
-> WithData
-> Bool
-> Bool
-> Bool
-> (Request -> Response BodyReader -> IO ())
-> APIAction a
APIAction
{ $sel:method:APIAction :: Method
method = Method
GET
, $sel:pathSegments:APIAction :: [PathSegment]
pathSegments = [PathSegment]
forall a. Monoid a => a
mempty
, $sel:requestData:APIAction :: WithData
requestData = WithData
NoData
, $sel:needsAuth:APIAction :: Bool
needsAuth = Bool
True
, $sel:followRedirects:APIAction :: Bool
followRedirects = Bool
True
, $sel:rawJSON:APIAction :: Bool
rawJSON = Bool
True
, $sel:checkResponse:APIAction :: Request -> Response BodyReader -> IO ()
checkResponse = \Request
_ Response BodyReader
_ -> () -> IO ()
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
}
joinPathSegments :: Foldable t => t PathSegment -> ByteString
joinPathSegments :: t PathSegment -> ByteString
joinPathSegments = PathSegment -> ByteString
T.encodeUtf8 (PathSegment -> ByteString)
-> (t PathSegment -> PathSegment) -> t PathSegment -> ByteString
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (PathSegment -> PathSegment -> PathSegment)
-> PathSegment -> t PathSegment -> PathSegment
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\PathSegment
a PathSegment
b -> PathSegment
"/" PathSegment -> PathSegment -> PathSegment
forall a. Semigroup a => a -> a -> a
<> PathSegment
a PathSegment -> PathSegment -> PathSegment
forall a. Semigroup a => a -> a -> a
<> PathSegment
b) PathSegment
forall a. Monoid a => a
mempty
writeUA :: UserAgent -> ByteString
writeUA :: UserAgent -> ByteString
writeUA UserAgent { PathSegment
$sel:author:UserAgent :: UserAgent -> PathSegment
$sel:version:UserAgent :: UserAgent -> PathSegment
$sel:appID:UserAgent :: UserAgent -> PathSegment
$sel:platform:UserAgent :: UserAgent -> PathSegment
author :: PathSegment
version :: PathSegment
appID :: PathSegment
platform :: PathSegment
.. } = PathSegment -> ByteString
T.encodeUtf8 PathSegment
withInfo
where
withInfo :: PathSegment
withInfo = [PathSegment] -> PathSegment
forall a. Monoid a => [a] -> a
mconcat [ PathSegment
info, PathSegment
" ", PathSegment
"(", PathSegment
"by ", PathSegment
author, PathSegment
")" ]
info :: PathSegment
info = PathSegment -> [PathSegment] -> PathSegment
T.intercalate PathSegment
":" [ PathSegment
platform, PathSegment
appID, PathSegment
version ]
paginatorToFormData :: (Thing t, Paginable a) => Paginator t a -> WithData
paginatorToFormData :: Paginator t a -> WithData
paginatorToFormData = Form -> WithData
WithForm (Form -> WithData)
-> (Paginator t a -> Form) -> Paginator t a -> WithData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Paginator t a -> Form
forall a. ToForm a => a -> Form
toForm
emptyPaginator :: forall t a. Paginable a => Paginator t a
emptyPaginator :: Paginator t a
emptyPaginator = Paginator :: forall t a.
Maybe t
-> Maybe t
-> Word
-> Bool
-> Bool
-> PaginateOptions a
-> Paginator t a
Paginator
{ $sel:before:Paginator :: Maybe t
before = Maybe t
forall a. Maybe a
Nothing
, $sel:after:Paginator :: Maybe t
after = Maybe t
forall a. Maybe a
Nothing
, $sel:limit:Paginator :: Word
limit = Word
25
, $sel:showAll:Paginator :: Bool
showAll = Bool
False
, $sel:srDetail:Paginator :: Bool
srDetail = Bool
False
, $sel:opts:Paginator :: PaginateOptions a
opts = Paginable a => PaginateOptions a
forall a. Paginable a => PaginateOptions a
defaultOpts @a
}
mkTextFormData :: [(Text, Text)] -> WithData
mkTextFormData :: [(PathSegment, PathSegment)] -> WithData
mkTextFormData = Form -> WithData
WithForm (Form -> WithData)
-> ([(PathSegment, PathSegment)] -> Form)
-> [(PathSegment, PathSegment)]
-> WithData
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(PathSegment, PathSegment)] -> Form
mkTextForm
apiRequestLimit :: Num n => n
apiRequestLimit :: n
apiRequestLimit = n
100
submissionIDFromURL :: MonadThrow m => Text -> m SubmissionID
submissionIDFromURL :: PathSegment -> m SubmissionID
submissionIDFromURL = ([PathSegment] -> m SubmissionID)
-> ([PathSegment] -> m SubmissionID)
-> PathSegment
-> m SubmissionID
forall (m :: * -> *) a.
MonadThrow m =>
([PathSegment] -> m a)
-> ([PathSegment] -> m a) -> PathSegment -> m a
idFromURL [PathSegment] -> m SubmissionID
f [PathSegment] -> m SubmissionID
g
where
f :: [PathSegment] -> m SubmissionID
f = \case
PathSegment
"gallery" : PathSegment
sid : [PathSegment]
_ -> PathSegment -> m SubmissionID
mkID PathSegment
sid
PathSegment
"comments" : PathSegment
sid : [PathSegment]
_ -> PathSegment -> m SubmissionID
mkID PathSegment
sid
PathSegment
"r" : PathSegment
_ : PathSegment
"comments" : PathSegment
sid : [PathSegment]
_ -> PathSegment -> m SubmissionID
mkID PathSegment
sid
[PathSegment]
_ -> ClientException -> m SubmissionID
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m SubmissionID)
-> (PathSegment -> ClientException)
-> PathSegment
-> m SubmissionID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> ClientException
InvalidRequest
(PathSegment -> m SubmissionID) -> PathSegment -> m SubmissionID
forall a b. (a -> b) -> a -> b
$ [PathSegment] -> PathSegment
forall a. Monoid a => [a] -> a
mconcat [ PathSegment
"Path must be one of "
, PathSegment
"/r/<SUBREDDIT>/comments/<ID>/<NAME>/, "
, PathSegment
"/gallery/<ID>, or /comments/<ID>/"
]
g :: [PathSegment] -> m SubmissionID
g = \case
PathSegment
sid : [PathSegment]
_ -> PathSegment -> m SubmissionID
mkID PathSegment
sid
[PathSegment]
_ -> ClientException -> m SubmissionID
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m SubmissionID)
-> (PathSegment -> ClientException)
-> PathSegment
-> m SubmissionID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> ClientException
InvalidRequest (PathSegment -> m SubmissionID) -> PathSegment -> m SubmissionID
forall a b. (a -> b) -> a -> b
$ PathSegment
"Path may only contain /<ID>"
mkID :: PathSegment -> m SubmissionID
mkID = SubmissionID -> m SubmissionID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (SubmissionID -> m SubmissionID)
-> (PathSegment -> SubmissionID) -> PathSegment -> m SubmissionID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> SubmissionID
coerce
commentIDFromURL :: MonadThrow m => Text -> m CommentID
= ([PathSegment] -> m CommentID)
-> ([PathSegment] -> m CommentID) -> PathSegment -> m CommentID
forall (m :: * -> *) a.
MonadThrow m =>
([PathSegment] -> m a)
-> ([PathSegment] -> m a) -> PathSegment -> m a
idFromURL [PathSegment] -> m CommentID
f [PathSegment] -> m CommentID
forall b a. b -> m a
g
where
f :: [PathSegment] -> m CommentID
f = \case
PathSegment
"r" : PathSegment
_ : PathSegment
"comments" : PathSegment
_ : PathSegment
_ : PathSegment
cid : [PathSegment]
_ -> PathSegment -> m CommentID
mkID PathSegment
cid
[PathSegment]
_ -> ClientException -> m CommentID
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m CommentID)
-> (PathSegment -> ClientException) -> PathSegment -> m CommentID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> ClientException
InvalidRequest
(PathSegment -> m CommentID) -> PathSegment -> m CommentID
forall a b. (a -> b) -> a -> b
$ PathSegment
"Path must be /r/<SUBREDDIT>/comments/<SID>/<NAME>/<ID>"
g :: b -> m a
g = m a -> b -> m a
forall a b. a -> b -> a
const (m a -> b -> m a)
-> (PathSegment -> m a) -> PathSegment -> b -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ClientException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m a)
-> (PathSegment -> ClientException) -> PathSegment -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> ClientException
InvalidRequest
(PathSegment -> b -> m a) -> PathSegment -> b -> m a
forall a b. (a -> b) -> a -> b
$ PathSegment
"Cannot get comment ID from redd.it hosts"
mkID :: PathSegment -> m CommentID
mkID = CommentID -> m CommentID
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CommentID -> m CommentID)
-> (PathSegment -> CommentID) -> PathSegment -> m CommentID
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> CommentID
coerce
idFromURL :: MonadThrow m
=> ([PathSegment] -> m a)
-> ([PathSegment] -> m a)
-> Text
-> m a
idFromURL :: ([PathSegment] -> m a)
-> ([PathSegment] -> m a) -> PathSegment -> m a
idFromURL [PathSegment] -> m a
f [PathSegment] -> m a
g PathSegment
url = PathSegment -> m (ByteString, [PathSegment])
forall (m :: * -> *).
MonadThrow m =>
PathSegment -> m (ByteString, [PathSegment])
splitURL PathSegment
url m (ByteString, [PathSegment])
-> ((ByteString, [PathSegment]) -> m a) -> m a
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
(ByteString
host, [PathSegment]
ps)
| ByteString
host ByteString -> [ByteString] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [ByteString]
hosts -> [PathSegment] -> m a
f [PathSegment]
ps
| ByteString
host ByteString -> ByteString -> Bool
forall a. Eq a => a -> a -> Bool
== ByteString
"redd.it" -> [PathSegment] -> m a
g [PathSegment]
ps
| Bool
otherwise -> PathSegment -> m a
forall a. PathSegment -> m a
invalidURL PathSegment
"Unrecognized host"
where
hosts :: [ByteString]
hosts = [ ByteString
"reddit.com", ByteString
"www.reddit.com", ByteString
"old.reddit.com" ]
invalidURL :: PathSegment -> m a
invalidURL = ClientException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m a)
-> (PathSegment -> ClientException) -> PathSegment -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PathSegment -> ClientException
InvalidRequest
subAPIPath :: SubredditName -> PathSegment -> [PathSegment]
subAPIPath :: SubredditName -> PathSegment -> [PathSegment]
subAPIPath SubredditName
sname PathSegment
path = [ PathSegment
"r", SubredditName -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toUrlPiece SubredditName
sname, PathSegment
"api", PathSegment
path ]
subAboutPath :: SubredditName -> PathSegment -> [PathSegment]
subAboutPath :: SubredditName -> PathSegment -> [PathSegment]
subAboutPath SubredditName
sname PathSegment
path = [ PathSegment
"r", SubredditName -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toUrlPiece SubredditName
sname, PathSegment
"about", PathSegment
path ]
joinPerms
:: (Foldable t, Ord a, Enum a, Bounded a, ToHttpApiData a) => t a -> Text
joinPerms :: t a -> PathSegment
joinPerms t a
perms = PathSegment -> [PathSegment] -> PathSegment
T.intercalate PathSegment
","
([PathSegment] -> PathSegment) -> [PathSegment] -> PathSegment
forall a b. (a -> b) -> a -> b
$ [[PathSegment]] -> [PathSegment]
forall a. Monoid a => [a] -> a
mconcat [ [ PathSegment
"-all" ]
, PathSegment -> a -> PathSegment
forall a. ToHttpApiData a => PathSegment -> a -> PathSegment
prefixPerm PathSegment
"-" (a -> PathSegment) -> [a] -> [PathSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
omitted
, PathSegment -> a -> PathSegment
forall a. ToHttpApiData a => PathSegment -> a -> PathSegment
prefixPerm PathSegment
"+" (a -> PathSegment) -> [a] -> [PathSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [a]
included
]
where
included :: [a]
included = [a] -> [a]
forall a. Ord a => [a] -> [a]
nubOrd ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ t a -> [a]
forall (t :: * -> *) a. Foldable t => t a -> [a]
F.toList t a
perms
omitted :: [a]
omitted = [ a
forall a. Bounded a => a
minBound .. ] [a] -> [a] -> [a]
forall a. Eq a => [a] -> [a] -> [a]
\\ [a]
included
prefixPerm :: PathSegment -> a -> PathSegment
prefixPerm PathSegment
t = (PathSegment
t PathSegment -> PathSegment -> PathSegment
forall a. Semigroup a => a -> a -> a
<>) (PathSegment -> PathSegment)
-> (a -> PathSegment) -> a -> PathSegment
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> PathSegment
forall a. ToHttpApiData a => a -> PathSegment
toQueryParam
splitPath :: ByteString -> [ByteString]
splitPath :: ByteString -> [ByteString]
splitPath = Int -> [ByteString] -> [ByteString]
forall a. Int -> [a] -> [a]
drop Int
1 ([ByteString] -> [ByteString])
-> (ByteString -> [ByteString]) -> ByteString -> [ByteString]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Char -> ByteString -> [ByteString]
C8.split Char
'/'
splitURL :: MonadThrow m => URL -> m (ByteString, [PathSegment])
splitURL :: PathSegment -> m (ByteString, [PathSegment])
splitURL PathSegment
url = case URIParserOptions
-> ByteString -> Either URIParseError (URIRef Absolute)
parseURI URIParserOptions
laxURIParserOptions (ByteString -> Either URIParseError (URIRef Absolute))
-> ByteString -> Either URIParseError (URIRef Absolute)
forall a b. (a -> b) -> a -> b
$ PathSegment -> ByteString
T.encodeUtf8 PathSegment
url of
Right URI { Maybe Authority
ByteString
uriPath :: ByteString
uriAuthority :: Maybe Authority
uriAuthority :: URIRef Absolute -> Maybe Authority
uriPath :: URIRef Absolute -> ByteString
.. }
| Just Authority { Host
authorityHost :: Authority -> Host
authorityHost :: Host
authorityHost } <- Maybe Authority
uriAuthority
-> (ByteString, [PathSegment]) -> m (ByteString, [PathSegment])
forall (f :: * -> *) a. Applicative f => a -> f a
pure ( Host
authorityHost Host -> Getting ByteString Host ByteString -> ByteString
forall s a. s -> Getting a s a -> a
^. Getting ByteString Host ByteString
Lens' Host ByteString
hostBSL
, ByteString -> PathSegment
T.decodeUtf8 (ByteString -> PathSegment) -> [ByteString] -> [PathSegment]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ByteString -> [ByteString]
splitPath ByteString
uriPath
)
| Bool
otherwise -> m (ByteString, [PathSegment])
forall a. m a
invalidURL
Left URIParseError
_ -> m (ByteString, [PathSegment])
forall a. m a
invalidURL
where
invalidURL :: m a
invalidURL = ClientException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (ClientException -> m a) -> ClientException -> m a
forall a b. (a -> b) -> a -> b
$ PathSegment -> ClientException
InvalidResponse PathSegment
"splitURL: Couldn't parse URL"
catchEmptyListing :: MonadReddit m => m a -> m a
catchEmptyListing :: m a -> m a
catchEmptyListing m a
action = m a -> (APIException -> m a) -> m a
forall (m :: * -> *) e a.
(MonadCatch m, Exception e) =>
m a -> (e -> m a) -> m a
catch @_ @APIException m a
action ((APIException -> m a) -> m a) -> (APIException -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \case
e :: APIException
e@(JSONParseError PathSegment
_ ByteString
body) -> case ByteString -> Either String (Listing () ())
forall a. FromJSON a => ByteString -> Either String a
eitherDecode @(Listing () ()) ByteString
body of
Right Listing () ()
_ -> APIException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM (APIException -> m a)
-> (StatusMessage -> APIException) -> StatusMessage -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StatusMessage -> APIException
ErrorWithStatus
(StatusMessage -> m a) -> StatusMessage -> m a
forall a b. (a -> b) -> a -> b
$ Int -> PathSegment -> StatusMessage
StatusMessage Int
404 PathSegment
"Resource does not exist"
Left String
_ -> APIException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
e
APIException
e -> APIException -> m a
forall (m :: * -> *) e a. (MonadThrow m, Exception e) => e -> m a
throwM APIException
e