diff --git a/LICENSE b/LICENSE new file mode 100644 --- /dev/null +++ b/LICENSE @@ -0,0 +1,30 @@ +Copyright Author name here (c) 2016 + +All rights reserved. + +Redistribution and use in source and binary forms, with or without +modification, are permitted provided that the following conditions are met: + + * Redistributions of source code must retain the above copyright + notice, this list of conditions and the following disclaimer. + + * Redistributions in binary form must reproduce the above + copyright notice, this list of conditions and the following + disclaimer in the documentation and/or other materials provided + with the distribution. + + * Neither the name of Author name here nor the names of other + contributors may be used to endorse or promote products derived + from this software without specific prior written permission. + +THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS +"AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT +LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR +A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT +OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, +SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT +LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, +DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY +THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT +(INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE +OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. diff --git a/README.md b/README.md new file mode 100644 --- /dev/null +++ b/README.md @@ -0,0 +1,51 @@ +# gli [WIP] + +Goal is to fetch PR info etc. + +## Setup + +1. `stack setup` +2. `stack build` +3. `stack exec which gli` to get the binary path +4. `alias gli=binary_path` + + +## Flow + +1. **Store the gitlab credentials on a file locally. (e.g. ~/.gli.yml)** + + sample file + ``` + accounts: + my_hosted_gitlab: + key: abcd1234xyz + url: https://gitlab.dev.my_hosted_gitlab.com/api/v3 + gitlab: + key: xyz4321dcba + url: https://gitlab.com/api/v3 + ``` + You can get the credentials from https://gitlab.com/profile/account + +2. **Setup `gli` for a git repo** + + This will create a repo specific `gli.yml` file, which will store all the information regarding the repo, and will also be checked out from git. + + ``` + $ cd my_gitlab_repo_path + $ gli setup -f ~/.gli.yml + $ cat gli.yml + project: + ssh_url_to_repo: git@gitlab.com:organization/repo_name.git + name: repo_name + id: 123 + description: 'killer app 42' + masterFileConfig: + key: gitlab + file: /Users/goromlagche/.gli.yml + ``` + +3. **Fetch all open PR related info** + + ``` + $ gli prs + ``` diff --git a/Setup.hs b/Setup.hs new file mode 100644 --- /dev/null +++ b/Setup.hs @@ -0,0 +1,2 @@ +import Distribution.Simple +main = defaultMain diff --git a/app/Main.hs b/app/Main.hs new file mode 100644 --- /dev/null +++ b/app/Main.hs @@ -0,0 +1,6 @@ +module Main where + +import Gli.Cli + +main :: IO () +main = runParser diff --git a/gli.cabal b/gli.cabal new file mode 100644 --- /dev/null +++ b/gli.cabal @@ -0,0 +1,58 @@ +name: gli +version: 0.0.1-alpha +synopsis: Initial project template from stack +description: Please see README.md +homepage: https://github.com/goromlagche/gli#readme +license: BSD3 +license-file: LICENSE +author: goromlagche +maintainer: mrinmoy.das91@gmail.com +copyright: 2016 Mrinmoy Das +category: Web +build-type: Simple +extra-source-files: README.md +cabal-version: >=1.10 + +library + hs-source-dirs: src + exposed-modules: Gli.Types + , Gli.Cli + , Gli.Setup + , Gli.Gitlab + build-depends: base >= 4.7 && < 5 + , containers + , time + , friendly-time + , http-client + , http-conduit + , http-client-tls + , text + , aeson + , attoparsec + , bytestring + , optparse-applicative + , process + , network-uri + , yaml + default-language: Haskell2010 + +executable gli + hs-source-dirs: app + main-is: Main.hs + ghc-options: -threaded -rtsopts -with-rtsopts=-N + build-depends: base + , gli + default-language: Haskell2010 + +test-suite gli-test + type: exitcode-stdio-1.0 + hs-source-dirs: test + main-is: Spec.hs + build-depends: base + , gli + ghc-options: -threaded -rtsopts -with-rtsopts=-N + default-language: Haskell2010 + +source-repository head + type: git + location: https://github.com/goromlagche/gli diff --git a/src/Gli/Cli.hs b/src/Gli/Cli.hs new file mode 100644 --- /dev/null +++ b/src/Gli/Cli.hs @@ -0,0 +1,71 @@ +{-# LANGUAGE DuplicateRecordFields #-} + +module Gli.Cli where + +import qualified Data.Map.Strict as M +import Data.Maybe +import qualified Data.Text as T +import qualified Data.Yaml as Y +import Gli.Gitlab +import Gli.Setup +import Gli.Types +import Options.Applicative +import Prelude hiding (id) + +opts :: ParserInfo Commands +opts = info (helper <*> versionOption <*> commands) + ( fullDesc + <> progDesc "Tiny git\"lab/hub\" cli wrapper" + <> header "gli - make PR review easy again" ) + where + versionOption = infoOption "Version 0.0.1-alpha" + ( long "Version" + <> short 'v' + <> help "Show version") + +commands :: Parser Commands +commands = subparser ((command "setup" + (info (helper <*> (CmdSetup <$> parseSetupFile)) + ( fullDesc + <> progDesc "Setup you project" ))) + <> (command "prs" + (info (pure CmdPrs) + ( fullDesc + <> progDesc "Get all PR info" )))) + +parseSetupFile :: Parser Setup +parseSetupFile = Setup + <$> strOption + ( long "file" + <> short 'f' + <> metavar "FILE" + <> help "Accepts input file which has gitlab keys" ) + +runCli :: Commands -> IO () +runCli (CmdSetup cmd) = setupProject $ keyFile cmd +runCli CmdPrs = do + localCfg <- Y.decodeFile localYmlFile :: IO (Maybe LocalYmlContent) + let masterFileKey = masterFileConfig $ fromJust localCfg + let filePath = file masterFileKey + let fileKey = key (masterFileKey :: MasterFileConfig) + let projectID = id (project (fromJust localCfg) :: Project) + masterCfg <- Y.decodeFile filePath :: IO (Maybe GliCfg) + case masterCfg of + Nothing -> error $ mappend "Unable to parse file " (show filePath) + Just b -> + case M.lookup fileKey (accountMap (accounts b)) of + Nothing -> error $ concat[ "Unable to find key" + , T.unpack fileKey + , " in masterfile " + , filePath] + Just c -> do + mergeRequests (AccountConfig (key (c :: AccountConfig)) gitlabUrl) + where + gitlabUrl = + url c + ++ "/projects/" + ++ show projectID + ++ "/merge_requests?state=opened" + +runParser :: IO () +runParser = execParser opts >>= runCli diff --git a/src/Gli/Gitlab.hs b/src/Gli/Gitlab.hs new file mode 100644 --- /dev/null +++ b/src/Gli/Gitlab.hs @@ -0,0 +1,61 @@ +{-# LANGUAGE DuplicateRecordFields #-} +{-# LANGUAGE OverloadedStrings #-} + +module Gli.Gitlab where + +import Data.Aeson +import qualified Data.ByteString.Char8 as B +import qualified Data.ByteString.Internal as BI +import qualified Data.ByteString.Lazy.Internal as BLI +import qualified Data.Text as T +import Data.Time.Format.Human (humanReadableTime) +import Gli.Types +import Network.HTTP.Client +import Network.HTTP.Client.TLS +import Network.HTTP.Simple +import Prelude hiding (id) + +apiCall :: AccountConfig -> IO BLI.ByteString +apiCall accountConfig = do + manager <- newManager tlsManagerSettings + request' <- parseRequest (url accountConfig) + let request = setRequestManager manager + $ setRequestHeader "PRIVATE-TOKEN" + [(B.pack $ key (accountConfig :: AccountConfig))] + $ request' + + response <- httpLBS request + return (getResponseBody response) + +getProject :: T.Text -> AccountConfig -> IO Project +getProject repoUrl a = do + projectResponseBody <- + apiCall (AccountConfig (key (a :: AccountConfig)) (url a ++ "/projects")) + case parseProject projectResponseBody of + Just projects -> do + let project = head $ filter (\p -> ssh_url_to_repo p == repoUrl) projects + return (project) + Nothing -> error "Unable to fetch projects" + +parseProject :: BLI.ByteString -> Maybe [Project] +parseProject body = decode body :: Maybe [Project] + +mergeRequests :: AccountConfig -> IO () +mergeRequests cfg = do + prResponseBody <- apiCall cfg + let body = justBody $ parseMergeRequest prResponseBody + mapM_ modifyAndShow body + +modifyAndShow :: MergeRequest -> IO () +modifyAndShow m = do + c <- humanReadableTime $ created_at m + u <- humanReadableTime $ updated_at m + putStrLn $ unlines (lines (show m) ++ [ "Created At: " ++ show c + , "Updated At: " ++ show u]) + +parseMergeRequest :: BLI.ByteString -> Maybe [MergeRequest] +parseMergeRequest body = decode body :: Maybe [MergeRequest] + +justBody :: Maybe [a] -> [a] +justBody Nothing = [] +justBody (Just elems) = elems diff --git a/src/Gli/Setup.hs b/src/Gli/Setup.hs new file mode 100644 --- /dev/null +++ b/src/Gli/Setup.hs @@ -0,0 +1,62 @@ +{-# LANGUAGE OverloadedStrings #-} + +module Gli.Setup where + +import qualified Data.Attoparsec.Text as P +import qualified Data.Map.Strict as M +import qualified Data.Text as T +import Data.Yaml +import Gli.Gitlab +import Gli.Types +import Network.URI +import System.Process + +setupProject :: String -> IO () +setupProject file = do + origin <- readProcess "git" + ["config", "--get", "remote.origin.url"] + "" + case P.parseOnly parseGitUrl (T.pack (origin)) of + Left msg -> print msg + Right gitUrl -> do + print gitUrl + cfg <- decodeFile file :: IO (Maybe GliCfg) + case cfg of + Nothing -> putStrLn $ mappend "Unable to parse file " (show file) + Just b -> if M.null matchedKeyVal + then putStrLn $ mappend "Unable to find a relevent key for \ + \the domain, please check the config \ + \file " (show file) + else do + project <- getProject + (T.strip (T.pack origin)) (head $ M.elems $ matchedKeyVal) + encodeFile localYmlFile (LocalYmlContent + (MasterFileConfig file matchedKey) + project) + appendFile gitInfoExcludeFile localYmlFile + where + matchedKey = head $ M.keys $ matchedKeyVal + matchedKeyVal = fetchKeyFromAccount (accounts b) (domain gitUrl) + +parseGitUrl :: P.Parser GitUrl +parseGitUrl = do + _ <- P.string "git@" + d <- P.takeTill (':' ==) + _ <- P.char ':' + r <- P.takeTill ('\n' ==) + return $ GitUrl d r + +fetchKeyFromAccount :: Account -> T.Text -> M.Map T.Text AccountConfig +fetchKeyFromAccount a g = + M.filter (\v -> g == httpDomainConfig(url v)) (accountMap a) + +httpDomainConfig :: String -> T.Text +httpDomainConfig u = + case parseURI u of + Nothing -> error "Unable to find remote url" + Just a -> case uriAuthority a of + Nothing -> error "Unable to parse the url" + Just b -> T.pack $ uriRegName b + +accountMap :: Account -> M.Map T.Text AccountConfig +accountMap (Account acc) = acc diff --git a/src/Gli/Types.hs b/src/Gli/Types.hs new file mode 100644 --- /dev/null +++ b/src/Gli/Types.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DuplicateRecordFields #-} + +module Gli.Types where + +import Data.Aeson +import qualified Data.ByteString.Char8 as B +import Data.Map.Strict as M +import qualified Data.Text as T +import Data.Time +import GHC.Generics (Generic) + +data Setup = + Setup { keyFile :: String } deriving (Show) + +data Commands = CmdSetup Setup + | CmdPrs + deriving (Show) + +data Project = + Project { id :: Int + , description :: Maybe T.Text + , name :: T.Text + , ssh_url_to_repo :: T.Text + } deriving (Generic) + +instance Show Project where + show (Project pid pdescription pname purl) = + unlines [ "GitLab Project" + , "Id: " ++ show pid + , "Name: " ++ show pname + , "Descripion: " ++ justOrEmpty pdescription + , "Git Url: " ++ show purl + , "" + ] + +data MergeRequest = MergeRequest { id :: Int + , title :: Maybe T.Text + , iid :: Int + , project_id :: Int + , description :: Maybe T.Text + , source_branch :: T.Text + , upvotes :: Int + , downvotes :: Int + , author :: User + , assignee :: Maybe User + , source_project_id :: Int + , target_project_id :: Int + , labels :: [Maybe T.Text] + , work_in_progress :: Bool + , milestone :: Maybe T.Text + , merge_when_build_succeeds :: Bool + , merge_status :: T.Text + , subscribed :: Maybe Bool + , web_url :: T.Text + , sha :: T.Text + , created_at :: UTCTime + , updated_at :: UTCTime + } deriving (Generic) + +instance Show MergeRequest where + show (MergeRequest mid mtitle _ _ mdescription msource_branch + _ _ mauthor massignee _ + _ _ mwork_in_progress _ + _ mmerge_status _ mweb_url _ mcreated mupdated) = + unlines [ "ID: " ++ show mid + , "URL: " ++ show mweb_url + , "Title: " ++ justOrEmpty mtitle + , "Descripion: " ++ justOrEmpty mdescription + , "Author: " ++ show mauthor + , "Assignee: " ++ justOrEmpty massignee + , "WIP: " ++ show mwork_in_progress + , "Status: " ++ show mmerge_status + , "Branch: " ++ show msource_branch + ] + +data User = User { name :: T.Text + , username :: T.Text + } deriving (Generic) + +instance Show User where + show (User _ uusername) = show uusername + +data GliCfg = GliCfg { accounts :: Account + } deriving (Generic, Show) + +newtype Account = Account (Map T.Text AccountConfig) + deriving (Generic, Show) + +data AccountConfig = AccountConfig { key :: String + , url :: String + } deriving (Generic, Show) + +type GitlabAccountConfig = (String, B.ByteString) + +data GitUrl = GitUrl { domain :: T.Text + , repo :: T.Text + } + +data LocalYmlContent = LocalYmlContent { masterFileConfig :: MasterFileConfig + , project :: Project + } deriving (Generic, Show) + +data MasterFileConfig = MasterFileConfig { file :: FilePath + , key :: T.Text + } + deriving (Generic, Show) + +instance Show GitUrl where + show (GitUrl gdomain grepo) = + unlines [ "Git Project Found" + , "Domain: " ++ show gdomain + , "Repo: " ++ show grepo + ] + +instance ToJSON MergeRequest where + toEncoding = genericToEncoding defaultOptions +instance ToJSON User where + toEncoding = genericToEncoding defaultOptions +instance ToJSON Project where + toEncoding = genericToEncoding defaultOptions +instance ToJSON Account where + toEncoding = genericToEncoding defaultOptions +instance ToJSON AccountConfig where + toEncoding = genericToEncoding defaultOptions +instance ToJSON LocalYmlContent where + toEncoding = genericToEncoding defaultOptions +instance ToJSON MasterFileConfig where + toEncoding = genericToEncoding defaultOptions + +instance FromJSON MergeRequest +instance FromJSON User +instance FromJSON GliCfg +instance FromJSON Account +instance FromJSON AccountConfig +instance FromJSON Project +instance FromJSON LocalYmlContent +instance FromJSON MasterFileConfig + + +justOrEmpty :: Show a => Maybe a -> String +justOrEmpty (Just a) = show a +justOrEmpty Nothing = "" + +localYmlFile :: FilePath +localYmlFile = "gli.yml" + +gitInfoExcludeFile :: FilePath +gitInfoExcludeFile = ".git/info/exclude" diff --git a/test/Spec.hs b/test/Spec.hs new file mode 100644 --- /dev/null +++ b/test/Spec.hs @@ -0,0 +1,2 @@ +main :: IO () +main = putStrLn "Test suite not yet implemented"