Parse TF Modules FParsec

BReuse.Helpers.fs

module BReuse.Helpers

open System

let failNullOrEmpty (x:string) =
    if isNull x then failwith "Null not expected"
    elif String.IsNullOrEmpty x then failwith "Empty not expected"


module String =
    let isValueString x =
        not <| isNull x && not <| String.IsNullOrWhiteSpace x
        
    let tryIndexOf delim (text:string) =
        failNullOrEmpty delim
        if String.IsNullOrEmpty text then
            None
        else
            match text.IndexOf delim with
            | i when i >= 0 -> Some i
            | _ -> None
            
    let tryAfter delim (text:string) =
        failNullOrEmpty delim
        match tryIndexOf delim text with
        | Some i -> 
            //(text,delim,i).Dump()
            Some text[i + delim.Length ..]
        | _ -> None

    let tryBefore delim (text:string) =
        failNullOrEmpty delim
        tryIndexOf delim text
        |> Option.map(fun i -> text[0..i - 1])
        
    let startsWith (delim:string) (text:string) =
        failNullOrEmpty delim
        if String.IsNullOrEmpty text then
            false
        else text.StartsWith delim

    let contains delim (text:string) =
        failNullOrEmpty delim
        tryIndexOf delim text |> Option.isSome

let (|ValueString|NonValueString|) x =
    if String.IsNullOrWhiteSpace x then NonValueString
    else ValueString x
let afterOrSelf delim text =
    String.tryAfter delim text |> Option.defaultValue text
let beforeOrSelf delim text =
    String.tryBefore delim text |> Option.defaultValue text

let after delim text =
    let fail() =
        if String.IsNullOrEmpty text then failwith $"Empty input"
        else failwith $"After '{text}'"
    String.tryAfter delim text |> Option.defaultWith fail
let before delim text =
    let fail() =
        if String.IsNullOrEmpty text then failwith $"Empty input"
        else failwith $"Before '{text}'"
    String.tryBefore delim text |> Option.defaultWith fail

let trim (x:string) =
    if String.IsNullOrEmpty x then
        x
    else x.Trim()
let trimEnd x = 
    if String.IsNullOrEmpty x then
        x
    else x.TrimEnd()

let trim1 (delim:char) (x:string) =
    if String.IsNullOrEmpty x then
        x
    else x.Trim(delim)

let (|Trim|) x =
    trim x
module Regex =
    open System.Text.RegularExpressions
    let createRegex (pattern:string) =
        if String.IsNullOrEmpty pattern then failwith "Empty regex pattern"
        Regex(pattern)

    let tryMatch (r:Regex) (line:string) =
        if String.IsNullOrEmpty line then None
        else
            let m = r.Match(line)
            if m.Success then Ok m
            else Error m
            |> Some
    let rMatch pattern =
        let r = createRegex pattern
        fun line ->
            match tryMatch r line with
            | None -> None
            | Some (Error _) -> None
            | Some (Ok m) -> Some m

let (|RMatch|_|) pattern =
    let rm= Regex.rMatch pattern
    fun line -> rm line
let (|RMatch1|_|) pattern =
    let rm = Regex.rMatch pattern
    fun line -> rm line |> Option.map(fun r -> r.Groups[1].Value)
let (|RMatch2|_|) pattern =
    let rm = Regex.rMatch pattern
    fun line -> rm line |> Option.map(fun r -> r.Groups[1].Value, r.Groups[2].Value)

module Tuple =
    let mapSnd f (x,y) = x, f y

module Result =
    let getOkOrFail title =
        function
        | Ok x -> x
        | Error e -> failwithf "%s:%A" title e

module Seq =
    let truncateOpt iOpt items =
        match iOpt with
        | None -> items
        | Some i -> items |> Seq.truncate i
    let splitResults items =
        ((List.empty,List.empty), items)
        ||> Seq.fold(fun (oks,errors) ->
            function
            | Ok v -> v::oks, errors
            | Error e -> oks, e::errors
        )

    let requiresOk title items =
        items
        |> splitResults
        |> function
            | [], [] -> failwithf "%s: No successes, no failures" title
            | items, [] -> items,[]
            | [], errors -> 
                failwithf "%s: No successes, some failures: %i" title errors.Length
            | oks, errors ->
                oks, errors
        // | SplitR (oks,errors) ->
        //     if oks.Length > 0 || errors.Length = 0 then items,errors
        //     else
        //         failwithf "%s: No successes, some failures:(Ok %i,Error %i)" title oks.Length errors.Length

