Add a quick n' dirty migration support

package.yaml

@@ -34,6 +34,7 @@ library:
     - system-filepath
     - uuid
     - sqlite-simple
+    - neat-interpolation
 
 executables:
   haskell-restish-todo-exe:

src/Components/TaskStore/Migrations/SQLite.hs

+{-# 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
+               );
+               |]
+     }
+    ]

src/Components/TaskStore/SQLite.hs

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

src/Config.hs

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

src/Types.hs

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

src/Util.hs

+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