path: root/src/deckdata-io.adb

--  This source is licensed under the Sunset License v1.0


with

    Ada.Characters.Latin_1,
    Ada.Directories,
    Ada.Strings.Fixed,
    Ada.Strings.Maps,
    Ada.Text_IO,
    Deckdata.CSV,
    Deckdata.FMD,
    GNAT.Regpat,
    GNATCOLL.JSON,
    UnZip;


package body Deckdata.IO is


    package Latin renames Ada.Characters.Latin_1;
    package FD renames Ada.Directories;
    package Strfix renames Ada.Strings.Fixed;
    package Strmap renames Ada.Strings.Maps;
    package TIO renames Ada.Text_IO;
    package Pat renames GNAT.Regpat;
    package JS renames GNATCOLL.JSON;




    function To_Unbounded_String
            (Item : in Field_ID)
        return SU.Unbounded_String is
    begin
        return SU.Unbounded_String (Item);
    end To_Unbounded_String;

    function To_Unbounded_String
            (Item : in Field)
        return SU.Unbounded_String is
    begin
        return SU.Unbounded_String (Item);
    end To_Unbounded_String;




    procedure Finalize
           (This : in out Deck_Handle) is
    begin
        if This.Opened then
            FD.Delete_File (-This.Tempfile);
        end if;
    end Finalize;




    function Generate_Temp_Name
        return String
    is
        Handle   : TIO.File_Type;
        Filename : SU.Unbounded_String;
    begin
        TIO.Create (File => Handle);
        Filename := +TIO.Name (Handle);
        TIO.Close (Handle);
        return -Filename;
    end Generate_Temp_Name;




    function Matches
           (Models : in Model_Map;
            Notes  : in Note_Vector)
        return Boolean
    is
        use type Ada.Containers.Count_Type;
    begin
        for Note of Notes loop
            if not Models.Contains (Note.Model) or else
                Note.Fields.Length > Models.Element (Note.Model).Fields.Length
            then
                return False;
            end if;
        end loop;
        return True;
    end Matches;




    procedure Read_Media_Collection
           (Filename  : in     String;
            Media     :    out Media_Collection)
    is
        Temp : String := Generate_Temp_Name;

        Input_Handle : TIO.File_Type;
        Raw_Data     : SU.Unbounded_String;
        JSON_Data    : JS.JSON_Value;

        procedure Map_Iteration
               (Name  : in JS.UTF8_String;
                Value : in JS.JSON_Value)
        is
            Val : SU.Unbounded_String := JS.Get (Value);
        begin
            Media.Map.Insert (Media_Name (Val), Media_ID (+Name));
        end Map_Iteration;
    begin
        UnZip.Extract (Filename, "media", Temp);

        TIO.Open (Input_Handle, TIO.In_File, Temp);
        while not TIO.End_Of_File (Input_Handle) loop
            SU.Append (Raw_Data, TIO.Get_Line (Input_Handle) & Latin.LF);
        end loop;
        TIO.Close (Input_Handle);
        FD.Delete_File (Temp);

        JSON_Data := JS.Read (-Raw_Data);
        JS.Map_JSON_Object (JSON_Data, Map_Iteration'Access);
        Media.Filename := +Filename;
    end Read_Media_Collection;




    procedure Open_Database
           (Filename : in     String;
            Deck     : in out Deck_Handle)
    is
        Temp : String := Generate_Temp_Name;
    begin
        UnZip.Extract (Filename, "collection.anki2", Temp);
        Deck.SQL_Handle.Open (Temp);
        Deck.Opened := True;
        Deck.Tempfile := +Temp;
    end Open_Database;


    function Is_Open
           (Deck : in Deck_Handle)
        return Boolean is
    begin
        return Deck.Opened;
    end Is_Open;


    procedure Close_Database
           (Deck : in out Deck_Handle) is
    begin
        if Deck.Opened = False then
            return;
        end if;
        Deck.SQL_Handle.Close;
        Deck.Opened := False;
        FD.Delete_File (-Deck.Tempfile);
        Deck.Tempfile := +"";
    end Close_Database;




    procedure Extract_Field_IDs
           (Value : in     JS.JSON_Array;
            FIDs  :    out Field_ID_Vector)
    is
        Index   : Positive;
        Item    : JS.JSON_Value;
        Ordinal : Integer;
    begin
        Index := JS.Array_First (Value);
        while JS.Array_Has_Element (Value, Index) loop
            Item := JS.Array_Element (Value, Index);
            Ordinal := JS.Get (Item, "ord") + 1;
            if Ordinal > Integer (FIDs.Length) then
                FIDs.Set_Length (Ada.Containers.Count_Type (Ordinal));
            end if;
            declare
                Name : String := JS.Get (Item, "name");
            begin
                FIDs.Replace_Element (Field_Ordinal (Ordinal), Field_ID (+Name));
            end;
            Index := Index + 1;
        end loop;
    end Extract_Field_IDs;


    procedure Regex_Fields
           (Raw_Data : in     JS.UTF8_String;
            FIDs     :    out Field_ID_Vector)
    is
        use type Pat.Match_Location;
        Matches : Pat.Match_Array (0 .. 1);
        Regexp  : Pat.Pattern_Matcher :=
            --  My god I hate regular expressions, they're such unreadable nonsense
            Pat.Compile ("{{(?:(?:\w|\s)+:)?((?:\w|\s)+)}}", Pat.Single_Line);
        Marker  : Positive := Raw_Data'First;
    begin
        loop
            Pat.Match (Regexp, Raw_Data, Matches, Marker);
            exit when Matches (1) = Pat.No_Match;
            declare
                Item : String := Raw_Data (Matches (1).First .. Matches (1).Last);
            begin
                if Item /= "FrontSide" then
                    FIDs.Append (Field_ID (+Item));
                end if;
            end;
            Marker := Matches (0).Last + 1;
        end loop;
    end Regex_Fields;


    procedure Extract_Templates
           (Value : in     JS.JSON_Array;
            TMPLs :    out Template_Vector)
    is
        Index : Positive;
        Item  : JS.JSON_Value;
        Current_Tmpl : Template;
    begin
        Index := JS.Array_First (Value);
        while JS.Array_Has_Element (Value, Index) loop
            Item := JS.Array_Element (Value, Index);
            Regex_Fields (JS.Get (Item, "qfmt"), Current_Tmpl.Question);
            Regex_Fields (JS.Get (Item, "afmt"), Current_Tmpl.Answer);
            TMPLs.Append (Current_Tmpl);
            Current_Tmpl.Question.Clear;
            Current_Tmpl.Answer.Clear;
            Index := Index + 1;
        end loop;
    end Extract_Templates;


    procedure Extract_Model
           (Name   : in     JS.UTF8_String;
            Value  : in     JS.JSON_Value;
            Models : in out Model_Map)
    is
        Current_Model : Model;
    begin
        Extract_Field_IDs (JS.Get (Value, "flds"), Current_Model.Fields);
        Extract_Templates (JS.Get (Value, "tmpls"), Current_Model.Templates);
        Models.Insert (Model_ID (+Name), Current_Model);
    end Extract_Model;


    procedure Query_Models
           (Deck   : in out Deck_Handle;
            Models :    out Model_Map)
    is
        Statement : SQLite3.SQLite3_Statement;
        Raw_Data  : SU.Unbounded_String;
        JSON_Data : JS.JSON_Value;

        procedure JSON_Callback
               (Name  : in JS.UTF8_String;
                Value : in JS.JSON_Value) is
        begin
            Extract_Model (Name, Value, Models);
        end JSON_Callback;
    begin
        Deck.SQL_Handle.Prepare ("SELECT models FROM col", Statement);
        Statement.Step;
        Raw_Data := Statement.Column (0);
        JSON_Data := JS.Read (-Raw_Data);
        JS.Map_JSON_Object (JSON_Data, JSON_Callback'Access);
    end Query_Models;




    procedure Tokenize_Fields
           (Raw_Data : in     SU.Unbounded_String;
            Fields   :    out Field_Vector)
    is
        Charset  : Strmap.Character_Set := Strmap.To_Set (Latin.US);
        Position : Positive := 1;
        Next     : Natural := 1;
    begin
        while Next /= 0 and Position <= SU.Length (Raw_Data) loop
            Next := SU.Index (Raw_Data, Charset, Position);
            if Position <= Next then
                Fields.Append (Field (SU.Unbounded_Slice (Raw_Data, Position, Next - 1)));
            else
                Fields.Append (Field (SU.Unbounded_Slice
                   (Raw_Data, Position, SU.Length (Raw_Data))));
            end if;
            Position := Next + 1;
        end loop;
    end Tokenize_Fields;


    procedure Query_Notes
           (Deck  : in out Deck_Handle;
            Notes :    out Note_Vector)
    is
        use type SQLite3.Status_Code;
        Statement    : SQLite3.SQLite3_Statement;
        Current_Note : Note;
        Raw_Model    : SU.Unbounded_String;
    begin
        Deck.SQL_Handle.Prepare ("SELECT mid, flds FROM notes", Statement);
        loop
            Statement.Step;
            exit when Statement.Status /= SQLite3.SQLITE_ROW;
            Raw_Model := Statement.Column (0);
            Current_Note.Model := Model_ID (Raw_Model);
            Tokenize_Fields (Statement.Column (1), Current_Note.Fields);
            Notes.Append (Current_Note);
            Current_Note.Fields.Clear;
        end loop;
    end Query_Notes;




    function Compose_Name
           (Directory : in String;
            Basename  : in String;
            Extension : in String;
            Model_Num : in Positive)
        return SU.Unbounded_String
    is
        Result : SU.Unbounded_String := +FD.Compose (Directory, Basename);
    begin
        if Model_Num > 1 then
            SU.Append (Result, "-" & Strfix.Trim (Integer'Image (Model_Num), Ada.Strings.Left));
        end if;
        SU.Append (Result, "." & Extension);
        return Result;
    end Compose_Name;


    function Compose_Dir
           (Directory : in String;
            Basename  : in String;
            Model_Num : in Positive)
        return SU.Unbounded_String
    is
        Result : SU.Unbounded_String := +FD.Compose (Directory, Basename);
    begin
        if Model_Num > 1 then
            SU.Append (Result, "-" & Strfix.Trim (Integer'Image (Model_Num), Ada.Strings.Left));
        end if;
        return Result;
    end Compose_Dir;


    procedure Extract_Images
           (Texts  : in out Field_Vector;
            Outdir : in     SU.Unbounded_String;
            Media  : in     Media_Collection)
    is
        use type Pat.Match_Location;
        Matches : Pat.Match_Array (0 .. 2);
        Regexp : Pat.Pattern_Matcher := Pat.Compile
            --  Absolutely disgusting regexes
           ("<img\s+(?:alt=""[^""]*""\s+|alt=\S*\s+)?src=(?:""([^""]*)""|(\S*)\s)\s*/>",
            Pat.Single_Line);
        Marker : Positive;
        Location : Pat.Match_Location;
        Match_Name : SU.Unbounded_String;
    begin
        for Text of Texts loop
            Marker := 1;
            loop
                Pat.Match (Regexp, -(SU.Unbounded_String (Text)), Matches, Marker);
                exit when Matches (0) = Pat.No_Match;
                Location := (if Matches (1) = Pat.No_Match then Matches (2) else Matches (1));
                Match_Name := SU.Unbounded_Slice
                   (SU.Unbounded_String (Text), Location.First, Location.Last);
                if Media.Map.Contains (Media_Name (Match_Name)) then
                    if not FD.Exists (-Outdir) then
                        FD.Create_Directory (-Outdir);
                    end if;
                    if not FD.Exists (FD.Compose (-Outdir, -Match_Name)) then
                        UnZip.Extract
                           (-Media.Filename,
                            SU.To_String (SU.Unbounded_String
                               (Media.Map.Element (Media_Name (Match_Name)))),
                            FD.Compose (-Outdir, -Match_Name));
                    end if;
                    SU.Insert (SU.Unbounded_String (Text), Location.First, "%%/");
                end if;
                Marker := Matches (0).Last + 1;
            end loop;
        end loop;
    end Extract_Images;




    procedure Write_CSV
           (Directory : in String;
            Basename  : in String;
            Models    : in Model_Map;
            Notes     : in Note_Vector;
            Overwrite : in Boolean := False)
    is
        package My_CSV is new CSV;

        Counter : Positive := 1;
        Outname : SU.Unbounded_String;
        File_Handle : TIO.File_Type;
        Row_Size : Positive;
    begin
        for C in Models.Iterate loop
            Outname := Compose_Name (Directory, Basename, "csv", Counter);
            if FD.Exists (-Outname) then
                if not Overwrite then
                    raise FD.Name_Error;
                else
                    FD.Delete_File (-Outname);
                end if;
            end if;
            TIO.Create (File_Handle, TIO.Out_File, -Outname);
            Row_Size := Positive (Model_Maps.Element (C).Fields.Length);
            My_CSV.Put_Header (File_Handle, Model_Maps.Element (C).Fields);
            for N of Notes loop
                if N.Model = Model_Maps.Key (C) then
                    My_CSV.Put_Row (File_Handle, N.Fields, Row_Size);
                end if;
            end loop;
            TIO.Close (File_Handle);
            Counter := Counter + 1;
        end loop;
    end Write_CSV;




    procedure Write_FMD
           (Directory : in String;
            Basename  : in String;
            Models    : in Model_Map;
            Notes     : in Note_Vector;
            Media     : in Media_Collection;
            Overwrite : in Boolean := False)
    is
        Counter : Positive := 1;
        Outname, Outdir : SU.Unbounded_String;
        File_Handle : TIO.File_Type;
        Current_Entry : Field_Vector;
        Entry_Size : Positive;
    begin
        for C in Models.Iterate loop
            Outname := Compose_Name (Directory, Basename, "fmd", Counter);
            Outdir := Compose_Dir (Directory, Basename, Counter);
            if FD.Exists (-Outname) then
                if not Overwrite then
                    raise FD.Name_Error with "output file " & (-Outname) & " already exists";
                else
                    FD.Delete_File (-Outname);
                end if;
            end if;
            if FD.Exists (-Outdir) and not Overwrite then
                raise FD.Name_Error with "media directory " & (-Outdir) & " already exists";
            end if;
            TIO.Create (File_Handle, TIO.Out_File, -Outname);
            Entry_Size := Positive (Model_Maps.Element (C).Fields.Length);
            FMD.Put_Header (File_Handle);
            FMD.Put_Fields (File_Handle, Model_Maps.Element (C).Fields);
            FMD.Start_Pack_Section (File_Handle);
            for Tmpl of Model_Maps.Element (C).Templates loop
                FMD.Put_Pack (File_Handle, Tmpl.Question, Tmpl.Answer);
            end loop;
            FMD.End_Pack_Section (File_Handle);
            FMD.Start_Entry_Section (File_Handle);
            for N of Notes loop
                if N.Model = Model_Maps.Key (C) then
                    Current_Entry := N.Fields;
                    Extract_Images (Current_Entry, Outdir, Media);
                    FMD.Put_Entry (File_Handle, Current_Entry, Entry_Size);
                end if;
            end loop;
            FMD.End_Entry_Section (File_Handle);
            FMD.Put_Footer (File_Handle);
            TIO.Close (File_Handle);
            Counter := Counter + 1;
        end loop;
    end Write_FMD;


end Deckdata.IO;