{-# LANGUAGE OverloadedStrings #-}

-- |
-- Module      : GitLab
-- Description : Contains the 'runGitLab' function to run GitLab actions
-- Copyright   : (c) Rob Stewart, Heriot-Watt University, 2019
-- License     : BSD3
-- Maintainer  : robstewart57@gmail.com
-- 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
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
  Manager -> GitLabServerConfig -> GitLab a -> IO a
forall a. Manager -> GitLabServerConfig -> GitLab a -> IO a
runGitLabWithManager Manager
manager GitLabServerConfig
cfg GitLab a
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> ")
  String
hostUrl <- IO String
getLine
  IO () -> IO ()
forall a. IO a -> IO a
forall (m :: * -> *) a. MonadIO m => IO a -> m a
liftIO (String -> IO ()
putStr String
"Enter GitLab access token\n> ")
  String
pass <- IO String
getLine
  GitLabServerConfig -> GitLab a -> IO a
forall a. GitLabServerConfig -> GitLab a -> IO a
runGitLab (GitLabServerConfig
cfg {url = T.pack hostUrl, token = AuthMethodToken (T.pack pass)}) GitLab a
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
  Either (Response ByteString) (Maybe Version)
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 Either (Response ByteString) (Maybe Version)
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
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
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}
  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)