45ff8a8 · squeal · git.iko.soy

git.iko.soy/squeal

simplify migrations a bit

commit45ff8a8a2d3fc7682fd6a41f5e8f02f0f063a2ae authorEitan Chatav <eitan@Eitans-MacBook-Pro.local> dateMon 25 Mar 2019, 09:51 (8 years ago) parent6aec0cc

2 files changed+57−111

compare with dev

unifiedsplit

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+56−99 squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−12

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+56−99

@@ -137,7 +137,7 @@ data Migration io schemas0 schemas1 = Migration

137137 -- Each `name` in a `Migration` should be unique.

138138 , up :: PQ schemas0 schemas1 io () -- ^ The `up` instruction of a `Migration`.

139139 , down :: PQ schemas1 schemas0 io () -- ^ The `down` instruction of a `Migration`.

140− }

140+ } deriving (GHC.Generic)

141141

142142-- | Run `Migration`s by creating the `MigrationsTable`

143143-- if it does not exist and then in a transaction, for each each `Migration`

@@ -146,11 +146,8 @@ data Migration io schemas0 schemas1 = Migration

146146migrateUp

147147 :: MonadBaseControl IO io

148148 => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to run

149− -> PQ

150− ("migrations" ::: MigrationsSchema ': schemas0)

151− ("migrations" ::: MigrationsSchema ': schemas1)

152− io ()

153−migrateUp migration =

149+ -> PQ schemas0 schemas1 io ()

150+migrateUp migration = unsafePQ $

154151 define createMigrations

155152 & pqBind okResult

156153 & pqThen (transactionallySchema_ (upMigrations migration))

@@ -159,37 +156,27 @@ migrateUp migration =

159156 upMigrations

160157 :: MonadBaseControl IO io

161158 => AlignedList (Migration io) schemas0 schemas1

162− -> PQ

163− ("migrations" ::: MigrationsSchema ': schemas0)

164− ("migrations" ::: MigrationsSchema ': schemas1)

165− io ()

159+ -> PQ MigrationsSchemas MigrationsSchemas io ()

166160 upMigrations = \case

167161 Done -> return ()

168162 step :>> steps -> upMigration step & pqThen (upMigrations steps)

169163

170164 upMigration

171165 :: MonadBase IO io

172− => Migration io schemas0 schemas1 -> PQ

173− ("migrations" ::: MigrationsSchema ': schemas0)

174− ("migrations" ::: MigrationsSchema ': schemas1)

175− io ()

166+ => Migration io schemas0 schemas1

167+ -> PQ MigrationsSchemas MigrationsSchemas io ()

176168 upMigration step =

177169 queryExecuted step

178− & pqBind (\ executed ->

179− if executed == 1 -- up step has already been executed

180− then PQ (\ _ -> return (K ())) -- unsafely switch schemas

181− else

182− pqEmbed (up step) -- safely switch schemas

183− & pqThen (manipulateParams insertMigration (Only (name step)))

184− -- insert execution record

185− & pqBind okResult)

170+ & pqBind ( \ executed -> unless (executed == 1)

171+ $ unsafePQ (up step)

172+ & pqThen (manipulateParams insertMigration (Only (name step)))

173+ -- insert execution record

174+ & pqBind okResult )

186175

187176 queryExecuted

188177 :: MonadBase IO io

189− => Migration io schemas0 schemas1 -> PQ

190− ("migrations" ::: MigrationsSchema ': schemas0)

191− ("migrations" ::: MigrationsSchema ': schemas0)

192− io Row

178+ => Migration io schemas0 schemas1

179+ -> PQ MigrationsSchemas MigrationsSchemas io Row

193180 queryExecuted step = do

194181 result <- runQueryParams selectMigration (Only (name step))

195182 okResult result

@@ -202,11 +189,8 @@ migrateUp migration =

202189migrateDown

203190 :: MonadBaseControl IO io

204191 => AlignedList (Migration io) schemas0 schemas1 -- ^ migrations to rewind

205− -> PQ

206− ("migrations" ::: MigrationsSchema ': schemas1)

207− ("migrations" ::: MigrationsSchema ': schemas0)

208− io ()

209−migrateDown migrations =

192+ -> PQ schema1 schema0 io ()

193+migrateDown migrations = unsafePQ $

210194 define createMigrations

211195 & pqBind okResult

212196 & pqThen (transactionallySchema_ (downMigrations migrations))

@@ -214,37 +198,28 @@ migrateDown migrations =

214198

215199 downMigrations

216200 :: MonadBaseControl IO io

217− => AlignedList (Migration io) schemas0 schemas1 -> PQ

218− ("migrations" ::: MigrationsSchema ': schemas1)

219− ("migrations" ::: MigrationsSchema ': schemas0)

220− io ()

201+ => AlignedList (Migration io) schemas0 schemas1

202+ -> PQ MigrationsSchemas MigrationsSchemas io ()

221203 downMigrations = \case

222204 Done -> return ()

223205 step :>> steps -> downMigrations steps & pqThen (downMigration step)

224206

225207 downMigration

226208 :: MonadBase IO io

227− => Migration io schemas0 schemas1 -> PQ

228− ("migrations" ::: MigrationsSchema ': schemas1)

229− ("migrations" ::: MigrationsSchema ': schemas0)

230− io ()

209+ => Migration io schemas0 schemas1

210+ -> PQ MigrationsSchemas MigrationsSchemas io ()

231211 downMigration step =

232212 queryExecuted step

233− & pqBind (\ executed ->

234− if executed == 0 -- up step has not been executed

235− then PQ (\ _ -> return (K ())) -- unsafely switch schemas

236− else

237− pqEmbed (down step) -- safely switch schemas

238− & pqThen (manipulateParams deleteMigration (Only (name step)))

239− -- delete execution record

240− & pqBind okResult)

213+ & pqBind ( \ executed -> unless (executed == 0)

214+ $ unsafePQ (down step)

215+ & pqThen (manipulateParams deleteMigration (Only (name step)))

216+ -- delete execution record

217+ & pqBind okResult )

241218

242219 queryExecuted

243220 :: MonadBase IO io

244− => Migration io schemas0 schemas1 -> PQ

245− ("migrations" ::: MigrationsSchema ': schemas1)

246− ("migrations" ::: MigrationsSchema ': schemas1)

247− io Row

221+ => Migration io schemas0 schemas1

222+ -> PQ MigrationsSchemas MigrationsSchemas io Row

248223 queryExecuted step = do

249224 result <- runQueryParams selectMigration (Only (name step))

250225 okResult result

@@ -256,8 +231,8 @@ okResult result = do

256231 when (not (status `elem` [CommandOk, TuplesOk])) $ do

257232 errorMessageMaybe <- resultErrorMessage result

258233 case errorMessageMaybe of

259− Nothing -> error "migrateDown: unknown error"

260− Just msg -> error ("migrationDown: " <> show msg)

234+ Nothing -> error "migration: unknown error"

235+ Just msg -> error ("migration: " <> show msg)

261236

262237-- | The `TableType` for a Squeal migration.

263238type MigrationsTable =

@@ -275,57 +250,43 @@ instance SOP.Generic MigrationRow

275250instance SOP.HasDatatypeInfo MigrationRow

276251

277252type MigrationsSchema = '["schema_migrations" ::: 'Table MigrationsTable]

253+type MigrationsSchemas = Public MigrationsSchema

278254

279255-- | Creates a `MigrationsTable` if it does not already exist.

280−createMigrations

281− :: Has "migrations" schemas MigrationsSchema

282− => Definition schemas schemas

256+createMigrations :: Definition MigrationsSchemas MigrationsSchemas

283257createMigrations =

284− createSchemaIfNotExists #migrations >>>

285− createTableIfNotExists (#migrations ! #schema_migrations)

258+ createTableIfNotExists #schema_migrations

286259 ( (text & notNullable) `as` #name :*

287260 (timestampWithTimeZone & notNullable & default_ currentTimestamp)

288261 `as` #executed_at )

289262 ( unique #name `as` #migrations_unique_name )

290263

291264-- | Inserts a `Migration` into the `MigrationsTable`

292−insertMigration

293− :: Has "migrations" schemas MigrationsSchema

294− => Manipulation '[] schemas '[ 'NotNull 'PGtext] '[]

295−insertMigration = insertInto_ (#migrations ! #schema_migrations) . Values_ $

265+insertMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

266+insertMigration = insertInto_ #schema_migrations . Values_ $

296267 (param @1) `as` #name :* defaultAs #executed_at

297268

298269-- | Deletes a `Migration` from the `MigrationsTable`

299−deleteMigration

300− :: Has "migrations" schemas MigrationsSchema

301− => Manipulation '[] schemas '[ 'NotNull 'PGtext ] '[]

302−deleteMigration = deleteFrom_ (#migrations ! #schema_migrations) (#name .== param @1)

270+deleteMigration :: Manipulation_ MigrationsSchemas (Only Text) ()

271+deleteMigration = deleteFrom_ #schema_migrations (#name .== param @1)

303272

304273-- | Selects a `Migration` from the `MigrationsTable`, returning

305274-- the time at which it was executed.

306275selectMigration

307− :: Has "migrations" schemas MigrationsSchema

308− => Query '[] '[] schemas '[ 'NotNull 'PGtext ]

309− '[ "executed_at" ::: 'NotNull 'PGtimestamptz ]

310−selectMigration = select_

311− (#executed_at `as` #executed_at)

312− ( from (table ((#migrations ! #schema_migrations) `as` #m))

313− & where_ (#name .== param @1))

314−

315−fetchAllMigrations

316− :: Query '[] '[] '["migrations" ::: MigrationsSchema] '[] (RowPG MigrationRow)

317−fetchAllMigrations =

318− select_ ( #name `as` #migrationName

319− :* #executed_at `as` #executedAt)

320− (from (table (#migrations ! #schema_migrations)))

276+ :: Query_ MigrationsSchemas (Only Text) (P ("executed_at" ::: UTCTime))

277+selectMigration = select_ #executed_at

278+ $ from (table (#schema_migrations))

279+ & where_ (#name .== param @1)

280+

281+fetchAllMigrations :: Query_ MigrationsSchemas () MigrationRow

282+fetchAllMigrations = select_

283+ (#name `as` #migrationName :* #executed_at `as` #executedAt)

284+ (from (table #schema_migrations))

321285

322286unsafePQ :: (Functor m) => PQ db0 db1 m x -> PQ db0' db1' m x

323287unsafePQ (PQ pq) = PQ $ fmap (SOP.K . SOP.unK) . pq . SOP.K . SOP.unK

324288

325−data Command = Display

326− | AllUp

327− | AllDown

328− deriving (GHC.Generic, Show)

289+data Command = Display | AllUp | AllDown deriving (GHC.Generic, Show)

329290

330291defaultMain

331292 :: ByteString

@@ -338,24 +299,20 @@ defaultMain connectTo migrations = do

338299 maybe (pure ()) (performCommand connectTo migrations) command

339300

340301readCommandFromArgs :: IO (Maybe Command)

341−readCommandFromArgs = do

342− args <- getArgs

343− case args of

344− ["db:migrate"] -> pure . Just $ AllUp

345− ["db:rollback"] -> pure . Just $ AllDown

346− ["db:status"] -> pure . Just $ Display

347− _ -> displayUsage >> pure Nothing

302+readCommandFromArgs = getArgs >>= \case

303+ ["migrate"] -> pure . Just $ AllUp

304+ ["rollback"] -> pure . Just $ AllDown

305+ ["status"] -> pure . Just $ Display

306+ _ -> displayUsage >> pure Nothing

348307

349308displayUsage :: IO ()

350309displayUsage = do

351310 putStrLn "Invalid command. Use:"

352− putStrLn "db:migrate to run all available migrations"

353− putStrLn "db:rollback to rollback all available migrations"

354− putStrLn "db:status to display migrations run and migrations left to run"

355−

356−type RunMigrationName = Text

311+ putStrLn "migrate to run all available migrations"

312+ putStrLn "rollback to rollback all available migrations"

313+ putStrLn "status to display migrations run and migrations left to run"

357314

358−getRunMigrationNames :: (MonadBase IO m) => PQ db0 db0 m [RunMigrationName]

315+getRunMigrationNames :: (MonadBase IO m) => PQ db0 db0 m [Text]

359316getRunMigrationNames =

360317 fmap migrationName <$> (unsafePQ (define createMigrations & pqThen (runQuery fetchAllMigrations)) >>= getRows)

361318

@@ -365,12 +322,12 @@ displayListOfNames xs =

365322 let singleName n = T.putStrLn $ "\t- " <> n

366323 in traverse_ singleName xs

367324

368−displayUnrunned :: [RunMigrationName] -> IO ()

325+displayUnrunned :: [Text] -> IO ()

369326displayUnrunned unrunned =

370327 T.putStrLn "Migrations left to run:"

371328 >> displayListOfNames unrunned

372329

373−displayRunned :: [RunMigrationName] -> IO ()

330+displayRunned :: [Text] -> IO ()

374331displayRunned runned =

375332 T.putStrLn "Migrations already run:"

376333 >> displayListOfNames runned

squeal-postgresql/src/Squeal/PostgreSQL/PQ.hs+1−12

@@ -202,8 +202,7 @@ evalPQ (PQ pq) conn = unK <$> pq conn

202202-- [enriched category](https://ncatlab.org/nlab/show/enriched+category).

203203-- An indexed monad transformer transforms a `Monad` into an indexed monad.

204204-- And, `IndexedMonadTransPQ` is a class for indexed monad transformers that

205−-- support running `Definition`s using `define` and embedding a computation

206−-- in a larger schema using `pqEmbed`.

205+-- support running `Definition`s using `define`.

207206class IndexedMonadTransPQ pq where

208207

209208 -- | indexed analog of `<*>`

@@ -243,12 +242,6 @@ class IndexedMonadTransPQ pq where

243242 -> x -> pq schemas0 schemas2 m z

244243 pqAndThen g f x = pqBind g (f x)

245244

246− -- | Safely embed a computation in a larger schema.

247− pqEmbed

248− :: Monad m

249− => pq schemas0 schemas1 m x

250− -> pq (schema ': schemas0) (schema : schemas1) m x

251−

252245 -- | Run a `Definition` with `LibPQ.exec`, we expect that libpq obeys the law

253246 --

254247 -- @define statement1 & pqThen (define statement2) = define (statement1 >>> statement2)@

@@ -268,10 +261,6 @@ instance IndexedMonadTransPQ PQ where

268261 K x' <- x conn

269262 unPQ (f x') (K (unK conn))

270263

271− pqEmbed (PQ pq) = PQ $ \ (K conn) -> do

272− K x <- pq (K conn)

273− return $ K x

274−

275264 define (UnsafeDefinition q) = PQ $ \ (K conn) -> do

276265 resultMaybe <- liftBase $ LibPQ.exec conn q

277266 case resultMaybe of