Core.hs

-----------------------------------------------------------------------------
-- |
-- Module     : Gitlab.Core
-- Copyright  : (c) Daniel Firth 2018
-- License    : BSD3
-- Maintainer : locallycompact@gmail.com
-- Stability  : experimental
--
-- This file defines general functions for interacting with the Gitlab V4 API
-- (https://docs.gitlab.com/ce/api/)
--
-----------------------------------------------------------------------------
module Gitlab.Core
  ( HasGitlabConfig(..)
  , GitlabConfig(..)
  , MonadGitlab
  , gitlabRequest
  , rParam
  )
where

import           Data.Yaml
import           Network.HTTP.Simple
import           Network.HTTP.Conduit
import           Network.HTTP.Types
import           RIO
import qualified RIO.Text                      as Text

class HasGitlabConfig a where
  gitlabConfigL :: Lens' a GitlabConfig

data GitlabConfig = GitlabConfig {
  glBaseUrl :: Text
, glToken   :: Text
} deriving (Eq, Show)

instance HasGitlabConfig GitlabConfig where
  gitlabConfigL = id

type MonadGitlab env m = (MonadReader env m, HasGitlabConfig env, MonadIO m, MonadThrow m)

gitlabRequest
  :: (MonadGitlab env m, FromJSON a)
  => ByteString
  -> ByteString
  -> RequestBody
  -> m a
gitlabRequest method path body = do
  conf     <- ask . view $ gitlabConfigL
  request' <- parseRequest $ Text.unpack $ glBaseUrl conf
  let headers =
        [ ("PRIVATE-TOKEN", fromString . Text.unpack $ glToken conf)
        , ("Content-Type" , "application/json; charset=utf-8")
        ]
  let request =
        setRequestMethod method
          $ setRequestPath ("/api/v4" <> path)
          $ setRequestHeaders headers
          $ setRequestBody body request'
  response <- httpJSON request
  return $ getResponseBody response

rParam x = urlEncode False (fromString . Text.unpack $ x)