Commit 49c7aaa4 authored by MrMan's avatar MrMan

progress implementing insert

parent e66d38db
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
......@@ -10,11 +11,14 @@
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE FlexibleContexts #-}
module Components.EntityStore.SQLite
(SQLiteEntityStore)
where
import Data.Proxy (Proxy)
import Control.Applicative((<|>))
import Components.EntityStore.Migrations.SQLite (migrations)
import Config (CompleteEntityStoreConfig, EntityStoreConfig(..))
......@@ -30,6 +34,7 @@ import Database.SQLite.Simple.FromRow (RowParser)
import Database.SQLite.Simple.ToField (ToField(..))
import Types
import Util (rightOrThrow)
import NeatInterpolation (text)
import qualified Data.Text as DT
data SQLiteEntityStore = SQLiteEntityStore
......@@ -250,15 +255,83 @@ instance Constructable SQLiteEntityStore CompleteEntityStoreConfig EntityStoreEr
connectionFailure :: SomeException -> IO (Either EntityStoreError SQLiteEntityStore)
connectionFailure = pure . Left . ConnectionFailureES . ("Failed to connect to DB: "<>) . DT.pack . show
-- instance EntityStore SQLiteEntityStore where
-- create :: forall entity. SQLiteEntityStore -> Complete entity -> IO (Either EntityStoreError (Complete entity))
-- create = undefined
withActiveConn :: SQLiteEntityStore -> (Connection -> IO (Either EntityStoreError a)) -> IO (Either EntityStoreError a)
withActiveConn store action = maybe disconnectionError action $ stsConn store
-- get :: forall entity. SQLiteEntityStore -> Complete entity -> IO (Either EntityStoreError (Complete entity))
-- get = undefined
ensureUUID :: entity -> IO (Either EntityStoreError (WithID entity))
ensureUUID e = Right . flip UUIDID e <$> nextRandom
-- update :: forall entity. SQLiteEntityStore -> Partial entity -> IO (Either EntityStoreError (Complete entity))
-- update = undefined
insertAndReturnEntity :: forall (entity :: FBounded). Connection -> WithID (Complete entity) -> IO (Either EntityStoreError (WithID (Complete entity)))
insertAndReturnEntity conn (Int64ID _ _) = pure $ Left $ UnexpectedErrorES "insertion with integer based UUIDs is not allowed"
insertAndReturnEntity conn entity@(UUIDID uuid _) = Right <$> insertAndGet
where
insertAndGet = insertEntity conn entity >> getEntityByUUID conn uuid
instance Insertable 'SQL Task where
getInsertInfo :: EntityInsertInfo paradigm
getInsertInfo = undefined -- TODO: define insertion information necessary for a Task
instance Insertable 'SQL e => Insertable 'SQL (WithID e) where
getInsertInfo :: EntityInsertInfo paradigm
getInsertInfo = undefined -- TODO: use the insert info of the underlying thing and add on
data QueryWithParams = QWP Query [NamedParam]
-- delete :: forall entity. SQLiteEntityStore -> Complete entity -> IO (Either EntityStoreError (Complete entity))
-- delete = undefined
buildInsertQuery :: Insertable 'SQL entity => entity -> Maybe QueryWithParams
buildInsertQuery e = case getInsertInfo e of
(SQLEII tblName cols valueGetters) -> Just $ makeInsertQuery tblName cols valueGetter e
_ -> Nothing
makeInsertQuery :: Insertable 'SQL entity => TableName -> SQLColumnNames -> SQLValueGetters entity -> entity -> QueryWithParams
makeInsertQuery (TN tbl) (SQLCN colNames) (SQLVG valueGetters) entity = QWP query params
where
queryText = Query $ [text| INSERT INTO $tbl ( $columnPhrase ) VALUES ( $valueQs ) |]
columnPhrase = undefined
valueQs = undefined
params = undefined
insertEntity :: Insertable 'SQL entity => Connection -> WithID entity -> IO (Either EntityStoreError ())
insertEntity conn e = case buildInsertQuery e of
Nothing -> pure $ Left $ UnexpectedErrorES "Failed to generate insert query"
Just (QWP query params) -> Right <$> execute conn query params
getEntityByUUID :: Insertable 'SQL entity => Connection -> UUID -> IO (Either EntityStoreError (WithID entity))
getEntityByUUID conn uuid = maybe invalidEntityError doQuery tableName
where
invalidEntityError :: IO (Either EntityStoreError (WithID entity))
invalidEntityError = pure $ Left $ UnexpectedErrorES "Failed to generate entity name"
tableName :: Maybe TableName
tableName = case getInsertInfo (undefined :: Proxy entity) of
(SQLEII tblName _ _) -> Just tblName
_ -> Nothing
doQuery tbl = pure (makeSelectByUUIDQuery tbl uuid)
>>= \(QWP q p) -> query conn q p
makeSelectByUUIDQuery :: TableName -> UUID -> QueryWithParams
makeSelectByUUIDQuery (TN tbl) uuid = QWP query ["uuid" := uuid]
where
uuidTxt = toText uuid
query = Query $ [text| SELECT * FROM $tbl WHERE uuid = $uuidTxt |]
-- | Generalized typeclass for entity storage.
instance EntityStore 'SQL SQLiteEntityStore where
create store (Validated entity) = withActiveConn store _work
where
_work c = ensureUUID entity
>>= rightOrThrow
-- | Generate an insert query for the `WithID entity`
>>= insertAndReturnEntity c
-- | Get an entity by ID
get :: forall entity. SQLiteEntityStore -> Complete entity -> IO (Either EntityStoreError (Complete entity))
get = undefined
-- | Update an existing entity by ID
update :: forall entity. SQLiteEntityStore -> Partial entity -> IO (Either EntityStoreError (Complete entity))
update = undefined
-- | Delete an entity by ID
delete :: forall entity. SQLiteEntityStore -> Complete entity -> IO (Either EntityStoreError (Complete entity))
delete = undefined
......@@ -274,6 +274,8 @@ data EntityStoreError = NoSuchEntityES EntityID
| ConnectionFailureES DT.Text
deriving (Eq, Show, Read)
instance Exception EntityStoreError
newtype TableName = TN { getTableName :: DT.Text } deriving (Eq, Show, Read)
newtype SQLColumnNames = SQLCN { getColumnNames :: [DT.Text] } deriving (Eq, Show, Read)
newtype SQLValueGetters entity = SQLVG { getValueGetters :: [entity -> Maybe SQLData] }
......@@ -290,8 +292,8 @@ class Insertable (paradigm :: DBParadigm) entity where
getInsertInfo :: EntityInsertInfo paradigm
data EntityInsertInfo (p :: DBParadigm) where
EII_SQL :: TableName -> SQLColumnNames -> SQLValueGetters entity -> EntityInsertInfo 'SQL
EII_DocumentStore :: TableName -> EntityInsertInfo 'DocumentStore
SQLEII :: TableName -> SQLColumnNames -> SQLValueGetters entity -> EntityInsertInfo 'SQL
DocumentStoreEII :: TableName -> EntityInsertInfo 'DocumentStore
-- | Generalized typeclass for entity storage.
class EntityStore (paradigm :: DBParadigm) store where
......@@ -299,7 +301,7 @@ class EntityStore (paradigm :: DBParadigm) store where
Insertable paradigm entity =>
store
-> Validated (Complete entity)
-> IO (Either EntityStoreError (Complete entity))
-> IO (Either EntityStoreError (WithID (Complete entity)))
-- | Get an entity by ID
get :: 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