gli (empty) → 0.0.1
raw patch · 10 files changed
+492/−0 lines, 10 filesdep +aesondep +attoparsecdep +basesetup-changed
Dependencies added: aeson, attoparsec, base, bytestring, containers, friendly-time, gli, http-client, http-client-tls, http-conduit, network-uri, optparse-applicative, process, text, time, yaml
Files
- LICENSE +30/−0
- README.md +51/−0
- Setup.hs +2/−0
- app/Main.hs +6/−0
- gli.cabal +58/−0
- src/Gli/Cli.hs +71/−0
- src/Gli/Gitlab.hs +61/−0
- src/Gli/Setup.hs +62/−0
- src/Gli/Types.hs +149/−0
- test/Spec.hs +2/−0
+ LICENSE view
@@ -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.
+ README.md view
@@ -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+ ```
+ Setup.hs view
@@ -0,0 +1,2 @@+import Distribution.Simple+main = defaultMain
+ app/Main.hs view
@@ -0,0 +1,6 @@+module Main where++import Gli.Cli++main :: IO ()+main = runParser
+ gli.cabal view
@@ -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
+ src/Gli/Cli.hs view
@@ -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
+ src/Gli/Gitlab.hs view
@@ -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
+ src/Gli/Setup.hs view
@@ -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
+ src/Gli/Types.hs view
@@ -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"
+ test/Spec.hs view
@@ -0,0 +1,2 @@+main :: IO ()+main = putStrLn "Test suite not yet implemented"