f7b7fd5 · squeal · git.iko.soy

git.iko.soy/squeal

on dev help sign in

Add a basic implementation of migration command

f7b7fd5Raveline8 years ago

squeal-postgresql/src/Squeal/PostgreSQL/Migration.hs+121−21

compare with dev

unifiedsplit

@@ -88,17 +88,16 @@ withConnection "host=localhost port=5432 dbname=exampledb" $

88Row 2

89Row 0

90-}

91−

92−{-# LANGUAGE

93− DataKinds

91+{-# LANGUAGE DataKinds #-}

92+{-# LANGUAGE DeriveGeneric #-}

93+{-# LANGUAGE FlexibleContexts #-}

94− , GADTs

94+{-# LANGUAGE GADTs #-}

95− , LambdaCase

95+{-# LANGUAGE LambdaCase #-}

96+{-# LANGUAGE OverloadedLabels #-}

97+{-# LANGUAGE OverloadedStrings #-}

96− , PolyKinds

98+{-# LANGUAGE PolyKinds #-}

97− , OverloadedLabels

98− , TypeApplications

99+{-# LANGUAGE TypeApplications #-}

99− , FlexibleContexts

100− , TypeOperators

100+{-# LANGUAGE TypeOperators #-}

101−#-}

102

101

103module Squeal.PostgreSQL.Migration

102module Squeal.PostgreSQL.Migration

104 ( -- * Migration

103 ( -- * Migration

@@ -111,23 +110,32 @@ module Squeal.PostgreSQL.Migration

111 , insertMigration

110 , insertMigration

112 , deleteMigration

111 , deleteMigration

113 , selectMigration

112 , selectMigration

113+ -- * CLI

114+ , defaultMain

114 ) where

115 ) where

115

116

116−import Control.Monad

117+import Control.Monad

117−import Control.Monad.Base

118+import Control.Monad.Base

118−import Control.Monad.Trans.Control

119+import Control.Monad.Trans.Control

119−import Generics.SOP (K(..))

120+import Data.ByteString (ByteString)

121+import Data.Foldable (traverse_)

120−import Data.Function ((&))

122+import Data.Function ((&))

121−import Data.Text (Text)

123+import Data.List ((\\))

122−

124+import Data.Text (Text)

125+import qualified Data.Text.IO as T (putStrLn)

126+import Data.Time (UTCTime)

127+import Generics.SOP (K (..))

128+import qualified Generics.SOP as SOP

129+import qualified GHC.Generics as GHC

123−import Squeal.PostgreSQL

130+import Squeal.PostgreSQL

131+import System.Environment

124

132

125-- | A `Migration` should contain an inverse pair of

133-- | A `Migration` should contain an inverse pair of

126-- `up` and `down` instructions and a unique `name`.

134-- `up` and `down` instructions and a unique `name`.

127data Migration io schemas0 schemas1 = Migration

135data Migration io schemas0 schemas1 = Migration

128 { name :: Text -- ^ The `name` of a `Migration`.

136 { name :: Text -- ^ The `name` of a `Migration`.

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

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

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

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

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

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

132 }

140 }

133

141

@@ -248,7 +256,7 @@ okResult result = do

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

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

249 errorMessageMaybe <- resultErrorMessage result

257 errorMessageMaybe <- resultErrorMessage result

250 case errorMessageMaybe of

258 case errorMessageMaybe of

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

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

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

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

253

261

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

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

@@ -258,6 +266,14 @@ type MigrationsTable =

258 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz

266 , "executed_at" ::: 'Def :=> 'NotNull 'PGtimestamptz

259 ]

267 ]

260

268

269+data MigrationRow =

270+ MigrationRow { migrationName :: Text

271+ , executedAt :: UTCTime }

272+ deriving (GHC.Generic, Show)

273+

274+instance SOP.Generic MigrationRow

275+instance SOP.HasDatatypeInfo MigrationRow

276+

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

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

262

278

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

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

@@ -295,3 +311,87 @@ selectMigration = select_

295 (#executed_at `as` #executed_at)

311 (#executed_at `as` #executed_at)

296 ( from (table ((#migrations ! #schema_migrations) `as` #m))

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

297 & where_ (#name .== param @1))

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)))

321+

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

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

324+

325+data Command = Display

326+ | AllUp

327+ | AllDown

328+ deriving (GHC.Generic, Show)

329+

330+defaultMain

331+ :: ByteString

332+ -- ^ connection string

333+ -> AlignedList (Migration IO) db0 db1

334+ -- ^ migrations

335+ -> IO ()

336+defaultMain connectTo migrations = do

337+ command <- readCommandFromArgs

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

339+

340+readCommandFromArgs :: 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

348+

349+displayUsage :: IO ()

350+displayUsage = do

351+ 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

357+

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

359+getRunMigrationNames =

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

361+

362+displayListOfNames :: [Text] -> IO ()

363+displayListOfNames [] = T.putStrLn "\tNone"

364+displayListOfNames xs =

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

366+ in traverse_ singleName xs

367+

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

369+displayUnrunned unrunned =

370+ T.putStrLn "Migrations left to run:"

371+ >> displayListOfNames unrunned

372+

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

374+displayRunned runned =

375+ T.putStrLn "Migrations already run:"

376+ >> displayListOfNames runned

377+

378+performCommand

379+ :: ByteString

380+ -- ^ Connection string

381+ -> AlignedList (Migration IO) db0 db1

382+ -- ^ Known migrations

383+ -> Command

384+ -- ^ Operation to perform

385+ -> IO ()

386+performCommand connectTo migrations Display =

387+ withConnection connectTo $ do

388+ runNames <- getRunMigrationNames

389+ let names = extractList name migrations

390+ unrunNames = names \\ runNames

391+ liftBase $ displayRunned runNames >> displayUnrunned unrunNames

392+performCommand connectTo migrations AllUp =

393+ withConnection connectTo (migrateUp migrations)

394+ >> performCommand connectTo migrations Display

395+performCommand connectTo migrations AllDown =

396+ withConnection connectTo (migrateDown migrations)

397+ >> performCommand connectTo migrations Display

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

@@ -84,8 +84,8 @@ module Squeal.PostgreSQL.Schema

84 , GroupedBy

85 -- * Aligned lists

86 , AlignedList (..)

87− , single

88 , extractList

87 , extractList

88+ , single

89 -- * Data Definitions

90 , Create

91 , Drop