{-# 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.JobArtifacts,
    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.API.Events,
    module GitLab.SystemHooks.GitLabSystemHooks,
    module GitLab.SystemHooks.Types,
    module GitLab.SystemHooks.Rules,
  )
where

import Control.Monad.Except
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.Events
import GitLab.API.Commits
import GitLab.API.Discussions
import GitLab.API.Groups
import GitLab.API.Issues
import GitLab.API.JobArtifacts
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 = AuthMethodToken "my_access_token" }
-- >     issueEnabled Nothing = False
-- >     issueEnabled (Just b) = b
runGitLab :: GitLabServerConfig -> GitLab a -> IO (Either GitLabError a)
runGitLab :: forall a.
GitLabServerConfig -> GitLab a -> IO (Either GitLabError 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 (Either GitLabError a)
forall a.
Manager
-> GitLabServerConfig -> GitLab a -> IO (Either GitLabError 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 (Either GitLabError a)
runGitLabPassPrompt :: forall a.
GitLabServerConfig -> GitLab a -> IO (Either GitLabError 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 (Either GitLabError a)
forall a.
GitLabServerConfig -> GitLab a -> IO (Either GitLabError 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 (Either GitLabError a)
runGitLabWithManager :: forall a.
Manager
-> GitLabServerConfig -> GitLab a -> IO (Either GitLabError a)
runGitLabWithManager Manager
manager GitLabServerConfig
cfg (GitLabT ReaderT GitLabState (ExceptT GitLabError IO) a
action) = do
  let withVersionCheck :: IO (Either GitLabError b) -> IO (Either GitLabError b)
withVersionCheck IO (Either GitLabError b)
func = do
        -- test the token access
        let (GitLabT ReaderT
  GitLabState
  (ExceptT GitLabError IO)
  (Either (Response ByteString) (Maybe Version))
versionCheck) = GitLabT
  (ExceptT GitLabError IO)
  (Either (Response ByteString) (Maybe Version))
gitlabVersion
        Either GitLabError (Either (Response ByteString) (Maybe Version))
tokenTest <- ExceptT
  GitLabError IO (Either (Response ByteString) (Maybe Version))
-> IO
     (Either GitLabError (Either (Response ByteString) (Maybe Version)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT
  GitLabState
  (ExceptT GitLabError IO)
  (Either (Response ByteString) (Maybe Version))
-> GitLabState
-> ExceptT
     GitLabError IO (Either (Response ByteString) (Maybe Version))
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT
  GitLabState
  (ExceptT GitLabError IO)
  (Either (Response ByteString) (Maybe Version))
versionCheck (GitLabServerConfig -> Manager -> GitLabState
GitLabState GitLabServerConfig
cfg Manager
manager))
        case Either GitLabError (Either (Response ByteString) (Maybe Version))
tokenTest of
          Left (GitLabError Text
t) -> Either GitLabError b -> IO (Either GitLabError b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (GitLabError -> Either GitLabError b
forall a b. a -> Either a b
Left (Text -> GitLabError
GitLabError Text
t))
          Right (Left Response ByteString
response) ->
            case Response ByteString -> Status
forall body. Response body -> Status
responseStatus Response ByteString
response of
              (Status Int
401 ByteString
"Unauthorized") -> Either GitLabError b -> IO (Either GitLabError b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitLabError b -> IO (Either GitLabError b))
-> Either GitLabError b -> IO (Either GitLabError b)
forall a b. (a -> b) -> a -> b
$ GitLabError -> Either GitLabError b
forall a b. a -> Either a b
Left (Text -> GitLabError
GitLabError Text
"access token not accepted.")
              Status
st -> Either GitLabError b -> IO (Either GitLabError b)
forall a. a -> IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either GitLabError b -> IO (Either GitLabError b))
-> Either GitLabError b -> IO (Either GitLabError b)
forall a b. (a -> b) -> a -> b
$ GitLabError -> Either GitLabError b
forall a b. a -> Either a b
Left (Text -> GitLabError
GitLabError (Text
"unexpected HTTP status: " Text -> Text -> Text
forall a. Semigroup a => a -> a -> a
<> String -> Text
T.pack (Status -> String
forall a. Show a => a -> String
show Status
st)))
          Right (Right Maybe Version
_versionInfo) -> IO (Either GitLabError b)
func
      goAhead :: IO (Either GitLabError a)
goAhead = ExceptT GitLabError IO a -> IO (Either GitLabError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT GitLabState (ExceptT GitLabError IO) a
-> GitLabState -> ExceptT GitLabError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT GitLabState (ExceptT GitLabError IO) a
action (GitLabServerConfig -> Manager -> GitLabState
GitLabState GitLabServerConfig
cfg Manager
manager))
  -- No version check without authentication because /version is not public.
  case GitLabServerConfig -> AuthMethod
token GitLabServerConfig
cfg of
    AuthMethod
AuthMethodNone -> IO (Either GitLabError a)
goAhead
    AuthMethod
_ -> IO (Either GitLabError a) -> IO (Either GitLabError a)
forall {b}. IO (Either GitLabError b) -> IO (Either GitLabError b)
withVersionCheck  IO (Either GitLabError a)
goAhead

-- | 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 (Either GitLabError a)
runGitLabDbg :: forall a. GitLab a -> IO (Either GitLabError a)
runGitLabDbg (GitLabT ReaderT GitLabState (ExceptT GitLabError 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}
  ExceptT GitLabError IO a -> IO (Either GitLabError a)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ReaderT GitLabState (ExceptT GitLabError IO) a
-> GitLabState -> ExceptT GitLabError IO a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
runReaderT ReaderT GitLabState (ExceptT GitLabError IO) a
action (GitLabServerConfig -> Manager -> GitLabState
GitLabState GitLabServerConfig
cfg Manager
manager))