45ff8a8 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

simplify migrations a bit

45ff8a8Eitan Chatav8 years ago

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

compare with dev

unifiedsplit

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

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

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

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

140− }

140+ } deriving (GHC.Generic)

141

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

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

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

146migrateUp

147 :: MonadBaseControl IO io

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

149− -> PQ

149+ -> PQ schemas0 schemas1 io ()

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

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

152− io ()

153−migrateUp migration =

150+migrateUp migration = unsafePQ $

154 define createMigrations

151 define createMigrations

155 & pqBind okResult

152 & pqBind okResult

156 & pqThen (transactionallySchema_ (upMigrations migration))

153 & pqThen (transactionallySchema_ (upMigrations migration))

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

159 upMigrations

156 upMigrations

160 :: MonadBaseControl IO io

157 :: MonadBaseControl IO io

161 => AlignedList (Migration io) schemas0 schemas1

158 => AlignedList (Migration io) schemas0 schemas1

162− -> PQ

159+ -> PQ MigrationsSchemas MigrationsSchemas io ()

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

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

165− io ()

166 upMigrations = \case

160 upMigrations = \case

167 Done -> return ()

161 Done -> return ()

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

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

169

163

170 upMigration

164 upMigration

171 :: MonadBase IO io

165 :: MonadBase IO io

172− => Migration io schemas0 schemas1 -> PQ

166+ => Migration io schemas0 schemas1

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

167+ -> PQ MigrationsSchemas MigrationsSchemas io ()

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

175− io ()

176 upMigration step =

168 upMigration step =

177 queryExecuted step

169 queryExecuted step

178− & pqBind (\ executed ->

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

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

171+ $ unsafePQ (up step)

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

181− else

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

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

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

184− -- insert execution record

173+ -- insert execution record

185− & pqBind okResult)

174+ & pqBind okResult )

186

175

187 queryExecuted

176 queryExecuted

188 :: MonadBase IO io

177 :: MonadBase IO io

189− => Migration io schemas0 schemas1 -> PQ

178+ => Migration io schemas0 schemas1

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

179+ -> PQ MigrationsSchemas MigrationsSchemas io Row

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

192− io Row

193 queryExecuted step = do

180 queryExecuted step = do

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

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

195 okResult result

182 okResult result

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

202migrateDown

189migrateDown

203 :: MonadBaseControl IO io

190 :: MonadBaseControl IO io

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

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

205− -> PQ

192+ -> PQ schema1 schema0 io ()

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

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

208− io ()

209−migrateDown migrations =

193+migrateDown migrations = unsafePQ $

210 define createMigrations

194 define createMigrations

211 & pqBind okResult

195 & pqBind okResult

212 & pqThen (transactionallySchema_ (downMigrations migrations))

196 & pqThen (transactionallySchema_ (downMigrations migrations))

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

214

198

215 downMigrations

199 downMigrations

216 :: MonadBaseControl IO io

200 :: MonadBaseControl IO io

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

201+ => AlignedList (Migration io) schemas0 schemas1

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

202+ -> PQ MigrationsSchemas MigrationsSchemas io ()

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

220− io ()

221 downMigrations = \case

203 downMigrations = \case

222 Done -> return ()

204 Done -> return ()

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

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

224

206

225 downMigration

207 downMigration

226 :: MonadBase IO io

208 :: MonadBase IO io

227− => Migration io schemas0 schemas1 -> PQ

209+ => Migration io schemas0 schemas1

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

210+ -> PQ MigrationsSchemas MigrationsSchemas io ()

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

230− io ()

231 downMigration step =

211 downMigration step =

232 queryExecuted step

212 queryExecuted step

233− & pqBind (\ executed ->

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

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

214+ $ unsafePQ (down step)

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

236− else

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

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

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

239− -- delete execution record

216+ -- delete execution record

240− & pqBind okResult)

217+ & pqBind okResult )

241

218

242 queryExecuted

219 queryExecuted

243 :: MonadBase IO io

220 :: MonadBase IO io

244− => Migration io schemas0 schemas1 -> PQ

221+ => Migration io schemas0 schemas1

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

222+ -> PQ MigrationsSchemas MigrationsSchemas io Row

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

247− io Row

248 queryExecuted step = do

223 queryExecuted step = do

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

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

250 okResult result

225 okResult result

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

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

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

257 errorMessageMaybe <- resultErrorMessage result

232 errorMessageMaybe <- resultErrorMessage result

258 case errorMessageMaybe of

