Commit 8ba324ce authored by MrMan's avatar MrMan

Start scaffolding code for EntityStore

parent 73d643c0
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Components.EntityStore.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,
state TEXT NOT NULL
);
|]
}
]
This diff is collapsed.
......@@ -37,6 +37,9 @@ defaultPort = 5000
defaultTaskStoreFilePath :: FilePath
defaultTaskStoreFilePath = ":memory:"
defaultEntityStoreFilePath :: FilePath
defaultEntityStoreFilePath = ":memory:"
type Host = String
type Port = Integer
newtype ProcessEnvironment = ProcessEnvironment {getProcessEnv :: [(String, String)]} deriving (Eq)
......@@ -55,6 +58,7 @@ data AppConfig f = AppConfig
{ host :: f Host
, port :: f Port
, taskStoreConfig :: f (TaskStoreConfig f)
, entityStoreConfig :: f (EntityStoreConfig f)
}
type CompleteAppConfig = AppConfig Identity
......@@ -73,21 +77,23 @@ instance Semigroup CompleteAppConfig where
a <> b = b
instance Monoid CompleteAppConfig where
mempty = AppConfig (Identity defaultHost) (Identity defaultPort) (Identity mempty)
mempty = AppConfig (Identity defaultHost) (Identity defaultPort) (Identity mempty) (Identity mempty)
instance Semigroup PartialAppConfig where
a <> b = AppConfig { host=resolveMaybes host
, port=resolveMaybes port
, taskStoreConfig=resolveMaybes taskStoreConfig
, entityStoreConfig=resolveMaybes entityStoreConfig
}
where
resolveMaybes :: (PartialAppConfig -> Maybe a) -> Maybe a
resolveMaybes getter = getter b <|> getter a
instance Monoid PartialAppConfig where
mempty = AppConfig Nothing Nothing Nothing
mempty = AppConfig Nothing Nothing Nothing Nothing
newtype TaskStoreConfig f = TaskStoreConfig { tscDBFilePath :: f FilePath }
newtype EntityStoreConfig f = EntityStoreConfig { escDBFilePath :: f FilePath }
type CompleteTaskStoreConfig = TaskStoreConfig Identity
deriving instance Generic CompleteTaskStoreConfig
......@@ -101,6 +107,18 @@ deriving instance Eq PartialTaskStoreConfig
deriving instance Show PartialTaskStoreConfig
deriving instance FromJSON PartialTaskStoreConfig
type CompleteEntityStoreConfig = EntityStoreConfig Identity
deriving instance Generic CompleteEntityStoreConfig
deriving instance Eq CompleteEntityStoreConfig
deriving instance Show CompleteEntityStoreConfig
deriving instance FromJSON CompleteEntityStoreConfig
type PartialEntityStoreConfig = EntityStoreConfig Maybe
deriving instance Generic PartialEntityStoreConfig
deriving instance Eq PartialEntityStoreConfig
deriving instance Show PartialEntityStoreConfig
deriving instance FromJSON PartialEntityStoreConfig
instance Semigroup CompleteTaskStoreConfig where
a <> b = b
......@@ -116,6 +134,21 @@ instance Semigroup PartialTaskStoreConfig where
instance Monoid PartialTaskStoreConfig where
mempty = TaskStoreConfig Nothing
instance Semigroup CompleteEntityStoreConfig where
a <> b = b
instance Monoid CompleteEntityStoreConfig where
mempty = EntityStoreConfig (Identity defaultEntityStoreFilePath)
instance Semigroup PartialEntityStoreConfig where
a <> b = EntityStoreConfig { escDBFilePath=resolveMaybes escDBFilePath }
where
resolveMaybes :: (PartialEntityStoreConfig -> Maybe a) -> Maybe a
resolveMaybes getter = getter a <|> getter b
instance Monoid PartialEntityStoreConfig where
mempty = EntityStoreConfig Nothing
----------
-- JSON --
----------
......@@ -161,6 +194,7 @@ instance FromENV PartialAppConfig where
fromENV pEnv = AppConfig { host=prop "TODO_HOST"
, port=readMaybe =<< prop "TODO_PORT"
, taskStoreConfig=Just $ fromENV pEnv
, entityStoreConfig=Just $ fromENV pEnv
}
where
prop :: String -> Maybe String
......@@ -172,6 +206,12 @@ instance FromENV PartialTaskStoreConfig where
prop :: String -> Maybe String
prop = flip lookup (getProcessEnv pEnv)
instance FromENV PartialEntityStoreConfig where
fromENV pEnv = EntityStoreConfig { escDBFilePath=prop "ENTITY_STORE_FILE_PATH" }
where
prop :: String -> Maybe String
prop = flip lookup (getProcessEnv pEnv)
-- | The class of configurations that can absorb partials of themselves to maintain a whole
class AbsorbPartial complete partial where
absorbPartial :: complete -> partial -> complete
......@@ -181,15 +221,23 @@ instance AbsorbPartial CompleteAppConfig PartialAppConfig where
absorbPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
, taskStoreConfig = Identity $ absorbPartial tsc maybeTSC
, entityStoreConfig = Identity $ absorbPartial esc maybeESC
}
where
tsc = runIdentity $ taskStoreConfig c
maybeTSC = fromMaybe mempty $ taskStoreConfig p
esc = runIdentity $ entityStoreConfig c
maybeESC = fromMaybe mempty $ entityStoreConfig p
instance AbsorbPartial CompleteTaskStoreConfig PartialTaskStoreConfig where
absorbPartial :: CompleteTaskStoreConfig -> PartialTaskStoreConfig -> CompleteTaskStoreConfig
absorbPartial c p = TaskStoreConfig { tscDBFilePath = maybe (tscDBFilePath c) Identity (tscDBFilePath p) }
instance AbsorbPartial CompleteEntityStoreConfig PartialEntityStoreConfig where
absorbPartial :: CompleteEntityStoreConfig -> PartialEntityStoreConfig -> CompleteEntityStoreConfig
absorbPartial c p = EntityStoreConfig { escDBFilePath = maybe (escDBFilePath c) Identity (escDBFilePath p) }
buildConfigWithDefault :: CompleteAppConfig -> [PartialAppConfig] -> CompleteAppConfig
buildConfigWithDefault orig partials = orig `absorbPartial` combinedPartials
where
......@@ -208,6 +256,10 @@ defaultCompleteAppConfig = mempty
defaultCompleteTaskStoreConfig :: CompleteTaskStoreConfig
defaultCompleteTaskStoreConfig = mempty
-- | The default configuration *is* a fully specified complete app config @ mempty state
defaultCompleteEntityStoreConfig :: CompleteEntityStoreConfig
defaultCompleteEntityStoreConfig = mempty
-- | The default partially specified configuration is mempty
defaultPartialAppConfig :: PartialAppConfig
defaultPartialAppConfig = mempty
......
......@@ -71,6 +71,9 @@ type NotStartedPartialTask = Task Maybe 'NotStarted
-- Not started, completely specified tasks
type NotStartedTask = Task Identity 'NotStarted
type Partial a = a Maybe
type Complete a = a Identity
----------------
-- Validation --
----------------
......@@ -241,7 +244,7 @@ data MigrationError = NoMigrationPath -- ^ A path between the migrations could n
instance Exception MigrationError
class TaskStore store => HasMigratableDB store where
class 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
......@@ -260,3 +263,25 @@ class TaskStore store => HasMigratableDB store where
-- 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 ())
type EntityID = Either UUID Int
data EntityStoreError = NoSuchEntityES EntityID
| UnexpectedErrorES DT.Text
| DisconnectedES DT.Text
| ConnectionFailureES DT.Text
deriving (Eq, Show, Read)
-- | Generalized typeclass for entity storage.
class EntityStore store where
-- | Create an entity
create :: forall entity. store -> Complete entity -> IO (Either EntityStoreError (Complete entity))
-- | Get an entity by ID
get :: forall entity. store -> Complete entity -> IO (Either EntityStoreError (Complete entity))
-- | Update an existing entity by ID
update :: forall entity. store -> Partial entity -> IO (Either EntityStoreError (Complete entity))
-- | Delete an entity by ID
delete :: forall entity. store -> Complete entity -> IO (Either EntityStoreError (Complete entity))
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