Utils.hs

{-# 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
    , 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.Containers.ListUtils       ( nubOrd )
import qualified Data.Foldable                   as F
import           Data.Generics.Wrapped           ( wrappedFrom, wrappedTo )
import           Data.List                       ( (\\) )
import qualified Data.Text                       as T
import           Data.Text                       ( Text )
import qualified Data.Text.Encoding              as T

import           Network.Reddit.Types
import           Network.Reddit.Types.Submission
import           Network.Reddit.Types.Subreddit

import           URI.ByteString
                 ( Authority(..)
                 , URIRef(URI, uriPath, uriAuthority)
                 , 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
    { method          = GET
    , pathSegments    = mempty
    , requestData     = NoData
    , needsAuth       = True
    , followRedirects = True
    , rawJSON         = True
    , checkResponse   = \_ _ -> pure ()
    }

-- | Join a collection of 'PathSegment's, with a leading slash
joinPathSegments :: Foldable t => t PathSegment -> ByteString
joinPathSegments = T.encodeUtf8 . foldr (\a b -> "/" <> a <> b) mempty

-- | Convert a 'UserAgent' to its textual value
writeUA :: UserAgent -> ByteString
writeUA UserAgent { .. } = T.encodeUtf8 withInfo
  where
    withInfo = mconcat [ info, " ", "(", "by ", author, ")" ]

    info     = T.intercalate ":" [ platform, appID, version ]

paginatorToFormData :: (Thing t, Paginable a) => Paginator t a -> WithData
paginatorToFormData = WithForm . toForm

-- | An empty, default 'Paginator'. Includes the default 'PaginateOptions' for
-- the type @a@
emptyPaginator :: forall t a. Paginable a => Paginator t a
emptyPaginator = Paginator
    { before   = Nothing
    , after    = Nothing
    , limit    = 25
    , showAll  = False
    , srDetail = False
    , opts     = defaultOpts @a
    }

-- | Convert @(Text, Text)@ pairs into a URL-encoded 'Form'
mkTextFormData :: [(Text, Text)] -> WithData
mkTextFormData = WithForm . mkTextForm

apiRequestLimit :: Num n => n
apiRequestLimit = 100

-- | Parse a 'SubmissionID' from a Reddit URL
submissionIDFromURL :: MonadThrow m => Text -> m SubmissionID
submissionIDFromURL url = case parsed of
    Left _           -> invalidURL "Invalid URL provided"
    Right URI { .. }
        | Just Authority { authorityHost } <- uriAuthority    --
            -> case wrappedTo authorityHost of
                host
                    | host `elem` [ "reddit.com", "www.reddit.com" ]    --
                        -> case splitPath uriPath of
                            [ "gallery", sid ] -> pure $ mkID sid
                            ("comments" : sid : _) -> pure $ mkID sid
                            ("r" : _ : "comments" : sid : _) ->
                                pure $ mkID sid
                            _ -> invalidURL
                                $ mconcat [ "Path must be one of "
                                          , "/r/<SUBREDDIT>/comments/<ID>/<NAME>/, "
                                          , "/gallery/<ID>, or /comments/<ID>/"
                                          ]

                    | host == "redd.it" -> case splitPath uriPath of
                        [ sid ] -> pure $ mkID sid
                        _       -> invalidURL "Path may only contain /<ID>"

                    | otherwise -> invalidURL "Unrecognized host"
        | otherwise -> invalidURL "URL authority not present or unrecognized"
  where
    parsed     = parseURI laxURIParserOptions $ T.encodeUtf8 url

    invalidURL = throwM . InvalidRequest

    mkID       = wrappedFrom . T.decodeUtf8

-- | Get the API path for a subreddit given its 'SubredditName'
subAPIPath :: SubredditName -> PathSegment -> [PathSegment]
subAPIPath sname path = [ "r", toUrlPiece sname, "api", path ]

-- | Get the \"about\" path for a subreddit given its 'SubredditName'
subAboutPath :: SubredditName -> PathSegment -> [PathSegment]
subAboutPath sname path = [ "r", toUrlPiece sname, "about", 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 perms = T.intercalate ","
    $ mconcat [ [ "-all" ]
              , prefixPerm "-" <$> omitted
              , prefixPerm "+" <$> included
              ]
  where
    included     = nubOrd $ F.toList perms

    omitted      = [ minBound .. ] \\ included

    prefixPerm t = (t <>) . toQueryParam

-- | Split a URL path
splitPath :: ByteString -> [ByteString]
splitPath = drop 1 . C8.split '/'

-- | Get the host and path segments from a URL
splitURL :: MonadThrow m => URL -> m (ByteString, [PathSegment])
splitURL url = case parseURI laxURIParserOptions $ T.encodeUtf8 url of
    Right URI { .. }
        | Just Authority { authorityHost } <- uriAuthority --
            ->
            pure (wrappedTo authorityHost, T.decodeUtf8 <$> splitPath uriPath)
        | otherwise -> invalidURL
    Left _           -> invalidURL
  where
    invalidURL = throwM $ InvalidResponse "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 action = catch @_ @APIException action $ \case
    e@(JSONParseError _ body) -> case eitherDecode @(Listing () ()) body of
        Right _ -> throwM . ErrorWithStatus
            $ StatusMessage 404 "Resource does not exist"
        Left _  -> throwM e
    e -> throwM e