'////////////////////////////////////////////////////////////////////////////
'
'	ISA Server Ad blocking import  / export script
'
'	Author:	Jim Harrison
'
'	Contact:	jim@jalojash.org
'			www.jalojash.org/isascripts
'
'	Created:	4/15/02
'
'	Purpose:	Creates a destination set and a site & content rule to block advertisements in 
'			web pages
'
'	Usage:	Either dbl-click it from Windows explorer or as "cscript ISA_Ads.vbs" from a 
'			command line
'
'	History:	4/15/02 - First working version
'			4/20/02 - Fixed bug in SCR creation that would cause "conf can't be read"
'					event log errors 
'
'	ToDo:	Lots - see each section for small details
'			Make it Enterprise-policy aware
'			Make it merge-smart
'
'////////////////////////////////////////////////////////////////////////////

'so we don't lie to ourselves about our variables
Option Explicit

'global class for general use
Dim Tools

'Let's do this
Set Tools = New ISATools
Main

'Let's undo this
Set Tools = Nothing


'////////////////////////////////////////////////////////////////////////////
'
'	Sub Main
'
'	Purpose:	Handles the inital ISA and XML object creation and chains off to other routines
'			depending on the options chosen
'
'	Input:	None
'
'	Output:	XMLDocument and ISA objects for other routines
'
'	ToDo:	nothing?
'
'////////////////////////////////////////////////////////////////////////////

Sub Main

	'ISA variables
	Dim FPC
	Dim ISA

	'XML variables
	Dim XMLDoc

	'Create the ISA Server admin object
	Set FPC = CreateObject ( "FPC.Root" )
	FPC.Refresh
	Set ISA = FPC.Arrays.GetContainingArray

	'create the XML document object
	Set XMLDoc = CreateObject ( "Microsoft.XMLDom" )
	XMLDoc.Async = False
	
	'Let's get someone to make a decision
	Select Case ImpExp
		Case "import": Import XMLDoc, ISA
		Case "export": Export XMLDoc, ISA
	End Select
	
End Sub


'////////////////////////////////////////////////////////////////////////////
'
'	Function ImpExp
'
'	Purpose:	Prompts the user for their choice of "Import" or "Export" and handles 
'			incorrect input
'
'	Input:	from the user via Tools class input routine
'
'	Output:	returns one of two valid options to caller
'
'	ToDo:	nothing?
'
'////////////////////////////////////////////////////////////////////////////

Function ImpExp (  )

	Dim Answer
	Answer = LCase ( Tools.GetAns ( Tools.ImpExp, "Import" ) )
	Select Case Answer
		Case "import", "export": ImpExp = Answer
		Case Else: 
			Tools.ShowErr ( Tools.OptsErr )
			ImpExp
	End Select

End Function


'////////////////////////////////////////////////////////////////////////////
'
'	Sub Import
'
'	Purpose:	Reads the input file and creates the destination set based on the data found 
'			there
'
'	Input:	XMLDoc and ISA objects from sub Main
'			from the user via Tools class input routine
'			from the xml file
'
'	Output:	creates a destination set in ISA with data from source XML
'
'	ToDo:	add capability to read CSV, TSV as well as XML
'
'////////////////////////////////////////////////////////////////////////////

Sub Import  ( XMLDoc, ISA )

	On Error Resume Next

	Dim Ads
	Dim DestinationSet
	Dim Destination
	Dim OldDest
	Dim DType
	Dim Ans
	Dim InVal1
	Dim InVal2
	Dim InVal3
	Const DestExist = &h80070002
	Const Domain 	= 0
	Const SingleIP	= 1
	Const IPRange	= 2

	Ans = Tools.GetAns ( Tools.SrcFileMsg, Tools.FileIn )
	If Tools.FindFile ( Ans ) Then
		Tools.FileIn = Ans
		XMLDoc.Load ( Tools.FileIn )
	Else
		Tools.ShowErr ( Tools.FNFMsg )
		Import XMLDoc, ISA
	End If
	
	Set Ads = XMLDoc.SelectSingleNode ( "Ads" )

	'try to create the DS, and ask] for merge if fails
	Set DestinationSet = MakeDs ( ISA )

	'came back to do it; let's see what there is to do
	For Each Destination in Ads.SelectNodes ( "Destination" )

		DType = CInt ( Destination.GetAttribute ( "Type" ) )

		Select Case DType
			Case Domain
				InVal1 = Destination.GetAttribute ( "DomainName" )
				InVal2 = ""
			Case SingleIP
				InVal1 = Destination.GetAttribute ( "IP_From" )
				InVal2 = ""
			Case IPRange
				InVal1 = Destination.GetAttribute ( "IP_From" )
				InVal2 = Destination.GetAttribute ( "IP_To" )
		End Select

		InVal3 = Destination.GetAttribute ( "Path" ) 
		DestinationSet.Add InVal1, InVal2, InVal3

		Err.Clear

	Next

	DestinationSet.Save

	MakeScr ISA

	Tools.Showinfo "Done with the Import thingy.."

