chore: initial commit

.gitignore

@@ -0,0 +1 @@
+/.deps

README.md

@@ -0,0 +1,33 @@
+# gtf-server
+
+<!-- TODO: add description -->
+
+## Installation
+
+<!-- TODO: add installation instructions -->
+
+## Usage
+
+<!-- TODO: add usage examples -->
+
+## Options
+
+<!-- FIXME: listing of options this app accepts -->
+
+## Examples
+
+<!-- TODO: add more examples -->
+
+## Contributing
+
+<!-- TODO: add contribution guide -->
+
+### Running tests
+
+Tests can be run with the `deps` script:
+
+    deps --profiles dev tasks/run-tests
+
+## License
+
+<!-- FIXME: provide license information -->

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"}}}}}

doc/intro.md

@@ -0,0 +1,3 @@
+# Introduction to gtf-server
+
+TODO: write [great documentation](http://jacobian.org/writing/what-to-write/)

flsproject.fnl

@@ -0,0 +1 @@
+{:fennel-path "src/?.fnl" :lua-version "lua53" :macro-path "src/?.fnlm"}

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)
+);

sql/find-stops.sql

@@ -0,0 +1,5 @@
+--- find a stop near *pos*
+SELECT *
+FROM stops
+WHERE
+id = :id

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!}

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}

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)

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}

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 :>d)))
+(fn decode-uint [stream little-endian?]
+  (stream:decode (if little-endian? :<I4 :>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 :>d) value))
+(fn encode-uint [value little-endian?]
+  (string.pack (if little-endian? :<I4 :>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}

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))

test/html.fnl

@@ -0,0 +1 @@
+(local t (require :faith))

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}