foreign keys are a thing

(and they can be useful, too!)

Also, documentation & deleting imports / extensions that aren't used.

5 files changed, 60 insertions, 74 deletions

diff --git a/lib/API.hs b/lib/API.hs
index 3fb4c3c..dc348d3 100644
--- a/lib/API.hs
+++ b/lib/API.hs
@@ -1,15 +1,9 @@
-{-# LANGUAGE DataKinds             #-}
-{-# LANGUAGE DerivingStrategies    #-}
-{-# LANGUAGE FlexibleContexts      #-}
-{-# LANGUAGE FlexibleInstances     #-}
-{-# LANGUAGE GADTs                 #-}
-{-# LANGUAGE MultiParamTypeClasses #-}
-{-# LANGUAGE TypeFamilies          #-}
-{-# LANGUAGE TypeOperators         #-}
-{-# LANGUAGE UndecidableInstances  #-}
+{-# LANGUAGE DataKinds     #-}
+{-# LANGUAGE TypeOperators #-}
 
-
-module API where
+-- | The sole authorative definition of this server's API, given as a Servant-style
+-- Haskell type. All other descriptions of the API are generated from this one.
+module API (API, CompleteAPI) where
 
 import           Data.Map     (Map)
 import           Data.Swagger (Swagger)
@@ -21,6 +15,7 @@ import           Servant      (Application, FromHttpApiData (parseUrlPiece),
 import           Servant.API  (Capture, FromHttpApiData, Get, JSON, Post,
                                ReqBody, type (:<|>) ((:<|>)))
 
+-- | The server's API (as it is actually intended).
 type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "timetable" :> Capture "Station ID" StationID :> Get '[JSON] (Map TripID (Trip Deep))
   :<|> "trip" :> Capture "Trip ID" TripID :> Get '[JSON] (Trip Deep)
@@ -31,5 +26,22 @@ type API = "stations" :> Get '[JSON] (Map StationID Station)
   :<|> "trip" :> "ping" :> ReqBody '[JSON] TripPing :> Post '[JSON] ()
   -- debug things
   :<|> "debug" :> "state" :> Get '[JSON] (Map Token [TripPing])
+
+-- | The server's API with an additional debug route for accessing the specification
+-- itself. Split from API to prevent the API documenting the format in which it is
+-- documented, which would be silly and way to verbose.
 type CompleteAPI = "debug" :> "openapi" :> Get '[JSON] Swagger
   :<|> API
+
+{-
+TODO:
+there should be a basic API allowing the questions:
+ - what are the next trips leaving from $station? (or $geolocation?)
+ - all stops of a given tripID
+
+then the "ingress" API:
+ - train ping (location, estimated delay, etc.)
+ - cancel trip
+ - add trip?
+
+-}
diff --git a/lib/GTFS.hs b/lib/GTFS.hs
index a77a487..be80745 100644
--- a/lib/GTFS.hs
+++ b/lib/GTFS.hs
@@ -5,7 +5,6 @@
 {-# LANGUAGE FlexibleContexts           #-}
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE KindSignatures             #-}
 {-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
@@ -15,7 +14,8 @@
 {-# LANGUAGE TypeFamilies               #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
-
+-- | All kinds of stuff that has to deal with GTFS directly
+-- (i.e. parsing, querying, Aeson instances, etc.)
 module GTFS where
 
 
@@ -105,7 +105,7 @@ instance CSV.FromField Day where
 instance ToSchema Time where
   declareNamedSchema _ = do
     dings <- declareNamedSchema (Proxy @Int)
-    pure $ (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings)
+    pure (set (S.schema . S.description) (Just "Zeit in Sekunden seit Tagesanfang") dings)
 
 
 data Depth = Shallow | Deep
diff --git a/lib/Persist.hs b/lib/Persist.hs
index b4df1fb..3115ce3 100644
--- a/lib/Persist.hs
+++ b/lib/Persist.hs
@@ -6,19 +6,16 @@
 {-# LANGUAGE FlexibleInstances          #-}
 {-# LANGUAGE GADTs                      #-}
 {-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
 {-# LANGUAGE MultiParamTypeClasses      #-}
 {-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE RecordWildCards            #-}
 {-# LANGUAGE StandaloneDeriving         #-}
 {-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TupleSections              #-}
 {-# LANGUAGE TypeApplications           #-}
 {-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeOperators              #-}
 {-# LANGUAGE UndecidableInstances       #-}
 
-
+-- | Data types that are or might yet be saved in the database, and possibly
+-- also a few little convenience functions for using persistent.
 module Persist where
 
 import           Data.Aeson                  (FromJSON, ToJSON, ToJSONKey)
@@ -32,7 +29,7 @@ import           Database.Persist.Sql        (PersistFieldSql,
 import           Database.Persist.TH
 import           GTFS
 import           PersistOrphans
-import           Servant                     (FromHttpApiData)
+import           Servant                     (FromHttpApiData, ToHttpApiData)
 
 import           Conduit                     (ResourceT)
 import           Control.Monad.IO.Class      (MonadIO (liftIO))
@@ -53,7 +50,8 @@ import           Web.PathPieces              (PathPiece)
 newtype Token = Token UUID
   deriving newtype
    ( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData
-   , ToJSONKey, PersistField, PersistFieldSql, PathPiece)
+   , ToJSONKey, PersistField, PersistFieldSql, PathPiece
+   , ToHttpApiData, Read )
 instance ToSchema Token where
   declareNamedSchema _ = declareNamedSchema (Proxy @String)
 instance ToParamSchema Token where
@@ -62,14 +60,14 @@ instance ToParamSchema Token where
 
 share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
 RunningTrip sql=tt_tracker_token
-  Id UUID default=uuid_generate_v4()
+  Id Token default=uuid_generate_v4()
   expires UTCTime
   blocked Bool
   tripNumber Text
   deriving Eq Show Generic
 
 TripPing json sql=tt_trip_ping
-  token Token
+  token RunningTripId
   latitude Double
   longitude Double
   delay Double
@@ -78,8 +76,10 @@ TripPing json sql=tt_trip_ping
 
 |]
 
+instance ToSchema RunningTripId where
+  declareNamedSchema _ = declareNamedSchema (Proxy @UUID)
 instance ToSchema TripPing where
   declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
 
-runSql :: MonadIO m => Pool SqlBackend -> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a) -> m a
+runSql :: MonadIO m => Pool SqlBackend -> ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a -> m a
 runSql pool = liftIO . flip runSqlPersistMPool pool
diff --git a/lib/PersistOrphans.hs b/lib/PersistOrphans.hs
index 68e9738..1f521cc 100644
--- a/lib/PersistOrphans.hs
+++ b/lib/PersistOrphans.hs
@@ -1,9 +1,9 @@
--- | This module contains instances for the Data.UUID UUID type
--- to be mapped to postgresql's custom builtin uuid type.
+-- | 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
+module PersistOrphans () where
 
 
 import           Data.Either.Combinators (maybeToRight)
@@ -25,8 +25,10 @@ instance PersistField UUID where
     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 4a78735..91f1f36 100644
--- a/lib/Server.hs
+++ b/lib/Server.hs
@@ -1,25 +1,14 @@
-{-# LANGUAGE DataKinds                  #-}
-{-# LANGUAGE DeriveAnyClass             #-}
-{-# LANGUAGE DeriveGeneric              #-}
-{-# LANGUAGE DerivingStrategies         #-}
-{-# LANGUAGE FlexibleContexts           #-}
-{-# LANGUAGE FlexibleInstances          #-}
-{-# LANGUAGE GADTs                      #-}
-{-# LANGUAGE GeneralizedNewtypeDeriving #-}
-{-# LANGUAGE LambdaCase                 #-}
-{-# LANGUAGE MultiParamTypeClasses      #-}
-{-# LANGUAGE QuasiQuotes                #-}
-{-# LANGUAGE RecordWildCards            #-}
-{-# LANGUAGE StandaloneDeriving         #-}
-{-# LANGUAGE TemplateHaskell            #-}
-{-# LANGUAGE TupleSections              #-}
-{-# LANGUAGE TypeApplications           #-}
-{-# LANGUAGE TypeFamilies               #-}
-{-# LANGUAGE TypeOperators              #-}
-{-# LANGUAGE TypeSynonymInstances       #-}
-{-# LANGUAGE UndecidableInstances       #-}
+{-# LANGUAGE DerivingStrategies #-}
+{-# LANGUAGE ExplicitNamespaces #-}
+{-# LANGUAGE FlexibleContexts   #-}
+{-# LANGUAGE FlexibleInstances  #-}
+{-# LANGUAGE LambdaCase         #-}
+{-# LANGUAGE RecordWildCards    #-}
+{-# LANGUAGE TypeApplications   #-}
 
-module Server where
+
+-- Implementation of the API. This module is the main point of the program.
+module Server (application) where
 import           Conduit                        (MonadTrans (lift), ResourceT)
 import           Control.Concurrent.STM
 import           Control.Monad                  (when)
@@ -56,7 +45,7 @@ import           GTFS
 import           Servant                        (Application,
                                                  FromHttpApiData (parseUrlPiece),
                                                  Server, err401, err404, serve,
-                                                 throwError, type (:>))
+                                                 throwError)
 import           Servant.API                    (Capture, FromHttpApiData, Get,
                                                  JSON, Post, ReqBody,
                                                  type (:<|>) ((:<|>)))
@@ -76,8 +65,6 @@ application gtfs dbpool = do
   doMigration dbpool
   pure $ serve (Proxy @CompleteAPI) $ server gtfs dbpool
 
-
-
 -- databaseMigration :: ConnectionString -> IO ()
 doMigration pool = runSql pool $
   -- TODO: before that, check if the uuid module is enabled
@@ -98,23 +85,24 @@ server gtfs@GTFS{..} dbpool = handleDebugAPI :<|> handleStations :<|> handleTime
           Nothing  -> throwError err404
         handleRegister tripID = do
           expires <- liftIO $ getCurrentTime <&> addUTCTime validityPeriod
-          RunningTripKey uuid <- runSql dbpool $ insert (RunningTrip expires False tripID)
-          pure (Token uuid)
+          RunningTripKey token <- runSql dbpool $ insert (RunningTrip expires False tripID)
+          pure token
         handleTripPing ping = do
-          checkTokenValid dbpool (tripPingToken ping)
+          checkTokenValid dbpool (coerce $ tripPingToken ping)
           -- TODO: are these always inserted in order?
           runSql dbpool $ insert ping
           pure ()
         handleDebugState = do
-          now <- liftIO $ getCurrentTime
+          now <- liftIO getCurrentTime
           runSql dbpool $ do
            running <- selectList [RunningTripBlocked ==. False, RunningTripExpires >=. now] []
-           pairs <- forM running $ \(Entity (RunningTripKey uuid) _) -> do
-             entities <- selectList [TripPingToken ==. Token uuid] []
-             pure (Token uuid, fmap entityVal entities)
+           pairs <- forM running $ \(Entity token@(RunningTripKey uuid) _) -> do
+             entities <- selectList [TripPingToken ==. token] []
+             pure (uuid, fmap entityVal entities)
            pure (M.fromList pairs)
         handleDebugAPI = pure $ toSwagger (Proxy @API)
 
+-- TODO: proper debug logging for expired tokens
 checkTokenValid :: Pool SqlBackend -> Token -> Handler ()
 checkTokenValid dbpool token = do
   trip <- try $ runSql dbpool $ get (coerce token)
@@ -133,19 +121,3 @@ hasExpired limit = do
 
 validityPeriod :: NominalDiffTime
 validityPeriod = nominalDay
-
-
-
-
-{-
-TODO:
-there should be a basic API allowing the questions:
- - what are the next trips leaving from $station? (or $geolocation?)
- - all stops of a given tripID
-
-then the "ingress" API:
- - train ping (location, estimated delay, etc.)
- - cancel trip
- - add trip?
-
--}