// let (|SplitR|) items =
//     Seq.splitResults items

// module Array =

module Async =
    let map f x =
        async {
            let! x = x
            return f x
        }

    let catch a =  
        a
        |> Async.Catch
        |> map (function |Choice1Of2 x -> Ok x | Choice2Of2 ex -> Error ex)
// [<RequireQualifiedAccess>] 
// module IO =
//     let mungePath (path:string) =
//         failNullOrEmpty path



module Diagnostics =
    open System.Diagnostics
    let runPs fn args wd =
            use ps = new Process()
            ps.StartInfo.FileName <- fn
            ps.StartInfo.WorkingDirectory <- wd
            ps.StartInfo.Arguments <- String.concat " " args
            ps.StartInfo.UseShellExecute <- false
            ps.StartInfo.CreateNoWindow <- true
            ps.StartInfo.RedirectStandardOutput <- true
            ps.StartInfo.RedirectStandardError <- true
            
            let capture = System.Collections.Concurrent.ConcurrentQueue()
            ps.OutputDataReceived.Add(fun args -> capture.Enqueue(Ok args.Data) )
            ps.ErrorDataReceived.Add(fun args -> capture.Enqueue(Error args.Data))
            if not <| ps.Start() then
                failwith $"Unable to start {wd} '{fn}'"
            //System.Threading.Thread.Sleep(300)
            ps.BeginOutputReadLine()
            ps.BeginErrorReadLine()
            ps.WaitForExit()
            ps.CancelOutputRead()
            ps.CancelErrorRead()
            
            capture |> Seq.toList

    let runPsAsync fn args wd =
        async {
            //printfn "About to start '%s' '%A' in '%s'" fn args wd
            use ps = new Process()
            ps.StartInfo.FileName <- fn
            ps.StartInfo.WorkingDirectory <- wd
            ps.StartInfo.Arguments <- String.concat " " args
            ps.StartInfo.UseShellExecute <- false
            ps.StartInfo.CreateNoWindow <- true
            ps.StartInfo.RedirectStandardOutput <- true
            ps.StartInfo.RedirectStandardError <- true
            
            let capture = System.Collections.Concurrent.ConcurrentQueue()
            ps.OutputDataReceived.Add(fun args -> capture.Enqueue(Ok args.Data) )
            ps.ErrorDataReceived.Add(fun args -> capture.Enqueue(Error args.Data))
            if not <| ps.Start() then
                failwith $"Unable to start {wd} '{fn}'"
            //System.Threading.Thread.Sleep(300)
            ps.BeginOutputReadLine()
            ps.BeginErrorReadLine()
            do! ps.WaitForExitAsync() |> Async.AwaitTask
            ps.CancelOutputRead()
            ps.CancelErrorRead()

            return capture |> Seq.toList
        }
        |> Async.catch

ParseTFModule.fsx

// . linq => linqpad file
// fparsec and BReuse
// walk all tf repos, pull/fetch git latest, parse and munge data found

// walk all tf repos, pull/fetch git latest, parse and munge data found

let cName = "SBS"

let removeFpkRepoPrefix = after "SBS.Octopus.tf-fpk-"
let addFpkRepoUrl = sprintf "https://github.com/LexisNexis-RBA/%s"
let mutable failures = List.empty

let inline dump title (x:'t) =
    x.Dump(description=title)

let expectedEnvs = [
    "fpk", [
        $"{cName}.Octopus.tf-fpk-devhosted"
        $"{cName}.Octopus.tf-fpk-devops-hosted"
        $"{cName}.Octopus.tf-fpk-daria"
        $"{cName}.Octopus.tf-fpk-sbs-local"
        $"{cName}.Octopus.tf-fpk-sbs-aws-fpk"
        $"{cName}.Octopus.tf-fpk-qahosted"
        $"{cName}.Octopus.tf-fpk-peggyhill"
        $"{cName}.Octopus.tf-fpk-devtemplate"
        $"{cName}.Octopus.tf-fpk-prodhosted"
        $"{cName}.Octopus.tf-fpk-perfhosted"
    ]
]
let dirs =
    let delimiter = "Octopus.tf-"
    Directory.EnumerateDirectories(Path.Combine(Environment.ExpandEnvironmentVariables "%devdir%", cName.ToLower()))
    |> Seq.filter(fun x -> x.Contains delimiter)
    |> Seq.map(fun fp ->
        let children =
            Seq.collect id [
                Directory.EnumerateDirectories(fp, ".git", SearchOption.AllDirectories)
                //Directory.EnumerateDirectories(fp, ".github", SearchOption.AllDirectories)
            ]
            //|> Seq.truncateOpt dirLimitOpt
            |> Seq.map Path.GetDirectoryName
            |> List.ofSeq
        fp |> after delimiter,children
    )
    //|> Seq.truncateOpt repoLimitOpt
    |> List.ofSeq
let noCache (f:Func<_>,x) = f.Invoke()    

// may not be tested properly (we iterated to get here and so all children might be up to date when we test this function
let inline cbk x y z items = BReuse.LinqPad.cacheByKeyCollection x y z items
let gitUpdateAll items = cbk Util.Cache "gitUpdateAll" (fun items -> BReuse.GitHelpers.updateAll items (fun d outputs -> outputs |> dump d)|> Async.RunSynchronously) items
let gitRemotes items = cbk noCache "gitRemotes" (fun items -> BReuse.GitHelpers.tryGetRemotes items |> Async.RunSynchronously) items
let gitBranches items = cbk Util.Cache "gitBranches" (fun items -> BReuse.GitHelpers.tryGetBranches items |> Async.RunSynchronously) items

type SettingValue =
    // hold int, bool, float, string
    | Simple of string
    | Array of SettingValue list
    | Other of (string * SettingValue) list
    | FailedObject
    | Trivia
    with
        member x.ToDump() =
            match x with
            | Simple v -> box v
            | Array items -> box items
            | Other items -> box items
            | FailedObject -> "<Encoded>"
            
type US = unit    

type ProjectEnvironment = {
    EId: string
    Vars: (string * SettingValue) list
}
type AttachedProject = {
    Project: string
    Envs: ProjectEnvironment list
}
type ModuleBlock = {
    Module: string
    ClientCode: string
    ClientId: string
    Projects: AttachedProject list
    TenantTags: string list
    Settings: (string*SettingValue) list
}

let ws = spaces

let optComma = opt (attempt (ws >>. pchar ',' .>> ws)) >>% ()
let nonEscapeChar: Parser<char,US> =
    satisfy (fun c -> c <> '"' && c <> '\\') <?> "non-escape char"
let escapeSequence: Parser<char,US> =
    pchar '\\' >>. (anyOf "\"\\rn") <?> "escape seq"
    
let singleLineComment:Parser<_,US> =
    (pstring "#" <|> pstring "//")
    >>. ws
    >>. restOfLine true
    <?> "comment"
    
let ignoreCommentTrail = optional singleLineComment >>% ()    

let quotedString: Parser<string ,US> =
    let qs = between (pchar '"') (pchar '"') (manyChars (nonEscapeChar <|> escapeSequence))
    qs .>> attempt (ws>>. ignoreCommentTrail)
    
//let stringLiteral: Parser<string,US> = 
//    between (pstring "\"") (pstring "\"") (manyChars (noneOf "\""))
let identifier: Parser<string,US> =
    many1Satisfy (fun c -> System.Char.IsLetter c || c = '_' ) <?> "identifier start"
    .>>. manySatisfy (fun c -> System.Char.IsLetterOrDigit c || c = '_' || c = '.')
    <?> "identifier cont"
    |>> (fun (first, rest) -> first + rest)
    <?> "identifier"
    
let anyString = identifier <|> quotedString <?> "anyString"

let nestedParser, nestedParserRef = createParserForwardedToRef<SettingValue, _>()

let lEqRSpec leftString rParser =
    (pstring leftString) .>> (ws .>> pstring "=" .>> ws |>> ignore) .>>. rParser |>> fun (_,x) -> x
    
let lEqR rParser =
    //(quotedString <|> identifier) .>> (ignoreCommentTrail >>. ws .>> pstring "=" .>> ws |>> ignore) .>>. rParser .>> ignoreCommentTrail
    anyString .>> (ws .>> pstring "=" .>> ws |>> ignore) .>>. rParser
    
let eotBlock =
    let notEot = charsTillString "EOT" true System.Int32.MaxValue
    let eotBlockSelf = pstring "<<-EOT" >>. notEot .>> ws
    eotBlockSelf
    
let fnWrap name =
    pstring $"{name}(" >>. nestedParser .>> pchar ')' <?> name
let trimspaceWrap =
    //pstring "trimspace(" >>. nestedParser .>> pchar ')'
    fnWrap "trimspace"
let chompWrap =
    fnWrap "chomp"
let replaceWrap =
    pstring "replace(" >>. nestedParser .>> optComma .>> (anyString >>% ()) .>> optComma .>> (anyString >>% ()) .>> pchar ')'
    <??> "replaceWrap"
    
let emptyArray: Parser<unit,_> = pchar '[' .>> ws .>> pchar ']' .>> ws <?> "empty array" >>% () // .>> ignoreCommentTrail >>% ()

// this appears to only work on comma sep values
let arrayParser p =
    let arrayItem = p  .>>  (optComma .>> optional singleLineComment) .>> ws
    choice [
        attempt emptyArray >>% List.empty
        between (pchar '[' >>. ws) (optComma >>. pchar ']') (many (attempt arrayItem))
    ] <?> "array" // .>> (attempt singleLineComment >>% ())
    
let wsKvps =
    // terraform allows mixing comma and whitespace delimited sequences!
    let trailOpt = opt (attempt (pchar ','))
    let kvpBody = choice [
        lEqR nestedParser
        singleLineComment >>% ("#",Trivia)
    ]
    ignoreCommentTrail
    >>. many (attempt (ws >>. kvpBody .>> ws .>> trailOpt)) <?> "wsKvps"
    .>> ignoreCommentTrail
    
let tObject: Parser<(string * SettingValue) list,_> =
    // allow empty object
    between (pchar '{' .>> ws) (ws >>. pchar '}') (attempt (
        choice [
            arrayParser (lEqR nestedParser)
            wsKvps
        ]
    )) 
    
let simpleParser: Parser<SettingValue,_> =
    choice [
        attempt quotedString |>> Simple
        identifier |>> Simple
        pint32 |>> fun x -> x |> string |> SettingValue.Simple
    ]
    |>> fun x -> x
    
let jsonEncode: Parser<_,_> =
    let notClose = charsTillString "})" true System.Int32.MaxValue
    pstring "jsonencode({" >>. ws >>. notClose >>% SettingValue.FailedObject
    
nestedParserRef.Value <- 
    choice [
        
        jsonEncode
        trimspaceWrap
        chompWrap
        replaceWrap
        eotBlock <?> "descrEot" |>> Simple
        attempt simpleParser
        tObject |>> fun x -> Other x
        arrayParser nestedParser |>> fun x -> Array x
        //singleLineComment >>% Trivia
    ] // .>> (attempt singleLineComment >>% ())

// begin parser processing -----------------------------------------

let getObject =
    function
    | SettingValue.Other settings -> settings
    | x -> failwithf "Expected object but was: %A" x
    
let getSimple =
    function
    | Simple v -> v
    | x -> failwithf "Expected simple but was: %A" x
let getArray f =
    function
    | Array vs -> vs |> List.map f
    | x -> failwithf "Expected array but was: %A" x
    
let mapObjectList f items =
    items |> List.map(getObject>>f)
    
let mungeEnv (props:(string * SettingValue) list) : ProjectEnvironment =
    match props with
    | ("id", Simple n)::("vars", Other props)::[] ->
        {
            EId= n
            Vars= props
        }
    | _ ->
        props.Dump("env?")
        failwith "bad Env"
   
let mungeProject (items:(string*SettingValue) list) : AttachedProject =
    // project, envs
    match items with
    | ("project",Simple n)::("envs",SettingValue.Array kvps)::[] ->
        {
            Project=n
            Envs= mapObjectList mungeEnv kvps
        }
    | _ ->
        items.Dump("mungeProject")
        failwithf "Unexpected value in %A" items
let tryGrab name items =
    ((None,List.empty),items)
    ||> Seq.fold(fun (foundOpt,other) (n,v) ->
        match foundOpt with
        | None -> if n = name then Some v, other else None,(n,v)::other
        | Some f -> Some f, (n,v)::other
    )
    |> fun (item,rest) -> item, List.rev rest
    
let moduleParser =
    (pstring "module" .>> ws >>% ()  >>. quotedString .>> ws) .>>. tObject
    |>> fun (mName,o) ->
    
        let clientName, o =  tryGrab "client_code" o
        let clientId, o = tryGrab "client_id" o
        let tenantTags, o = tryGrab "tenant_tags" o
        
        let init = {
            Module = mName
            ClientCode = clientName |> Option.map getSimple |> Option.defaultValue ""
            ClientId = clientId |> Option.map getSimple |> Option.defaultValue ""
            TenantTags = tenantTags |> Option.map (getArray getSimple) |> Option.defaultValue List.empty
            Projects = List.empty
            Settings = List.empty
            }
        (init,o)
        ||> List.fold(fun state ->
            function
            | "attached_projects", SettingValue.Array aps ->
                {state with Projects = (mapObjectList mungeProject aps )@state.Projects}
            | x,y ->  {state with Settings = (x,y)::state.Settings}
        )
        |> fun x ->
            {x with Settings = x.Settings |> List.rev; Projects = x.Projects |> List.rev}
            
let runModuleParser fn =
    File.ReadAllText fn
    |> run moduleParser
    |> function
        | Success (v,_,_) -> Result.Ok v
        | Failure(msg,pe,_us)  -> 
            //eprintfn "%s" msg
            //(fn,pe,us).Dump("Fail!")
            //failwith "Parser fail"
            Result.Error (fn,msg,pe)

let runOldProcess fn =            
    File.ReadAllText fn
    |> run moduleParser
    |> function
        | Success (v,_,_) -> v
        | Failure(msg,pe,us)  -> 
            eprintfn "%s" msg
            (pe,us).Dump("Fail!")
            failwith "Parser fail"
    |> fun x -> x.Dump()
    
dirs
|> Seq.map(fun (repo,dirs) ->

    //printfn "Starting on repo %s - %i item(s)" repo dirs.Length
    gitUpdateAll dirs |> ignore
    
    printfn "Finished pulls '%s'" repo
    //failwith "Halt"
    //let dirInfo = BReuse.GitHelpers.tryGetRemotes dirs |> Async.RunSynchronously
    //dirs.Dump("wtf?")
    let dirInfo = 
        gitRemotes dirs
        //|> fun x -> printfn "Finished git remotes!"; x
        |> Seq.requiresOk "gitRemotes"
        |>  fun (oks,errors) ->
            if errors.Length > 0 then errors.Dump("Some failures")
            oks
        //|> Result.getOkOrFail "Remotes"
        
        |> Map.ofList
        
    //printfn "Finished remotes '%s'" repo
    
    let obviousTenants =
        dirs
        |> Seq.map(fun d ->
            let ttfs =
                BReuse.Terraform.getFilesToGloss d
                //|> Seq.truncateOpt fileLimitOpt
                |> Seq.map runModuleParser
                |> Seq.choose(
                    function
                    | Result.Ok x -> Some x
                    | Result.Error y ->
                        failures <- (repo,d,y)::failures
                        None
                )
                |> List.ofSeq
            d,ttfs
        )
        |> Map.ofSeq
    // join the 2 explorations on the key, remotes should be the master
    let dirInfo2 =
        dirInfo
        |> Map.map(fun dir remote ->
            remote, obviousTenants |> Map.tryFind dir |> Option.defaultValue List.empty
        )
    let dirInfo3 =
        let _, items = expectedEnvs |> List.tryFind(fst >>  (=) repo) |> Option.defaultValue ("",List.empty)
        //items.Dump("checking for missing items")
        (dirInfo2, items)
        ||> List.fold(fun m e ->
            let e2 = removeFpkRepoPrefix e 
            match m |> Map.tryFindKey(fun k v -> k.EndsWith(e2)) with
            | None -> m |> Map.add e2 (addFpkRepoUrl e,List.empty)
            | Some v -> m
        )
    repo,dirInfo3 // , obviousTenants
)
|> Map.ofSeq
|> Dump
|> ignore

(failures |> List.rev).Dump("Failures")