switchboard.bas

Attribute VB_Name = "Switchboard"
'Copyright (c) 2020-2022 Adrian S. Lemoine
'
'Distributed under the Boost Software License, Version 1.0.
'(See accompanying file LICENSE_1_0.txt or copy at
'http://www.boost.org/LICENSE_1_0.txt)

Option Explicit

' Type Definition
Type CordType
  name As String
  run As Boolean
  url As String
End Type


Sub Switchboard()
'' This subroutine is able to read in project infromation from a file generated by a Python "cord"
'' and use this information to update the Project tasks.
''
'' Asumptions:
''    Board status have been added which match Python Output (Not Started, In progress, Under Review, Done)
''    Configuration file named config.txt is present in working directory
''    User will provide a match pattern to retreive the sprint ID number from a GitHub ID name
''      - Can use "default" to just find the number automatically
''      - Can pass and empty string ("") to skip the sprint assignment step
''      - Can pass a regular expression which will return the sprint ID number
    Dim ProjectName As String
    Dim ProjectPfx As String
    Dim PathName As String
    Dim GitHubCsvFilePath As String
    Dim JiraCsvFilePath As String
    Dim ConfigFile As String
    Dim PythonPath As String
    Dim GitHubCordPath As String
    Dim JiraCordPath As String
    Dim GitHubRepo As String
    Dim JiraURL As String
    Dim SprintLength As String
    Dim SprintPattern As String
    Dim GitHubFilter As String
    Dim JiraJql As String
    Dim JiraProject As String
    Dim LineFromFile As String
    Dim LineItems() As String
    Dim GitHubCordType As CordType
    Dim JiraCordType As CordType
    
    ProjectName = GetUNCPath(Application.ActiveProject.FullName)
    ProjectPfx = Replace(StripFileName(ProjectName), ".mpp", "")
    PathName = GetUNCPath(Application.ActiveProject.Path)
    GitHubCsvFilePath = PathName + "\" + "gh-" + ProjectPfx + ".csv"
    JiraCsvFilePath = PathName + "\" + "j-" + ProjectPfx + ".csv"
        
    ConfigFile = "config.txt"
    ''' Fetch configuration information
    Open PathName + "\" + ConfigFile For Input As #1
    
    ' Extract System Information
    Line Input #1, LineFromFile ' Ignore header
    If LineFromFile = "[System Information]" Then
      ' Extract Python Path
      Line Input #1, LineFromFile
      PythonPath = extract_path(LineFromFile)
      ' Extract path to Switchboard Python file
      Line Input #1, LineFromFile
      GitHubCordPath = extract_path(LineFromFile, "github_cord.py")
      JiraCordPath = extract_path(LineFromFile, "jira_cord.py")
      
    Else
      Err.Raise vbObjectError + 513, "Switchboard Module", _
        "Configuration file is not set up correctly."
    End If
    
    Line Input #1, LineFromFile ' Ignore paragraph break
    
    ' Extract Respository Information
    Line Input #1, LineFromFile
    If LineFromFile = "[Repository Information]" Then
      ' Extract Jira URL
      Line Input #1, LineFromFile
      JiraURL = extract_url(LineFromFile)
      
    Else
      Err.Raise vbObjectError + 513, "Switchboard Module", _
        "Configuration file is not set up correctly."
    End If
    
    Line Input #1, LineFromFile ' Ignore paragraph break
    
    ' Extract Project Information
    Line Input #1, LineFromFile
      If LineFromFile = "[Project Information]" Then
        Line Input #1, LineFromFile ' Ignore header
      Else
        Err.Raise vbObjectError + 513, "Switchboard Module", _
          "Configuration file is not set up correctly."
      End If
    
    ' Fetch project configuration
    Do Until EOF(1)
      Line Input #1, LineFromFile
      LineItems = parse_line(LineFromFile)
      If LineItems(0) = ProjectPfx Then
        GitHubRepo = LineItems(1)
        SprintLength = LineItems(2)
        SprintPattern = LineItems(3)
        GitHubFilter = LineItems(4)
        JiraJql = LineItems(5)
        JiraProject = LineItems(6)
        If GitHubRepo <> "" Then
          GitHubCordType.name = "GitHub"
          GitHubCordType.run = True
          GitHubCordType.url = "https://github.com/" + GitHubRepo + "/issues/"
        End If
        If JiraJql <> "" Then
          JiraCordType.name = "Jira"
          JiraCordType.run = True
          JiraCordType.url = JiraURL + "browse/"
        End If
      End If
    Loop
    
    ' Clean up
    Close #1
    LineFromFile = ""
   
   ''' Call Python scripts to fetch GitHub and Jira issues
    Dim wshell As Object
    Dim Args As String
    Dim script_output As String
    
    Set wshell = CreateObject("WScript.Shell")
    
    Args = "--github_repo " & Chr(34) & GitHubRepo & Chr(34) & _
      " --csv_file " & Chr(34) & GitHubCsvFilePath & Chr(34) & _
      " --sprint_length " & SprintLength & _
      " --git_filter_label " & Chr(34) & GitHubFilter & Chr(34)
    'MsgBox (PythonPath & " " & GitHubCordPath & " " & Args)

    If GitHubCordType.run Then
      script_output = run_cord(PythonPath & " " & GitHubCordPath & " " & Args, _
                               GitHubCordType.name, _
                               PathName)
    End If
    
    ''' Call Python script to fetch Jira issues
    Args = "--jira_server " & Chr(34) & JiraURL & Chr(34) & _
      " --csv_file " & Chr(34) & JiraCsvFilePath & Chr(34) & _
      " --jira_jql " & Chr(34) & JiraJql & Chr(34) & _
      " --jira_project " & Chr(34) & JiraProject & Chr(34)
    'MsgBox (PythonPath & " " & JiraCordPath & " " & Args)

    If JiraCordType.run Then
      script_output = run_cord(PythonPath & " " & JiraCordPath & " " & Args, _
                               JiraCordType.name, _
                               PathName)
    End If
    
    '' Update GitHub Issues
    If GitHubCordType.run Then
      Call update_project(GitHubCordType, GitHubCsvFilePath, SprintPattern)
    End If
    
    '' Update Jira Issues
    If JiraCordType.run Then
      Call update_project(JiraCordType, JiraCsvFilePath, SprintPattern)
    End If
    
    '' Recalculate Project
    Application.CalculateProject
    
    '' Remove CSV files
    If GitHubCordType.run Then
      Kill (GitHubCsvFilePath)
    End If
    If JiraCordType.run Then
      Kill (JiraCsvFilePath)
    End If

End Sub

Function run_cord(Cmd As String, CordName As String, Path As String) As String
''' Call Python scripts to fetch GitHub and Jira issues
  Dim wshell As Object
  Dim wsExec
  Dim oLine As String
  Dim output As String

  Set wshell = CreateObject("WScript.Shell")
  Set wsExec = wshell.exec(Cmd)
  While Not wsExec.stdout.AtEndOfStream
    oLine = wsExec.stdout.ReadLine
    If oLine <> "" Then
      ' vbCrLf is a carrage return + line feed
      output = output & oLine & vbCrLf
    End If
  Wend
  While Not wsExec.stderr.AtEndOfStream
    oLine = wsExec.stderr.ReadLine
    If oLine <> "" Then
      ' vbCrLf is a carrage return + line feed
      output = output & oLine & vbCrLf
    End If
  Wend
  If wsExec.ExitCode <> 0 Then
    Call write_log(output, Path)
    Err.Raise vbObjectError + 516, "Switchboard Module", _
          "Error: " & CordName & " cord execution failed!" & _
          "See error_log.txt for script output."
  End If

  run_cord = output
