{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : GitLab
-- Description : Contains the 'runGitLab' function to run GitLab actions
-- Copyright   : (c) Rob Stewart, Heriot-Watt University, 2019
-- License     : BSD3
-- Maintainer  : [email protected]
-- Stability   : stable
module GitLab
  ( runGitLab,
    runGitLabPassPrompt,
    runGitLabDbg,
    runGitLabWithManager,
    module GitLab.Types,
    module GitLab.API.Pipelines,
    module GitLab.API.Groups,
    module GitLab.API.Members,
    module GitLab.API.Commits,
    module GitLab.API.Projects,
    module GitLab.API.Users,
    module GitLab.API.Issues,
    module GitLab.API.Branches,
    module GitLab.API.Jobs,
    module GitLab.API.MergeRequests,
    module GitLab.API.Repositories,
    module GitLab.API.RepositoryFiles,
    module GitLab.API.Tags,
    module GitLab.API.Todos,
    module GitLab.API.Version,
    module GitLab.API.Notes,
    module GitLab.API.Boards,
    module GitLab.API.Discussions,
    module GitLab.SystemHooks.GitLabSystemHooks,
    module GitLab.SystemHooks.Types,
    module GitLab.SystemHooks.Rules,
  )
where

import Control.Monad.IO.Class
import Control.Monad.Trans.Reader
import Data.Default
import qualified Data.Text as T
import GitLab.API.Boards
import GitLab.API.Branches
import GitLab.API.Commits
import GitLab.API.Discussions
import GitLab.API.Groups
import GitLab.API.Issues
import GitLab.API.Jobs
import GitLab.API.Members
import GitLab.API.MergeRequests
import GitLab.API.Notes
import GitLab.API.Pipelines
import GitLab.API.Projects
import GitLab.API.Repositories
import GitLab.API.RepositoryFiles
import GitLab.API.Tags
import GitLab.API.Todos
import GitLab.API.Users
import GitLab.API.Version
import GitLab.SystemHooks.GitLabSystemHooks
import GitLab.SystemHooks.Rules
import GitLab.SystemHooks.Types
import GitLab.Types
import Network.HTTP.Conduit
import Network.HTTP.Types.Status
import System.IO

-- | runs a GitLab action.
--
-- Internally, this creates a single 'Manager', whichs keeps track of
-- open connections for keep-alive and which is shared between
-- multiple threads and requests.
--
-- An example of its use is:
--
-- > projectsWithIssuesEnabled :: IO [Project]
-- > projectsWithIssuesEnabled =
-- >   runGitLabyConfig $ filter (issueEnabled . issues_enabled) <$> allProjects
-- >   where
-- >     myConfig = defaultGitLabServer
-- >         { url = "https://gitlab.example.com"
-- >         , token = "my_access_token" }
-- >     issueEnabled Nothing = False
-- >     issueEnabled (Just b) = b
runGitLab :: GitLabServerConfig -> GitLab a -> IO a
runGitLab :: forall a. GitLabServerConfig -> GitLab a -> IO a
runGitLab GitLabServerConfig
cfg GitLab a
action = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  let settings :: ManagerSettings
settings = TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
forall a. Default a => a
def Maybe SockSettings
forall a. Maybe a
Nothing
  manager <- IO Manager -> IO Manager
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> IO Manager) -> IO Manager -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager ManagerSettings
settings
  runGitLabWithManager manager cfg action

-- | The same as 'runGitLab', except that it prompts for a GitLab
-- access token before running the GitLab action.
--
-- In this case you can just use 'defaultGitLabServer' with no
-- modification of the record field values, because these values will
-- be asked for at runtime:
--
-- > runGitLabPassPrompt defaultGitLabServer myGitLabProgram
runGitLabPassPrompt :: GitLabServerConfig -> GitLab a -> IO a
runGitLabPassPrompt :: forall a. GitLabServerConfig -> GitLab a -> IO a
runGitLabPassPrompt GitLabServerConfig
cfg GitLab a
action = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
NoBuffering
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStr String
"Enter GitLab server URL\n> ")
  hostUrl <- IO String
getLine
  liftIO (putStr "Enter GitLab access token\n> ")
  pass <- getLine
  runGitLab (cfg {url = T.pack hostUrl, token = AuthMethodToken (T.pack pass)}) action

-- | The same as 'runGitLab', except that it also takes a connection
-- manager as an argument.
runGitLabWithManager :: Manager -> GitLabServerConfig -> GitLab a -> IO a
runGitLabWithManager :: forall a. Manager -> GitLabServerConfig -> GitLab a -> IO a
runGitLabWithManager Manager
manager GitLabServerConfig
cfg (GitLabT ReaderT GitLabState IO a
action) = do
  -- test the token access
  let (GitLabT ReaderT
  GitLabState IO (Either (Response ByteString) (Maybe Version))
versionCheck) = GitLabT IO (Either (Response ByteString) (Maybe Version))
gitlabVersion
  tokenTest <- ReaderT
  GitLabState IO (Either (Response ByteString) (Maybe Version))
-> GitLabState -> IO (Either (Response ByteString) (Maybe Version))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  GitLabState IO (Either (Response ByteString) (Maybe Version))
versionCheck (GitLabServerConfig -> Manager -> GitLabState
GitLabState GitLabServerConfig
cfg Manager
manager)
  case tokenTest of
    Left Response ByteString
response ->
      case Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response of
        (Status Int
401 ByteString
"Unauthorized") -> String -> IO a
forall a. HasCallStack => String -> a
error String
"access token not accepted."
        Status
st -> String -> IO a
forall a. HasCallStack => String -> a
error (String
"unexpected HTTP status: " String -> String -> String
forall a. Semigroup a => a -> a -> a
<> Status -> String
forall a. Show a => a -> String
show Status
st)
    Right Maybe Version
_versionInfo ->
      -- it worked, run the user code.
      ReaderT GitLabState IO a -> GitLabState -> IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT GitLabState IO a
action (GitLabServerConfig -> Manager -> GitLabState
GitLabState GitLabServerConfig
cfg Manager
manager)

-- | Only useful for testing GitLab actions that lift IO actions with
-- liftIO. Cannot speak to a GitLab server. Only useful for the
-- gitlab-haskell tests.
runGitLabDbg :: GitLab a -> IO a
runGitLabDbg :: forall a. GitLab a -> IO a
runGitLabDbg (GitLabT ReaderT GitLabState IO a
action) = do
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO () -> IO ()) -> IO () -> IO ()
forall a b. (a -> b) -> a -> b
$ Handle -> BufferMode -> IO ()
hSetBuffering Handle
stdout BufferMode
LineBuffering
  manager <- IO Manager -> IO Manager
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (IO Manager -> IO Manager) -> IO Manager -> IO Manager
forall a b. (a -> b) -> a -> b
$ ManagerSettings -> IO Manager
newManager (TLSSettings -> Maybe SockSettings -> ManagerSettings
mkManagerSettings TLSSettings
forall a. Default a => a
def Maybe SockSettings
forall a. Maybe a
Nothing)
  let cfg = GitLabServerConfig {url :: Text
url = Text
"", token :: AuthMethod
token = Text -> AuthMethod
AuthMethodToken Text
"", retries :: Int
retries = Int
1, debugSystemHooks :: Maybe DebugSystemHooks
debugSystemHooks = Maybe DebugSystemHooks
forall a. Maybe a
Nothing}
  runReaderT action (GitLabState cfg manager)