Request.hs

{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TemplateHaskell #-}
{-# LANGUAGE UnicodeSyntax #-}
{-# LANGUAGE ViewPatterns #-}
-- | StackExchange API request manipulation routines
module Network.StackExchange.Request
  ( -- * Type
    Request(..), Auth(..), SE(..), Object(..)
    -- * Constructing requests
  , host, path, method, parse
  , query, token, key, site, filter, state, Scope(..), scope
  , client, redirectURI, secret, code
  ) where

import Data.Monoid (Monoid(..), (<>))
import GHC.TypeLits
import Prelude hiding (filter)

import           Control.Lens hiding (query)
import           Data.ByteString.Lazy (ByteString)
import           Data.Aeson (FromJSON)
import           Data.Aeson.Types (Value)
import           Data.Default (Default(..))
import           Data.Map (Map)
import qualified Data.Map as M
import           Data.Text.Lazy (Text)
import qualified Data.Text.Lazy as T
import           Data.Text.Lazy.Builder (toLazyText)
import           Data.Text.Lazy.Builder.Int (decimal)


-- | Whether to use authentication at all. Currently isn't used
data Auth = RequireToken | Ready


-- | SE response type
data Object =
    AccessToken -- ^ <https://api.stackexchange.com/docs/types/access-token>
  | AccountMerge -- ^ <https://api.stackexchange.com/docs/types/account-merge>
  | Answer -- ^ <https://api.stackexchange.com/docs/types/answer>
  | Badge -- ^  <https://api.stackexchange.com/docs/types/badge>
  | Comment -- ^ <https://api.stackexchange.com/docs/types/comment>
  | Error -- ^ <https://api.stackexchange.com/docs/types/error>
  | Event -- ^ <https://api.stackexchange.com/docs/types/event>
  | Filter -- ^ <https://api.stackexchange.com/docs/types/filter>
  | InboxItem -- ^ <https://api.stackexchange.com/docs/types/inbox-item>
  | Info -- ^ <https://api.stackexchange.com/docs/types/info>
  | NetworkUser -- ^ <https://api.stackexchange.com/docs/types/network-user>
  | Notification -- ^ <https://api.stackexchange.com/docs/types/notification>
  | Post -- ^ <https://api.stackexchange.com/docs/types/post>
  | Privilege -- ^ <https://api.stackexchange.com/docs/types/privilege>
  | Question -- ^ <https://api.stackexchange.com/docs/types/question>
  | QuestionTimeline -- ^ <https://api.stackexchange.com/docs/types/question-timeline>
  | Reputation -- ^ <https://api.stackexchange.com/docs/types/reputation>
  | ReputationHistory -- ^ <https://api.stackexchange.com/docs/types/reputation-history>
  | Revision -- ^ <https://api.stackexchange.com/docs/types/revision>
  | Site -- ^ <https://api.stackexchange.com/docs/types/site>
  | SuggestedEdit -- ^ <https://api.stackexchange.com/docs/types/suggested-edit>
  | Tag -- ^ <https://api.stackexchange.com/docs/types/tag>
  | TagScore -- ^ <https://api.stackexchange.com/docs/types/tag-score>
  | TagSynonym -- ^ <https://api.stackexchange.com/docs/types/tag-synonym>
  | TagWiki -- ^ <https://api.stackexchange.com/docs/types/tag-wiki>
  | TopTag -- ^ <https://api.stackexchange.com/docs/types/top-tag>
  | User -- ^ <https://api.stackexchange.com/docs/types/user>
  | UserTimeline -- ^ <https://api.stackexchange.com/docs/types/user-timeline>
  | WritePermission -- ^ <https://api.stackexchange.com/docs/types/write-permission>


-- | SE response value wrapper
newtype SE (a ∷ Object) = SE { unSE ∷ Value } deriving (Show, FromJSON)


-- | StackExchange API Request data type.
--
-- @a@ is a phantom type showing whether authentication is enabled
--
-- @n@ is a phantom type dissallowing combination of
-- different API calls in one request
--
-- @r@ is a type of parsed API call result
data Request (a ∷ Auth) (n ∷ Symbol) r = Request
  { _host ∷ Text -- ^ API host link
  , _path ∷ Text -- ^ API call link
  , _method ∷ Text -- ^ API call method (GET/POST)
  , _query ∷ Map Text Text -- ^ API call query parameters
  , _parse ∷ Maybe (ByteString → r) -- ^ API call result parsing function
  }


makeLensesFor
  [ ("_host", "__host")
  , ("_path", "__path")
  , ("_method", "__method")
  , ("_query", "__query")
  , ("_parse", "__parse")
  ]
  ''Request


-- | Subject to monoid and idempotent laws, they all are checked in request test suite
instance Monoid (Request a n r) where
  mempty = Request
    { _host = mempty
    , _path = mempty
    , _method = mempty
    , _query = mempty
    , _parse = Nothing
    }
  l `mappend` r = Request
    { _host = _host $ if T.null $ _host r then l else r
    , _path = _path $ if T.null $ _path r then l else r
    , _method = _method $ if T.null $ _method r then l else r
    , _query = _query r <> _query l
    , _parse = _parse $ case _parse r of Just _ → r; Nothing → l
    }


-- | Useful if what's needed is immediate result parse
instance Functor (Request a n) where
  fmap f = over __parse (fmap (f .))
  {-# INLINE fmap #-}


-- | Default StackExchange API request, defines only host link
instance Default (Request a n r) where
  def = mempty % __host .~ "https://api.stackexchange.com/2.1" % __method .~ "GET"
  {-# INLINE def #-}


-- | Request defining only API call host
--
-- Primarily used in Auth, not intended for usage by library user
host ∷ Text → Request a n r
host p = mempty % __host .~ p
{-# INLINE host #-}


-- | Request defining only API call path
--
-- Primarily used in API call wrappers, not intended for usage by library user
path ∷ Text → Request a n r
path p = mempty % __path .~ p
{-# INLINE path #-}


-- | Request defining only call method
--
-- Primarily used in API call wrappers, not intended for usage by library user
method ∷ Text → Request a n r
method m = mempty % __method .~ m
{-# INLINE method #-}


-- | Request defining only API call result parsing function
--
-- Primarily used in API call wrappers, not intended for usage by library user
parse ∷ (ByteString → r) → Request a n r
parse f = mempty % __parse ?~ f
{-# INLINE parse #-}


-- | Request defining only API call query parameters
--
-- Rather low level interface. For more specific usage 'site',
-- 'filter', etc calls may be more convenient
--
--
-- Takes a list of (key, value) parameters such as @[("order", "asc"), ("sort", "rank")]@
query ∷ [(Text, Text)] → Request a n r
query q = mempty % __query .~ M.fromList q
{-# INLINE query #-}


-- | Convert token requiring Request into ready one
token ∷ Text → Request RequireToken n r → Request Ready n r
token t = over __query (M.insert "access_token" t)
{-# INLINE token #-}


-- | Request defining only App key
key ∷ Text → Request a n r
key s = mempty % __query .~ M.singleton "key" s
{-# INLINE key #-}


-- | Request defining only API call site query parameter
site ∷ Text → Request a n r
site s = mempty % __query .~ M.singleton "site" s
{-# INLINE site #-}


-- | Request defining only API call filter query parameter
filter ∷ Text → Request a n r
filter f = mempty % __query .~ M.singleton "filter" f
{-# INLINE filter #-}


-- | Request defining only API call state query parameter
state ∷ Text → Request a n r
state s = mempty % __query .~ M.singleton "state" s
{-# INLINE state #-}


-- | Scope defines permission granted for application by user
data Scope = ReadInbox | NoExpiry | WriteAccess | PrivateInfo


-- | Request defining only API call scope query parameter
scope ∷ [Scope] → Request a n r
scope ss = mempty % __query .~ (M.singleton "scope" $ scopie ss)
 where
  scopie xs = T.intercalate "," . flip map xs $ \case
    ReadInbox   → "read_inbox"
    NoExpiry    → "no_expiry"
    WriteAccess → "write_access"
    PrivateInfo → "private_info"


-- | Request defining only Authentication API call application id
--
-- Primarily used in Authentication API call wrappers, not intended for usage by library user
client ∷ Int → Request a n r
client (toLazyText . decimal → c) = mempty % __query .~ M.singleton "client_id" c
{-# INLINE client #-}


-- | Request defining only Authentication API call redirect url
--
-- Primarily used in Authentication API call wrappers, not intended for usage by library user
redirectURI ∷ Text → Request a n r
redirectURI r = mempty % __query .~ M.singleton "redirect_uri" r
{-# INLINE redirectURI #-}


-- | Request defining only Authentication API call application secret
--
-- Primarily used in Authentication API call wrappers, not intended for usage by library user
secret ∷ Text → Request a n r
secret c = mempty % __query .~ M.singleton "client_secret" c
{-# INLINE secret #-}


-- | Request defining only Authentication API call code
--
-- Primarily used in Authentication API call wrappers, not intended for usage by library user
code ∷ Text → Request a n r
code c = mempty % __query .~ M.singleton "code" c
{-# INLINE code #-}