heddit-0.0.1: examples/RefreshTokens.hs

{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedLabels #-}
{-# LANGUAGE RecordWildCards #-}
{-# LANGUAGE TypeApplications #-}

-- | This small program demonstrates how to obtain an initial refresh token
-- to use with a 'WebApp' 'Client'. This is useful if you are not really running
-- a web server, but would like to use the \"code flow\" authentication process.
-- If successful, the program will print the refresh token at the end. You can
-- save this token and use it for later when creating a 'newClientWithManager'.
-- You must use this instead of 'newClient' in order to provide the initial
-- refresh token (otherwise, 'newClient' will try to use the authorization code
-- to get a brand-new refresh token).
--
-- The full steps to running this program are as follows:
--
--    1. If you haven't already:
--
--          * visit <https://www.reddit.com/prefs/apps/> while logged in
--          * create a new \"web app\" and set http:\/\/localhost:8080 as
--            the redirect URI
--          * save the client ID and client secret after creating the app
--
--    2. Export the environment variables @HEDDIT_CLIENT_ID@ and
--       @HEDDIT_CLIENT_SECRET@, corresponding to the values from Reddit,
--       and run the program
--
--    3. When prompted, enter the desired scopes. See the documentation
--       for 'Scope' for available values. All of the scope names are the
--       the same as the constructors, but lower-cased (except for 'Accounts',
--       which corresponds to \"account\"). You can also use the special
--       value \"*\" to request all scopes
--
--    4. After visiting the URL to authorize the application and granting
--       the requested scopes, you should be redirected to a page that
--       contains the refresh token. Save this and use it for later!
--
module RefreshTokens where

import           Control.Exception              ( bracket, throwIO )
import           Control.Monad

import           Data.Aeson                     ( eitherDecodeStrict )
import qualified Data.ByteString.Char8          as C8
import qualified Data.ByteString.Lazy.Char8     as LC8
import           Data.Generics.Labels           ()
import           Data.IORef
import qualified Data.Text                      as T
import           Data.Text                      ( Text )
import qualified Data.Text.Encoding             as T
import qualified Data.Text.IO                   as T

import           Lens.Micro.Platform

import           Network.Reddit
import           Network.Socket
import           Network.Socket.ByteString.Lazy ( recv, send )

import           System.Environment
import           System.Random

import           Web.FormUrlEncoded

main :: IO ()
main = do
    (clientID, clientSecret) <- getClientCredentials
    scopes <- getScopes
    state <- makeState
    T.putStrLn
        $ "Visit this URL in your browser: "
        <> getAuthURL redirectURI Permanent scopes clientID state

    socketClient <- receiveConnection
    recv socketClient 1024 <&> decodeParams >>= \case
        Nothing          -> throwIO
            $ InvalidResponse "Failed to decode query params in API response"
        Just (Form form) -> case traverse (getFormVal form)
                                          [ "code", "state" ] of
            Just [ code, s ] -> do
                when (state /= s) . throwIO
                    $ InvalidResponse "States do not match"
                let codeFlow   = CodeFlow redirectURI code
                    app        = WebApp clientSecret codeFlow
                    authConfig = AuthConfig clientID app ua
                token <- getRefreshToken authConfig
                sendMessage socketClient $ "Refresh token: " <> token
            _                ->
                throwIO $ InvalidResponse "Data missing from API response"
  where
    getFormVal form v = form ^? at v . _Just . _head

    ua = UserAgent "web" "refreshToken" "v0" "u/heddit-dev"

    redirectURI = "http://localhost:8080"

    getScopes = do
        T.putStrLn
            $ "Enter a comma-separated list of `Scope`s"
            <> " (e.g. `read,save,vote`), or `*` for all scopes"
        either (throwIO . userError) pure
            . traverse eitherDecodeStrict
            . fmap (quote . C8.strip)
            . C8.split ','
            =<< C8.getLine
      where
        quote x = "\"" <> x <> "\""

    makeState = T.pack . show <$> randomRIO @Int (0, 65000)

    getRefreshToken ac = do
        client <- newClient ac
        clientState <- readIORef $ client ^. #clientState
        case clientState ^. #accessToken . #refreshToken of
            Just token -> pure token
            Nothing    ->
                throwIO $ InvalidResponse "Failed to receive refresh token"

    getClientCredentials =
        (,) <$> getCred "HEDDIT_CLIENT_ID" <*> getCred "HEDDIT_CLIENT_SECRET"
      where
        getCred name = maybe (credError name) (pure . T.pack)
            =<< lookupEnv name

        credError name = throwIO . userError
            $ mconcat [ name
                      , " not found in environment."
                      , " Please `export $"
                      , name
                      , "=<VALUE>`"
                      , " before running this program"
                      ]

decodeParams :: LC8.ByteString -> Maybe Form
decodeParams txt = case LC8.words txt of
    _ : query : _ -> decodeQ =<< LC8.stripPrefix "/?" query
    _             -> Nothing
  where
    decodeQ = either (const Nothing) Just . urlDecodeForm

receiveConnection :: IO Socket
receiveConnection =
    getAddrInfo (Just hints) (Just "localhost") (Just "8080") >>= \case
        addr@AddrInfo { .. } : _ -> bracket (openSock addr) close $ \sock -> do
            setSocketOption sock ReuseAddr 1
            bind sock addrAddress
            listen sock 1
            (client, _) <- accept sock
            pure client
        [] -> throwIO $ OtherError "Failed to get socket address"
  where
    openSock AddrInfo { .. } = socket addrFamily Stream addrProtocol

    hints = defaultHints { addrSocketType = Stream, addrFamily = AF_INET }

sendMessage :: Socket -> Text -> IO ()
sendMessage sock msg = do
    T.putStrLn msg
    void . send sock
        $ mconcat [ "HTTP/1.1 200 OK\r\n\r\n"
                  , LC8.fromStrict $ T.encodeUtf8 msg
                  ]
    close sock