{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE GADTs #-}

{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE NamedFieldPuns #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE ScopedTypeVariables #-}
{-# LANGUAGE TypeApplications #-}

-- |
-- Module      : Network.Reddit.Utils
-- Copyright   : (c) 2021 Rory Tyler Hayford
-- License     : BSD-3-Clause
-- Maintainer  : rory.hayford@protonmail.com
-- Stability   : experimental
-- Portability : GHC
--
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(..) )

-- | Default settings for an 'APIAction' - a GET request with no path, form
-- data, or query string, and which requires authentication headers
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 ()
    }

-- | Join a collection of 'PathSegment's, with a leading slash
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

-- | Convert a 'UserAgent' to its textual value
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

-- | An empty, default 'Paginator'. Includes the default 'PaginateOptions' for
-- the type @a@
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
    }

-- | Convert @(Text, Text)@ pairs into a URL-encoded 'Form'
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

-- | Parse a 'SubmissionID' from a Reddit URL
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

-- | Parse a 'SubmissionID' from a Reddit URL
commentIDFromURL :: MonadThrow m => Text -> m CommentID
commentIDFromURL :: PathSegment -> m CommentID
commentIDFromURL = ([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) -- for various reddit.com hosts
          -> ([PathSegment] -> m a) -- for redd.it host
          -> 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

-- | Get the API path for a subreddit given its 'SubredditName'
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 ]

-- | Get the \"about\" path for a subreddit given its 'SubredditName'
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 ]

-- | Turn a container of permissions into a string Reddit uses to configure
-- permissions for different roles. Included permissions are prefixed with
-- \"+\", omitted ones with \"-\"
--
-- Can be used with 'ModPermission's and 'LivePermission's
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

-- | Split a URL path
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
'/'

-- | Get the host and path segments from a URL
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"

-- | HACK
-- For some reason, if a subreddit does not exist, Reddit returns an
-- empty @Listing@ instead of returning 404
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