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
    , 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
    { 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 = idFromURL f g
  where
    f    = \case
        "gallery" : sid : _ -> mkID sid
        "comments" : sid : _ -> mkID sid
        "r" : _ : "comments" : sid : _ -> mkID sid
        _ -> throwM . InvalidRequest
            $ mconcat [ "Path must be one of "
                      , "/r/<SUBREDDIT>/comments/<ID>/<NAME>/, "
                      , "/gallery/<ID>, or /comments/<ID>/"
                      ]

    g    = \case
        sid : _ -> mkID sid
        _       -> throwM . InvalidRequest $ "Path may only contain /<ID>"

    mkID = pure . coerce

-- | Parse a 'SubmissionID' from a Reddit URL
commentIDFromURL :: MonadThrow m => Text -> m CommentID
commentIDFromURL = idFromURL f g
  where
    f    = \case
        "r" : _ : "comments" : _ : _ : cid : _ -> mkID cid
        _ -> throwM . InvalidRequest
            $ "Path must be /r/<SUBREDDIT>/comments/<SID>/<NAME>/<ID>"

    g    = const . throwM . InvalidRequest
        $ "Cannot get comment ID from redd.it hosts"

    mkID = pure . coerce

idFromURL :: MonadThrow m
          => ([PathSegment] -> m a) -- for various reddit.com hosts
          -> ([PathSegment] -> m a) -- for redd.it host
          -> Text
          -> m a
idFromURL f g url = splitURL url >>= \case
    (host, ps)
        | host `elem` hosts -> f ps
        | host == "redd.it" -> g ps
        | otherwise -> invalidURL "Unrecognized host"
      where
        hosts      = [ "reddit.com", "www.reddit.com", "old.reddit.com" ]

        invalidURL = throwM . InvalidRequest

-- | 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 ( authorityHost ^. hostBSL
                    , 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