Commit 72f2f666 authored by MrMan's avatar MrMan

Add a quick n' dirty migration support

parent 8aac0faa
......@@ -34,6 +34,7 @@ library:
- system-filepath
- uuid
- sqlite-simple
- neat-interpolation
executables:
haskell-restish-todo-exe:
......
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Components.TaskStore.Migrations.SQLite where
import NeatInterpolation (text)
import Types (SQLMigration(..), SQLMigrationQuery(..))
migrations :: [SQLMigration]
migrations =
[SQLMigration
{ smFrom=0
, smTo=1
, smQuery=
SQLMigrationQuery
[text|
CREATE TABLE tasks(
uuid TEXT PRIMARY KEY NOT NULL,
name TEXT NOT NULL,
description TEXT NOT NULL,
status TEXT NOT NULL
);
|]
}
]
......@@ -2,22 +2,25 @@
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
{-# LANGUAGE LambdaCase #-}
module Components.TaskStore.SQLite where
import Config (CompleteTaskStoreConfig)
import Control.Exception (throw, catch, Exception, SomeException(..))
import Data.Either (Either)
import Data.Text as DT
import Data.UUID (UUID, toText, fromText)
import Data.Functor.Identity (Identity)
import Data.UUID.V4 (nextRandom)
import Database.SQLite.Simple (Connection, ToRow(..), FromRow(..), SQLData(..), field, execute, queryNamed, NamedParam((:=)))
import Database.SQLite.Simple.FromField (fieldData, ResultError(ConversionFailed), FieldParser, Field, FromField(..), returnError)
import Database.SQLite.Simple.FromRow (RowParser)
import Database.SQLite.Simple.ToField (ToField(..))
import Database.SQLite.Simple.ToField (ToField(..))
import Types
import Components.TaskStore.Migrations.SQLite (migrations)
import Config (CompleteTaskStoreConfig)
import Control.Exception (SomeException(..), throw, catch, try)
import Data.Either (Either)
import Data.Functor.Identity (Identity)
import Data.List (sort, find)
import Data.UUID (UUID, toText, fromText)
import Data.UUID.V4 (nextRandom)
import Database.SQLite.Simple
import Database.SQLite.Simple.FromField (fieldData, ResultError(ConversionFailed), FieldParser, Field, FromField(..), returnError)
import Database.SQLite.Simple.FromRow (RowParser)
import Database.SQLite.Simple.ToField (ToField(..))
import Types
import Util (rightOrThrow)
import qualified Data.Text as DT
data SQLiteTaskStore = SQLiteTaskStore
{ stsCfg :: CompleteTaskStoreConfig
......@@ -113,6 +116,7 @@ saveAndReturnTask c t = catch doInsert makeGenericInsertError
doInsert = execute c "INSERT INTO tasks (uuid, name, desc, state) VALUES (?,?,?,?)" t
>> pure (Right t)
instance TaskStore SQLiteTaskStore where
persistTask :: SQLiteTaskStore -> Validated (FullySpecifiedTask TaskState) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask TaskState)))
persistTask store (Validated newTask) = maybe disconnectionError _handler $ stsConn store
......@@ -121,11 +125,6 @@ instance TaskStore SQLiteTaskStore where
_handler conn = (flip UUIDID newTask <$> nextRandom) -- Use a random UUIDV4 to make a new `WithID (FullySpecifiedTask state)`
-- Insert the task
>>= saveAndReturnTask conn
-- Retrieve the task right after inserting it
-- >> queryNamed conn "SELECT * FROM tasks WHERE uuid=:uuid LIMIT 1" [":uuid" := uuid]
-- -- Pull out the first from the rows that return
-- >>= pure . maybe insertionFailedError (Right . fst) . uncons
completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask))
completeTask = undefined
......@@ -138,3 +137,82 @@ instance TaskStore SQLiteTaskStore where
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask = undefined
instance FromRow SQLMigrationVersion where
fromRow = fromRow
-- | Helper function for making migration failed errors
makeMigrationFailedError :: SQLMigration -> SomeException -> IO (Either MigrationError a)
makeMigrationFailedError m = pure . Left . MigrationQueryFailed from to . DT.pack . show
where
from = smFrom m
to = smTo m
executeMigration :: Connection -> SQLMigration -> IO (Either MigrationError ())
executeMigration conn m = catch runQuery (makeMigrationFailedError m)
where
query = Query $ getMigrationQuery $ smQuery m
runQuery = withTransaction conn (execute_ conn query)
>> pure (Right ())
-- | Helper function for making `VersionFetchFailed` `MigrationError`s
makeVersionFetchFailedError :: SomeException -> IO (Either MigrationError a)
makeVersionFetchFailedError = pure . Left . VersionFetchFailed . ("Unexpected version fetch failure: " <>) . DT.pack . show
getDBMigrationVersion :: Connection -> IO (Either MigrationError SQLMigrationVersion)
getDBMigrationVersion c = catch runQuery makeVersionFetchFailedError
where
getVersionQuery = Query "PRAGMA user_version;" -- Happens to return 0 if never set before in SQLite
runQuery = query_ c getVersionQuery
>>= \results -> pure $ case results of
[v, _] -> Right v
[] -> Left (VersionFetchFailed "Version retrieval query returned no results")
instance HasMigratableDB SQLiteTaskStore where
desiredVersion :: SQLiteTaskStore -> IO SQLMigrationVersion
desiredVersion _ = pure (SQLMigrationVersion 1)
availableMigrations :: SQLiteTaskStore -> IO [SQLMigration]
availableMigrations _ = pure $ sort migrations
getCurrentVersion :: SQLiteTaskStore -> IO (Either MigrationError SQLMigrationVersion)
getCurrentVersion = maybe _error _handler . stsConn
where
_error = pure $ Left $ VersionFetchFailed "Fetching current version failed"
_handler = getDBMigrationVersion
migrateTo :: SQLiteTaskStore -> ToSQLMigrationVersion -> IO (Either MigrationError ())
migrateTo s expected = maybe unexpectedMigrationErr tryHandler $ stsConn s
where
unexpectedMigrationErr :: IO (Either MigrationError ())
unexpectedMigrationErr = pure $ Left $ UnexpectedMigrationError "Failed to retrieve DB connection"
convertToUnexpectedError :: SomeException -> IO (Either MigrationError ())
convertToUnexpectedError = const $ pure $ Left $ UnexpectedMigrationError ""
tryHandler :: Connection -> IO (Either MigrationError ())
tryHandler conn = catch (handler conn) convertToUnexpectedError
-- | Recursively (!) runs all migrations by
-- There's quite a bit of wasted effort in here, but it's probably good enough (assuming it finishes :)).
handler :: Connection -> IO (Either MigrationError ())
handler conn = availableMigrations s
-- ^ Get the list of current migrations
>>= \usableMigrations -> getCurrentVersion s
-- ^ Get the current version
>>= rightOrThrow
-- ^ Get the current version
>>= \current -> pure (findNextMigration usableMigrations current)
-- ^ Determine the next migration
>>= \case
-- | We're either done or something went wrong
Nothing -> pure $ if current == expected then Right () else Left NoMigrationPath
-- | Perform a single migration then recur
Just m -> executeMigration conn m
>>= rightOrThrow
>> handler conn
-- | We are assuming monotonically increasing version numbers here, and that there exists at least
-- *one* migration between every version (i.e. v1->v2, v2->v3, etc). This is a bad assumption to make generally,
-- but I'm OK with it since this is generally how most people make migrations in my mind, implementation can change later if need be
findNextMigration ms current = find ((current+1==) . smFrom) ms
......@@ -8,24 +8,25 @@
module Config where
import Data.Monoid
import Control.Exception (Exception, try, throw)
import qualified Filesystem.Path as FP
import qualified Filesystem.Path.CurrentOS as FPCOS
import Control.Applicative ((<|>))
import Control.Exception (Exception, try, throw)
import Control.Monad (join, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Aeson (FromJSON(parseJSON), toJSON, eitherDecode)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Lazy as DBL
import Data.Functor.Identity
import Data.Text.IO as DTI
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid
import Data.Text as DT
import Data.Text.IO as DTI
import GHC.Generics
import Text.Parsec.Error (ParseError)
import Text.Read (readMaybe)
import Text.Toml (parseTomlDoc)
import Util (rightOrThrow)
import qualified Filesystem.Path as FP
import qualified Filesystem.Path.CurrentOS as FPCOS
defaultHost :: Host
defaultHost = "localhost"
......@@ -195,12 +196,6 @@ instance AbsorbPartial CompleteTaskStoreConfig PartialTaskStoreConfig where
absorbPartial :: CompleteTaskStoreConfig -> PartialTaskStoreConfig -> CompleteTaskStoreConfig
absorbPartial c p = TaskStoreConfig { tscDBFilePath = maybe (tscDBFilePath c) Identity (tscDBFilePath p) }
-- | Ensure that an Either resolves to it's Right value, ensure that a
rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(Right v) -> return v
buildConfigWithDefault :: CompleteAppConfig -> [PartialAppConfig] -> CompleteAppConfig
buildConfigWithDefault orig partials = orig `absorbPartial` combinedPartials
where
......
......@@ -180,3 +180,55 @@ data WithID a where
-- then `getRowIDValue id` will produce the appropriate SQLValue for use in a query using the specified SQL library
class HasRowIDValue id sqlvalue where
getRowIDValue :: id -> sqlvalue
-- | Holds a database version (expected to be a monotonically increasing number)
newtype SQLMigrationVersion = SQLMigrationVersion { getMigrationVersion :: Int } deriving (Eq, Show, Read, Ord, Num)
-- | Holds a SQL Query
newtype SQLMigrationQuery = SQLMigrationQuery { getMigrationQuery :: DT.Text } deriving (Eq, Show, Read)
-- | Specifies a `SQLMigrationVersion` that is the source of a migration path
type FromSQLMigrationVersion = SQLMigrationVersion
-- | Specifies a `SQLMigrationVersion` that is the target of a migration path
type ToSQLMigrationVersion = SQLMigrationVersion
data SQLMigration = SQLMigration
{ smFrom :: FromSQLMigrationVersion
-- ^ The starting migration version
, smTo :: ToSQLMigrationVersion
-- ^ The ending migration version
, smQuery :: SQLMigrationQuery
-- ^ Query to execute to perform the migration (also responsible)
} deriving (Eq)
instance Ord SQLMigration where
compare l r = compare (smFrom l) (smFrom r)
data MigrationError = NoMigrationPath -- ^ A path between the migrations could not be found
| MigrationQueryFailed FromSQLMigrationVersion ToSQLMigrationVersion DT.Text -- ^ An individual migration query failed
| VersionFetchFailed DT.Text -- ^ When we've failed to get the current version
| UnexpectedMigrationError DT.Text
deriving (Eq, Show)
instance Exception MigrationError
class TaskStore store => HasMigratableDB store where
-- | Retreive the desired version, this is normally just statically set @ compile time
-- The store isn't strictly necessary but just in case we decide to define the desired version in the database or config or elsewhere
desiredVersion :: store -> IO SQLMigrationVersion
-- | A list of available migrations that will be used by `migrateTo` to create a path from current (via `getCurrentVersion`) to `desiredVersion`
availableMigrations :: store -> IO [SQLMigration]
-- | Retrieve the current version of the database
getCurrentVersion :: store -> IO (Either MigrationError SQLMigrationVersion)
-- | Perform migrations to get to the current version
migrate :: store -> IO (Either MigrationError ())
migrate store = desiredVersion store >>= migrateTo store
-- | Finds and executes a path to the requested ToSQLMigration from
-- Currently when looking through `availableMigrations`, a monotonically increasing version number is assumed,
-- This means paths are made from version to version generally in one version increments (1 --[migrateTo]--> 2 --[migrateTo]-> 3)
migrateTo :: store -> ToSQLMigrationVersion -> IO (Either MigrationError ())
module Util where
import Control.Exception (Exception, throw)
-- | Ensure that an Either resolves to it's Right value
rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(Right v) -> return v
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment