Commit 8aac0faa authored by MrMan's avatar MrMan

Theoretically working persistTask has been written

parent b6f6c230
......@@ -33,6 +33,7 @@ library:
- bytestring
- system-filepath
- uuid
- sqlite-simple
executables:
haskell-restish-todo-exe:
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE InstanceSigs #-}
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
data SQLiteTaskStore = SQLiteTaskStore
{ stsCfg :: CompleteTaskStoreConfig
, stsConn :: Maybe Connection
}
-- | SQLiteTaskStore component
-- start & stop are no-ops since this component does little more than bundle together some functionality (for now)
instance Component SQLiteTaskStore where
start :: SQLiteTaskStore -> IO ()
start c = pure ()
stop :: SQLiteTaskStore -> IO ()
stop c = pure ()
-- | A validated object's ToRow is just the same as it's contained object's ToRow
-- this can probably be auto-derived but let's write it manually for now.
instance ToRow a => ToRow (Validated a) where
toRow = toRow . getValidatedObj
-- | UUIDs need to be converted to text before they can turn into fields
instance ToField UUID where
toField = SQLText . toText
instance ToField TaskState where
toField = SQLText . DT.pack . show
instance ToField TaskName where
toField = toField
instance FromField TaskName where
fromField = fromField
instance FromField TaskDesc where
fromField = fromField
instance ToField TaskDesc where
toField = toField
instance ToField a => ToField (Identity a) where
toField = toField
-- | ToRow (WithID a) can be generically performed if we just always put the ID first
-- this introduces the requirement that ids should always come first.
instance ToRow a => ToRow (WithID a) where
toRow (UUIDID id_ obj) = [toField id_] <> toRow obj
toRow (Int64ID id_ obj) = [toField id_] <> toRow obj
instance ToField state => ToRow (FullySpecifiedTask state) where
toRow t = toRow (tName t, tDescription t, tState t)
instance FromRow a => FromRow (WithID a) where
-- While normally FromRow instances are written like: `ValueConstructor <$> field <*> field ...`
-- I can't figure out how to cleanly construct and build the partial result using applicatives
-- since I need to pull out the ID, set it aside, then work on the rest, *then* use the right GADT constructor for WithId a
fromRow = field -- pull out first field (we assume it's the ID)
>>= \idSQLData -> fromRow -- parse the rest of the fields into an `a` value
>>= chooseCtor idSQLData -- Given the SQLData, use the right GADT constructor on the id + the `a` value
where
chooseCtor sqldata = case sqldata of
(SQLText txt) -> \obj -> case fromText txt of
Nothing -> throw $ ConversionFailed (show sqldata) "Text" "Invalid UUID failed fromText conversion"
Just uuid -> pure $ UUIDID uuid obj
(SQLInteger int) -> pure . Int64ID (fromIntegral int)
_ -> throw $ ConversionFailed (show sqldata) "???" "Unrecognized contents in ID field (no valid WithID GADT constructor)"
instance FromRow a => FromRow (Identity a) where
fromRow = fromRow
instance FromField a => FromField (Identity a) where
fromField = fromField
instance FromField TaskState where
fromField f = case fieldData f of
SQLText txt -> pure $ read $ DT.unpack txt
fd -> returnError ConversionFailed f "Unexpected TaskState field type"
instance (FromField state) => FromRow (FullySpecifiedTask state) where
fromRow = Task <$> field <*> field <*> field
instance (FromField state) => FromRow (PartialTask state) where
fromRow = Task <$> field <*> field <*> field
disconnectionError :: IO (Either TaskStoreError a)
disconnectionError = pure $ Left $ Disconnected "Store is disconnected"
makeGenericInsertError :: SomeException -> IO (Either TaskStoreError a)
makeGenericInsertError = pure . Left . UnexpectedError . ("INSERT command failed: " <>) . DT.pack . show
saveAndReturnTask :: ToField state => Connection -> WithID (FullySpecifiedTask state) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
saveAndReturnTask c t = catch doInsert makeGenericInsertError
where
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
where
-- | _handler does all the real work of persisting a task
_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
getTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
getTask = undefined
updateTask :: c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask = undefined
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask = undefined
......@@ -5,69 +5,21 @@
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
module Types where
import qualified Data.Text as DT
import Config (CompleteTaskStoreConfig)
import Control.Exception (throw, Exception)
import Data.Either (isRight)
import Data.Maybe (isJust, fromJust)
import Data.Functor.Identity (Identity(..))
import Data.UUID (UUID)
----------------
-- First Stab --
----------------
-- data TaskState = NotStarted | InProgress | Completed
-- data Task= Task { tName :: Text
-- , tDescription :: Text
-- , tState :: TaskState
-- }
---------------------
-- More Type Power --
---------------------
-- data TaskState = NotStarted
-- | InProgress
-- | Completed deriving (Enum, Read, Show)
-- data Task f = Task { tName :: f Text
-- , tDescription :: f Text
-- , tState :: f TaskState
-- }
-- type Complete f = f Identity
-- type Partial f = f Maybe
---------------
-- Too Much? --
---------------
-- data Completed
-- data InProgress
-- data NotStarted
-- data TaskState = Completed | InProgress | NotStarted
-- data Task f state = Task { tName :: f Text
-- , tDescription :: f Text
-- , tState :: f state
-- }
-- type Complete f = f Identity
-- type Partial f = f Maybe
-- type CompleteTask f = f Identity Completed
-- type IncompletePartialTask f = f Maybe InProgress
-- type IncompleteTask f = f Identity InProgress
-- type NotStartedPartialTask f = f Maybe NotStarted
-- type NotStartedTask f = f Identity NotStarted
-------------------------------------------
-- Definitely too much, but it compiles? --
-------------------------------------------
import Data.Int (Int64)
import Data.List (uncons)
import Data.Maybe (isJust, fromJust)
import Data.Monoid ((<>))
import Data.UUID (UUID, toText, fromText)
import qualified Data.Text as DT
-- Individual separate types for tasks to enable specifying them as part of (Task f state)
data Finished = FinishedState deriving (Eq, Read, Show)
......@@ -123,7 +75,7 @@ newtype FieldName = FieldName { getFieldName :: DT.Text } deriving (Eq, Show, Re
data ValidationError = InvalidField FieldName
| MissingField FieldName deriving (Eq, Show, Read)
data Validated t = Validated t
newtype Validated t = Validated { getValidatedObj :: t }
type ValidationCheck t = t -> Maybe ValidationError
......@@ -159,13 +111,16 @@ fsTaskName = DT.strip . getTName . runIdentity . tName
fsTaskDesc :: FullySpecifiedTask state -> DT.Text
fsTaskDesc = DT.strip . getTDesc . runIdentity . tDescription
fsTaskState :: FullySpecifiedTask TaskState -> TaskState
fsTaskState = runIdentity . tState
instance Validatable (FullySpecifiedTask state) where
validationChecks = [checkName, checkDescription]
where
checkName :: (FullySpecifiedTask state) -> Maybe ValidationError
checkName :: FullySpecifiedTask state -> Maybe ValidationError
checkName t = if DT.null (fsTaskName t) then Just (InvalidField taskNameField) else Nothing
checkDescription :: (FullySpecifiedTask state) -> Maybe ValidationError
checkDescription :: FullySpecifiedTask state -> Maybe ValidationError
checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing
pTaskName :: PartialTask state -> Maybe DT.Text
......@@ -177,13 +132,13 @@ pTaskDesc = (DT.strip . getTDesc <$>) . tDescription
instance Validatable (PartialTask state) where
validationChecks = [checkName, checkDescription]
where
checkName :: (PartialTask state) -> Maybe ValidationError
checkName :: PartialTask state -> Maybe ValidationError
checkName = maybe (Just (MissingField taskNameField)) notEmptyIfPresent . pTaskName
where
notEmptyIfPresent :: DT.Text -> Maybe ValidationError
notEmptyIfPresent v = if DT.null v then Just (InvalidField taskNameField) else Nothing
checkDescription :: (PartialTask state) -> Maybe ValidationError
checkDescription :: PartialTask state -> Maybe ValidationError
checkDescription = maybe (Just (MissingField taskDescField)) notEmptyIfPresent . pTaskDesc
where
notEmptyIfPresent :: DT.Text -> Maybe ValidationError
......@@ -194,65 +149,31 @@ instance Validatable (PartialTask state) where
----------------
class Component c where
start :: c -> IO ()
stop :: c -> IO ()
start :: c -> IO ()
stop :: c -> IO ()
class Component c => Constructable c cfg err where
construct :: cfg -> IO (Either err c)
data TaskStoreError = NoSuchTask TaskID
| UnexpectedError DT.Text
| Disconnected DT.Text
deriving (Eq, Show, Read)
instance Exception TaskStoreError
newtype TaskID = TaskID { getTaskID :: Int } deriving (Eq, Show, Read)
class Component c => TaskStore c where
persistTask :: c -> Validated (FullySpecifiedTask state) -> Either TaskStoreError (WithID (FullySpecifiedTask state))
completeTask :: c -> TaskID -> Either TaskStoreError (WithID CompletedTask)
getTask :: c -> TaskID -> Either TaskStoreError (WithID (FullySpecifiedTask state))
updateTask :: c -> TaskID -> PartialTask state -> Either TaskStoreError (WithID (FullySpecifiedTask state))
deleteTask :: c -> TaskID -> Either TaskStoreError (WithID (FullySpecifiedTask state))
--------------
-- Metadata --
--------------
-- -- The basic approach to modeling a thing+id
-- WithId a = { id :: Int
-- , obj :: a
-- }
-- -- But what if I chose a to id with UUIDs instead?
-- WithId a = { id :: UUID
-- , obj :: a
-- }
-- -- What if I allowed both to happen? SQLite does have rowids available by default, in the simplest way I can think of:
-- data WithId a = { id :: Maybe Int
-- , uuid :: Maybe UUID
-- , obj :: a
-- }
-- -- Hmnn, what if we get a little fancier, and unify (a disjoint union, anyone?) both possibilities?
-- newtype NumericID = { getNumericId :: Int } deriving (Eq, Show, Read)
-- data TaskID = NumericID
-- | UUID deriving (Eq, Show, Read)
-- data WithId a = { id :: TaskID
-- , obj :: a
-- }
-- -- Is there any benefit from getting *even* fancier? Is there a benefit from being *super explicit* about what kind of ID is present?
-- data WithId idt a = { id :: idt
-- , obj :: a
-- }
-- type WithNumericId = WithID Int a;
-- type WithUUID = WithID UUID a;
-- type WithAllIds = WithID (Int, UUID) a;
persistTask :: c -> Validated (FullySpecifiedTask TaskState) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask TaskState)))
completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask))
getTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask :: c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask :: c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
data WithID a where
UUIDID :: UUID -> a -> WithID a
IntID :: Int -> a -> WithID a
Int64ID :: Int64 -> a -> WithID a
-- | A typeclass consisting of types that can produce an ID usable by a SQL library to represent itself.
-- for example, if SQL library a can take `Int` for numeric IDs as well as `String`s for UUIDs, and id is an abstraction over both forms of ID,
......
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