End Sub


'////////////////////////////////////////////////////////////////////////////
'
'	Function MakeDs
'
'	Purpose:	creates a destination set named according to user input
'
'	Input:	ISA object from Sub Import 
'			from the user via Tools class input routine
'
'	Output:	returns a destination set object to sub Import
'
'	ToDo:	Ds Merge support
'
'////////////////////////////////////////////////////////////////////////////

Function MakeDs ( ISA )

	On Error Resume Next
	Dim Rtn
	Dim Ans
	Const DupDs = &h800700b7
	
	Err.Clear
	Rtn = Tools.GetAns ( Tools.DsQuery, Tools.DsName )

	Set MakeDs = ISA.PolicyElements.DestinationSets.Add ( Rtn )
	Select Case Err.Number
		Case 0
			Tools.DsName = Rtn
			MakeDs.Description = Tools.DsDescr
			Exit Function
		Case DupDs
			If Not Tools.AskYN ( Tools.DsDup ) Then
				If Not Tools.AskYN ( Tools.QuitMsg ) Then Set MakeDs = MakeDs ( ISA )
			End If
			Err.Clear
		Case Else
			If Not Tools.AskYN ( Tools.DsErr ) Then WScript.Quit
	End Select

	Set MakeDs = MakeDs ( ISA )

	Err.Clear

End Function


'////////////////////////////////////////////////////////////////////////////
'
'	Function MakeScr
'
'	Purpose:	creates a Site and Content Rule associated with the chosen destination set
'
'	Input:	XMLDoc and ISA objects from Import subroutine
'			from the user via Tools class input routine
'
'	Output:	creates a new S&C rule
'
'	ToDo:	option to change data in existing S&C Rule
'			ability to import this as well
'
'////////////////////////////////////////////////////////////////////////////

Function MakeScr ( ISA )

	On Error Resume Next
	Dim Rtn
	Dim TempScr
	Const DupScr = &h800700b7
	Const fpcArrayScope = 0
	Const fpcEnterpriseScope = 1
	
	Err.Clear
	Rtn = Tools.GetAns ( Tools.ScrQuery, Tools.ScrName )

	Set MakeScr = ISA.ArrayPolicy.SiteAndContentRules.Add ( Rtn )
'	Wscript.Echo "MakeScr ( " & Rtn & " ) = 0x" & Hex ( Err.Number )
	Select Case Err.Number
		Case 0
			Tools.ScrName = Rtn
		Case Else
			If Not Tools.AskYN ( Tools.ScrDup ) Then 
				WScript.Quit
			Else
				Set MakeScr = MakeScr ( ISA )
			End If
	End Select		

	MakeScr.Description = Tools.ScrDescr
	MakeScr.Enabled = "True"
	MakeScr.Action = "1"
	MakeScr.AppliesToContentMethod = "0"
	MakeScr.SetDestination "3", Tools.DsName
	MakeScr.SetSchedule  ( "Always" ), fpcArrayScope
	MakeScr.AppliesToMethod = "0"
	MakeScr.Save

End Function


'////////////////////////////////////////////////////////////////////////////
'
'	Sub Export
'
'	Purpose:	Creates an xml file containing the data in the chosen destination set
'
'	Input:	from the user via Tools class input routines
'			properties of the specified destination set
'
'	Output:	creates an xml file according to user input
'
'	ToDo:	option to merge data in existing XML, CSV, TSV file
'
'////////////////////////////////////////////////////////////////////////////

Sub Export ( XMLDoc, ISA )

	Dim Ads
	Dim DestinationSet
	Dim Destination
	Dim Dest
	Dim DType
	Dim NewDest
	Dim Rtn
	
	'Destination set info
	Const Domain 	= 0
	Const SingleIP	= 1
	Const IPRange	= 2

	AskDestFile

	Set DestinationSet = GetDs ( ISA )
	
	XMLDoc.LoadXML ( "<Ads/>" )
	Set Ads = XMLDoc.SelectSingleNode ( "Ads" )
	Ads.AppendChild ( XMLDoc.CreateComment ( Tools.XMLComm ) )
	For Each Destination in DestinationSet
		Set Dest = XMLDoc.CreateNode ( 1, "Destination", "" )
		Set NewDest = Ads.AppendChild ( Dest )
		DType = Destination.Type
		NewDest.SetAttribute "Type", DType
		Select Case DType
			Case Domain 
				NewDest.SetAttribute "DomainName", Destination.DomainName
			Case SingleIP
				NewDest.SetAttribute "IP_From", Destination.IP_From
			Case IPRange 
				NewDest.SetAttribute "IP_From", Destination.IP_From
				NewDest.SetAttribute "IP_To", Destination.IP_To
		End Select
		NewDest.SetAttribute "Path", Destination.Path
	Next

	XMLDoc.Save Tools.FileOut

	Tools.Showinfo "Done with the Export thingy.." & vbCrLf & "Saved it as: " & Tools.FileOut

End Sub


'////////////////////////////////////////////////////////////////////////////
'
'	Function AskDestFile
'
'	Purpose:	Prompts the user for a place to save the output file
'			Verifies the existence of the file
'
'	Input:	from the user via Tools class input routines
'
'	Output:	returns a verified file location
'
'	ToDo:	error checking and file merge support
'
'////////////////////////////////////////////////////////////////////////////

Function AskDestFile

	Dim Rtn
	
	'find out where to save the exported data
	AskDestFile = Tools.GetAns ( Tools.DestFileMsg, Tools.FileOut )
	If Tools.FindFile ( AskDestFile ) Then
		Tools.ShowErr ( Tools.FileExistsMsg )
		AskDestFile
	Else
		Tools.FileOut = AskDestFile
	End If

End Function


'////////////////////////////////////////////////////////////////////////////
'
'	Function GetDs
'
'	Purpose:	Prompts the user for the Destination Set of choice
'
'	Input:	ISA object from Export function
'			from the user via Tools class input routines
'			verifies the specified destination set
'
'	Output:	returns a DestinationSet object
'
'	ToDo:	error checking
'
'////////////////////////////////////////////////////////////////////////////

Function GetDs ( ISA )

	On Error Resume Next
	Dim Rtn
	'find out what Ds to export
	Rtn = Tools.GetAns ( Tools.DsQuery, Tools.DsName )
	Set GetDs = ISA.PolicyElements.DestinationSets.Item ( Rtn ) 
	If Err Then
		Tools.ShowErr ( Tools.DsErrMsg )
		Set GetDs = GetDs ( ISA )
	End If
	On Error Goto 0

End Function


'////////////////////////////////////////////////////////////////////////////
'
'	Class ISATools
'
'	Purpose:	the heart and soul of this beastie
'			contains all the common methods and properties needed by various subs 
'			and functions
'
'	Input:	from subs and functions
'
'	Output:	returns properties and method results to calling routines
'
'	ToDo:	depends on functionality added to main Script
'
'////////////////////////////////////////////////////////////////////////////

