Types.hs 13.3 KB
Newer Older
MrMan's avatar
MrMan committed
1 2 3 4 5
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE TypeSynonymInstances #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE GeneralizedNewtypeDeriving #-}
6 7
{-# LANGUAGE GADTs #-}
{-# LANGUAGE MultiParamTypeClasses #-}
8 9
{-# LANGUAGE FlexibleContexts #-}
{-# LANGUAGE InstanceSigs #-}
10 11 12 13
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE TypeInType #-}
{-# LANGUAGE ExplicitForAll #-}
14
{-# LANGUAGE AllowAmbiguousTypes #-}
15
{-# LANGUAGE ConstraintKinds #-}
MrMan's avatar
MrMan committed
16 17 18

module Types where

19
import           Data.Kind(Type, Constraint)
20 21
import           Config (CompleteTaskStoreConfig)
import           Control.Exception (throw, Exception)
MrMan's avatar
MrMan committed
22 23
import           Data.Either (isRight)
import           Data.Functor.Identity (Identity(..))
24 25 26 27 28 29
import           Data.Int (Int64)
import           Data.List (uncons)
import           Data.Maybe (isJust, fromJust)
import           Data.Monoid ((<>))
import           Data.UUID (UUID, toText, fromText)
import qualified Data.Text as DT
30
import           Database.SQLite.Simple (SQLData)
MrMan's avatar
MrMan committed
31 32 33 34 35 36 37

-- Task state for abstracting over TaskState
data TaskState = Finished
               | InProgress
               | NotStarted deriving (Eq, Enum, Read, Show)

-- Newtypes preventing careless
MrMan's avatar
MrMan committed
38 39
newtype TaskName = TaskName { getTName :: DT.Text } deriving (Eq, Show)
newtype TaskDesc = TaskDesc { getTDesc :: DT.Text } deriving (Eq, Show)
MrMan's avatar
MrMan committed
40

41 42
newtype TaskStateValue = TaskStateValue { getTStateLiteral :: DT.Text } deriving (Eq, Show)

MrMan's avatar
MrMan committed
43
-- The beefy task class
44 45 46 47
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
48 49 50 51 52

    -- | 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.
53
    UnknownStateT :: f TaskName -> f TaskDesc -> TaskStateValue -> Task state f
54

55
resolveFinishedT :: forall (state :: TaskState) (f :: Type -> Type). Task state f -> Either ValidationError (Task 'Finished f)
56 57 58 59 60
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)"
MrMan's avatar
MrMan committed
61 62

-- Completed tasks
63
type CompletedTask = Task 'Finished Identity
MrMan's avatar
MrMan committed
64

MrMan's avatar
MrMan committed
65
-- InProgress, partially specified tasks
66
type InProgressPartialTask = Task 'InProgress Maybe
MrMan's avatar
MrMan committed
67

MrMan's avatar
MrMan committed
68
-- InProgress, fully specified tasks
69
type InProgressTask = Task 'InProgress Identity
MrMan's avatar
MrMan committed
70 71

-- Not started, partially specified tasks
72
type NotStartedPartialTask = Task 'NotStarted Maybe
MrMan's avatar
MrMan committed
73 74

-- Not started, completely specified tasks
75
type NotStartedTask = Task 'NotStarted Identity
MrMan's avatar
MrMan committed
76

77 78 79
type Partial a = a Maybe
type Complete a = a Identity

MrMan's avatar
MrMan committed
80 81 82 83 84 85 86
----------------
-- Validation --
----------------

newtype FieldName = FieldName { getFieldName :: DT.Text } deriving (Eq, Show, Read)

data ValidationError = InvalidField FieldName
87 88
                     | MissingField FieldName
                     | WrongState DT.Text deriving (Eq, Show, Read)
MrMan's avatar
MrMan committed
89

MrMan's avatar
MrMan committed
90 91 92
instance Exception ValidationError
instance Exception [ValidationError]

93
newtype Validated t = Validated { getValidatedObj :: t }
MrMan's avatar
MrMan committed
94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111

type ValidationCheck t = t -> Maybe ValidationError

class Validatable t where
    -- | Helper method to quickly determine of a type is valid
    isValid :: t -> Bool
    isValid = either (const True) (const False) . validate

    -- | Run all checks on the validated
    validate :: t -> Either [ValidationError] (Validated t)
    validate t = if null errors then Right (Validated t) else Left errors
        where
          checkResults = [check t | check <- validationChecks]
          errors = [fromJust e | e <- checkResults, isJust e]

    -- | List of validation checks to run on the type (any of which could produce an error)
    validationChecks :: [ValidationCheck t]

112 113
type FullySpecifiedTask state = Task state Identity
type PartialTask state = Task state Maybe
MrMan's avatar
MrMan committed
114 115 116 117 118 119 120

taskNameField :: FieldName
taskNameField = FieldName "name"

taskDescField :: FieldName
taskDescField = FieldName "description"

121
showState :: forall (state :: TaskState) (f :: Type -> Type). Task state f -> String
122 123 124 125
showState (FinishedT _ _) = "Finished"
showState (InProgressT _ _) = "InProgress"
showState (NotStartedT _ _) = "NotStarted"

MrMan's avatar
MrMan committed
126 127
-- | Helper function to access task name for fully specified task
fsTaskName :: FullySpecifiedTask state -> DT.Text
128 129 130
fsTaskName (FinishedT (Identity name) _) = DT.strip $ getTName name
fsTaskName (InProgressT (Identity name) _) = DT.strip $ getTName name
fsTaskName (NotStartedT (Identity name) _) = DT.strip $ getTName name
MrMan's avatar
MrMan committed
131 132

fsTaskDesc :: FullySpecifiedTask state -> DT.Text
133 134 135
fsTaskDesc (FinishedT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (InProgressT _ (Identity desc)) = DT.strip $ getTDesc desc
fsTaskDesc (NotStartedT _ (Identity desc)) = DT.strip $ getTDesc desc
136

MrMan's avatar
MrMan committed
137 138 139
instance Validatable (FullySpecifiedTask state) where
    validationChecks = [checkName, checkDescription]
        where
140
          checkName :: FullySpecifiedTask state -> Maybe ValidationError
MrMan's avatar
MrMan committed
141 142
          checkName t = if DT.null (fsTaskName t) then Just (InvalidField taskNameField) else Nothing

143
          checkDescription :: FullySpecifiedTask state -> Maybe ValidationError
MrMan's avatar
MrMan committed
144 145 146
          checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing

pTaskName :: PartialTask state -> Maybe DT.Text
147 148 149 150
-- pTaskName = (DT.strip . getTName <$>) . tName
pTaskName (FinishedT name _) = DT.strip . getTName <$> name
pTaskName (InProgressT name _) = DT.strip . getTName <$> name
pTaskName (NotStartedT name _) = DT.strip . getTName <$> name
MrMan's avatar
MrMan committed
151 152

pTaskDesc :: PartialTask state -> Maybe DT.Text
153 154 155
pTaskDesc (FinishedT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (InProgressT _ desc) = DT.strip . getTDesc <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip . getTDesc <$> desc
MrMan's avatar
MrMan committed
156 157 158 159

instance Validatable (PartialTask state) where
    validationChecks = [checkName, checkDescription]
        where
160
          checkName :: PartialTask state -> Maybe ValidationError
MrMan's avatar
MrMan committed
161 162 163 164 165
          checkName = maybe (Just (MissingField taskNameField)) notEmptyIfPresent . pTaskName
              where
                notEmptyIfPresent :: DT.Text -> Maybe ValidationError
                notEmptyIfPresent v = if DT.null v then Just (InvalidField taskNameField) else Nothing

166
          checkDescription :: PartialTask state -> Maybe ValidationError
MrMan's avatar
MrMan committed
167 168 169 170
          checkDescription = maybe (Just (MissingField taskDescField)) notEmptyIfPresent . pTaskDesc
              where
                notEmptyIfPresent :: DT.Text -> Maybe ValidationError
                notEmptyIfPresent v = if DT.null v then Just (InvalidField taskDescField) else Nothing
171 172 173 174 175 176

----------------
-- Components --
----------------

class Component c where
177 178 179 180 181
    start  :: c -> IO ()
    stop   :: c -> IO ()

class Component c => Constructable c cfg err where
    construct :: cfg -> IO (Either err c)
182

MrMan's avatar
MrMan committed
183 184
data Identifier = UUIDID
                | INT64ID deriving (Eq, Show, Read)
185

MrMan's avatar
MrMan committed
186 187 188
data WithID (ident :: Identifier) a where
    WUUID   :: UUID -> a -> WithID 'UUIDID a
    WINT64  :: Int64 -> a -> WithID 'INT64ID a
189

MrMan's avatar
MrMan committed
190
    WID     :: Either UUID Int64 -> a -> WithID ident a
191

MrMan's avatar
MrMan committed
192 193 194
withoutID :: forall (ident :: Identifier) a. WithID ident a -> a
withoutID (WUUID _ a)  = a
withoutID (WINT64 _ a) = a
195

MrMan's avatar
MrMan committed
196 197 198
showID :: forall (ident :: Identifier) a. WithID ident a -> String
showID (WUUID v _)  = show v
showID (WINT64 v _) = show v
MrMan's avatar
MrMan committed
199

200 201 202 203 204
-- | A typeclass consisting of types that can produce an ID usable by a SQL library to represent itself.
-- for example, if SQL library a can take `Int` for numeric IDs as well as `String`s for UUIDs, and id is an abstraction over both forms of ID,
-- then `getRowIDValue id` will produce the appropriate SQLValue for use in a query using the specified SQL library
class HasRowIDValue id sqlvalue where
    getRowIDValue :: id -> sqlvalue
205 206 207 208 209 210 211 212 213 214 215 216 217 218 219 220 221 222 223 224

-- | Holds a database version (expected to be a monotonically increasing number)
newtype SQLMigrationVersion = SQLMigrationVersion { getMigrationVersion :: Int } deriving (Eq, Show, Read, Ord, Num)

-- | Holds a SQL Query
newtype SQLMigrationQuery = SQLMigrationQuery { getMigrationQuery :: DT.Text } deriving (Eq, Show, Read)

-- | Specifies a `SQLMigrationVersion` that is the source of a migration path
type FromSQLMigrationVersion = SQLMigrationVersion

-- | Specifies a `SQLMigrationVersion` that is the target of a migration path
type ToSQLMigrationVersion = SQLMigrationVersion

data SQLMigration = SQLMigration
    { smFrom  :: FromSQLMigrationVersion
    -- ^ The starting migration version
    , smTo    :: ToSQLMigrationVersion
    -- ^ The ending migration version
    , smQuery :: SQLMigrationQuery
    -- ^ Query to execute to perform the migration (also responsible)
MrMan's avatar
MrMan committed
225
    } deriving (Eq, Show)
226 227 228 229 230 231 232 233 234 235 236 237

instance Ord SQLMigration where
    compare l r = compare (smFrom l) (smFrom r)

data MigrationError = NoMigrationPath -- ^ A path between the migrations could not be found
                    | MigrationQueryFailed FromSQLMigrationVersion ToSQLMigrationVersion DT.Text -- ^ An individual migration query failed
                    | VersionFetchFailed DT.Text -- ^ When we've failed to get the current version
                    | UnexpectedMigrationError DT.Text
                      deriving (Eq, Show)

instance Exception MigrationError

238
class HasMigratableDB store where
239 240 241 242 243 244 245 246 247 248 249 250 251 252 253 254 255 256
    -- | Retreive the desired version, this is normally just statically set @ compile time
    --   The store isn't strictly necessary but just in case we decide to define the desired version in the database or config or elsewhere
    desiredVersion :: store -> IO SQLMigrationVersion

    -- | A list of available migrations that will be used by `migrateTo` to create a path from current (via `getCurrentVersion`) to `desiredVersion`
    availableMigrations :: store -> IO [SQLMigration]

    -- | Retrieve the current version of the database
    getCurrentVersion :: store -> IO (Either MigrationError SQLMigrationVersion)

    -- | Perform migrations to get to the current version
    migrate :: store -> IO (Either MigrationError ())
    migrate store = desiredVersion store >>= migrateTo store

    -- | Finds and executes a path to the requested ToSQLMigration from
    --   Currently when looking through `availableMigrations`, a monotonically increasing version number is assumed,
    --   This means paths are made from version to version generally in one version increments (1 --[migrateTo]--> 2 --[migrateTo]-> 3)
    migrateTo :: store -> ToSQLMigrationVersion -> IO (Either MigrationError ())
257 258 259

type EntityID = Either UUID Int

MrMan's avatar
MrMan committed
260
data EntityStoreError = NoSuchEntityES EntityID DT.Text
261 262 263 264 265
                      | UnexpectedErrorES DT.Text
                      | DisconnectedES DT.Text
                      | ConnectionFailureES DT.Text
                        deriving (Eq, Show, Read)

MrMan's avatar
MrMan committed
266 267
instance Exception EntityStoreError

268 269
newtype TableName = TN { getTableName :: DT.Text } deriving (Eq, Show, Read)
newtype SQLColumnNames = SQLCN { getColumnNames :: [DT.Text] } deriving (Eq, Show, Read)
270 271 272 273

-- | 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] }
274 275 276 277 278

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

MrMan's avatar
MrMan committed
279
-- | Kind (w/ help of DataKinds) that is used to parametrize over the storage paradigm of an EntityStore
280 281 282 283
data DBParadigm = SQL
                | DocumentStore
                  deriving (Eq, Show, Read)

MrMan's avatar
MrMan committed
284
-- | Types that are insertable under some database paradigm p
MrMan's avatar
MrMan committed
285 286
class Insertable (p :: DBParadigm) entity where
    getInsertInfo :: EntityInsertInfo p entity
287

MrMan's avatar
MrMan committed
288
-- | Insertion information for some type that is insertable under database paradigm p
MrMan's avatar
MrMan committed
289 290 291
data EntityInsertInfo (p :: DBParadigm) entity where
    SQLEII           :: TableName -> SQLColumnNames -> SQLValueGetters entity -> EntityInsertInfo 'SQL entity
    DocumentStoreEII :: TableName -> EntityInsertInfo 'DocumentStore entity
292

293
-- | Generalized typeclass for entity storage.
294
class EntityStore (readable :: Type -> Constraint) (paradigm :: DBParadigm) store where
MrMan's avatar
MrMan committed
295
    create :: forall (entity :: FBounded) (ident :: Identifier).
296 297 298 299 300
              (Insertable paradigm (Complete entity),
               readable (Complete entity))
              => store
                 -> Validated (Complete entity)
                 -> IO (Either EntityStoreError (WithID ident (Complete entity)))
301 302 303 304 305 306 307 308 309

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