Internal.hs

{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE ViewPatterns      #-}

module Network.Octohat.Internal
  ( putRequestTo
  , getRequestTo
  , postRequestTo
  , deleteRequestTo
  , composeEndpoint) where

import Control.Error.Safe
import Control.Lens (set, view)
import Control.Monad.Reader
import Data.Aeson
import Data.List
import Data.Text.Encoding (encodeUtf8)
import Network.Wreq
import qualified Network.Wreq.Types as WT
import qualified Data.ByteString.Lazy as BSL
import qualified Data.Text as T

import Network.Octohat.Types

composeEndpoint :: [T.Text] -> T.Text
composeEndpoint pathChunks = T.concat $ intersperse "/" ("https://api.github.com" : pathChunks)

getResponseEntity :: FromJSON a => Response BSL.ByteString -> Either GitHubReturnStatus a
getResponseEntity resp =
  case eitherDecode (view responseBody resp) of
    Left errorMessage -> Left (UnexpectedJSON errorMessage)
    Right decoded     -> Right decoded

requestOptions :: GitHub Options
requestOptions = do
  bearerToken <- ask
  let opts   = set auth (Just $ oauth2Bearer (encodeUtf8 $ unBearerToken bearerToken)) defaults
  let opts'  = set checkStatus (Just (\_ _ _ -> Nothing)) opts
  let opts'' = set (header "User-Agent") ["octohat v0.1"] opts'
  return opts''


postRequestTo :: (ToJSON b, WT.Postable b, FromJSON a) => T.Text -> b -> GitHub a
postRequestTo uri body = do
  opts     <- requestOptions
  response <- liftIO $ postWith opts (T.unpack uri) (toJSON body)
  checkForStatus response
  tryRight $ getResponseEntity response

getRequestTo :: FromJSON a => T.Text -> GitHub a
getRequestTo uri = do
  opts     <- requestOptions
  response <- liftIO $ getWith opts (T.unpack uri)
  checkForStatus response
  tryRight $ getResponseEntity response

putRequestTo :: FromJSON a => T.Text -> GitHub a
putRequestTo uri = do
  opts     <- requestOptions
  response <- liftIO $ putWith opts (T.unpack uri) EmptyBody
  checkForStatus response
  tryRight $ getResponseEntity response

deleteRequestTo :: T.Text -> GitHub DidDelete
deleteRequestTo uri = do
  opts     <- requestOptions
  response <- liftIO $ deleteWith opts (T.unpack uri)
  checkForStatus response
  return $ isDeleted (viewResponse response)

checkForStatus :: Response a -> GitHub ()
checkForStatus (viewResponse -> 404) = tryAssert NotFound False
checkForStatus (viewResponse -> 403) = tryAssert NotAllowed False
checkForStatus (viewResponse -> 401) = tryAssert RequiresAuthentication False
checkForStatus (viewResponse -> 422) = tryAssert ValidationFailed False
checkForStatus (viewResponse -> 500) = tryAssert InternalError False
checkForStatus (viewResponse -> 400) = tryAssert InvalidJSON False
checkForStatus (viewResponse -> _)   = tryAssert AllOk True

viewResponse :: Response a -> Int
viewResponse = view (responseStatus . statusCode)

isDeleted :: Int -> DidDelete
isDeleted 204 = Deleted
isDeleted 200 = Deleted
isDeleted _   = NotDeleted