Class ISATools

	'Script-specific text
	Private Version
	Private ScriptTitle

	'general mesages
	Private ImpExpMsg
	Private OptsErrMsg
	Private QuitMsg

	'File option Msgs
	Private CurrPath
	Private OutFileMsg1
	Private OutFileMsg2
	Private InFileMsg
	Private FileNotFound

	'file option variables
	Private OutFile
	Private InFile

	'destination set information
	Private DsQueryMsg
	Private DsDupMsg
	Private DsErrMsg
	Private Ds_Name
	Private Ds_Descr
	Private NoDsMsg

	'Site & Content Rule info
	Private ScrQueryMsg
	Private ScrDupMsg
	Private ScrErrMsg
	Private Scr_Name
	Private Scr_Descr
	Private NoScrMsg

	'Export XML data
	Private XMLComment

	'Some useful objects
	Private WshShell
	Private FSO

	'////////////////////////////////////////////////////////////////////////////
	'
	'	Sub Class_Initialize
	'
	'	Purpose:	defines the default state for class properties 
	'
	'	Input:	called by the "set Tools = New ISATools" command
	'
	'	Output:	Err.Success or Err.Failure to caller  ( intrinsic )
	'
	'	ToDo:	depends on changes in class
	'
	'////////////////////////////////////////////////////////////////////////////

	Private Sub Class_Initialize (  )
		'Create those useful objects
		Set WshShell = CreateObject ( "WScript.Shell" )
		Set FSO = CreateObject ( "Scripting.FileSystemObject" )

		'Script-specific text
		Version		= "1.0"
		ScriptTitle	= "ISA Server Ad import / export tool ver. "  & Version

		'General mesages
		ImpExpMsg	= "Do you want to Import or Export ad filter settings?"
		OptsErrMsg	= "Sorry; that's not a valid option"
		QuitMsg 		= "Do you want to quit?"

		'Export XML data
		XMLComment	= "You can hand edit this file, but please do not change the format" & _
					vbCrLf & "as the script depends on the present schema." & _
					vbCrLf & vbCrLf & "This is a list of ad sites that I've compiled over time." & _
					vbCrLf & "Feel free to add to it as you please." & _
					vbCrLf & "So that we can keep things current, please email your additions back to" & _
					vbCrLf & "jim@jalojash.org for posting to my scripting site." & _
					vbCrLf & vbCrLf & "If you want to hand-edit this, feel free to grab XMLNotepad from" &_
					vbCrLf & "http://msdn.microsoft.com/library/en-us/dnxml/html/xpsetup.exe"

		'File variable defaults
		CurrPath		= Left ( WScript.ScriptFullName, Len ( WScript.ScriptFullName )-Len ( WScript.ScriptName ) )
		OutFile 		= CurrPath & "ISA_Ads.xml"
		InFile		= OutFile

		'File option Msgs
		OutFileMsg1	= "Where do you want to put the export file?"
		OutFileMsg2	= "That file already exists; please choose another file name or path"
		InFileMsg		= "Where is the source file?"
		FileNotFound	= "I can't locate that file; please check the path and re-enter"

		'Ds messages
		DsDupMsg	= "That Destination Set already exists; would you like to create a new one?"
		DsErrMsg		= "Error 0x" & Hex ( Err.Number ) & " was encountered while trying to create the DS." & _
						vbCrLf & "Would you like to try again?"
		DsQuerymsg	= "What Destination Set would you like to use?"
		NoDsMsg		= "The specified Destination Set was not found; please check your entry."
		Ds_Name		= "NoAds"
		Ds_Descr		= "Ad Blocking Destination Set"

		'Scr messages
		ScrDupMsg	= "That Site & content Rule already exists; would you like to create another?"
		ScrErrMsg	= "Error 0x" & Hex ( Err.Number ) & " was encountered while trying to create the SCR." & _
						vbCrLf & "Would you like to try again?"
		ScrQuerymsg	= "What would you like to name the new Site & Content Rule?"
		NoScrMsg	= "The specified Site & Content Rule was not found; please check your entry."
		Scr_Name	= Ds_Name
		Scr_Descr	= "Ad Blocking Site & Content Rule"
	End Sub


	'////////////////////////////////////////////////////////////////////////////
	'
	'	Sub Class_Terminate
	'
	'	Purpose:	destroys the class and its data
	'
	'	Input:	called by the "set Tools = Nothing" command
	'
	'	Output:	Err.Success or Err.Failure to caller  ( intrinsic )
	'
	'	ToDo:	depends on changes in class
	'
	'////////////////////////////////////////////////////////////////////////////

	Private Sub Class_Terminate (  )
		Set WshShell = Nothing
		Set FSO = Nothing
	End Sub


	'////////////////////////////////////////////////////////////////////////////
	'
	'	Class properties
	'
	'	Purpose:	provide access to global data via class
	'
	'	Input:	only for "property Let" actions
	'
	'	Output:	only for "property Get" actions
	'
	'	ToDo:	depends on changes in class
	'
	'////////////////////////////////////////////////////////////////////////////

	'Returns text held in ImpExpMsg variable
	Public Property Get ImpExp
		ImpExp = ImpExpMsg
	End Property

	'Returns text held in OutFile variable
	Public Property Get FileOut
		FileOut = OutFile
	End Property

	'Modifies text held in OutFile variable
	Public Property Let FileOut ( InVal )
		OutFile = InVal
	End Property

	'Returns text held in InFile variable
	Public Property Get FileIn
		FileIn = InFile
	End property

	'Modifies text held in InFile variable
	Public Property Let FileIn ( InVal )
		InFile = InVal
	End Property

	'Returns text held in OutFileMsg1 variable
	Public Property Get DestFileMsg
		DestFileMsg = OutFileMsg1
	End Property
	
	'Returns text held in OutFileMsg2 variable
	Public Property Get FileExistsMsg
		FileExistsMsg = OutFileMsg2
	End Property

	'Returns text held in InFileMsg variable
	Public Property Get SrcFileMsg
		SrcFileMsg = InFileMsg
	End property

	'Returns text held in FilenotFound variable
	Public Property Get FNFMsg
		FNFMsg = FileNotFound	
	End Property
	
	'Returns text held in OptsErrMsg variable
	Public Property Get OptsErr
		OptsErr = OptsErrMsg
	End Property

	'Returns text held in DsQueryMsg variable
	Public Property Get DsQuery
		DsQuery = DsQueryMsg
	End property

	'Returns text held in NoDsmsg variable
	Public Property Get DsNFMsg
		DsNFMsg = NoDsMsg
	End property

	'Returns text held in DsDupMsg variable
	Public Property Get DsDup
		DsDup = DsDupMsg
	End Property

	'Returns text held in DsErrMsg variable
	Public Property Get DsErr
		DsErr = DsErrMsg
	End Property

	'Returns text held in Ds_Name variable
	Public Property Get DsName
		DsName = Ds_Name
	End Property

	'Modifies text held in Ds_Name variable
	Public Property Let DsName ( InVal )
		Ds_Name = InVal
	End Property

	'Returns text held in Ds_Descr variable
	Public Property Get DsDescr
		DsDescr = Ds_Descr
	End property

	'Returns text held in SrcQueryMsg variable
	Public Property Get ScrQuery
		ScrQuery = ScrQueryMsg
	End property

	'Returns text held in ScrDupMsg variable
	Public Property Get ScrDup
		ScrDup = ScrDupMsg
	End Property

	'Returns text held in ScrErrMsg variable
	Public Property Get ScrErr
		ScrErr = ScrErrMsg
	End Property

	'Returns text held in Scr_Name variable
	Public Property Get ScrName
		ScrName = Scr_Name
	End Property

	'Modifies text held in Scr_Name variable
	Public Property Let ScrName ( InVal )
		Scr_Name = InVal
	End Property

	'Returns text held in Scr_Descr variable
	Public Property Get ScrDescr
		ScrDescr = Scr_Descr
	End property

	'Returns text held in XMLComment variable
	Public Property Get XMLComm
		XMLComm = XMLComment
	End property

	'////////////////////////////////////////////////////////////////////////////
	'
	'	Class Methods
	'
	'	Purpose:	provide common actions via the class
	'
	'	Input:	only as required by each function
	'
	'	Output:	depends on the function
	'
	'	ToDo:	depends on changes in class
	'
	'////////////////////////////////////////////////////////////////////////////

	'Returns status of file existence  ( True/False )
	Public Function FindFile ( InVal )
		On Error Resume Next
		FindFile = FSO.GetFile ( InVal )
		If Err Then 
			FindFile = False
		Else
			FindFile = True
		End If
		On Error Goto 0
	End Function

	'Returns status of user action when prompted with informational "Msg"
	Public Function ShowInfo ( Msg )
		ShowInfo = WshShell.Popup  ( Msg, 2,  ScriptTitle, vbInformation + vbOk )
	End Function

	'Returns status of user action when prompted with Error "Msg"
	Public Function ShowErr ( Msg )
		ShowErr = WshShell.Popup  ( Msg, 2,  ScriptTitle, vbExclamation + vbOk )
	End Function

	'Returns user input when prompted with "Msg" and provided with "Default" answer
	Public Function GetAns ( Msg, Default )
		Dim Answer
		Answer = InputBox ( Msg, ScriptTitle, Default )
		If Answer = "" Then 
			If AskYN ( QuitMsg ) Then WScript.Quit
			GetAns Msg, Default
		Else
			GetAns = Answer
		End If
	End Function

	'Returns status of user action  ( Yes=True, No=False ) when prompted with "Msg"
	Public Function AskYN ( Msg )
		Select Case WshShell.Popup  ( Msg, , ScriptTitle, vbQuestion + vbYesNo )
			Case vbYes: AskYN = TRUE
			Case vbNo: AskYN = FALSE
			Case Else: AskYN = AskYN ( Msg )
		End Select
	End Function 

End Class