1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
|
{-# 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 UndecidableInstances #-}
module Persist where
import Data.Aeson (FromJSON, ToJSON, ToJSONKey)
import Data.Swagger (ToParamSchema (..), ToSchema (..),
genericDeclareNamedSchema)
import Data.Text (Text)
import Data.UUID (UUID)
import Database.Persist
import Database.Persist.Sql (PersistFieldSql,
runSqlPersistMPool)
import Database.Persist.TH
import GTFS
import PersistOrphans
import Servant (FromHttpApiData)
import Conduit (ResourceT)
import Control.Monad.IO.Class (MonadIO (liftIO))
import Control.Monad.Logger (NoLoggingT)
import Control.Monad.Reader (ReaderT)
import Data.Data (Proxy (..))
import Data.Pool (Pool)
import Data.Time (NominalDiffTime,
UTCTime (utctDay), addUTCTime,
dayOfWeek, diffUTCTime,
getCurrentTime, nominalDay)
import Database.Persist.Postgresql (SqlBackend)
import GHC.Generics (Generic)
import Web.PathPieces (PathPiece)
newtype Token = Token UUID
deriving newtype
( Show, ToJSON, FromJSON, Eq, Ord, FromHttpApiData
, ToJSONKey, PersistField, PersistFieldSql, PathPiece)
instance ToSchema Token where
declareNamedSchema _ = declareNamedSchema (Proxy @String)
instance ToParamSchema Token where
toParamSchema _ = toParamSchema (Proxy @String)
share [mkPersist sqlSettings, mkMigrate "migrateAll"] [persistLowerCase|
RunningTrip sql=tt_tracker_token
Id UUID default=uuid_generate_v4()
expires UTCTime
blocked Bool
tripNumber Text
deriving Eq Show Generic
TripPing json sql=tt_trip_ping
token Token
latitude Double
longitude Double
delay Double
timestamp UTCTime
deriving Show Generic Eq
|]
instance ToSchema TripPing where
declareNamedSchema = genericDeclareNamedSchema (swaggerOptions "ping")
runSql :: MonadIO m => Pool SqlBackend -> (ReaderT SqlBackend (NoLoggingT (ResourceT IO)) a) -> m a
runSql pool = liftIO . flip runSqlPersistMPool pool
|