233 case errorMessageMaybe of

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

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

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

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

261

236

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

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

263type MigrationsTable =

238type MigrationsTable =

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

275instance SOP.HasDatatypeInfo MigrationRow

250instance SOP.HasDatatypeInfo MigrationRow

276

251

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

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

253+type MigrationsSchemas = Public MigrationsSchema

278

254

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

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

280−createMigrations

256+createMigrations :: Definition MigrationsSchemas MigrationsSchemas

281− :: Has "migrations" schemas MigrationsSchema

282− => Definition schemas schemas

283createMigrations =

257createMigrations =

284− createSchemaIfNotExists #migrations >>>

285− createTableIfNotExists (#migrations ! #schema_migrations)

258+ createTableIfNotExists #schema_migrations

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

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

287 (timestampWithTimeZone & notNullable & default_ currentTimestamp)

260 (timestampWithTimeZone & notNullable & default_ currentTimestamp)

288 `as` #executed_at )

261 `as` #executed_at )

289 ( unique #name `as` #migrations_unique_name )

262 ( unique #name `as` #migrations_unique_name )

290

263

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

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

292−insertMigration

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

293− :: Has "migrations" schemas MigrationsSchema

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

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

266+insertMigration = insertInto_ #schema_migrations . Values_ $

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

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

297

268

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

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

299−deleteMigration

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

300− :: Has "migrations" schemas MigrationsSchema

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

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

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

303

272

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

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

305-- the time at which it was executed.

274-- the time at which it was executed.

306selectMigration

275selectMigration

307− :: Has "migrations" schemas MigrationsSchema

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

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

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

310−selectMigration = select_

277+selectMigration = select_ #executed_at

311− (#executed_at `as` #executed_at)

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

278+ $ from (table (#schema_migrations))

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

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

314−

280+

315−fetchAllMigrations

281+fetchAllMigrations :: Query_ MigrationsSchemas () MigrationRow

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

317−fetchAllMigrations =

282+fetchAllMigrations = select_

318− select_ ( #name `as` #migrationName

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

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

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

284+ (from (table #schema_migrations))

321

285

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

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

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

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

324

288

325−data Command = Display

326− | AllUp

327− | AllDown

328− deriving (GHC.Generic, Show)

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

329

290

330defaultMain

291defaultMain

331 :: ByteString

292 :: ByteString

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

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

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

339

300

340readCommandFromArgs :: IO (Maybe Command)

301readCommandFromArgs :: IO (Maybe Command)

341−readCommandFromArgs = do

302+readCommandFromArgs = getArgs >>= \case

342− args <- getArgs

343− case args of

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

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

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

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

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

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

347− _ -> displayUsage >> pure Nothing

306+ _ -> displayUsage >> pure Nothing

348

307

349displayUsage :: IO ()

308displayUsage :: IO ()

350displayUsage = do

309displayUsage = do

351 putStrLn "Invalid command. Use:"

310 putStrLn "Invalid command. Use:"

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

311+ putStrLn "migrate to run all available migrations"

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

312+ putStrLn "rollback to rollback all available migrations"

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

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

355−

356−type RunMigrationName = Text

357

314

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

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

359getRunMigrationNames =

316getRunMigrationNames =

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

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

361

318

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

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

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

366 in traverse_ singleName xs

323 in traverse_ singleName xs

367

324

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

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

369displayUnrunned unrunned =

326displayUnrunned unrunned =

370 T.putStrLn "Migrations left to run:"

327 T.putStrLn "Migrations left to run:"

371 >> displayListOfNames unrunned

328 >> displayListOfNames unrunned

372

329

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

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

374displayRunned runned =

331displayRunned runned =

375 T.putStrLn "Migrations already run:"

332 T.putStrLn "Migrations already run:"

376 >> displayListOfNames runned

333 >> displayListOfNames runned

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

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

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

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

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

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

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

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

207class IndexedMonadTransPQ pq where

206class IndexedMonadTransPQ pq where

208

207

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

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

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

243 -> x -> pq schemas0 schemas2 m z

242 -> x -> pq schemas0 schemas2 m z

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

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

245

244

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−

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

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

253 --

246 --

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

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

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

268 K x' <- x conn

261 K x' <- x conn

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

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

270

263

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

272− K x <- pq (K conn)

273− return $ K x

274−

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

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

276 resultMaybe <- liftBase $ LibPQ.exec conn q

265 resultMaybe <- liftBase $ LibPQ.exec conn q

277 case resultMaybe of

266 case resultMaybe of