add some persist stuff

this doesn't yet actually use the database, but it's getting close to
3am and I should probably go to bed or something

3 files changed, 78 insertions, 23 deletions

diff --git a/haskell-gtfs.cabal b/haskell-gtfs.cabal
index 2bce943..a54a9ff 100644
--- a/haskell-gtfs.cabal
+++ b/haskell-gtfs.cabal
@@ -59,8 +59,16 @@ library
                     , servant-swagger
                     , servant-docs
                     , lens
+                    , persistent
+                    , persistent-postgresql
+                    , monad-logger
+                    , mtl
+                    , unliftio-core
+                    , conduit
+                    , path-pieces
+                    , either
     hs-source-dirs:   lib
-    exposed-modules: GTFS, Server
+    exposed-modules: GTFS, Server, PersistOrphans
     default-language: Haskell2010
     default-extensions: OverloadedStrings
                       , ScopedTypeVariables
diff --git a/lib/PersistOrphans.hs b/lib/PersistOrphans.hs
new file mode 100644
index 0000000..68e9738
--- /dev/null
+++ b/lib/PersistOrphans.hs
@@ -0,0 +1,34 @@
+-- | This module contains instances for the Data.UUID UUID type
+-- to be mapped to postgresql's custom builtin uuid type.
+--
+-- Unfortunately, this breaks compatability with other SQL databases
+-- (though uuids aren't really supported by most anyways)
+module PersistOrphans where
+
+
+import           Data.Either.Combinators (maybeToRight)
+import qualified Data.Text               as T
+import           Data.UUID               (UUID)
+import           Data.UUID               as UUID
+import           Data.UUID.V4
+import           Database.Persist        (PersistField (..),
+                                          PersistValue (PersistLiteralEscaped),
+                                          SqlType (SqlOther))
+import           Database.Persist.Sql    (PersistFieldSql (..), SqlBackend,
+                                          migrate, runMigration)
+import           Web.PathPieces          (PathPiece (..))
+
+
+instance PersistField UUID where
+  toPersistValue = PersistLiteralEscaped . UUID.toASCIIBytes
+  fromPersistValue (PersistLiteralEscaped buf) =
+    maybeToRight "not a uuid (cannot decode)" $ UUID.fromASCIIBytes buf
+  fromPersistValue v = Left $ "not a uuid (wrong type in database): " <> T.pack (show v)
+  -- postgres is type-safe, so this should /hopefully/ never happen
+instance PersistFieldSql UUID where
+  sqlType = const $ SqlOther "uuid"
+instance PathPiece UUID where
+  fromPathPiece = UUID.fromText
+  toPathPiece = UUID.toText
+
+
diff --git a/lib/Server.hs b/lib/Server.hs
index d22be59..1b79300 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -4,12 +4,18 @@
 {-# LANGUAGE DerivingStrategies         #-}
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
+{-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
+{-# LANGUAGE MultiParamTypeClasses      #-}
+{-# LANGUAGE QuasiQuotes                #-}
 {-# LANGUAGE RecordWildCards            #-}
+{-# LANGUAGE StandaloneDeriving         #-}
+{-# LANGUAGE TemplateHaskell            #-}
 {-# LANGUAGE TypeApplications           #-}
+{-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE TypeSynonymInstances       #-}
-
+{-# LANGUAGE UndecidableInstances       #-}
 
 module Server where
 import           Servant                (Application,
@@ -40,14 +46,15 @@ import           Data.UUID              (UUID)
 import qualified Data.UUID              as UUID
 import qualified Data.UUID.V4           as UUID
 import           Data.Vector            (Vector)
+import           Database.Persist
+import           Database.Persist.TH
 import           GHC.Foreign            (withCStringsLen)
 import           GHC.Generics           (Generic)
 import           GTFS
+import           PersistOrphans
 import           Servant.Server         (Handler)
 import           Servant.Swagger        (toSwagger)
 
-
-
 newtype Token = Token UUID
   deriving newtype (Show, ToJSON, Eq, Ord, FromHttpApiData, ToJSONKey)
 instance ToSchema Token where
@@ -55,22 +62,29 @@ instance ToSchema Token where
 instance ToParamSchema Token where
   toParamSchema _ = toParamSchema (Proxy @String)
 
--- TODO: perhaps wrap into server-side struct to add network delay stats?
-data TrainPing = TrainPing
-  { pingLat       :: Float
-  , pingLong      :: Float
-  , pingDelay     :: Int
-  , pingTimestamp :: Time
-  } deriving (Generic)
-
-instance FromJSON TrainPing where
-  parseJSON = genericParseJSON (aesonOptions "ping")
-instance ToJSON TrainPing where
-  toJSON = genericToJSON (aesonOptions "ping")
-instance ToSchema TrainPing where
+share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
+TripToken sql=tt_tracker_token
+  Id UUID default=uuid_generate_v4()
+  issued UTCTime
+  blocked Bool
+  tripNumber Text
+  deriving Eq Show Generic
+
+TripPing json sql=tt_trip_ping
+  token UUID
+  latitude Double
+  longitude Double
+  delay Double
+  timestamp UTCTime
+  deriving Show Generic Eq
+
+|]
+
+
+instance ToSchema TripPing where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
 
-type KnownTrips = TVar (Map Token [TrainPing])
+type KnownTrips = TVar (Map Token [TripPing])
 
 type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Map TripID (Trip Deep))
@@ -79,9 +93,9 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   -- TODO: perhaps require a first ping for registration?
   :<|> "trainregister" :> Capture "Trip ID" TripID :> Post '[JSON] Token
   -- TODO: perhaps a websocket instead?
-  :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TrainPing :> Post '[JSON] ()
+  :<|> "trainping" :> Capture "Train Token" Token :> ReqBody '[JSON] TripPing :> Post '[JSON] ()
   -- debug things
-  :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TrainPing])
+  :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
 type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
   :<|> API
 
@@ -91,7 +105,7 @@ type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
 
 server :: GTFS -> KnownTrips -> Server CompleteAPI
 server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handleTimetable :<|> handleTrip
-  :<|> handleRegister :<|> handleTrainPing :<|> handleDebugState
+  :<|> handleRegister :<|> handleTripPing :<|> handleDebugState
   where handleStations = pure stations
         handleTimetable station = do
           today <- liftIO getCurrentTime <&> utctDay
@@ -103,7 +117,7 @@ server gtfs@GTFS{..} knownTrains = handleDebugAPI :<|> handleStations :<|> handl
           token <- UUID.nextRandom <&> Token
           atomically $ modifyTVar knownTrains (M.insert token [])
           pure token
-        handleTrainPing token ping = liftIO $ atomically $ do
+        handleTripPing token ping = liftIO $ atomically $ do
             modifyTVar knownTrains (M.update (\history -> Just (ping : history)) token)
             pure ()
         handleDebugState = liftIO $ readTVarIO knownTrains
@@ -116,7 +130,6 @@ application gtfs = do
 
 
 
-
 {-
 TODO:
 there should be a basic API allowing the questions: