foreign keys are a thing

(and they can be useful, too!)

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

1 files changed, 19 insertions, 47 deletions

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