DDG search drop in powered by ddg.patdryburgh.com
+
tl;dr - In this post I work my way through sprinkling in some DataKinds (shoutout to dcasto’s excellent primer), abstracting the TaskStore into an EntityStore, and adding servant to actually expose this EntityStore via an well-typed TodoAPI over HTTP. We actually get to a running server in this post, finally!
As always, I got some more excellent feedback from the r/haskell community, and I've added some extra sections and notes based on the feedback.
This is a multi part blog post with the following sections:
In this post we’re going to get into the rest of the fucking owl TaskStore and servant-powered API. The first few sections of this post were added to address and explore some good feedback from part 2.
To sum up where we are so far; we have a configurable, type-reinforced and abstracted (type-level effort is as always denoted by the strong typing tophat 💪 🎩 ), lightly DDD (onion model) architected, minimally tested program with a main that does nothing. In this post we’re going to get to adding just a bit more abstraction, and finally start wrapping our abstractions with a servant outer layer which will serve HTTP traffic from the outside world.
One thing that was brought to my attention after the last post was the potential usefulness of the DataKinds extension. If I were to give you a two second introduction to what a “kind” is, I would say it’s the “type of a type”. A slightly more nuanced explanation might be that it’s the way to distinguish Int from Maybe a at the type level.
We know Int is a type but what about Maybe (as in Maybe a)? It’s got a type in it’s definition but Maybe itself requires some other type (the a) that it doesn’t know yet – there’s something like a resolving step that has to happen before it’s use, kind of like how functions require some input before they can produce output. Intuition tells us that Maybe is likely a type as well, because it is created with the data type constructor just like other types, but it’s different.
The Haskell syntax for “thing that is a type” is *, but it’s pronounced “kind”, and we generally say that a type “has” a kind, or “is of kind” t. So Int “has” kind *, and Maybe has kind * -> *. The earlier intuition about Maybe a being a type is right, it’s a type, but it has a different kind from other types Int. Maybe is a kind of type that depends on another type – a type that needs another type to be itself.
Recently Haskell has also evolved to get rid of the likely-too-terse * in favor of Type. This means the kind of Int is Type, the kind of Maybe a is Type -> Type. It might be a bit surprising, but the kind of a fully-realized Maybe (like Maybe Int) is of kind Type. If you’re surprised by Maybe Int’s kind being Type, think about how functions work – a function with A -> B takes an A and produces a B when all the required arguments (only one in this case) are present. In the same vein you can think of Maybe a as a type that needs another one to complete it, and once it has one (in the case of Maybe Int), it’s the same kind as the other fully-resolved types like Int or String.
(UPDATE 12/14/18) NOTE The informal description above of types/kinds was greatly improved thanks to /u/chshersh who contributed feedback in the reddit thread. Back to our reguarly scheduled programming.
I’m neither mathematician, category theorist, or Haskell pro so if you want to learn about Kinds I’d recommend you read the excellent primer written by dcastro. Don’t worry, this post will be here when you get back.
Reading the dcastro’s primer is what enabled me to go past thinking I understood kinds to actually using them in my application – using the DataKinds extension can help clean up the code we wrote to distinguish between tasks in different states. The code originally looked like this:
-- Individual separate types for tasks to enable specifying them as part of (Task f state)
data Finished = FinishedState deriving (Eq, Read, Show)
data InProgress = InProgressState deriving (Eq, Read, Show)
data NotStarted = NotStartedState deriving (Eq, Read, Show)
-- Task state for abstracting over TaskState
data TaskState = Finished
| InProgress
| NotStarted deriving (Eq, Enum, Read, Show)
-- Newtypes preventing careless
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show)
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show)
-- The beefy task class
data Task f state = Task { tName :: f TaskName
, tDescription :: f TaskDesc
, tState :: f state
}
-- Completed tasks
type CompletedTask = Task Identity Finished
deriving instance Eq CompletedTask
deriving instance Show CompletedTask
-- ... more aliases like CompletedTask --
If you’ve digested the excellent kind system primer post I referred to earlier, you’d notice that I’m actually doing what it’s describing but manually – I’m “lifting” the term level values (TaskState’s Finished, InProgress, NotStarted value constructors) to types (data Finished, data InProgress, etc) and then using them. DataKinds does this promotion for me, so merely having the TaskState definition as it is now will make a shadow version of TaskState into a type of kind (Type -> Type, keep in mind that Type is just a synonym for *).
As TaskState :: Type gets lifted into TaskState :: Type -> Type, constructors like Finished which were terms/values of the original type get made into types themselves like Finished :: Type. Normally I’d have to use 'Finished to denote the lifted version, but usually GHC can figure out which one you mean (since the places that take types/kinds are usually very different from places that take values).
Since they’re already named the same, what DataKinds lets me do is remove the initial 3 data declarations as long as I be a little bit more specific about state:
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE DataKinds #-}
-- Task state for abstracting over TaskState
data TaskState = Finished
| InProgress
| NotStarted deriving (Eq, Enum, Read, Show)
-- Newtypes preventing careless
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show)
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show)
-- The beefy task class
data Task f (state :: TaskState) = Task { tName :: f TaskName
, tDescription :: f TaskDesc
, tState :: f state
}
Of course, things aren’t that easy, because while I was figuring my way around this, I ran into some errors/lack of intuition around the mechanics of DataKinds, I got this error:
/home/mrman/Projects/foss/haskell-restish-todo/src/Types.hs:39:61: error:
• Expected a type, but ‘state’ has kind ‘TaskState’
• In the first argument of ‘f’, namely ‘state’
In the type ‘f state’
In the definition of data constructor ‘Task’
|
39 | , tState :: f state
| ^^^^^
GHCI was having a problem with the f state portion – f is a kind of Type -> Type (ex. Maybe), and I originally declared state to be of the kind TaskState. That means the fully expanded type of f state would be Type -> (Type -> Type)… Which doesn’t make sense, since it needs more types to fulfill it than I have available. For example f TaskName is fine because the f (which is of kind Type -> Type) “uses up” the TaskName that I pass it, so it resolves to a normal Type.
I needed to find a way to use or store the type level TaskState and after scratching my head for a while, I realized that the parametrization is coming from inside the house happening at the type level itself! I no longer need to store the state in the object itself at all:
-- The beefy task class
data Task f (state :: TaskState) = Task { tName :: f TaskName
, tDescription :: f TaskDesc
}
-- Completed tasks
type CompletedTask = Task Identity 'Finished
deriving instance Eq CompletedTask
deriving instance Show CompletedTask
-- ... other similar aliases
This lead to some changes in the other parts of the code, particularly in places that used TaskState because I wasn’t sure which state the Task would be in. For example the TaskStore typeclass:
{-# LANGUAGE ExplicitForAll #-}
-- ... other code
class Component c => TaskStore c where
persistTask :: forall (state :: TaskState). c -> Validated (FullySpecifiedTask state) -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
completeTask :: c -> TaskID -> IO (Either TaskStoreError (WithID CompletedTask))
getTask :: forall (state :: TaskState). c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
updateTask :: forall (state :: TaskState). c -> TaskID -> PartialTask state -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
deleteTask :: forall (state :: TaskState). c -> TaskID -> IO (Either TaskStoreError (WithID (FullySpecifiedTask state)))
-- ... other code
I turned on the ExplicitForAll extension so I could be explicit about the fact that state could be any valid type in the Kind TaskState. After fixing stuff like this I had to go into SQLite.hs where some of the implementation stuff was and make some fixes, check the code for this section below to see everything I had to change. In particular the instance for ToRow for FullySpecifiedTask f state (i.e. Task Identity state) was troublesome:
-- **NOTE** Neither of the approaches below work!
-- | The approach doesn't work because pattern matching doesn't work like this (at least right now)
-- from what I understand, it's beacuse FullySpecifiedTask 'Finished and FullySpecifiedTask 'NotStarted become the *exact same type*
instance forall (state :: TaskState). ToRow (FullySpecifiedTask state) where
toRow (t :: FullySpecifiedTask 'Finished) = toRow (tName t, tDescription t, "Finished")
toRow (t :: FullySpecifiedTask 'NotStarted) = toRow (tName t, tDescription t, "NotStarted")
toRow (t :: FullySpecifiedTask 'InProgress) = toRow (tName t, tDescription t, "InProgress")
-- | The singular ToRow instances below don't work either, because I need to be able to abstract over state in ToRow (for when I save a task whose state I don't know).
-- For example persistTask doesn't know *which* state came in, and it depends on `FullySpecifiedTask state` having a `FromRow` instance.
-- Maybe if GHC could automatically derive the fact that since every promoted type in kind `TaskState` is covered then it's OK, but I don't know if that's even possible, I'm in over my head.
instance ToRow (FullySpecifiedTask 'Finished) where
toRow t = toRow (tName t, tDescription t, "Finished" :: String)
instance ToRow (FullySpecifiedTask 'NotStarted) where
toRow t = toRow (tName t, tDescription t, "NotStarted" :: String)
instance ToRow (FullySpecifiedTask 'InProgress) where
toRow t = toRow (tName t, tDescription t, "InProgress" :: String)
After a bit of searching on the internet I found an SO post introducing GADTs as a solution to this problem. We’ve used GADTs in the past and while it ocurred to me to use them here I thought that I needed to GADT-ize the TaskState class, but that didn’t make sense to me. Reading the SO post encouraged me to consider GADT-izing Task itself:
{-# LANGUAGE GADTs #-}
data Task f (state :: TaskState) where
FinishedT :: f TaskName -> f TaskDesc -> Task f 'Finished
InProgressT :: f TaskName -> f TaskDesc -> Task f 'InProgress
NotStartedT :: f TaskName -> f TaskDesc -> Task f 'NotStarted
We’re doing all this so we can properly distinguish between a Task 'Finished and a Task 'NotStarted, for the purpose of clarity in our code and when writing ToRow instances in SQLite.hs. The GADT-izing of Task prompted some churn in various functions like the following:
-- | Helper function to access task name for fully specified task
fsTaskName :: FullySpecifiedTask state -> DT.Text
fsTaskName (FinishedT (Identity name) _) = DT.strip $ getTName name
fsTaskName (InProgressT (Identity name) _) = DT.strip $ getTName name
fsTaskName (NotStartedT (Identity name) _) = DT.strip $ getTName name
After dealing with all the rippling changes to functions like fsTaskName (reproduced above), it was time to return to SQLite.hs and slay the dragons there. The ToRow instance for FullySpecifiedTask state was pretty trivial, thanks to the GADT:
instance forall (state :: TaskState). ToRow (FullySpecifiedTask state) where
toRow t@(FinishedT name desc) = toRow (name, desc, showState t)
toRow t@(InProgressT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
toRow t@(NotStartedT (Identity name) (Identity desc)) = toRow (name, desc, showState t)
-- `showState` is defined in Types.hs
showState :: forall (state :: TaskState) (f :: Type -> Type). Task f state -> String
showState (FinishedT _ _) = "Finished"
showState (InProgressT _ _) = "InProgress"
showState (NotStartedT _ _) = "NotStarted"
My relief at how the ToRow instance (above) basically wrote itself was short-lived because FromRow required far more thought/experimentation. The disconnect is that when we pull a value from the database, we don’t know what the database has stored in the state column – we don’t know the actual state of the Task we’re about to translate. Here’s the code I thought should work:
instance forall (state :: TaskState). FromRow (FullySpecifiedTask state) where
-- The code that I expected would work:
-- This *doesn't* work because GHC can't unify (FinishedT name desc), (InProgressT name desc) and (NotStarted name desc)
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "Finished") -> pure (FinishedT name desc)
(SQLText "InProgress") -> pure (InProgressT name desc)
(SQLText "NotStarted") -> pure (NotStartedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
I thought this would work since Task was defined as a GADT, assuming that the results of constructors FinishedT ..., InProgressT ..., NotStartedT ... would produce the same “constructor”. This code doesn’t compile with the following errors:
/home/mrman/Projects/foss/haskell-restish-todo/src/Components/TaskStore/SQLite.hs:127:45: error:
• Couldn't match type ‘'InProgress’ with ‘'Finished’
Expected type: RowParser (Task Identity 'Finished)
Actual type: RowParser (Task Identity 'InProgress)
• In the expression: pure (InProgressT name desc)
In a case alternative:
(SQLText "InProgress") -> pure (InProgressT name desc)
In the second argument of ‘(>>=)’, namely
‘\case
(SQLText "Finished") -> pure (FinishedT name desc)
(SQLText "InProgress") -> pure (InProgressT name desc)
(SQLText "NotStarted") -> pure (NotStartedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")’
|
127 | (SQLText "InProgress") -> pure (InProgressT name desc)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
/home/mrman/Projects/foss/haskell-restish-todo/src/Components/TaskStore/SQLite.hs:128:45: error:
• Couldn't match type ‘'NotStarted’ with ‘'Finished’
Expected type: RowParser (Task Identity 'Finished)
Actual type: RowParser (Task Identity 'NotStarted)
• In the expression: pure (NotStartedT name desc)
In a case alternative:
(SQLText "NotStarted") -> pure (NotStartedT name desc)
In the second argument of ‘(>>=)’, namely
‘\case
(SQLText "Finished") -> pure (FinishedT name desc)
(SQLText "InProgress") -> pure (InProgressT name desc)
(SQLText "NotStarted") -> pure (NotStartedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")’
|
128 | (SQLText "NotStarted") -> pure (NotStartedT name desc)
| ^^^^^^^^^^^^^^^^^^^^^^^^^^^^
I interpreted these errors to mean that when GHC saw FinishedT, it resolved state to 'Finished. This meant that when InProgressT and NotStartedT were used in the other case branches, what they produce Task f 'InProgress and Task f 'NotStarted (f is Identity since we’re dealing with a FullySpecifiedTask) do not match.
My next thought was that maybe what I needed to do was compose the different RowParsers for different Task f states:
instance forall (state :: TaskState). FromRow (FullySpecifiedTask state) where
-- Magic ?????? GHC seems to be able to figure out that no matter what type the `state` is it will pick the right FromRow instance?
-- I thought I would have to combine the parsers of individual types and make them fail individually i.e.
-- (fromRow :: RowParser (FullySpecifiedTask ')) <|> (fromRow :: RowParser (FullySpecifiedTask 'InProgress)) <|> ...
-- This isn't supposed to work...
fromRow = (fromRow :: RowParser (FullySpecifiedTask state))
instance FromRow (FullySpecifiedTask 'Finished) where
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "Finished") -> pure (FinishedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
instance FromRow (FullySpecifiedTask 'InProgress) where
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "InProgress") -> pure (InProgressT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
instance FromRow (FullySpecifiedTask 'NotStarted) where
fromRow = field
>>= \name -> field
>>= \desc -> field
>>= \case
(SQLText "NotStarted") -> pure (NotStartedT name desc)
_ -> throw (ConversionFailed "???" "???" "NOPE")
While this code compiles, it’s very very supicious (as I’ve included in the note), just like when I made the meaningless fromRow instances in part-2. This code can’t work – how could GHC possibly know which instance to pick when trying to pull something out of the database? The only way it could know is if I told it – meaning I’d have to use something like fromRow dbRow :: FullySpecifiedTask 'InProgress when I tried to pull something from the DB. The issue with that of course is that we don’t know the state in the DB.
After a while I realized that I was not considering another feature of GADTs – the ability to encode a different constructor for the case where we don’t actually know the right type but know something about it. See if you can understand the definition:
newtype TaskStateValue = TaskStateValue { getTStateLiteral :: DT.Text } deriving (Eq, Show)
-- The beefy task class
data Task f (state :: TaskState) where
FinishedT :: f TaskName -> f TaskDesc -> Task f 'Finished
InProgressT :: f TaskName -> f TaskDesc -> Task f 'InProgress
NotStartedT :: f TaskName -> f TaskDesc -> Task f 'NotStarted
-- | The case where we don't know what the state actually is
-- Ex. when we pull a value from the DB, we can't be polymorphic over state with the other constructors
-- but the database *has* to know what was stored forthe state.
-- Once we have an UnknownStateT we can write functions that try to translate to what we expect/require and fail otherwise.
UnknownStateT :: f TaskName -> f TaskDesc -> TaskStateValue -> Task f state
So now we have a value constructor UnknownStateT that represents a Task with a state that is unknown. We’ve added a field to the value constructor to store information about the state we don’t know yet, making it possible to convert our UnknownStateT to a FinishedT if we inspect the TaskStateValue in the constructor. TaskStateValue is just a Data.Text, so "Finished" is an example of what we might expect to see. What we’ve done here is to actually punt the problem – when we pull a Task out of the DB, we’re going to have to create it using UnknownStateT, and then write some other function that can convert to one of the other constructors like FinishedT, by pattern matching on the constructor. Here’s what the FromRow instance would then look like:
instance FromField TaskStateValue where
fromField = (TaskStateValue <$>) . (fromField :: FieldParser DT.Text)
instance forall (state :: TaskState). FromRow (FullySpecifiedTask state) where
fromRow = UnknownStateT <$> field <*> field <*> field
This means I can write functions like:
resolveFinishedT :: forall (state :: TaskState) (f :: Type -> Type). Task f state -> Either ValidationError (Task f 'Finished)
resolveFinishedT (t@FinishedT{}) = Right t
resolveFinishedT (UnknownStateT name desc stateValue) = case stateValue of
(TaskStateValue "Finished") -> Right (FinishedT name desc)
_ -> Left $ WrongState "Task state is incompatible (not in finished state)"
resolveFinishedT _ = Left $ WrongState "Task state is incompatible (not in finished state)"
This function is polymorphic over two things – the state and the Functor f (i.e. Maybe or Identity), and based on the constructor and/or the extra data passed along with UnknownStateT, it can resolve a Task that had a previously unresolved type-level state to one where we do know the state at the type level (in this case Finished). Of course, users of this function are forced to deal with the fact that the Task they’re holding might not fit the state they expect.
WHEW!! We’ve just used a bunch of advanced haskell features here (💪 🎩) for arguably little gain over the previous code. Despite the complexity introduced I thought it was worth it to try and use the “proper” abstraction provided by Haskell to achieve our goal – representing the completion state of the task at the type level.
This code also serves as a decent practical example of a usage of DataKinds, and was a good chance for me to feel my way around using kind-level tricks. As always, if this makes you uncomfortable, feel free to skip it – the previous way we were doing things was more than enough to ensure we could talk about the state a task was in, and if that was uncomfortable you can always go back to the regular Task f type (which doesn’t store the state at the type level at all, just inside @ tState). I ran the updated integration tests (which are only testing persistTask right now), and they seem to be OK, so I’m going to consider this done-ish.
I personally am super iffy on whether I should use this at all, or just go back to the simpler but more verbose/hackish methodology from before, but I’d like to press on and see how far we can get. I was not expecting this post to get so hot and heavy (type-wise) so quickly but it’s been instructive for me and hopefully for others as well.
Check out the full commit/repo that goes with this section to see everything that had to change to make things work.
TaskStore to an EntityStore (💪 🎩)While writing the TaskStore you might have had a sneaking suspicion that we could abstract the pattern (which is very clearly just the CRUD pattern at the database level). Well, we’re about to do just that – we’re going to turn the abstraction up a notch and divorce ourselves from managing Tasks but rather concern ourselves with managing Entitys.
Making a different Stores every few weeks to manage all the different entities (Task, User, etc) we want to keep track of would be terribly inefficient. Other languages solve this in lots of other ways, the repository pattern (C# generally), DAO pattern (Java generally), and while we’re going to write a somewhat similar solution here, we’re going to make it better, because we’re going to use Haskell’s beautiful type system to write code that is type-reinforced, as demonstrably correct as possible, and doesn’t take 20 minutes of reading through various mostly-empty files and config to understand. Someone who has climbed the steep climb to learn Haskell (and even those who haven’t) should be able to look at the code and be thoroughly unsurprised and almost scoff at it’s simplicity (even though the my night understand all the type machinery involved).
In the previous post I also didn’t actually finish the TaskStore – this time we’re going to go all the way through, building the complete EntityStore from the bottom up.
EntityStore componentAs the EntityStore is basically kind of like a super high-level Repository for everything, it’s going to very closely match the CRUD features we implemented in the TaskStore, but generalized for any Entity. We’ll be using this EntityStore to create, read, update, and delete entities from our request handlers in the main application eventually.
Our approach is typeclass driven, so everything starts with trying to capture the group of operations we expect a type that qualifies as an EntityStore to be able to perform:
class EntityStore store where
-- | Create an entity
create :: store -> entity? -> IO (Either error? entity?)
-- | Get an entity
get :: store -> entity? -> IO (Either error? entity?) -- AKA "read"
-- | Update an existing entity
update :: store -> entity? -> IO (Either error? entity?)
-- | Delete an entity
delete :: store -> entity? -> IO (Either error? entity?)
Here are the parts that are somewhat unclear as of now:
store to perform operations, but what does one of the entities look like?We can take a stab at answering these two questions by getting more sophisticated with our types – one approach is to make EntityStore parametrically polymorphic over the type of the entity:
class EntityStore store entity where
-- ... rest of it
This takes care of the first problem – we can now use entity without impunity! Let’s solve the next problem – what kind of error should we return? The simplest way to solve this is to just make it up:
data EntityStoreError = NoSuchEntity EntityID
| UnexpectedError DT.Text
| Disconnected DT.Text
| ConnectionFailure DT.Text
deriving (Eq, Show, Read)
As you might imagine this is basically the same as TaskStoreError but with Task substituted for Entity. What about the third issue? Obviously we’re not going to want to do updates and deletes and even gets with the whole object, every time. To be able to look up an entity (which right now can be anything) by an some identifier, we need to know it has an identitfier – we need to constrain the type parameter entity.
We’ve seen this issue once before in the previous post, and solved it with a GADT there. This time, let’s add a type class that represents what we care about:
-- The GADT we created last time, for layering the property of "having an identity" over any type `a`
data WithID a where
UUIDID :: UUID -> a -> WithID a
IntID :: Int -> a -> WithID a
data ID = UUID | Int
class HasID a where
getId :: a -> ID
Now let’s use this to constrain the entity in EntityStore entity:
class WithID entity => EntityStore store entity where
-- | Create an entity
create :: store -> entity -> IO (Either EntityStoreError entity)
-- | Get an entity by ID
get :: store -> entity -> IO (Either EntityStoreError entity)
-- | Update an existing entity by ID
update :: store -> Partial entity -> IO (Either EntityStoreError entity)
-- | Delete an entity by ID
delete :: store -> entity -> IO (Either EntityStoreError entity)
Now we’ve got a decently abstracted typeclass for EntityStore that actually compiles. If we were to try and verbalize this typeclass, we might say:
A class of types named
EntityStoreexists, such that eachsthat qualifies as anEntityStoreis capable of performingcreate,get,update, anddeleteoperations.s’s operations are qualified/polymorphic over all typesethat statisfy the constraintWithID.
Let’s explore a slightly different and more complicated way of to represent this class, let’s flex our (💪 🎩) by using an existential type! We’ll also make gratuitous use of the Explicit ForAll extension to make it very obvious what’s going on. We’ll also sprinkle in our distinctions between Partial and Complete objects:
-- | 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))
The big difference here is that we’ve actually hidden the fact that the EntityStore is parameterized over the entity from whoever uses the thing. While the benefit is arguable here, I personally think it’s useful becuase when I deal with an entity store, I generally want it to be smart enough to figure out what to do with my entity (as long as I’ve constructed and given it the right object).
If we wanted to get fancier (💪 🎩) with this implementation there are a bunch of ways we can get more abstract with this:
update :: store -> IDOf Task -> Partial Task -> IO (Either EntityStoreError entity))IO isn’t strictly necessary here, we don’t care what monad the entity store runs inGenerics to really handle any type that comes through by pulling it apart and using reflection to generate an Entity (hardcore 💪 🎩)It’s also important to note that no one would actually expect delete to be defined how it is – you normally wouldn’t have to completely specify an entity to delete it, except in the classical case. Life is much easier when we have identifying information.
For now let’s stop where we are, we’ll come back to some of these things later. Keep in mind that we are very possibly already over-using advanced type features here by just considering the existential type solution. Existential type classes have been criticized for being overused and it would be wise to use some caution. For now let’s jump into the implementation before we do any more abstraction and see how it feels. SPOILER: we’re going to run into a bunch of problems that will motivate more abstraction.
EntityStoreAfter creating EntityStore/SQLite.hs (which basically mirrors TaskStore/SQLite.hs), first up is handling creation of Entity values. Let’s see what it looks like if we try and use the implementation for persistTask from the TaskStore instance we had before:
saveAndReturnEntity :: forall (state :: EntityState). Connection -> WithID (FullySpecifiedEntity state) -> IO (Either EntityStoreError (WithID (FullySpecifiedEntity state)))
saveAndReturnEntity c t = catch doInsert makeGenericInsertError
where
doInsert = execute c "INSERT INTO entities (uuid, name, description, state) VALUES (?,?,?,?)" t
>> pure (Right t)
instance EntityStore SQLiteEntityStore where
create :: forall entity. SQLiteEntityStore -> Complete entity -> IO (Either EntityStoreError (Complete entity))
create store e = maybe disconnectionError _handler $ stsConn store
where
-- | _handler does all the real work of persisting a entity
_handler conn = (flip UUIDID newEntity <$> nextRandom) -- Use a random UUIDV4 to make a new `WithID (FullySpecifiedEntity state)`
-- Insert the entity
>>= saveAndReturnEntity conn
There are immediately a few issues that spring to mind:
Validated a? Should we enforce that all created objects need to be validated?entities might have been appropriate if we were using the Entity-Attribute-Value model, but we’re definitely not).entities table we’re going to need a way to figure out what column names and what values to pull out of the objects that are getting stored.EntityStore is backed by a SQL-based store. If we were using a document store, at the very least the nomenclature would be different – this is an important distinction/specialization angle in the general sense.WithID a just for this).Issues 1 and 5 are the simplest, so let’s address them first by changing the signature for create:
-- | Create an entity
create :: forall entity. store -> Validated (Complete entity) -> IO (Either EntityStoreError (Complete entity))
Easy peasy, we’ve made sure to make use of both Validated a and WithID a.
Unfortunately, issues 2-4 are not so easily solved. Trying to think about how to solve those issues reveals a seemingly necessary specialization stopping us from abstracting over the create operation. In particular, for a SQL-compliant backing store, we need to know information like the table name and the columns for a given Entity before we can generically insert.
There are at least two main ways to solve this specialization issue to enable a generic store: lexcial (naming based) type class specialization and a type-level approach.
The simplest way to approach the issues listed above is to just get more specific at the syntax level about what an EntityStore is and bake our assumptions in:
{-# LANGUAGE AllowAmbiguousTypes #-}
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] }
class SQLEntityStore store => SQLInsertable store entity where
tableName :: TableName
columnNames :: SQLColumnNames
columnValues :: SQLValueGetters entity
-- | Alias for the kind of types with f bounded type polymorphism applied to one or more fields
-- ex. data T f = T { name :: f DT.Text }, where f might be a type like `Maybe a` or `Identity a`
type FBounded = (Type -> Type) -> Type
-- | Generalized typeclass for entity storage.
class SQLEntityStore store where
-- | Create an entity
create :: forall (entity :: FBounded).
SQLInsertable store (Complete entity)
=> store
-> Validated (Complete entity)
-> IO (Either EntityStoreError (Complete entity))
-- ... other code
Some notes on the code above:
TableName, SQLColumnNames and SQLValueGetters are newtypes that help us be more explicit about insertion metadataSQLInsertable makes the metadata we need to do an insert accessible any given entity that has an instance.AllowAmbiguousTypes was required due to the fact that store in SQLInsertable can’t be decided until we write instances.FBounded is a synonym for the kind of types that use a functor to wrap one or more fields. Our Task is basically of these, if we quickly change it’s definition (Task f (state :: TaskState) -> Task (state :: TaskState) f)create is modified to only be able to insert FBounded entitiy values that are SQLInsertable with the store in questionThis solution gives up on specifying EntityStore at a level abstraction above database paradigms – we pick the SQL-compatable paradigm and name it SQLEntityStore. With this code, we’ve expressed our requirement for more information about a given entity when we want to insert it generically, though it’s a little bit “hardcoded”. Since we’ll be using SQLite (and the excellent sqlite-simple package), you can think of SQLite wherever you see “SQL”.
Immediately after doing this I actually went and defined this specialization at the type level but complexity spiraled out of control super quick, and I figured it would be irresponsible to just drop it in the middle of this post for any readers that don’t have a fetish for Haskell’s type system. I’ve moved the section to the end (after the wrapup), so head down there to check out how this could be done in a database pardigm generic way. For the actual code going forward we’re going to use the less abstract SQLEntityStore typeclass.
Some of the types have shifted a bit after getting through create so let’s take another quick peek at some relevant parts of Types.hs:
data Identifier = UUIDID
| INT64ID deriving (Eq, Show, Read)
data WithID (ident :: Identifier) a where
WUUID :: UUID -> a -> WithID 'UUIDID a
WINT64 :: Int64 -> a -> WithID 'INT64ID a
WID :: Either UUID Int64 -> a -> WithID ident a
type EntityID = Either UUID Int
newtype TableName entity = TN { getTableName :: DT.Text } deriving (Eq, Show, Read)
newtype SQLColumnNames entity = SQLCN { getColumnNames :: [DT.Text] } deriving (Eq, Show, Read)
class ToRow entity => SQLInsertable entity where
tableName :: TableName entity
columnNames :: SQLColumnNames entity
-- | Generalized typeclass for entity storage.
class SQLEntityStore store where
-- | Create an entity
create :: forall (ident :: Identifier) (entity :: FBounded).
( SQLInsertable (Complete entity)
, FromRow (Complete entity)
)
=> store
-> Validated (Complete entity)
-> IO (Either EntityStoreError (WithID ident (Complete entity)))
A few notes on the changes here:
WithID has been converted to a GADT and makes use of DataKinds to be specific about which kind of ID is included at the type level (good thing we got cozy with DataKinds earlier, huh?)WithID has a constructor that allows for not knowing which ident is being used (even though there are only two), because sometimes GHC can’t unify (?) WithID 'UUIDID a and WithID ident a. This is kind of like when we had the UnknownStateT constructor for Task.TableName and SQLColumnNames are possibly obnoxious newtypesentity in TableName at all if it’s not used on the right hand side? Well it’s actually a phantom type (💪 🎩), it’ll be crucial later.SQLInsertable typeclass is key to retrieving SQL schema information about an entity (as we’ll see later)SQLEntityStore’s create definition has beefed up a little bit – I’m being overly friendly with ExplicitForAll because it Constraints for create – they’re exactly what you need to be able to insert and pull out a row, which hints at what the implementation will look like (can you guess what I do after I insert?)Hopefully the code above is relatively understandable, even if isn’t necessarily clear how it’s all going to fit together just yet.
(UPDATE 12/14/18) NOTE As /u/chshersh noted on reddit, there’s a better way to do things than the WID I introduced above. We can avoid making the inherently ambiguous WID value constructor by actually using an existential wrapper (💪 🎩) around the GADT itself like so:
data WithID (ident :: Identifier) a where
WUUID :: UUID -> a -> WithID 'UUIDID a
WINT64 :: Int64 -> a -> WithID 'INT64ID a
data WithAnyID a = forall (ident :: Identifier) . WithAnyID (WithID ident a)
This way, any code that needs to use the abstract version can use WithAnyID and code that knows what the Identifier is can use WithID. I didn’t go back and change the code to do this but wanted to at least show the approach here. Back to our regularly scheduled programming.
OK, let’s look at the implementation code in EntityStore/SQLite.hs (out of order for followability):
-- | Generalized typeclass for entity storage.
instance SQLEntityStore 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
>>= rightOrThrow
-- | Need to obscure the ident type here because ghc knows it can only be UUID
>>= pure . Right . uuidToGenericIdent
-- ... other instance code ...
-- | Ensure that a UUID is present on a given entity
ensureUUID :: entity -> IO (Either EntityStoreError (WithID 'UUIDID entity))
ensureUUID e = Right . flip WUUID e <$> nextRandom
-- | Insert and return an entity
insertAndReturnEntity :: forall (ident :: Identifier) entity.
( SQLInsertable (WithID ident (Complete entity))
, SQLInsertable (Complete entity)
, FromRow (Complete entity))
=> Connection
-> WithID ident (Complete entity)
-> IO (Either EntityStoreError (WithID ident (Complete entity)))
insertAndReturnEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "insertion with integer based UUIDs is not allowed"
insertAndReturnEntity conn entity@(WUUID uuid _) = insertEntity conn entity
-- | Right now only saving by UUID is allowed
>> getEntityByUUID conn uuid
>>= rightOrThrow
-- | We need to obscure the type to match for "any" ident
>>= pure . Right . uuidToGenericIdent
-- | Convert an type-specified identifier to a generic one identifier to a generic one
-- This is necessary when interfaces need the generic version but haskell is smart enough to know which is there and can't unify them
uuidToGenericIdent :: forall (ident :: Identifier) e. WithID 'UUIDID e -> WithID ident e
uuidToGenericIdent (WUUID uuid v) = WID (Left uuid) v
instance SQLInsertable (Complete (Task state)) where
tableName = TN $ "tasks"
columnNames = SQLCN $ ["name", "desc", "state"]
-- | If some value e is SQLInsertable, then the same value with a UUID is insertable
-- All we do is ensure the columns include a "uuid" column at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'UUIDID e) where
tableName = TN $ "tasks"
columnNames = SQLCN $ ["uuid"] ++ innerCols
where
(SQLCN innerCols) = (columnNames :: SQLColumnNames e)
-- | If some value e is insertable in the SQL paradigm, then the same value with an ID is insertable
-- All we do is ensure teh columns include an "id" at the beginning
instance forall e. SQLInsertable e => SQLInsertable (WithID 'INT64ID e) where
tableName = TN $ "tasks"
columnNames = SQLCN $ ["id"] ++ innerCols
where
(SQLCN innerCols) = (columnNames :: SQLColumnNames e)
data QueryWithParams = QWP Query [SQLData]
-- | Build the insertion SQL query for a given entity with it's ID
buildInsertQuery :: forall (ident :: Identifier) (entity :: FBounded). -- | polymorphic over entities and identifiers (uuid/int64)
(SQLInsertable (Complete entity),
SQLInsertable (WithID ident (Complete entity))) -- | entity must be insertable under SQL & complete w/ an ID
=> WithID ident (Complete entity)
-> QueryWithParams
buildInsertQuery e = makeInsertQuery tblName cNames e
where
tblName = tableName :: TableName (WithID ident (Complete entity))
cNames = columnNames :: SQLColumnNames (WithID ident (Complete entity))
-- | Build the insertion query for a given entity
makeInsertQuery :: (SQLInsertable entity, ToRow entity) => TableName entity -> SQLColumnNames entity -> entity -> QueryWithParams
makeInsertQuery (TN tbl) (SQLCN colNames) entity = QWP insertQuery params
where
insertQuery = Query $ [text| INSERT INTO $tbl ( $columnPhrase ) VALUES ( $valueQs ) |]
columnPhrase = DT.intercalate "," colNames
valueQs = DT.intercalate "," $ take (length colNames) $ repeat "?"
params = toRow entity
-- | Do the actual insertion for an entity
insertEntity :: forall (ident :: Identifier) entity.
( SQLInsertable (WithID ident (Complete entity))
, SQLInsertable (Complete entity))
=> Connection
-> WithID ident (Complete entity)
-> IO (Either EntityStoreError ())
insertEntity conn (WINT64 _ _) = pure $ Left $ UnexpectedErrorES "entities must be UUID-identified"
insertEntity conn e@(WUUID uuid _) = Right <$> execute conn query params
where
(QWP query params) = buildInsertQuery e
-- | Retrieve an entity by UUID
getEntityByUUID :: forall entity.
( SQLInsertable entity
, FromRow (WithID 'UUIDID entity))
=> Connection
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID entity))
getEntityByUUID conn uuid = pure (makeSelectByUUIDQuery tableName uuid)
>>= \(QWP q p) -> query conn q p
>>= \case
(x:_) -> pure $ Right x
_ -> pure $ Left $ NoSuchEntityES (Left uuid) "Failed to find task with given UUID"
where
tableName = tableName :: TableName (WithID 'UUIDID entity)
-- | Create the select query for an entity
makeSelectByUUIDQuery :: (SQLInsertable entity) => TableName entity -> UUID -> QueryWithParams
makeSelectByUUIDQuery (TN tbl) uuid = QWP query (toRow (Only uuid))
where
uuidTxt = toText uuid
query = Query $ [text| SELECT * FROM $tbl WHERE uuid = $uuidTxt |]
There’s a lot to go through here, but starting from the SQLEntityStore instance and going backwards is a good way to go about it (since it’s how the code was actually written). The code should be readable, but here are some highlights:
create is to ensure the entity has a UUID, insert and return it, then return the generalized WithId ident entity version (GHC complains if you try to return a WithID 'UUIDID entity due to the typeclass’s definition).ensureUUID is a bit code-golf-y for my taste but I let it ride – basically nextRandom produces a random UUID, then I use the WUUID value constructor of WithID to make a WithID 'UUIDID entity. It’s wrapped in an Either because nextRandom could fail, but I don’t do anything to handle that failure just yet (I’ll get to it later).insertandReturnEntity has a massive but hopefully legible type signature, and does what it says on the tin (though it doesn’t handle WINT64-ID’d things right now).ExplicitForAll, and every single forall annotation is extraneous, but I’m starting to enjoy them, since it makes things so explicitEntitysSQLInsertable are crucially important, and they’re where the phantom type magic I mentioned in passing earlier comes in – we can easily access columnNames :: SQLColumnNames e of some random e that we don’t know because entity is in the left hand side SQLColumnNames type (but not in the right).Hopefully this is pretty easy to follow – if not entirely too verbose. If you spot any bugs or weird ways of doing things that could be made better feel free to send me an email – keep in mind that this code will likely not immediately compile if you cut & paste it, but the code in the repo will.
NOTE One bad result of all this fancy typing is that I’ve blown by the current exhaustive pattern match checking abilities of Haskell (I think). You might think that pattern matching is an easily solved problem in GHC but it’s surprisingly complex – Ryan Scott gave a great talk about the topic @ MuniHac 2018. In particular, due to some changes I made as I went (in particular adding the WID GADT constructor), some function definitions became incomplete but GHC couldn’t figure it out and warn me. I realized this while writing and running the tests, which is no better than any other language and kind of dissappointing. Here’s an example of what I saw:
Failures:
src/Types.hs:221:1:
1) Components.EntityStore.SQLite, entity store create, works with default config
uncaught exception: PatternMatchFail
src/Types.hs:(221,1)-(222,28): Non-exhaustive patterns in function showID
One of the things I like most about Haskell is the fact that I can catch silly things like this before code is run, but the expressive power I’m making use of along with the realization of how hard the problem of typechecking is menas I’m OK with this reality. To be fair, I did write the bug – it might be a little unfair for the compiler to do absolutely all of the work. Check out the full working code listing/repo below, including one test of the create functionality (we’re only done with create so far anyway).
Well considering that we wrote a function for reading entities out of the DB in the process of writing create, let’s just use it!
getByID store eid = withActiveConn store _work
where
_work conn = case eid of
(Left uuid) -> getEntityByUUID conn uuid
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
This code did require a small constraint addition, I had left off SQLInsertable (Complete entity) (since I need access to the table name). Outside of that, the implementation is nice and easy and we can kind of pat ourselves on the back since we kinda-sorta already have a test for it.
Now that we’ve got insertion and reading covered, let’s handle the update case. The update case is a little more difficult, because we need to generate SQL statements that can work with given Partial (Task state) – that is to say, a partially specified task in some state. We may even have to write a ToRow instance as well, I think up until now we’ve only had a ToRow instance for a FullySpecifiedTask (AKA Complete (Task state)). The simplest way I can imagine solving this is with a new typeclass that contains the information we need:
class SQLUpdatable e where
updateColumns :: e -> SQLColumnNames e
updateValues :: e -> [SQLData]
For some type e to be SQLUpdatable we need to determine the columns to update and the values to update them to. BTW, this would be a great place for dependent types to add more (💪 🎩) to our code here – we know that the SQLColumnNames e (which is really just a [Data.Text] along with the unused phantom type) and [SQLData] must be the same length, it would be cool to enforce this at the type level. Another approach might be to bundle the columns and values into tuples like (SQLColumnName, SQLData) and produce that. This post is already getting pretty long so I’m not even going to try looking at that this time though.
Here are some changes in Types.hs:
-- The beefy task class
data Task (state :: TaskState) f where
-- ... other constructors ...
-- | the `f` next to TaskStateValue is new
UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task state f
class SQLUpdatable e where
updateColumns :: e -> SQLColumnNames e
updateColumns = SQLCN . map fst . updateColumnsAndValues
updateValues :: e -> [SQLData]
updateValues = map snd . updateColumnsAndValues
updateColumnsAndValues :: e -> [(SQLColumnName, SQLData)]
updateColumnsAndValues e = resolveMaybes $ removeFailedGetters $ applyToE $ updateColumnGetters e
where
resolveMaybes = map (second fromJust)
removeFailedGetters = filter (isJust . snd)
applyToE = map (second (\fn -> fn e))
updateColumnGetters :: e -> [(SQLColumnName, e -> Maybe SQLData)]
One huge thing that came in handy was knowledge of Data.Bifunctor for messing with tuple types. Huge thanks to George Wilson for one of his great (💪 🎩) talks with laws(!!!) for reviewing some lesser known but fun typeclasses. In particular, remembering that the second function saved me from writing some dreadful code instead of applyToE.
You might have noticed that the definition for Task got changed – originally, I didn’t make the TaskStateValue an f property because it seemed obvious that all Tasks would have a well defined TaskState. This became a problem when trying to parse state updates – you might receive an update that only contains the changed description of a task, but without any changes to it’s state. Since updates are Partial ts, it’s impossible to make one without feeding in a TaskStateValue – every other field gets wrapped with a Maybe (you can just pass Nothing), but the TaskStateValue (which I falsely assumed would “always be well defined”, has no good definition, precisely because it’s a partial update). Luckily the fix is pretty easy – just wrap the TaskStateValue in the f constructor same as the other fields.
And as for the actual implementation:
updateEntityByUUID :: forall entity.
( SQLInsertable (Complete entity)
, SQLUpdatable (Partial entity)
, FromRow (Complete entity)
, FromRow (WithID 'UUIDID (Complete entity)))
=> Connection
-> UUID
-> Partial entity
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
updateEntityByUUID conn uuid partial = withTransaction conn updateAndCheckChnages
>>= \case
1 -> getEntityByUUID conn uuid
_ -> pure $ Left $ UnexpectedErrorES "Update failed, no rows were changed"
where
(TN tbl) = tableName :: TableName (Complete entity)
(SQLCN cols) = updateColumns partial
setPhrase = DT.intercalate "," $ (<>"=?") <$> cols
values = updateValues partial
valuesWithID = values <> [toField uuid]
updateQuery = Query $ [text| UPDATE $tbl SET $setPhrase WHERE uuid = ? |]
updateAndCheckChnages = execute conn updateQuery valuesWithID
>> changes conn
instance SQLEntityStore SQLiteEntityStore where
-- ... other stuff ...
updateByID store eid (Validated partial) = withActiveConn store _work
where
_work conn = case eid of
(Left uuid) -> updateEntityByUUID conn uuid partial
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
The most interesting bit of the above was how I managed to generate a basic UPDATE query for some generic entity that was SQLInsertable and SQLUpdatable. This took a combination of the functionality provided by both type classes, along with needing to define a scheme to retrieve the relevant columns and their values that needed to be updated. Here’s how it fits together:
e is SQLInsertable, which means we can get the name of the table it is stored ine is SQLUpdatable, which means that we have to provide a tuple of SQL column names and getters give a list getters (updateColumnGetters :: e -> [(SQLColumnName, e -> Maybe SQLData)])SQLUpdatable provides free access to a list of updateColumns and updateValues that are knowable given an instance and a working updateColumnGetters implementationSET portion of an UPDATE SQL query by doing some string manipulationUPDATE SQL query, and execute it, passing in the values of updateValues to the query to fill in all the ?s, including the UUID for the ending WHERE clauseAs I’ve said previously, in the end we’re still just ending up with running a templated, parametrized SQL query… But this is a pretty generic, write-once way to do it. Also if you’re wondering, everytime I’ve said “getter” in the lines was indeed another missed chance to use the lens package, I really do need to properly grok it sometime…
To finish this up, we’re going to implement the D in CRUD. We’re going to be a tad bit sophisticated about this though, because a common issue in OLTP (i.e. your basic API-like web service) workloads is how to delete. Deletes can be “soft”, which is when you leave the object/row in the database, but flip a some property that signifies deletion (let’s say deleted) to true. A delete can also be “hard” in that an object/row is completely removed from the table.
We can add consideration for this to our code by introducing a new typeclass and using the phantom type trick from earlier:
data DeletionMode e = Soft
| Hard deriving (Eq, Show, Read)
class HasDeletionMode entity where
deletionMode :: DeletionMode entity
As we’ve seen a few times now, this approach will let us be able to write stuff like deletionMode :: DeletionMode e for some e that we’re using abstractly, and we can pattern match on the answer. Let’s jump into the implementation, as the code here is very similar to the other cases, outside of this small wrinkle. In Types.hs we’ll have to add this code and change some of our existing typeclasses:
data DeletionMode e = Soft
| Hard deriving (Eq, Show, Read)
class SQLDeletable entity where
deletionMode :: DeletionMode entity
class SQLEntityStore store where
-- ... other definitions ...
deleteByID :: forall (ident :: Identifier) (entity :: FBounded).
FromRow (Complete entity)
( SQLInsertable (Complete entity)
, SQLDeletable entity
, FromRow (Complete entity))
=> store
-> EntityID
The actual implementation is fairly straight forward:
deleteEntityByUUID :: forall entity.
( SQLInsertable (Complete entity)
, SQLDeletable entity
, FromRow (Complete entity)
, FromRow (WithID 'UUIDID (Complete entity)))
=> Connection
-> UUID
-> IO (Either EntityStoreError (WithID 'UUIDID (Complete entity)))
deleteEntityByUUID conn uuid = getEntityByUUID conn uuid
>>= rightOrThrow
>>= \beforeDelete -> withTransaction conn deleteAndCheckChanges
>>= \case
1 -> pure $ Right $ beforeDelete
_ -> pure $ Left $ UnexpectedErrorES "Delete failed, no rows were changed"
where
(TN tbl) = tableName :: TableName (Complete entity)
deleteQuery = case deletionMode :: DeletionMode entity of
Hard -> Query $ [text| DELETE FROM $tbl WHERE uuid = ? |]
Soft -> Query $ [text| UPDATE $tbl SET deleted=1 WHERE uuid = ? |]
deleteAndCheckChanges = execute conn deleteQuery (Only uuid)
>> changes conn
deleteAndCheckChanges = execute conn deleteQuery (Only uuid)
>> changes conn
instance SQLEntityStore SQLiteEntityStore where
-- ... other implementations ...
deleteByID store eid = withActiveConn store _work
where
_work conn = case eid of
(Left uuid) -> deleteEntityByUUID conn uuid
>>= rightOrThrow
>>= pure . Right . uuidToGenericIdent
_ -> pure $ Left $ UnsupportedOperationES "integer-identified entities are currently unsupported"
With this we’re finally done generalizing our TaskStore to an EntityStore in a relatively reasonable way! We can start using this component for something other than tests! Even with the basic mechanics we’ve introduced, we’ve accomplished something that can be difficult to put together cleanly and safely in other languages. As mentioned previously, though we’ve specialized to a SQL based entity store here at the syntax level (SQLInsertable, SQLDeletable, etc), but we can actually extend this model to be abstract over the database paradigm as well (check the extra section after the wrapup).
EntityStoreNow that we have a theoretically working EntityStore, we’re going to want to actually use it from somewhere, how about the HTTP API I’ve been promising for the entire blog post series? Before we get there though, we’ll need to modify our program code to actually make an instance of SQLEntityStore to use.
SQLEntityStore on the big stage – mainLet’s ensure the machinery around our SQLEntityStore actually works, from main, in preparation to use it with servant. Of course, calling start doesn’t actually do anything interesting right now, but we can think of start basically as a chance for components to get ready for use (maybe we’ll use forkIO or do some interesting stuff in EntityStore’s start function in the future). In Main.hs we can add some new imports and modify the existing code:
-- just the new imports listed here
import Data.Functor.Identity
import Config (AppConfig(..))
import Types
import Util (rightOrThrow)
import Components.EntityStore.SQLite
-- | IO action that runs the server
runServer :: Options -> IO ()
runServer Options{cfgPath=path} = pullEnvironment
>>= makeAppConfig path
>>= rightOrThrow
>>= server
-- | Build an entity store for use in the main application
buildEntityStore :: Complete EntityStoreConfig -> IO SQLiteEntityStore
buildEntityStore cfg = putStrLn "[info] initializing EntityStore with config:"
>> pPrint cfg
>> (construct cfg :: IO (Either EntityStoreError SQLiteEntityStore))
>>= rightOrThrow
-- | Start up the server and serve requests
server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg
>>= \entityStore -> putStrLn "<SERVER START>"
where
entityStoreCfg = runIdentity $ entityStoreConfig cfg
The codebase has changed a lot since we first wrote Main.hs not knowing what everything else would look like, but not many changes were required to add the SQLEntityStore. We’ve created the AppConfig such that it must contain configuration for the EntityStore, so we just extract it and since the EntityStore is Constructable, we construct one. Here’s what happens when we run what we have now:
$ stack exec haskell-restish-todo-exe server
[info] initializing EntityStore with config:
EntityStoreConfig { escDBFilePath = Identity ":memory:" }
<SERVER START>
OK awesome, everything hasn’t fallen apart, we’re still getting decent default settings, and the EntityStore is not failing in creation at least. At this point “production” is basically identical to our test environment, where changes only live for the duration of the server’s uptime (since we’re using SQLite in-memory). There isn’t much to actually see, since we’re not actually doing anything with the SQLiteEntityStore in main, but this caps off our deep dealings with this component.
Let’s finally start talking about our API, and getting our feet wet with servant.
It sounds crazy but this is the perfect time to forget all the domain modeling and abstraction/type building we’ve been doing for a little while to get our feet wet with servant. In the DDD onion-style approach, we’ve just taken a step across the boundary into the outer edges of the onion – let’s reset our minds. We’ll do this by just getting a basic servant API up and running, and starting it in main (right next to, but not interacting with our component).
Before we get started you’ll want to add some packages to your package.yaml, namely servant, servant-server and warp, under the requirements for the executble:
# ... other yaml ...
executables:
haskell-restish-todo-exe:
main: Main.hs
source-dirs: app
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- haskell-restish-todo
- optparse-applicative
- pretty-simple
- text
- servant
- servant-server
- warp
# ... other yaml ...
It might be a good idea at this point to read through the servant tutorial (more specifically the “web API as a type section”). Simply stated, the allure of servant is that it supports the concept of type-safe APIs (💪 🎩) – this means when we want to define an API we start with a type that specifies it:
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module Server where
import qualified Data.Text as DT
import Servant.API
type HelloWorldAPI =
"hello" :> QueryParam "name" DT.Text :> Get '[JSON] DT.Text
:<|> "goodbye" :> QueryParam "name" DT.Text :> Get '[JSON] DT.Text
I’ve seen route definitions in tons of libraries across the front and back ends of application development and this is one of the cleanest, concise, and functional (in the it-actually-contributes-value sense) ways I’ve ever seen. Servant uses a bunch of type level (💪 🎩) trickery and methods to get this beautifully ergonomic interface, but that’s a topic for another time. After defining this trivial API, we actualy have our API as a type!
What we need to do now is define a Server that can expose this API and handlers that handle individual routes:
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
module Server where
import Data.Semigroup ((<>))
import Servant.API
import Servant.Server (Server, Handler)
import qualified Data.Text as DT
type Name = DT.Text
type Greeting = DT.Text
type HelloWorldAPI =
"hello" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
:<|> "goodbye" :> QueryParam "name" DT.Text :> Get '[JSON] Greeting
helloWorldServer :: Server HelloWorldAPI
helloWorldServer = handleHello
:<|> handleGoodbye
handleHello :: Maybe Name -> Handler Greeting
handleHello Nothing = return $ "hello world"
handleHello (Just name) = return $ "hello " <> name
handleGoodbye :: Maybe Name -> Handler Greeting
handleGoodbye Nothing = return $ "goodbye world"
handleGoodbye (Just name) = return $ "goodbye " <> name
Some notes on the code above:
OverloadedStrings quite possibly the most beloved language extension of all timeimport of Servant.Server for dealing with the servant-specific HTTP ServerName and Greeting introduced to make our HelloWorldAPI a bit more legiblehelloWorldServer a Server that “serves” the HelloWorldAPI we’ve defined, which consists of two composed handlersFor a much more in-depth tutorial, check out servant’s guide on implementing servers. A few meta-notes/commentary on what’s happening here:
servant is doing some interesting stuff on the hood to get a type like Server HelloWorldAPI to even work, or for handlers of seemingly random functions to compose and be able to recognized as combining to offer a Server HelloWorldAPI.How servant works is outside the scope of this article (nevermind the fact that I couldn’t write it, since I’m no servant expert), but let’s keep going and make this Server HelloWorldAPI into an Application that can be run by Warp, the fast webserver which implements the Web Application Interface, AKA WAI, which powers servant. I’ve included only the new code/imports below:
module Server
(app)
where
-- ... other imports
import Data.Proxy
import Servant.Server (Server, Handler, Application, serve)
-- ... other code
helloWorldAPI :: Proxy HelloWorldAPI
helloWorldAPI = Proxy
app :: Application
app = serve helloWorldAPI helloWorldServer
Now, let’s actually start this server in main:
-- ... other imports ...
import Server (app)
import Network.Wai.Handler.Warp (run)
-- ... other code ...
-- | Start up the server and serve requests
server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg
>>= \entityStore -> startApp
where
entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg
startApp = putStrLn ("Starting server at port [" <> show appPort <> "]...")
>> run appPort app
So far so good! Now, if you now run the compiled binary after building the project, you’ll actually have an API server you can contact over HTTP:
$ stack exec haskell-restish-todo-exe server & # background start the server
[1] 26608
$ [info] initializing EntityStore with config:
EntityStoreConfig { escDBFilePath = Identity ":memory:" }
Starting server at port [5000]...
# (enter press to get a shell not obscured by output)
$ curl -X GET 'localhost:5000/hello'
"hello world"
$ curl -X GET 'localhost:5000/hello?name=vados'
"hello vados"
$ curl -X GET 'localhost:5000/goodbye?name=victor'
"goodbye victor"
$ kill %1 # kill the background-ed server process since it will never stop... make sure something *else* isn't running in the background
[1]+ Terminated stack exec haskell-restish-todo-exe server
With this, you’ve successfully created your first API with servant! Isn’t it awesome? Thanks to some (💪 🎩) on servant’s part we’ve got some beautifully typed, concise, and a HTTP server up and running in no time! Well enough “Hello World”, let’s start doing the work to support what we’re here for.
I won’t blame you if you’ve forgotten, but we were on our way to building an simple TODO API. Let’s get back to it – the end should be in sight at this point!
EntityStore from inside our API handler(s)Now that we’ve got a running HTTP server, the obvious next step is to start trying to plumb calls to our EntityStore from inside the handler methods. This is where things get sticky – we created our EntityStore in main (under the IO, aka “anything-goes” monad), but servant handlers run in the Handler monad, which is really just a type alias for ExceptT ServantErr IO a. That’s a pretty intense type signature there, but it gets easier of you realize you have to read it right to left – an IO monad which produces an a wrapped by a monad transformer ExceptT which produces Exceptions of type ServantErr sometimes. That’s a lot to unpack, but don’t worry if you don’t understand it right away, it’s abstracted away from us, since we deal in Handler a (e.g. Handler Greeting).
Back to the problem at hand – even though Handler a is great the case where everything we need to handle a request is in the request, but obviously it’s not enough if we need access to other resources in our program, like our EntityStore. There problem we need to solve is how do we access/use our EntityStore from inside the (monadic) context provided to us by servant?
There are at least three ways you could actually do this:
TMVar or concurrency features of haskell (with or without unsafePerformIO)EntityStore into the applicationEntityStoreThough there are times when global variables are warranted, just hearing “global variable” is 99% of the time enough to put me off a solution (doubly so with unsafePerformIO), so that approach is out.
servant provides a mechanism called Context which we can use to pass data into our application, but it’s not really the right solution because the information we need to pass is not for the server, it’s for our handlers (you could argue this point but just trust me for now), so that’s out.
At this point it should be obvious what the solution we’re going to explore is – the right way to handle threading our EntityStore through our servant handlers is to change the monad in which servant operates – changing the (💪 🎩) type machinery powering servant itself. There are some complex concepts involved (i.e. monads, natural transformations), but it’s the way servant was meant to be used and is the best generally flexible non-hacky solution.
This might be a good time to read the servant documentation on this that was linked above. There’s also an excellent cookbook recipe on the site which goes over what I’m about to go over.
entering another monadic contextNOTE You might have noticed in the documentation that servant’s code no longer uses the enter mechanism so this pun/joke doesn’t really work but I’m using it anyway.
There are a bunch of monads we could use, and in fact I actually used the StateT monad transformer when I first discovered this path myself. Since then I’ve found that a bunch of others have standardized on a marginally different monad transformer context for this use case – ReaderT, so let’s use that.
As far as integrating the alternative monadic context with servant, the idea is to show that there is a natural transformation – i.e. a way to transform – servant’s default monadic context (Handler a, AKA ExceptT ServantErr IO a) into your ReaderT YourAppState Handler a. Once you have this natural transformation (denoted ~>) relationship between the two monadic contexts, servant can use your custom context as if it was a Handler a – which means you can store and extract all the additional context you want, and servant is none the wiser.
While there are other monads you could use (like StateT as I did the first time I encountered this), using a ReaderT has some particular benefits (laid out well in the FP Complete post), and it also firmly avoids the problem of unwrapping/getting access to various monadic contexts in that you might normally encounter with a naive application of the monad transformer approach. Though you could similarly stuff all your state into a StateT, I’m going with the ReaderT pattern from now on as they’re generally interchangable and the FP Complete article was compelling enough to get me to switch.
Note that though the servant tutorial goes to the Reader monad, I’ll be going straight to using the monad transformer ReaderT (as in ReaderT AppState IO if it was stacked on top of the IO monad), which is similar, but different. The code below is basically the exact same as the cookbook entry on custom monads as it better matches what we’re about to do. Let’s create a natural transformation from the custom context we’ll make, a ReaderT AppState Handler, to Handler a:
-- | Our application state
data AppState = forall estore. SQLEntityStore estore =>
AppState { appConfig :: Complete AppConfig
, entityStore :: estore
}
-- | Our custom application handler monad for use with servant
type AppHandler = ReaderT AppState Handler
-- | Natural transformation for custom servant monad
appToServantHandler :: AppState -> AppHandler a -> Handler a
appToServantHandler state appM = runReaderT appM state
NOTE to use ReaderT you’ll need to add the dependency on transformers in package.yaml.
Interesting bits about the above code:
AppState We used some advanced type trickery (💪 🎩), in particular the existentially qualified type estore – we can hide the fact that our app state contains any type estore as long as it has a SQLEntityStore instanceHandler a, and our full type will be AppHandler a)~> operator, and it’s pretty straight forwardThe concept can be pretty mind-bending, but luckily the implementation is anti-climactic. Now we need to get our Server HelloWorldAPI (as we’ve written it) and servant to both use the new monadic context. OK, so now that we have a transformation function, let’s rewrite our server to use the new AppHandler a:
-- ... some language extensions ..
module Server
(buildApp)
where
-- ... other imports ...
import Servant.Server (ServerT, Application, serve, hoistServer)
import Types
helloWorldServer :: ServerT HelloWorldAPI AppHandler
-- ... implementation unchanged ...
handleHello :: Maybe Name -> AppHandler Greeting
-- ... implementation unchanged ...
handleGoodbye :: Maybe Name -> AppHandler Greeting
-- ... implementation unchanged ...
buildApp :: AppState -> Application
buildApp state = serve helloWorldAPI $ hoistServer helloWorldAPI naturalTransform helloWorldServer
where
naturalTransform = appToServantHandler state
Here are the big important parts that changed:
hoistServer, ServerT)Handler a turned into AppHandler aServer HelloWorldAPI (AKA ExceptT ServantErr HelloWorldAPI (IO a)) became ServerT HelloWorldAPI AppHandler (AKA something like ExceptT ServantErr HelloWorldAPI (ReaderT AppState (IO a)))app now requires an AppState to build an Application – we need state for our ReaderT that we can partially apply to create the natural transform before we can “hoist” a server written in our thing (AppHandler a) to one servant can use (Handler a)Let’s fix Main.hs to use this new paradigm – we’ll need to build one of these AppStates:
import Server (buildApp)
-- | Start up the server and serve requests
server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg
-- ^ Build the entity store
>>= pure . AppState cfg
-- ^ Build the app config with the entity store
>>= startApp
where
entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg
startApp state = putStrLn ("Starting server at port [" <> show appPort <> "]...")
Now everything should compile, and the server should act as before, almost as if nothing has changed:
$ stack exec haskell-restish-todo-exe server &
[1] 15882
$ [info] initializing EntityStore with config:
EntityStoreConfig { escDBFilePath = Identity ":memory:" }
Starting server at port [5000]...
# (enter press)
$ curl -X GET 'localhost:5000/hello?name=victor'
"hello victor"
$ curl -X GET 'localhost:5000/goodbye'
"goodbye world"
$ kill %1
[1]+ Terminated stack exec haskell-restish-todo-exe server
Now we’ve got our boring hello world server working in our new custom monad, where we have access to AppState, which contains a pointer to some SQLEntityStore-capable type (along with things like the whole app config). The only thing left to do now is start converting HelloWorldAPI into what we actually want – an API fit for a basic TODO application.
Now that we have handlers that run in our AppHandler monad which includes some SQLEntityStore-capable type (SQLiteEntityStore for us, but handler doesn’t know that), let’s make the real API – let’s start with our routes as specified by the type itself:
type TodoAPI =
"todos" :> Get '[JSON] [Completed (Task state)]
This would seem simple enough, but we’ve already run into a problem – state needs to be defined for aliases using type! There’s no way for us to tell GHC that state can and will vary. We get this error if we try to use the code above:
λ :r
[5 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:24:44: error:
Not in scope: type variable ‘state’
|
24 | "todos" :> Get '[JSON] [Complete (Task state)]
| ^^^^^
OK, well we have two choices for dealing with the polymorphism of state that I can think of – lifting it to the definition (i.e. type TodoAPI state) or using a forall somewhere. Let’s try pulling it out:
type TodoAPI state =
"todos" :> Get '[JSON] [Complete (Task state)]
Well this kinda works, but now we have to start bubbling the this state up everywhere. TodoAPI needs to become TodoAPI state and so on and so forth. This is heading in the wrong direction – it seems semantically wrong – our API isn’t parametrized by the state of the tasks it serves up, it’s just the one endpoint that might serve up different tasks with different states.
Here’s an example of an error you get from the state in TodoAPI state bubbling up:
λ :r
[5 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:26:21: error:
• The type synonym ‘TodoAPI’ should have 1 argument, but has been given none
• In the type signature:
helloWorldServer :: ServerT TodoAPI AppHandler
|
26 | helloWorldServer :: ServerT TodoAPI AppHandler
| ^^^^^^^^^^^^^^^^^^^^^^^^^^
forall seems more like what we want here, we want an endpoint that “for all” possible values of state returns Complete Tasks. Let’s try that?
type TodoAPI = forall (state :: TaskState).
"todos" :> Get '[JSON] [Complete (Task state)]
That doesn’t work but the compiler is helpful as to why:
λ :r
[5 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:23:49: error:
Illegal symbol '.' in type
Perhaps you intended to use RankNTypes or a similar language
extension to enable explicit-forall syntax: forall <tvs>. <type>
|
23 | type TodoAPI state = forall (state :: TaskState).
| ^
It’s suggesting we use RankNTypes there, but I know from experience that it’s generally complaining about the forall <clauses> . that’s showing up, so let’s enable the less intrusive ExplicitForAll. Even after enabling ExplicitForAll things don’t work out though – we get a rather grave error:
λ :r
[5 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:27:21: error:
• Illegal polymorphic type: TodoAPI
GHC doesn't yet support impredicative polymorphism
• In the type signature:
helloWorldServer :: ServerT TodoAPI AppHandler
|
27 | helloWorldServer :: ServerT TodoAPI AppHandler
| ^^^^^^^^^^^^^^^^^^^^^^^^^^
Well cool, now I know the word for what I was trying to do – “impredicative polymorphism”. I don’t deeply understand what that phrase means but I’m going to take this as a good point to stop for this approach. The fact that this error showed up and is so specific generally signals that what we’re trying to do just isn’t supported yet by GHC (and is likely some really hard to solve problem).
So we’re all out of options… Or are we? Remember when we needed to deal with the fact that we might not know the type coming from the database in the Task GADT?
-- The beefy task class
data Task (state :: TaskState) f where
FinishedT :: f TaskName -> f TaskDesc -> Task 'Finished f
InProgressT :: f TaskName -> f TaskDesc -> Task 'InProgress f
NotStartedT :: f TaskName -> f TaskDesc -> Task 'NotStarted f
UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> Task state f
Yes, that UnknownStateT constructor was the type that things got assigned when we didn’t know the state at construction time. If only we could make one of these, but not as a constructor, but as a type itself so we can use it in the TodoAPI type. There’s also one more (💪 🎩) method that might help us, in particular we’ve used it up until now to hide types: existential types!
Types.hs:
{-# LANGUAGE RankNTypes #-}
newtype TaskWithState = TWS { getTask :: forall (s :: TaskState). Complete (Task s) }
NOTE the RankNTypes extension necessary for qualifying the type inside there (the GHC error message suggested this earlier).
Server.hs:
type TodoAPI =
"todos" :> Get '[JSON] [TaskWithState]
Aaaand presto, it compiles! It wasn’t easy to figure this out – but my internal process while trying things was “how can I hide state from the TodoAPI definition?”. Eventually I realized that way that might work would be to hide the polymorphic type with an existential (forall), and I could protect myself a little bit by at least specifying the kind of the type (TaskState).
Since we’ve written zero code that deals in this new TaskWithState type, We’re are going to need to define conversions from Complete (Task state) (or a Complete (Task 'Finished), Complete (Task 'NotStarted), etc) to TaskWithState, but that should be pretty easy, we should be able to just use the TWS value constructor.
Let’s assume everything is OK since it compiles and go on to writing the handler for this.
EntityStore in our handlersLet’s add the handler/server for the route/API we just made:
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
listTodos :: AppHandler [TaskWithState]
listTodos = return []
Pretty simple, but even with this we get an error, in particular that TaskWithState doesn’t have a ToJSON instance:
λ :r
[4 of 8] Compiling Types ( /home/mrman/Projects/foss/haskell-restish-todo/src/Types.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/src/Types.hs:60:10: error:
Not in scope: type constructor or class ‘ToJSON’
|
60 | instance ToJSON (TaskWithState) where
| ^^^^^^
This actually makes perfect sense, and is a feature – we told our API that we were going to return JSON (the route ends in Get '[JSON] [TaskWithState]), and servant and GHC are smart enough to realize that whatever we’re returning needs to have a ToJSON instance. Let’s just put something there to satisfy the compiler for now – we haven’t dealt with generating ToJSON instances for anything yet, let’s put it off:
instance ToJSON (TaskWithState) where
toJSON = undefined
I sure do love me some undefined! OK, let’s get back to the problem at hand, we need to change our return [] into something that actually pulls out the SQLEntityStore es we have, and calls the listing function of our EntityStore. You can get access to the information a ReaderT is storing (in our case AppState) by using ReaderT’s ask:
listTodos :: AppHandler [TaskWithState]
listTodos = ask
>>= \appState -> listEntities (entityStore appState)
Well the compiler oh-so-helpfully let’s us know there are a few problems:
λ :r
[5 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:30:27: error:
Variable not in scope: listEntities :: t0 -> t1
|
30 | >>= \state -> listEntities (entityStore state)
| ^^^^^^^^^^^^
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:30:41: error:
• Cannot use record selector ‘entityStore’ as a function due to escaped type variables
Probable fix: use pattern-matching syntax instead
• In the first argument of ‘listEntities’, namely
‘(entityStore state)’
In the expression: listEntities (entityStore state)
In the second argument of ‘(>>=)’, namely
‘\ state -> listEntities (entityStore state)’
|
30 | >>= \state -> listEntities (entityStore state)
| ^^^^^^^^^^^
The first problem is pretty simple – I never actually defined a typeclass method that could list a bunch entities, silly me! The second problem is a bit scarier – why can’t I use the record selector entityStore defined on AppState?
I’m getting a bad feeling that this might be a complication from adding that existentially typed estore! For now let’s solve that easier first issue.
SQLEntityStore typeclassIn all the planning we’ve done so far, I totally overlooked writing and endpoint for listing entities, here’s the code real quick:
Types.hs:
-- ... other code
class SQLEntityStore store where
-- ... other methods
-- | Get a listing of all entities
list :: forall (ident :: Identifier) (entity :: FBounded).
( SQLInsertable (WithID ident (Complete entity))
, FromRow (WithID ident (Complete entity)))
=> store
-> IO (Either EntityStoreError [WithID ident (Complete entity)])
EntityStore/SQLite.hs:
-- | List entities
listEntities :: forall entity.
( SQLInsertable entity
, SQLInsertable entity
, FromRow entity)
=> Connection
-> IO (Either EntityStoreError [entity])
listEntities conn = Right <$> query_ conn selectAllQuery
where
(TN tbl) = tableName :: TableName (WithID 'UUIDID entity)
selectAllQuery = Query $ [text| SELECT * FROM $tbl |]
instance SQLEntityStore SQLiteEntityStore where
-- ... other implementations ...
list store = withActiveConn store _work
where
_work conn = listEntities conn
SQLiteSpec.hs
-- ... other tests
describe "entity store lsit" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> create store (expected :: Validated NotStartedTask)
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>> (list store :: IO (Either EntityStoreError [(WithID 'UUIDID (Complete (Task state)))]))
>>= rightOrThrow
>>= (`shouldBe` 1) . length
Note that we don’t do any pagination or advanced stuff here, it’s basically a DB dump – we’ll fix/enhance this in Part 4.
OK, now we’ve gotten rid of the first issue we had (listEntities not being defined), but we’ve got the gnarlier second issue to deal with. For some reason GHC couldn’t use our entityStore record selector inside AppState. Here’s the error again:
λ :r
[7 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:30:41: error:
• Cannot use record selector ‘entityStore’ as a function due to escaped type variables
Probable fix: use pattern-matching syntax instead
• In the first argument of ‘listEntities’, namely
‘(entityStore state)’
In the expression: listEntities (entityStore state)
In the second argument of ‘(>>=)’, namely
‘\ state -> listEntities (entityStore state)’
|
30 | >>= \state -> listEntities (entityStore state)
| ^^^^^^^^^^^
Alright, let’s try and fix this issue with what the error suggests – pattern matching syntax:
listTodos :: AppHandler [TaskWithState]
listTodos = ask
>>= \(AppState _ estore) -> list estore
That worked! Now we have another error letting us know that the TaskWithState definition earlier was not exactly what we needed:
λ :r
[7 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted )
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:30:41: error:
• Couldn't match type ‘IO’
with ‘Control.Monad.Trans.Reader.ReaderT
AppState Servant.Server.Internal.Handler.Handler’
Expected type: Control.Monad.Trans.Reader.ReaderT
AppState Servant.Server.Internal.Handler.Handler [TaskWithState]
Actual type: IO
(Either EntityStoreError [WithID ident0 (Complete entity0)])
• In the expression: list estore
In the second argument of ‘(>>=)’, namely
‘\ (AppState _ estore) -> list estore’
In the expression: ask >>= \ (AppState _ estore) -> list estore
|
30 | >>= \(AppState _ estore) -> list estore
| ^^^^^^^^^^^
There are a few problems we have here:
TaskWithState doesn’t match what list estore returns. Complete (Task state) needs to be something more like WithID ident (Complete (Task state))list entityStore operation works in the IO monad, and we’re in AppHandler (which has an IO deep down), we need to use liftIO to lift it into our monadic contextlist entityStore operation returns an Either EntityStoreError [...], but our app handler only returns the list (it’s in ExceptT so we can also error out)Here’s a stab at what might fix this issue with some helpers to deal with the possibility of failure:
Util.hs
-- ... other imports
import Servant.Server (ServantErr(..), err500)
-- ... other code
-- | Ensure that an Either resolves to it's Right value
rightOrServantErr :: (Exception a, Monad m) => ServantErr -> Either a b -> m b
rightOrServantErr err (Left _) = throw err
rightOrServantErr _ (Right v) = return v
genericServerError :: ServantErr
genericServerError = err500 { errBody = "Unexpected server error" }
Server.hs
listTodos :: AppHandler [TaskWithState]
listTodos = ask
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID ident (Complete (Task state))]))
>>= rightOrServantErr genericServerError
>>= pure . (TWS <$>)
Unfortunately, there’s still one last bug with this code – GHC can’t tell that WithID ident (Complete (Task state)) is the same as forall (ident :: Identifier) (state :: TaskState). WithID ident (Complete (Task state)):
λ :r
[5 of 8] Compiling Server ( /home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs, interpreted)
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:34:25: error:
• Couldn't match type ‘WithID ident0 (Complete (Task state0))’
with ‘forall (ident :: Identifier) (s :: TaskState).
WithID ident (Complete (Task s))’
Expected type: WithID ident0 (Complete (Task state0))
-> TaskWithState
Actual type: (forall (ident :: Identifier) (s :: TaskState).
WithID ident (Complete (Task s)))
-> TaskWithState
• In the first argument of ‘(<$>)’, namely ‘TWS’
In the second argument of ‘(.)’, namely ‘(TWS <$>)’
In the second argument of ‘(>>=)’, namely ‘pure . (TWS <$>)’
|
34 | >>= pure . (TWS <$>)
| ^^^
Thinking about this, it makes sense – the types that ident and state can be are different from the types in the second declaration – it’s limited to kinds Identifier and TaskState (the first declaration is not limited at all). I was very confused as to how to fix this for a while, but there are two obvious options that might work:
ident and state in the right place (i.e. everywhere) properlyident and state in the TaskWithState definition#1 is the more correct solution, but #2 was easier, so I tried it first:
newtype TaskWithState = TWS { getTask :: forall ident state. WithID ident (Complete (Task state)) }
It didn’t work immediately, but I wasn’t completely sure why it didn’t work. I either had to start removing the kind signatures everywhere (so commit harder to the loosening of the constraint). Since this was supposed to be the easier way and it wasn’t as easy as I thought, I figured I’d just try to solve with #1 instead, but that also posed so many code changes that it seemed only good as a last resort.
I was stuck on this for a long time until I searched “impredicative types” on Google and came across the page on impredicative types on sdiehl’s wonderful haskell writeup – there’s an extension, ImpredicativeTypes that we can use!
type TaskWithStateAndID = forall (ident :: Identifier) (state :: TaskState). WithID ident (Complete (Task state))
Unfortunately As you’ll noticed I’ve introduced an alias here to make it a bit easier to type out. After taking this step I spend a bunch more time sitting and thinking about this error that results from trying to use TaskWithSTateAndID in the TodoAPI type:
/home/mrman/Projects/foss/haskell-restish-todo/app/Server.hs:36:41: error:
• Couldn't match type ‘WithID i0 (Complete (Task s0))’
with ‘TaskWithStateAndID’
Expected type: Control.Monad.Trans.Reader.ReaderT
AppState
Servant.Server.Internal.Handler.Handler
[TaskWithStateAndID]
Actual type: Control.Monad.Trans.Reader.ReaderT
AppState
Servant.Server.Internal.Handler.Handler
[WithID i0 (Complete (Task s0))]
... more stuff ...
Basically GHC can’t tell that WithID i0 (Complete (Task s0)) is the same as TaskWithStateAndID (which we defined an alias for earlier). Even if I do my best to make these type signatures identical (as in matching exactly what list is putting out, GHC can’t handle it. The only thing that ended up working was building a function that could theoretically do a conversion:
fromEntity :: forall (ident :: Identifier) (entity :: FBounded) (state :: TaskState).
WithID ident (Complete entity)
-> Maybe TaskWithStateAndID
fromEntity _ = Nothing
This got me past the error I was seeing but left me with two more:
SQLInsertable not being deducable for WithID ident (Complete (Task s))ToJSON instance not being defined for TaskWithStateAndID (AKA forall (i :: Identifier) (s :: TaskState). WithID i (Complete (Task s)))The first issue was easily solved, though it took me a while to notice – I forgot to import Components.EntityStore.SQLite so a bunch of instances were missing. I did have to get more specific about what I was returning when listing, so that GHC could deduce the SQLInsertable instance.
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID 'UUIDID (Complete (Task state))]))
This was necessary because I only have SQLInsertable instances defined for 'UUIDID and INT64ID – I don’t have an instance for any identifier that could be in that place. It’s also hard to write a generic instance because I don’t know how to turn the ident back into a value to pattern match on (I believe there’s some kind machinery, namely singletons for this but I’m already in deep enough, we’ll leave that for another exercise).
In this case, since I’m actively choosing to ignore 'INT64ID cases all over the code (and just throw errors), I’m going to continue that streak here. While it is nice to be able to specify at the type level which ID type is being used, I need to rethink how it’s done or go with a simpler approach.
Long story short while ImpredicativeTypes got me past the error, it looks like the second issue (trying to hide the state in the TodoAPI type) is not really solvable with GHC right now. GHC definining typeclass instances with types qualified in that way. I did find an SO post that says you could but I’m no where near skilled enough to use the code there comfortably. So if I can’t use impredicative types like TaskWithStateAndID (the earlier alias to that long thing), how else can this work?
Well the simplest solution I could think of was actually including a vague type and getting more concrete:
Types.hs
-- Task state for abstracting over TaskState
data TaskState = Finished
| InProgress
| NotStarted
| Some deriving (Eq, Enum, Read, Show)
type TaskWithStateAndID = WithID 'UUIDID (Complete (Task Some))
instance ToJSON TaskWithStateAndID where
toJSON = undefined
Server.hs
type TodoAPI =
"todos" :> Get '[JSON] [TaskWithStateAndID]
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
listTodos :: AppHandler [TaskWithStateAndID]
listTodos = ask
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithID 'UUIDID (Complete (Task state))]))
>>= rightOrServantErr genericServerError
>>= pure . map fromJust . filter isJust . (convert <$>)
convert :: WithID 'UUIDID (Complete (Task state)) -> Maybe TaskWithStateAndID
convert _ = Nothing
This code compiles, but has two obvious flaws that I’m going to sort through:
ToJSON instance for the very very specific TaskWithStateAndID is undefinedconvert which is supposed to somehow convert a UUID-identified task in some state into a possible TaskWithStateAndID (AKA WithID 'UUIDID (Complete (Task Some))) is not writtenNormally adding another TaskState would break a bunch of other case matching in other places, but we’re actually fine here because Task is a GADT – no one could create a Task with Some as it’s TaskStateValue, because we don’t support it anywhere. At worst the code should error imediately (which is not so good) but generally it should be impossible to even deal with the values in the first place. Anyway, here’s what the code look slike to fix the two points above:
Types.hs:
-- ... other extensions
{-# LANGUAGE DeriveGeneric #-}
-- ... other imports
import GHC.Generics (Generic)
import Data.Aeson (ToJSON(..), (.=), object)
-- ... other code
type TaskWithStateAndID = WithID 'UUIDID (Complete (Task Some))
-- | Bridge Tasks in SomeState to their actual ToJSON instances
instance ToJSON TaskWithStateAndID where
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON _ = error "nope" -- should never get here
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'Finished))) where
toJSON (WUUID uuid (FinishedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WINT64 num (FinishedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WID (Left uuid) (FinishedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= Finished]
toJSON (WID (Right num) (FinishedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= Finished]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'Finished)))"
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'InProgress))) where
toJSON (WUUID uuid (InProgressT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WINT64 num (InProgressT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WID (Left uuid) (InProgressT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON (WID (Right num) (InProgressT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= InProgress]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'InProgress)))"
instance forall (ident :: Identifier). ToJSON (WithID ident (Complete (Task 'NotStarted))) where
toJSON (WUUID uuid (NotStartedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WINT64 num (NotStartedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WID (Left uuid) (NotStartedT n d)) = object ["uuid" .= uuid, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON (WID (Right num) (NotStartedT n d)) = object ["id" .= num, "name" .= n, "description" .= d, "state" .= NotStarted]
toJSON _ = error "failed to resolve ToJSON instance of (WithID ident (Complete (Task 'NotStarted)))"
Yikes :(. As soon as we get over how ugly and repetitive this code is, it turns out this code actually solves both issues – by using this Some value constructor, I have a catch-all that I can use, and as long as I can pull it from the database I can ask for it when necessary. If I need to make it more specific then I’ll add code to do so. The code certainly got very messy, but it does compile.
Finally, we have a theoretically working listing endpoint! With all the type trickery and with how much we’ve pushed GHC, we’ve opened ourselves up to the world of runtime errors quite a bit, so I’m pretty skeptical that things will work. Only one way to find out! First the empty read case (trying to list TODOs from the API when there are none):
$ [info] initializing EntityStore with config:
EntityStoreConfig { escDBFilePath = Identity ":memory:" }
Starting server at port [5000]...
# (enter press)
$ curl -X GET 'localhost:5000/todos'
[]
So far so good, though this doesn’t really tell us much other than the server starts up and the handler runs without failing. The more interesting test is hard-coding an entity into the DB at startup to make sure something gets put in the DB, then trying to pull it out. I’m particularly suspicious that the code will pull the wrong type of Task out and error from missing some deserializing machinery:
server :: Complete AppConfig -> IO ()
server cfg = buildEntityStore entityStoreCfg -- | Build & start the entity store
>>= \entityStore -> start entityStore
-- | TEST CODE, REMOVE
>> makeTestTask
>>= rightOrThrow
>>= create entityStore
>>= rightOrThrow
-- | Build the app config with the entity store
>> pure (AppState cfg entityStore)
-- | Start the app
>>= startApp
where
makeTestTask = pure $ validate $ NotStartedT (Identity (TaskName "test")) (Identity (TaskDesc "test description"))
entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg
startApp state = putStrLn ("Starting server at port [" <> show appPort <> "]...")
>> run appPort (buildApp state)
And the moment of truth:
$ stack exec haskell-restish-todo-exe server &
[1] 13014
$ [info] initializing EntityStore with config:
EntityStoreConfig { escDBFilePath = Identity ":memory:" }
Starting server at port [5000]...
( enter press)
$ curl -X GET 'localhost:5000/todos'
nope
CallStack (from HasCallStack):
error, called at src/Types.hs:118:16 in haskell-restish-todo-0.1.0.0-JDwYiqJ5R007sp4JR7VOqA:Types
curl: (52) Empty reply from server
$ kill %1
[1]+ Terminated stack exec haskell-restish-todo-exe server
Ahhh, that’s more like it, the smell of fresh failure in the morning. Even better than normal failure, it failed in a way I didn’t expect – here’s where the error happened:
-- | Bridge Tasks in SomeState to their actual ToJSON instances
instance ToJSON TaskWithStateAndID where
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON _ = error "nope" -- should never get here
Guess which line it got to? Yep, the one it should never get to! I’m quite surprised because this means it parsed the thing out of the database correctly, but failed in actually turning it into JSON. Not at all where I expected it to fail (deserializing from database). let’s fill out the missing cases here:
-- | Bridge Tasks in SomeState to their actual ToJSON instances
instance ToJSON TaskWithStateAndID where
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WUUID uuid (UnknownStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WID (Left uuid) (SomeStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "Finished")))) = toJSON $ (WUUID uuid (FinishedT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "InProgress")))) = toJSON $ (WUUID uuid (InProgressT n d))
toJSON (WID (Left uuid) (UnknownStateT n d (Identity (TSV "NotStarted")))) = toJSON $ (WUUID uuid (NotStartedT n d))
-- | GHC says the code below is inaccessible, I choose to believe it
-- toJSON (WUUID uuid (FinishedT n d)) = toJSON $ (WUUID uuid (FinishedT n d))
-- toJSON (WUUID uuid (InProgressT n d)) = toJSON $ (WUUID uuid (InProgressT n d))
-- toJSON (WUUID uuid (NotStartedT n d)) = toJSON $ (WUUID uuid (NotStartedT n d))
toJSON _ = error "nope" -- should never get here
Yikes x2 :(. This ToJSON instance is pretty ridiculous, but let’s keep going until we get something that works (we’ll deal with walking back from this ridiculous state of affairs in the next section). Let’s cross our fingers and try again:
$ stack exec haskell-restish-todo-exe server &
[1] 15671
$ [info] initializing EntityStore with config:
EntityStoreConfig { escDBFilePath = Identity ":memory:" }
Starting server at port [5000]...
$ curl -X GET 'localhost:5000/todos'
[{"state":"NotStarted","uuid":"6ea285c6-4a3f-4aa9-bd9d-cca9d077742b","name":{"getTName":"test"},"description":{"getTDesc":"test description"}}]$
IT WORKED!! The representation is a little weird (due to the newtypes we’re using for TaskName and TaskDesc), but we’ve got some properly structured JSON output! Listing of the todo entities is working, UUIDs are getting generated, a working, slightly more useful API is now ready! If you’re wondering about the executable size:
$ du -hs ./.stack-work/install/x86_64-linux-tinfo6/lts-12.18/8.4.4/bin/haskell-restish-todo-exe
12M ./.stack-work/install/x86_64-linux-tinfo6/lts-12.18/8.4.4/bin/haskell-restish-todo-exe
$ ldd ./.stack-work/install/x86_64-linux-tinfo6/lts-12.18/8.4.4/bin/haskell-restish-todo-exe
linux-vdso.so.1 (0x00007ffd2911e000)
libm.so.6 => /usr/lib/libm.so.6 (0x00007f0d34438000)
libpthread.so.0 => /usr/lib/libpthread.so.0 (0x00007f0d34417000)
libz.so.1 => /usr/lib/libz.so.1 (0x00007f0d34200000)
librt.so.1 => /usr/lib/librt.so.1 (0x00007f0d341f6000)
libutil.so.1 => /usr/lib/libutil.so.1 (0x00007f0d341f1000)
libdl.so.2 => /usr/lib/libdl.so.2 (0x00007f0d341ec000)
libgmp.so.10 => /usr/lib/libgmp.so.10 (0x00007f0d34156000)
libc.so.6 => /usr/lib/libc.so.6 (0x00007f0d33f92000)
/lib64/ld-linux-x86-64.so.2 => /usr/lib64/ld-linux-x86-64.so.2 (0x00007f0d34600000)
Now that we’ve got this all figured out it will be relatively easy to extend this pattern to all the other routes which are thin wrappers over calls to the EntityStore. While you could spend a lot of time looking at the code below, don’t – the code is going to get drastically simplified in the very next section and that code will probably be a lot more pleasant to look at.
working-e2e-list-endpoint-with-hardcoded-test)
OK, so we’ve used a bunch of relatively complicated type machinery (💪 🎩) up until now, and now that we’ve gotten this far we can see the forest (not just the trees). While it was exhilarating to use some of these constructs to build our code, it’s a good idea to start shedding some unnecessary complexity where we can. Along the way I noticed a few areas that either didn’t provide value or that I ended up hacking around that could be simplified:
TaskState at the Task type level (i.e. Task (state :: TaskState) f)UUID or Int64ID and accounting for both at the type levelnewtypes causing excessive unpacking and complicated deriving clauses and unintended JSON encodingThe advanced typing facilities we’ve used became most cumbersome when dealing with the outside world – either the database or requests we’d be getting from users. I think a good way to handle these interaction points is actually to create super-simple fully-specified boring types, but define our operations in advanced types where possible, so we can make use of have guarantees at the type level but still make things easy on ourselves when dealing with the outside world. This looks like the following:
type Name = DT.Text
type Description = DT.Text
data Task = { name :: Name
, description :: Description
, state :: TaskState
}
data TaskF f = { name :: f Name
, description :: f Description
, state :: f TaskState
}
data TaskWithState (state :: TaskState) f = { name :: f Name
, description :: f Description
}
data WithUUID a = WUUID UUID a
There are actually libraries that do the Type f boilerplate for you like conkin and rank2classes, but for this relatively small example I’m going to leave this stuff manually specified. With this simplified group of types, I can go back and greatly simplify the logic all over the codebase and be a little less clever. Data from the outside (clients or the database) will be read in in the easiest form, and I’ll write conversion functions as necessary when I want to work in a world with more stricter/more powerful types.
I’ve said it time and time again but one of the best features of Haskell is how easy refactoring is. All I needed to was start simplifying types and following the compiler all the way to very-close-to-working code. The compiler catches all the cases I miss, all the functions I forget to convert, all the constraints I forget to fix. This is one of the reasons I can’t go back to langauges that don’t inference or have strong type specification requirements – the amount of time I could have spent debugging is scary to even imagine. I was never with the “write crazy tests” and I’m increasingly beginning to think that needing to writing a bunch of tests for confidence in your code is a result of not being able to rely on your type system (or not relying on the type systme enough).
While I was writing this code, I wonder if there would be some more interesting way to have this sort of aspect-driven functionality for types, something like:
type WithAspects (a :: Type) (aspectKind :: Type -> Type) (aspectType :: Type) = WA a '[(aspectKind, aspectType)]
computation :: SomeType '[contains (FBound, Maybe)] -> Maybe (SomeType '[contains (FBound, Identity)])
computation = ...
I think this is interesting because then I can move stuff like task state up to the type level, but also compose that with other properties. There are already libraries like vinyl (check out the intro docs) which do something similar, so maybe I’m late to the game here. Either way, I’m going to leave that for another day of exploration!
The greatly simplified code should be a bit easier to follow, so make sure to take a look!
Alright, now that we’ve got some more reasonable simplified code, it’s time to build the rest of the API. We’ve talked about mechanics enough already, so I’ll just skip to the finished code:
Server.hs
type TodoAPI =
"todos" :> Get '[JSON] [WithUUID Task]
:<|> "todos" :> Capture "uuid" UUID :> Get '[JSON] (WithUUID Task)
:<|> "todos" :> Capture "uuid" UUID :> ReqBody '[JSON] (Partial TaskF) :> Patch '[JSON] (WithUUID Task)
:<|> "todos" :> Capture "uuid" UUID :> Delete '[JSON] (WithUUID Task)
:<|> "todos" :> ReqBody '[JSON] Task :> Post '[JSON] (WithUUID Task)
todoServer :: ServerT TodoAPI AppHandler
todoServer = listTodos
:<|> getTodoByUUID
:<|> patchTodoByUUID
:<|> deleteTodoByUUID
:<|> createTodo
listTodos :: AppHandler [WithUUID Task]
listTodos = ask
>>= \(AppState _ estore) -> liftIO (list estore :: IO (Either EntityStoreError [WithUUID Task]))
>>= rightOrServantErr genericServerError
getTodoByUUID :: UUID -> AppHandler (WithUUID Task)
getTodoByUUID uuid = ask
>>= \(AppState _ estore) -> liftIO (getByUUID estore uuid :: IO (Either EntityStoreError (WithUUID Task)))
>>= rightOrServantErr genericServerError
patchTodoByUUID :: UUID -> Partial TaskF -> AppHandler (WithUUID Task)
patchTodoByUUID uuid partial = pure (validate partial)
>>= rightOrConvertToServantErr
>>= \validated -> ask
>>= \(AppState _ estore) -> liftIO (updateByUUID estore uuid validated :: IO (Either EntityStoreError (WithUUID (Complete TaskF))))
>>= rightOrConvertToServantErr
>>= pure . (toTaskFromF <$>)
deleteTodoByUUID :: UUID -> AppHandler (WithUUID Task)
deleteTodoByUUID uuid = ask
>>= \(AppState _ estore) -> liftIO (deleteByUUID estore uuid :: IO (Either EntityStoreError (WithUUID Task)))
>>= rightOrServantErr genericServerError
createTodo :: Task -> AppHandler (WithUUID Task)
createTodo todo = pure (validate todo)
>>= rightOrConvertToServantErr
>>= \validated -> ask
>>= \(AppState _ estore) -> liftIO (create estore validated :: IO (Either EntityStoreError (WithUUID Task)))
>>= rightOrConvertToServantErr
We’ve done it! We’ve got a functioning HTTP server that serves our very basic Todo API with nice reinforced types! Finally this crazy long series of blog posts has paid off with some sort of discernable value.
A few small changes were required in Types.hs and some other files – The final commit to implement the API is listed below:
Alright, so it’s been a wild ride but now we’ve got an dynamically configurable HTTP-based REST-ish API up and running in Haskell! We’ve engineered a pretty generic SQLEntityStore that can handle whatever types we throw at it as long as they have the right typeclasses specified. Along the way we’ve also discovered as omewhat tiered (💪 🎩) system – we use Tasks when necessary, TaskFs when we want some more power and TaskFInState (state :: TaskState) when we want to be very specific, and it’s up to callers to bring us the right thing.
Next time, we’re going to do a tiny bit more abstraction (get rid of the pesky IOs everywhere), and use an approach I’ve dubbed “classy mtl readers” to restrict what the monads in our handlers can do for some extra safety. We’ll also explore ideas and patterns that would come up in more realistic application development (things like response envelopes, pagination, etc).
As always, thanks for reading!
Click here to view the guaranteed-to-compile code in the repo (@ tag part-3)
Remember way back when we we solved the specialization problem by just changing EntityStore to SQLEntityStore? Well another way we can excite ourselves with types solve the paradigm specialization problem is by finding a way to express this specialization at the type level! We can specialize our EntityStore and relevant type typeclasses themselves, with a bit of help from DataKinds, ConstraintKinds and tons of other type level shenanigans. I actually ended up going down this rabbit hole while writing the earlier part of the post then realized it would be insane to have such a huge diversion and intense type stuff so early.
The code is really intense but is possible which is pretty awesome. Here are a few important pieces:
newtype TableName = TN { getTableName :: DT.Text } deriving (Eq, Show, Read)
newtype SQLColumnNames = SQLCN { getColumnNames :: [DT.Text] } deriving (Eq, Show, Read)
-- | These getters will be applied to the object when we need to pull values out to insert
-- Should be the same length as SQLColumnNames
newtype SQLValueGetters entity = SQLVG { getValueGetters :: [entity -> SQLData] }
-- | Kind (w/ help of DataKinds) that is used to parametrize over the storage paradigm of an EntityStore
data DBParadigm = SQL
| DocumentStore
deriving (Eq, Show, Read)
-- | Types that are insertable under some database paradigm p
class Insertable (p :: DBParadigm) entity where
getInsertInfo :: EntityInsertInfo p entity
-- | Insertion information for some type that is insertable under database paradigm p
data EntityInsertInfo (p :: DBParadigm) entity where
SQLEII :: TableName -> SQLColumnNames -> SQLValueGetters entity -> EntityInsertInfo 'SQL entity
DocumentStoreEII :: TableName -> EntityInsertInfo 'DocumentStore entity
-- | Generalized typeclass for entity storage.
class EntityStore (readable :: Type -> Constraint) (paradigm :: DBParadigm) store where
create :: forall (entity :: FBounded) (ident :: Identifier).
(Insertable paradigm (Complete entity),
readable (Complete entity))
=> store
-> Validated (Complete entity)
-> IO (Either EntityStoreError (WithID ident (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))
The approach involves actually abstracting over the DB paradigm itself at the type level, in addition to using ConstraintKinds to generate constraints depending on the paradigm we’re using (in particular for the 'SQL paradigm I require ToRow). I’m not going to go into it too much here because it would probably double the length of this already-long post. I do like the fact of how readable haskell can be – a value like WithID ident (Complete entity) is certainly a complicated one, but it’s almost english readable, and helpful hints like entity :: FBounded and ident :: Identifier can let you know a little bit more about the polymoprhic kinds involved.
I didn’t go forward with this design for this post because it was just too much, but I did go as far as getting everything to compile before ripping it out and using the simpler lexcial “hardcoded” approach of defining a SQLEntityStore. You can check it out below: