From 4097972f8417eaadbf748d79474b83199207a592 Mon Sep 17 00:00:00 2001 From: Fey Naomi Schrewe Date: Sat, 10 Jan 2026 22:09:34 +0100 Subject: [PATCH] chore: initial commit --- .gitignore | 1 + README.md | 33 +++++++++++ deps.fnl | 22 ++++++++ doc/intro.md | 3 + flsproject.fnl | 1 + sql/create-tables.sql | 62 ++++++++++++++++++++ sql/find-stops.sql | 5 ++ src/debug-macros.fnlm | 9 +++ src/html.fnl | 20 +++++++ src/main.fnl | 128 ++++++++++++++++++++++++++++++++++++++++++ src/sqlite.fnl | 43 ++++++++++++++ src/wkb.fnl | 107 +++++++++++++++++++++++++++++++++++ tasks/run-tests | 10 ++++ test/html.fnl | 1 + test/wkb-test.fnl | 25 +++++++++ 15 files changed, 470 insertions(+) create mode 100644 .gitignore create mode 100644 README.md create mode 100644 deps.fnl create mode 100644 doc/intro.md create mode 100644 flsproject.fnl create mode 100644 sql/create-tables.sql create mode 100644 sql/find-stops.sql create mode 100644 src/debug-macros.fnlm create mode 100644 src/html.fnl create mode 100644 src/main.fnl create mode 100644 src/sqlite.fnl create mode 100644 src/wkb.fnl create mode 100644 tasks/run-tests create mode 100644 test/html.fnl create mode 100644 test/wkb-test.fnl diff --git a/.gitignore b/.gitignore new file mode 100644 index 0000000..597caeb --- /dev/null +++ b/.gitignore @@ -0,0 +1 @@ +/.deps \ No newline at end of file diff --git a/README.md b/README.md new file mode 100644 index 0000000..b215f77 --- /dev/null +++ b/README.md @@ -0,0 +1,33 @@ +# gtf-server + + + +## Installation + + + +## Usage + + + +## Options + + + +## Examples + + + +## Contributing + + + +### Running tests + +Tests can be run with the `deps` script: + + deps --profiles dev tasks/run-tests + +## License + + \ No newline at end of file diff --git a/deps.fnl b/deps.fnl new file mode 100644 index 0000000..f3eddec --- /dev/null +++ b/deps.fnl @@ -0,0 +1,22 @@ +{:project-name "gtf-server" + :project-version "0.1.0" + + :deps {:ftcsv {:type :rock + :version :1.5.0} + :lsqlite3 {:type :rock + :version :0.9.6}} + + :paths {:fennel ["src/?.fnl"] + :macro ["src/?.fnlm"] + :lua ["src/?.lua"]} + + :profiles + {:dev + {:deps {:ht.sr.technomancy/faith + {:type :git :sha "89f7a6677821cfd6a0702cf22725dccbde1eb08c" + :paths {:fennel ["?.fnl"]}}} + :paths {:fennel ["test/?.fnl"] + :macro ["test/?.fnlm"] + :lua ["test/?.lua"]}} + :aot + {:deps {"fennel" {:type :rock :version "1.5.3"}}}}} diff --git a/doc/intro.md b/doc/intro.md new file mode 100644 index 0000000..03ef91f --- /dev/null +++ b/doc/intro.md @@ -0,0 +1,3 @@ +# Introduction to gtf-server + +TODO: write [great documentation](http://jacobian.org/writing/what-to-write/) \ No newline at end of file diff --git a/flsproject.fnl b/flsproject.fnl new file mode 100644 index 0000000..53ba04c --- /dev/null +++ b/flsproject.fnl @@ -0,0 +1 @@ +{:fennel-path "src/?.fnl" :lua-version "lua53" :macro-path "src/?.fnlm"} \ No newline at end of file diff --git a/sql/create-tables.sql b/sql/create-tables.sql new file mode 100644 index 0000000..4565c94 --- /dev/null +++ b/sql/create-tables.sql @@ -0,0 +1,62 @@ +--- Create tables for gtfs information +PRAGMA trusted_schema=1; + +CREATE TABLE stops ( + id TEXT PRIMARY KEY, + name TEXT, + code TEXT, + description TEXT, + platform TEXT, + parent TEXT +); + +SELECT InitSpatialMetaData(); +SELECT AddGeometryColumn( + 'stops', + 'location', + 25832, + 'POINT', + 'XY' +); +SELECT CreateSpatialIndex('stops', 'location'); + +CREATE TABLE routes ( + id TEXT PRIMARY KEY, + short_name TEXT, + long_name TEXT, + description TEXT, + type INTEGER, + color INTEGER, + text_color INTEGER +); + +CREATE TABLE trips ( + id TEXT PRIMARY KEY, + route_id TEXT, + service_id TEXT, + headsign TEXT, + short_name TEXT +); + +CREATE TABLE stop_times ( + trip_id TEXT, + sequence INTEGER, + arrival TEXT, + departure TEXT, + stop_id TEXT, + PRIMARY KEY(trip_id, sequence) +); + +CREATE TABLE calendar ( + service TEXT PRIMARY KEY, + days INTEGER NOT NULL, + start_date TEXT NOT NULL, + end_date TEXT NOT NULL +); + +CREATE TABLE calendar_dates ( + service TEXT, + date TEXT, + type INTEGER, + PRIMARY KEY(service, date) +); diff --git a/sql/find-stops.sql b/sql/find-stops.sql new file mode 100644 index 0000000..8666398 --- /dev/null +++ b/sql/find-stops.sql @@ -0,0 +1,5 @@ +--- find a stop near *pos* +SELECT * +FROM stops +WHERE +id = :id diff --git a/src/debug-macros.fnlm b/src/debug-macros.fnlm new file mode 100644 index 0000000..48db3f0 --- /dev/null +++ b/src/debug-macros.fnlm @@ -0,0 +1,9 @@ +; vi:ft=fennel +(fn dbg! [x] + "prints and returns the value of a given expression for quick and dirty debugging" + `(let [val# ,x + f# (require :fennel)] + (print ,(view x) := (f#.view val#)) + val#)) + +{: dbg!} diff --git a/src/html.fnl b/src/html.fnl new file mode 100644 index 0000000..dd4a820 --- /dev/null +++ b/src/html.fnl @@ -0,0 +1,20 @@ +(local self-closing [:area + :base + :br + :col + :embed + :hr + :img + :input + :link + :meta + :param + :source + :track + :wbr]) + +(fn html [elements]) + +(fn page [elements]) + +{: html : page} diff --git a/src/main.fnl b/src/main.fnl new file mode 100644 index 0000000..ef8ff31 --- /dev/null +++ b/src/main.fnl @@ -0,0 +1,128 @@ +(local {: view} (require :fennel)) +(local csv (require :ftcsv)) +(local sql (require :sqlite)) +(local {: OK} (require :lsqlite3)) +(local {: encode-wkb} (require :wkb)) + +(fn execute-statement [db script-name] + (let [script (with-open + [script + (io.open (.. "sql/" script-name ".sql"))] + (script:read :*all))] + (if (not= OK (db:execute script)) + (error (db:errmsg))))) + +(local day-index + (collect [i day (ipairs [:monday + :tuesday + :wednesday + :thursday + :friday + :saturday + :sunday])] + day (- i 1))) +(fn days->bitmap [row] + (accumulate [mask 0 + day shift (pairs day-index)] + (if (= (. row day) :1) + (bor mask (lshift 1 shift)) + mask))) + +(fn latlng->wkb [tbl row] + (let [name (string.sub tbl 1 (- (length tbl) 1)) + lat (. row (.. name "_lat")) + long (. row (.. name "_lng")) + point [:point lat long]] + (if (and lat long) + (let [wkb (encode-wkb point true) + bytes (table.pack (string.byte wkb 1 (length wkb))) + hex (table.concat (icollect [_ b (ipairs bytes)] + (string.format :%02x b)) "")] + (.. "ST_Transform(ST_GeomFromWkb(x'" hex "', 4326), 25832)"))))) + +(fn create-insert-statement [tbl mapping row] + (when (. mapping :days) + (set row.days (days->bitmap row))) + (when (. mapping :location) + (set row.location (latlng->wkb tbl row))) + (let [keys (icollect [k (pairs row)] k) + color-key? (fn [key] (string.match key :color$)) + val->str (fn [key value] + (if + (= value "") :NULL + (color-key? key) (tonumber value 16) + (= key :location) value + (.. "'" (string.gsub value "'" "''") "'")))] + (.. + "INSERT INTO " + tbl + "(" + (table.concat + (icollect [_ key (ipairs keys)] + (. mapping key)) + ",") + ") VALUES (" + (table.concat + (icollect [_ key (ipairs keys)] + (if (. mapping key) + (let [value (. row key)] + (val->str key value)))) + "," ) + ")"))) + +(fn insert-table [db tbl mapping] + (let [file-path (.. "gtfs-data/" tbl ".txt")] + (print "inserting into " tbl) + (each [_ line (csv.parseLine file-path {:headers true})] + (let [stmt (create-insert-statement + tbl mapping line)] + (match (db:execute stmt) + OK nil + _ (do + (print stmt) + (error (.. "error inserting: " (db:errmsg))))))))) + +(local mappings + {:stops {:stop_id :id + :stop_desc :description + :stop_name :name + :stop_code :code + :platform_code :platform + :parent_station :parent + :location :location} + :routes {:route_id :id + :route_short_name :short_name + :route_long_name :long_name + :route_desc :description + :route_type :type + :route_color :color + :route_text_color :text_color} + :trips {:trip_id :id + :route_id :route_id + :service_id :service_id + :headsign :headsign + :trip_short_name :short_name} + :stop_times {:trip_id :trip_id + :stop_sequence :sequence + :stop_id :stop_id + :departure_time :departure + :arrival_time :arrival} + :calendar {:service_id :service + :start_date :start_date + :end_date :end_date + :days :days} + :calendar_dates {:service_id :service + :date :date + :exception_type :type}}) + +(fn main [] + "I don't do much, yet." + (with-open [db (sql.connection)] + (execute-statement db :create-tables) + (db:execute "BEGIN TRANSACTION") + (each [k v (pairs mappings)] + (insert-table db k v)) + (db:execute "COMMIT") + (db:execute "ANALYZE"))) + +(main) diff --git a/src/sqlite.fnl b/src/sqlite.fnl new file mode 100644 index 0000000..b7c6b43 --- /dev/null +++ b/src/sqlite.fnl @@ -0,0 +1,43 @@ +(local sqlite (require :lsqlite3)) + +(local sql-files [:find-stops]) + +(fn call-statement [{: statement : args} params] + (statement:reset) + (each [i name (ipairs args)] + (statement:bind i (. params name))) + (statement:nrows)) + +(fn prepare-sql [db file] + (let [sql (with-open [f (io.open (.. "sql/" file ".sql"))] + (f:read :*all))] + (case (db:prepare sql) + (nil code ?msg) + (error (.. "error preparing statement " + file + ": " + code + " " + (or ?msg "unknown error"))) + statement + (let [args + (fcollect [n 1 (statement:bind_parameter_count)] + (statement:bind_parameter_name n))] + (setmetatable + {: statement + : args} + {:__call call-statement + :close (fn [] (statement:finalize))}))))) + +(fn connection [] + (case (sqlite.open :gtfs.db) + (nil ?code ?msg) (error + (.. "Failed to open database: " + (or ?code :nil) + " " + (or ?msg ""))) + db (do + (db:load_extension :mod_spatialite) + db))) + +{: connection} diff --git a/src/wkb.fnl b/src/wkb.fnl new file mode 100644 index 0000000..2d0e184 --- /dev/null +++ b/src/wkb.fnl @@ -0,0 +1,107 @@ +(local geometry-types + [:point + :linestring + :polygon + :multi-point + :multi-linestring + :multi-polygon + :geometry-collection]) +(local geometry-id + (collect [code name (pairs geometry-types)] + name code)) + +(fn read-stream [bstr] + "create a stream to read from from a binary string" + {: bstr + :offset 1 + :decode + (fn [self fmt] + (let [(val new-offset) + (string.unpack fmt self.bstr self.offset)] + (set self.offset new-offset) + val)) + :get-byte + (fn [self] + (let [byte (string.byte self.bstr self.offset)] + (set self.offset (+ self.offset 1)) + byte))}) + +(fn decode-double [stream little-endian?] + (stream:decode (if little-endian? :d))) +(fn decode-uint [stream little-endian?] + (stream:decode (if little-endian? :I4))) + +(fn decode-point [stream coord-count little-endian?] + (fcollect [_ 1 coord-count] + (decode-double stream little-endian?))) +(fn decode-linestring [stream coord-count little-endian?] + (let [count (decode-uint stream little-endian?)] + (fcollect [_ 1 count] + (decode-point stream coord-count little-endian?)))) +(fn decode-polygon [stream coord-count little-endian?] + (let [count (decode-uint stream little-endian?)] + (fcollect [_ 1 count] + (decode-linestring stream coord-count little-endian?)))) + +(fn decode-wkb [bstr] + "decode well known binary representation of geometry into an array tree. + +trees are of the general form `[discriminator & content]`, where discriminator is an identifier from [geometry-types], and the minimum amount of structure to uniquely disambiguate the geometry. The rxception is that the coordinate count is disambiguated by structure rather than by discriminator + +# Examples +The examples are in wkt for better readability + +`POINT(0.5 0.7)` decodes to `[:point 0.5 0.7]` +`LINESTRING(0.1 0.3 0.7 0.8)` decodes to `[:linestring [0.1 0.3] [0.7 0.8]]` +`POLYGON((0.1 0.5 0.8 0.9) (0.4 0.2 0.7 0.3))` decodes to `[:polygon [[0.1 0.5] [0.8 0.9]] [[0.4 0.2] [0.7 0.3]]]` +" + (let [stream (read-stream bstr) + little-endian? (case (stream:get-byte) + 0 false + 1 true + _ nil) + geom-type (. geometry-types (decode-uint stream little-endian?)) + coord-count 2] + (if (= little-endian? nil) + nil + [geom-type + (table.unpack + (case geom-type + :point + (decode-point stream coord-count little-endian?) + :linestring + (decode-linestring stream coord-count little-endian?) + :polygon + (decode-polygon stream coord-count little-endian?)))]))) + +(fn encode-double [value little-endian?] + (string.pack (if little-endian? :d) value)) +(fn encode-uint [value little-endian?] + (string.pack (if little-endian? :I4) value)) + +(fn encode-point [rope [x y] little-endian?] + (table.insert rope (encode-double x little-endian?)) + (table.insert rope (encode-double y little-endian?))) +(fn encode-linestring [rope points little-endian?] + (table.insert rope (encode-uint (length points) little-endian?)) + (each [_ point (ipairs points)] + (encode-point rope point little-endian?))) +(fn encode-polygon [rope linestrings little-endian?] + (table.insert rope (encode-uint (length linestrings) little-endian?)) + (each [_ curve (ipairs linestrings)] + (encode-linestring rope curve little-endian?))) + +(fn encode-wkb [[discriminator & content] little-endian?] + (local rope + [(if little-endian? "\x01" "\x00") + (encode-uint (. geometry-id discriminator) little-endian?)]) + (case discriminator + :point + (encode-point rope content little-endian?) + :linestring + (encode-linestring rope content little-endian?) + :polygon + (encode-polygon rope content little-endian?)) + (table.concat rope "")) + +{: decode-wkb : encode-wkb : geometry-types} diff --git a/tasks/run-tests b/tasks/run-tests new file mode 100644 index 0000000..e0d6115 --- /dev/null +++ b/tasks/run-tests @@ -0,0 +1,10 @@ +;; -*- mode: fennel; -*- vi:ft=fennel +(local t (require :faith)) + +(local test-modules + [:wkb-test]) + +(t.run + (if (= 0 (length arg)) + test-modules + arg)) diff --git a/test/html.fnl b/test/html.fnl new file mode 100644 index 0000000..169746e --- /dev/null +++ b/test/html.fnl @@ -0,0 +1 @@ +(local t (require :faith)) diff --git a/test/wkb-test.fnl b/test/wkb-test.fnl new file mode 100644 index 0000000..33e47b0 --- /dev/null +++ b/test/wkb-test.fnl @@ -0,0 +1,25 @@ +(local t (require :faith)) +(local {: encode-wkb : decode-wkb} (require :wkb)) + +(local data {"\x01\x01\x00\x00\x00\x00\x00\x00\x00\x00\x00\xe0\x3f\x66\x66\x66\x66\x66\x66\xe6\x3f" + [:point 0.5 0.7] + "\x01\x02\x00\x00\x00\x03\x00\x00\x00\x35\x5e\xba\x49\x0c\x02\xbb\xbf\xc5\xfe\xb2\x7b\xf2\xc0\x49\x40\x50\x8d\x97\x6e\x12\x83\xc0\xbf\xb9\x8d\x06\xf0\x16\xc0\x49\x40\x1c\xeb\xe2\x36\x1a\xc0\xc3\xbf\x91\xed\x7c\x3f\x35\xbe\x49\x40" + [:linestring + [-0.1055 51.5074] + [-0.1290 51.5007] + [-0.1543 51.4860]] + "\x01\x03\x00\x00\x00\x02\x00\x00\x00\x05\x00\x00\x00\x00\x00\x00\x00\x00\x80\x41\x40\x00\x00\x00\x00\x00\x00\x24\x40\x00\x00\x00\x00\x00\x80\x46\x40\x00\x00\x00\x00\x00\x80\x46\x40\x00\x00\x00\x00\x00\x00\x2e\x40\x00\x00\x00\x00\x00\x00\x44\x40\x00\x00\x00\x00\x00\x00\x24\x40\x00\x00\x00\x00\x00\x00\x34\x40\x00\x00\x00\x00\x00\x80\x41\x40\x00\x00\x00\x00\x00\x00\x24\x40\x04\x00\x00\x00\x00\x00\x00\x00\x00\x00\x34\x40\x00\x00\x00\x00\x00\x00\x3e\x40\x00\x00\x00\x00\x00\x80\x41\x40\x00\x00\x00\x00\x00\x80\x41\x40\x00\x00\x00\x00\x00\x00\x3e\x40\x00\x00\x00\x00\x00\x00\x34\x40\x00\x00\x00\x00\x00\x00\x34\x40\x00\x00\x00\x00\x00\x00\x3e\x40" + [:polygon + [[35 10] [45 45] [15 40] [10 20] [35 10]] + [[20 30] [35 35] [30 20] [20 30]]]}) + +(fn test-decode [] + (each [bstr decoded (pairs data)] + (t.= decoded (decode-wkb bstr)))) + +(fn test-encode [] + (each [encoded spec (pairs data)] + (t.= encoded (encode-wkb spec true)))) + +{: test-decode + : test-encode}