{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeApplications #-}
module Main where
import qualified GitHub.Auth as Github
import qualified GitHub.Endpoints.Issues as Github
import qualified GitHub.Endpoints.Issues.Labels as Github
-- import qualified GitHub.Data.Name as Github
import qualified Data.Vector as V
import qualified Data.ByteArray as BA
import qualified Data.Text as T
import System.Directory (getHomeDirectory)
import Data.Word (Word8)
import Data.Proxy
import Data.List (intercalate)
import Control.Monad
import System.Environment
import System.Exit
isHex :: Char -> Bool
isHex = flip elem ("0123456789abcdefABCDEF" :: String)
toToken :: String -> Github.Auth
toToken s
| all isHex s = Github.OAuth $ BA.pack $ map toW8 s
| otherwise = err
where
toW8 :: Char -> Word8
toW8 = fromIntegral . fromEnum
err = error $ "not a valid token. only expecting an hexadecimal token, but got: " ++ show s
data Cmd = List | Create String String | Delete [String] | Sync String
deriving (Show,Eq)
newtype Color = Color String
deriving (Eq)
instance Show Color where
show (Color s) = s
newtype LabelName = LabelName String
deriving (Eq)
instance Show LabelName where
show (LabelName s) = s
data Label = Label { getLabelName :: LabelName, getLabelColor :: Color }
deriving (Show,Eq)
data LabelCommand =
LabelDelete LabelName
| LabelCreate LabelName Color
| LabelUpdate LabelName LabelName Color
deriving (Show,Eq)
lblNameToGithub :: LabelName -> Github.Name entity
lblNameToGithub (LabelName name) = Github.mkName Proxy $ T.pack name
labelCommand :: LabelCommand -> Github.Auth -> Github.Name Github.Owner -> Github.Name Github.Repo -> IO (Either Github.Error ())
labelCommand (LabelDelete lbl) =
\tok ghHandle repo -> Github.deleteLabel tok ghHandle repo (lblNameToGithub lbl)
labelCommand (LabelCreate lbl (Color color)) =
\tok ghHandle repo -> fmap (const ()) <$> Github.createLabel tok ghHandle repo (lblNameToGithub lbl) color
labelCommand (LabelUpdate old new (Color color)) =
\tok ghHandle repo -> fmap (const ()) <$> Github.updateLabel tok ghHandle repo (lblNameToGithub old) (lblNameToGithub new) color
readToken :: IO Github.Auth
readToken = do
home <- getHomeDirectory
maybe (error "file doesn't contain a token") toToken . headM . lines <$> readFile (home ++ "/" ++ ".gh-labeler")
where
headM [] = Nothing
headM (x:_) = Just x
parseColor :: String -> Either String Color
parseColor l = case l of
('#':lHash) | isColorFormat lHash -> Right $ Color lHash
| otherwise -> invalidColor
_ | isColorFormat l -> Right $ Color l
| otherwise -> invalidColor
where
invalidColor = Left ("invalid: color " ++ l)
isColorFormat s = length s == 6 && all isHex s
readLabels :: String -> IO [Label]
readLabels file = do
(sequence . map toLabel . map breakOne . lines <$> readFile file) >>= either failExit pure
where
breakOne s = let (s1,s2) = break (== ' ') s
in (s1, tail s2)
toLabel (colorS, name) =
case parseColor colorS of
Left err -> Left (err ++ " for " ++ name)
Right color -> Right $ Label (LabelName name) color
failExit :: String -> IO a
failExit s = putStrLn ("error: " ++ s) >> exitFailure
processError :: LabelCommand -> Either Github.Error () -> IO ()
processError cmd (Left err) = failExit (show err ++ " when trying to " ++ show cmd)
processError _ _ = pure ()
getRepoLabels :: Github.Auth -> Github.Name Github.Owner -> Github.Name Github.Repo -> IO [Label]
getRepoLabels tok ghHandle repo = do
result <- Github.labelsOnRepo' (Just tok) ghHandle repo
case result of
Left e -> failExit ("failed getting labels on repository " ++ show ghHandle ++ "/" ++ show repo ++ ":\n" ++ show e)
Right r ->
case sequence $ map toLabel $ V.toList r of
Left err -> failExit err
Right l -> pure l
where
toLabel lbl =
case parseColor (T.unpack $ Github.labelColor lbl) of
Left err -> Left (err ++ " for label " ++ lblName)
Right c -> Right $ Label (LabelName lblName) c
where lblName = T.unpack (Github.untagName $ Github.labelName lbl)
findLabel :: LabelName -> [Label] -> Maybe Label
findLabel name = go
where go [] = Nothing
go (x@(Label n _):xs)
| n == name = Just x
| otherwise = go xs
command :: Github.Name Github.Owner -> Github.Name Github.Repo -> Cmd -> IO ()
command ghHandle repo List = do
tok <- readToken
labels <- getRepoLabels tok ghHandle repo
mapM_ (putStrLn . showLabel) labels
where
showLabel :: Label -> String
showLabel (Label name color) =
show name ++ " " ++ show color
command ghHandle repo (Sync file) = do
tok <- readToken
labels <- readLabels file
existingLabels <- getRepoLabels tok ghHandle repo
forM_ labels $ \(Label name color) -> do
case findLabel name existingLabels of
Nothing -> do
putStrLn ("creating label " ++ show name ++ " with color " ++ show color)
let cmd = LabelCreate name color
processError cmd =<< labelCommand cmd tok ghHandle repo
Just (Label _ currentCol)
| currentCol == color -> do
putStrLn ("skipping label " ++ show name)
| otherwise -> do
putStrLn ("updating label " ++ show name ++ " color from " ++ show currentCol ++ " to " ++ show color)
let cmd = LabelUpdate name name color
processError cmd =<< labelCommand cmd tok ghHandle repo
let others = filter (\(Label n _) -> not $ elem n labelNames) existingLabels
where labelNames = map getLabelName labels
let quote s = "\"" ++ s ++ "\""
let x = map (quote . show . getLabelName) others
putStrLn $ "other tags: " ++ intercalate " " x
pure ()
command ghHandle repo (Create name color) = do
tok <- readToken
case parseColor color of
Left err -> putStrLn err >> exitFailure
Right c -> do
let cmd = LabelCreate (LabelName name) c
processError cmd =<< labelCommand cmd tok ghHandle repo
command ghHandle repo (Delete names) = do
tok <- readToken
--existingLabels <- getRepoLabels tok ghHandle repo
forM_ names $ \n -> do
let cmd = LabelDelete (LabelName n)
putStrLn ("Deleting " ++ n)
processError cmd =<< labelCommand cmd tok ghHandle repo
main :: IO ()
main = do
args <- getArgs
case args of
ghHandle:repo:"list":[] ->
command (Github.mkName Proxy $ T.pack ghHandle) (Github.mkName Proxy $ T.pack repo) List
ghHandle:repo:"create":name:color:[] ->
command (Github.mkName Proxy $ T.pack ghHandle) (Github.mkName Proxy $ T.pack repo) (Create name color)
ghHandle:repo:"sync":file:[] ->
command (Github.mkName Proxy $ T.pack ghHandle) (Github.mkName Proxy $ T.pack repo) (Sync file)
ghHandle:repo:"delete":l ->
command (Github.mkName Proxy $ T.pack ghHandle) (Github.mkName Proxy $ T.pack repo) (Delete l)
_ -> do
putStrLn "usage: gh-labeler <github-handle> <repository> <cmd>"
putStrLn ""
putStrLn " list"
putStrLn " sync <label-file>"
putStrLn " create <label> <color>"
putStrLn " delete <label1> [label2...]"
putStrLn ""
putStrLn "label file format:"
putStrLn " <hexa color> <name>"