End Function

Function update_project(CT As CordType, CsvFilePath As String, SprintPattern As String)
  Dim IssueIdField
  Dim ProjectFieldDur As Long
  Dim ProjectFieldBS As Long
  Dim i As Integer
  Dim LineFromFile As String
  Dim LineItems() As String
  Dim gid As Integer
  Dim NewTask As Task
  
  Open CsvFilePath For Input As #2
   
    ''' Get field IDs
    ProjectFieldDur = FieldNameToFieldConstant("Duration", pjProject)
    ProjectFieldBS = FieldNameToFieldConstant("Board Status", pjProject)
    
    ''' Create dictionary relating task ID to repository ID
    Dim unique_id As Long
    Dim repo_id As String
    Dim dict
    Dim ii As Integer

    Set dict = CreateObject("Scripting.Dictionary")
    For i = 1 To ActiveProject.Tasks.count
      If get_repo_id(CT.name, i) = vbNullString Then
      Else
        unique_id = Application.ActiveProject.Tasks(i).UniqueID
        repo_id = get_repo_id(CT.name, i)
        dict.Add repo_id, unique_id
      End If
    Next i
    
    ' Skip header row
    Line Input #2, LineFromFile
    
    ''' Update and add tasks with information from CSV file
    Do Until EOF(2)
      Line Input #2, LineFromFile
      LineItems = parse_line(LineFromFile)
      If dict.exists(CStr(LineItems(7))) Then
        gid = dict(CStr(LineItems(7)))
        ' If the task is a Summary task, only update name, labels, TSR, and links
        If Application.ActiveProject.Tasks.UniqueID(gid).Summary Then
          Application.ActiveProject.Tasks.UniqueID(gid).name = prune_string(LineItems(0))
          'Add Labels
          Application.ActiveProject.Tasks.UniqueID(gid).Text6 = LineItems(8)
          Application.ActiveProject.Tasks.UniqueID(gid).Text8 = LineItems(9)
          Application.ActiveProject.Tasks.UniqueID(gid).Text9 = LineItems(5)
          If CT.name = "Jira" Then
            'Add Target Software Release
            Application.ActiveProject.Tasks.UniqueID(gid).Text5 = LineItems(10)
            'Add the "Reports to" links
            Application.ActiveProject.Tasks.UniqueID(gid).Text10 = LineItems(11)
          End If
        Else
          Application.ActiveProject.Tasks.UniqueID(gid).name = prune_string(LineItems(0))
          Application.ActiveProject.Tasks.UniqueID(gid).SetField FieldID:=ProjectFieldDur, Value:=LineItems(2)
          'Only set start date. Rely on duration to calculate finsih date
          Application.ActiveProject.Tasks.UniqueID(gid).Start = LineItems(3)
          ' If a pattern has been supplied set the sprint
          If SprintPattern = "" Then
          Else
            Application.ActiveProject.Tasks.UniqueID(gid).Sprint = set_sprint(LineItems(5), SprintPattern)
            ' If this is the first time a sprint is being set, set the baseline start and finish.
            '   Check if the baseline is set
            If Not Application.ActiveProject.Tasks.UniqueID(gid).Sprint = "No Sprint" _
                And Application.ActiveProject.Tasks.UniqueID(gid).BaselineStart = "NA" Then
              Application.ActiveProject.Tasks.UniqueID(gid).BaselineStart = LineItems(3)
              Application.ActiveProject.Tasks.UniqueID(gid).BaselineFinish = LineItems(4)
            End If
          End If
          Application.ActiveProject.Tasks.UniqueID(gid).SetField FieldID:=ProjectFieldBS, Value:=LineItems(6)
          'Add Labels
          Application.ActiveProject.Tasks.UniqueID(gid).Text6 = LineItems(8)
          Application.ActiveProject.Tasks.UniqueID(gid).Text8 = LineItems(9)
          Application.ActiveProject.Tasks.UniqueID(gid).Text9 = LineItems(5)
          If CT.name = "Jira" Then
            'Add Target Software Release
            Application.ActiveProject.Tasks.UniqueID(gid).Text5 = LineItems(10)
            'Add the "Reports to" links
            Application.ActiveProject.Tasks.UniqueID(gid).Text10 = LineItems(11)
          End If
          ' Set Percent Complete last to stop Project from overwriting
          If LineItems(1) = vbNullString Then
            Application.ActiveProject.Tasks.UniqueID(gid).PercentComplete = 0
          Else
            Application.ActiveProject.Tasks.UniqueID(gid).PercentComplete = CInt(LineItems(1))
          End If
        End If
      Else
        Set NewTask = Application.ActiveProject.Tasks.Add(prune_string(LineItems(0)))
        NewTask.SetField FieldID:=ProjectFieldDur, Value:=LineItems(2)
        'Only set start date. Rely on duration to calculate finsih date
        NewTask.Start = LineItems(3)
        ' If a pattern has been supplied set the sprint
        If SprintPattern = "" Then
        Else
          NewTask.Sprint = set_sprint(LineItems(5), SprintPattern)
          ' If there is a sprint set, set the baseline start and finish
          If Not NewTask.Sprint = "No Sprint" Then
            NewTask.BaselineStart = LineItems(3)
            NewTask.BaselineFinish = LineItems(4)
          End If
        End If
        NewTask.SetField FieldID:=ProjectFieldBS, Value:=LineItems(6)
        'Add Repo Issue Number
        If CT.name = "GitHub" Then
          NewTask.Text2 = LineItems(7)
        ElseIf CT.name = "Jira" Then
          NewTask.Text1 = LineItems(7)
        Else
          Err.Raise vbObjectError + 515, "Switchboard Module", _
          "Error: " & CT.name & " is not a cord type!"
        End If
        'Add URL
        NewTask.Hyperlink = LineItems(7)
        NewTask.HyperlinkAddress = CT.url + LineItems(7)
        'Add Labels
        NewTask.Text6 = LineItems(8)
        NewTask.Text8 = LineItems(9)
        NewTask.Text9 = LineItems(5)
        If CT.name = "Jira" Then
          'Add Target Software Release
          NewTask.Text5 = LineItems(10)
          'Add the "Reports to" links
          NewTask.Text10 = LineItems(11)
        End If
        ' Set Percent Complete last to stop Project from overwriting
        If LineItems(1) = vbNullString Then
           NewTask.PercentComplete = 0
        Else
           NewTask.PercentComplete = CInt(LineItems(1))
        End If
        
      End If

    Loop
        
  Close #2
End Function

Function parse_line(str As String) As String()
Dim RegEx As Object
Dim pattern
Dim str_array() As String
Dim i As Integer

' Find only the commas outside of the quotes
pattern = ",(?=([^" & Chr(34) & "]*" & Chr(34) & "[^" & Chr(34) & "]*" & Chr(34) & ")*(?![^" & Chr(34) & "]*" & Chr(34) & "))"
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
RegEx.pattern = pattern
str_array = Split(RegEx.Replace(str, "$;$"), "$;$")

' Remove leading whitespace
pattern = "^\s+"
RegEx.pattern = pattern
For i = LBound(str_array) To UBound(str_array)
  str_array(i) = RegEx.Replace(str_array(i), "")
Next i

' Remove outer quotes
pattern = "^" & Chr(34) & "|" & Chr(34) & "$"
RegEx.pattern = pattern
For i = LBound(str_array) To UBound(str_array)
  str_array(i) = RegEx.Replace(str_array(i), "")
Next i

parse_line = str_array

End Function

Function extract_path(ByVal str As String, Optional fname As String = "") As String
Dim RegEx As Object
Dim pattern

' Find "Python Path:" or "Switchboard Path:" and remove from string
pattern = ".*Path:\s*"
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
RegEx.pattern = pattern
str = RegEx.Replace(str, "")

' Set up quotes and optionally add string
'' Remove current quotes
pattern = """"
RegEx.pattern = pattern
str = RegEx.Replace(str, "")

'' Add string
If fname = "" Then
Else
  str = str + "\" + fname
End If

'' Remove double \
pattern = "\\\\"
RegEx.pattern = pattern
If RegEx.test(str) Then
  str = RegEx.Replace(str, "\")
End If

'' Add quotes
''' Chr(34) is the double quotes character
str = Chr(34) & str & Chr(34)
extract_path = str

End Function

Function extract_url(str As String) As String
Dim RegEx As Object
Dim pattern

' Find "GitHub Instance:" or "Jira Instance:" and remove from string
pattern = ".*Instance:\s*"
Set RegEx = CreateObject("vbscript.regexp")
RegEx.Global = True
RegEx.pattern = pattern
str = RegEx.Replace(str, "")

' Set up quotes
'' Remove current quotes
pattern = """"
RegEx.pattern = pattern
str = RegEx.Replace(str, "")

extract_url = str

End Function

Function StripFileName(Path As String) As String
  Dim PathElems As Variant
  
  PathElems = Split(Path, "\")
  StripFileName = PathElems(UBound(PathElems))

End Function

Function GetUNCPath(Path As String) As String
  Dim CurrentDrive As String
  Dim network As Object
  Dim drives As Object
  Dim el As Variant
  Dim RegEx As Object
  Dim RegEx2 As Object
  Dim pattern As String
  Dim str As String
  Dim NewPath As String
  Dim PathDirs As Variant
  Dim NewPathDirs As Variant
  Dim i As Integer
  Dim ii As Integer
  
  ''' Skip function if the string is not a path
  pattern = "[:\\/]"
  Set RegEx = CreateObject("vbscript.regexp")
  RegEx.Global = True
  RegEx.pattern = pattern
  If Not RegEx.test(Path) Then
    GetUNCPath = Path
    Exit Function
  End If
  
  CurrentDrive = Left(Path, 2)
  ''' If the file in not on an external drive exit function
  If CurrentDrive = "C:" Or CurrentDrive = "\\" Then
    GetUNCPath = Path
    Exit Function
  End If
  
  ''' Otherwise find the UNC Path (Universal Nameing Convention)
  Set network = CreateObject("WScript.Network")
  Set drives = network.enumnetworkdrives
  
  ''' Find the inital part (directory) of the path
  pattern = ".*:[\\/]*"
  RegEx.pattern = pattern
  str = RegEx.Replace(Path, "")
  pattern = "[\\/].*"
  RegEx.pattern = pattern
  str = RegEx.Replace(str, "")
  
  ''' Match the path to a drive
  For Each el In drives
    RegEx.pattern = str
    If RegEx.test(el) Then
      NewPath = el
      Exit For
    End If
  Next
  
  pattern = "/"
  RegEx.pattern = pattern
  Set RegEx2 = CreateObject("vbscript.regexp")
  pattern = "\\"
  RegEx2.pattern = pattern
  
  ''' Add remaining path
  ' Check the slashes used
  If RegEx.test(Path) Then
    PathDirs = Split(Path, "/")
  ElseIf RegEx2.test(Path) Then
    PathDirs = Split(Path, "\")
  Else
    MsgBox ("Error: Unable to parse path!")
  End If
  NewPathDirs = Split(NewPath, "\")
  ' Compare the paths to find the missing portion
  For i = UBound(PathDirs) To 1 Step -1
    If PathDirs(i) = NewPathDirs(UBound(NewPathDirs)) Then
      ' Skip if the file is in the top level directory
      If i < UBound(PathDirs) Then
        For ii = i + 1 To UBound(PathDirs)
          NewPath = NewPath + "\" + PathDirs(ii)
        Next ii
      End If
      Exit For
    End If
  Next i
  
  GetUNCPath = NewPath
End Function

Function set_sprint(str As String, pattern As String) As String
  Dim RegEx As Object
  Dim Matches As Object
  Dim match
  Dim count As Integer
  Dim sprintID As String
  Dim returnstr As String
  
  ' If the user has used the default setting just find the number
  If pattern = "default" Then
    pattern = "(\d+)"
  End If
  
  Set RegEx = CreateObject("vbscript.regexp")
  RegEx.Global = True
  RegEx.pattern = pattern
  If RegEx.test(str) Then
    Set Matches = RegEx.Execute(str)
    
    count = 0
    For Each match In Matches
      count = count + 1
      sprintID = match.subMatches.Item(0)
    Next match
    
    ' Raise an error if the pattern matches more than one section of the string
    If count > 1 Then
      Err.Raise VBA.vbObjectError + 514, "Function: set_sprint", _
        "The match pattern has matched more than one section of the milestone string." _
         + " Please provide a regular expression which will only match the ID number of the sprint."
    End If
    
    returnstr = "Sprint " & sprintID
  Else
    ' Only return an empty string when a milestones does not match pattern.
    '   This will allow milestones we don't care about to slip through.
    returnstr = ""
  End If
  set_sprint = returnstr
End Function

Function prune_string(str As String) As String
  ' Ensure the task name is less than 240 characters.
  If Len(str) > 240 Then
    str = Left(str, 240)
  End If
  
  prune_string = str
End Function

Function get_repo_id(CordType As String, i As Integer) As String
  Dim str As String
  If CordType = "GitHub" Then
      str = Application.ActiveProject.Tasks(i).Text2
  ElseIf CordType = "Jira" Then
      str = Application.ActiveProject.Tasks(i).Text1
  Else
      Err.Raise vbObjectError + 515, "Switchboard Module", _
          "Error: " & CordType & " is not a cord type!"
  End If
  get_repo_id = str
End Function

Sub write_log(txt As String, pwd As String)
 
 Open pwd & "\error_log.txt" For Append As #3
 Write #3, txt
 Close #3
 
End Sub