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

module Types where

MrMan's avatar
MrMan committed
21
import           Data.HashMap.Lazy (insert)
22
import           GHC.Generics (Generic)
MrMan's avatar
MrMan committed
23
import           Data.Aeson (FromJSON(..), ToJSON(..), (.=), Value(..), object)
24
import           Control.Monad.Trans.Reader (ReaderT(..))
MrMan's avatar
MrMan committed
25
import           Data.Bifunctor (second)
26
import           Data.Kind(Type, Constraint)
27
import           Config (AppConfig, CompleteTaskStoreConfig)
28
import           Control.Exception (throw, Exception)
MrMan's avatar
MrMan committed
29 30
import           Data.Either (isRight)
import           Data.Functor.Identity (Identity(..))
31 32 33 34 35 36
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
37
import           Database.SQLite.Simple (SQLData, ToRow, FromRow)
38
import           Servant (Handler)
MrMan's avatar
MrMan committed
39 40 41 42

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

MrMan's avatar
MrMan committed
46

47
instance ToJSON TaskState
MrMan's avatar
MrMan committed
48 49

-- Newtypes preventing careless
MrMan's avatar
MrMan committed
50 51 52
type TaskName = DT.Text
type TaskDesc = DT.Text
type TaskStateValue = DT.Text
53

MrMan's avatar
MrMan committed
54 55 56
validTaskStateValues :: [TaskStateValue]
validTaskStateValues = ["Finished", "InProgress", "NotStarted"]

MrMan's avatar
MrMan committed
57 58 59 60 61 62 63 64 65
type Partial a = a Maybe
type Complete a = a Identity

data Task = Task { tName  :: TaskName
                 , tDesc  :: TaskDesc
                 , tState :: TaskStateValue
                 } deriving (Eq, Show, Read, Generic)

instance ToJSON Task
MrMan's avatar
MrMan committed
66
instance FromJSON Task
MrMan's avatar
MrMan committed
67 68 69 70 71 72 73 74

data TaskF f = TaskF { tfName  :: f TaskName
                     , tfDesc  :: f TaskDesc
                     , tfState :: f TaskStateValue
                     }

deriving instance Eq (Complete TaskF)
deriving instance Show (Complete TaskF)
MrMan's avatar
MrMan committed
75 76 77 78
deriving instance Generic (Complete TaskF)

instance ToJSON (Complete TaskF)
instance FromJSON (Complete TaskF)
MrMan's avatar
MrMan committed
79

MrMan's avatar
MrMan committed
80 81
deriving instance Eq (Partial TaskF)
deriving instance Show (Partial TaskF)
MrMan's avatar
MrMan committed
82 83 84 85
deriving instance Generic (Partial TaskF)

instance ToJSON (Partial TaskF)
instance FromJSON (Partial TaskF)
86

MrMan's avatar
MrMan committed
87

MrMan's avatar
MrMan committed
88
-- The beefy task class
MrMan's avatar
MrMan committed
89 90 91 92
data TaskFInState (state :: TaskState) f where
    FinishedT :: f TaskName -> f TaskDesc -> TaskFInState 'Finished f
    InProgressT :: f TaskName -> f TaskDesc -> TaskFInState 'InProgress f
    NotStartedT :: f TaskName -> f TaskDesc -> TaskFInState 'NotStarted f
93 94 95 96 97

    -- | 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.
MrMan's avatar
MrMan committed
98
    UnknownStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> TaskFInState state f
MrMan's avatar
MrMan committed
99

MrMan's avatar
MrMan committed
100 101 102 103 104
    -- | Similar case, but for when we need to fix the state type variable to *something*
    SomeStateT :: f TaskName -> f TaskDesc -> f TaskStateValue -> TaskFInState 'Some f

deriving instance forall (state :: TaskState). Show (Complete (TaskFInState state))
deriving instance forall (state :: TaskState). Show (Partial (TaskFInState state))
105

MrMan's avatar
MrMan committed
106 107 108 109 110 111 112
instance forall (state :: TaskState). Eq (Complete (TaskFInState state)) where
    v1 == v2 = toTask v1 == toTask v2

-- Aliases for different task states
type FinishedTask = TaskFInState 'Finished
type InProgressTask = TaskFInState 'InProgress
type NotStartedTask = TaskFInState 'NotStarted
113

MrMan's avatar
MrMan committed
114 115 116 117
----------------
-- Validation --
----------------

MrMan's avatar
MrMan committed
118
type FieldName = DT.Text
MrMan's avatar
MrMan committed
119 120

data ValidationError = InvalidField FieldName
121
                     | MissingField FieldName
MrMan's avatar
MrMan committed
122 123 124
                     | WrongState DT.Text deriving (Eq, Show, Read, Generic)

instance ToJSON ValidationError
MrMan's avatar
MrMan committed
125

MrMan's avatar
MrMan committed
126 127 128
instance Exception ValidationError
instance Exception [ValidationError]

129
newtype Validated t = Validated { getValidatedObj :: t }
MrMan's avatar
MrMan committed
130 131 132 133 134 135

type ValidationCheck t = t -> Maybe ValidationError

class Validatable t where
    -- | Helper method to quickly determine of a type is valid
    isValid :: t -> Bool
MrMan's avatar
MrMan committed
136
    isValid = isRight . validate
MrMan's avatar
MrMan committed
137 138 139 140 141 142 143 144 145 146 147

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

MrMan's avatar
MrMan committed
148 149 150 151 152 153 154
-- | Utility function for converting a TaskFInState with some state into a regular Task
toTask :: forall (state :: TaskState). Complete (TaskFInState state) -> Task
toTask (NotStartedT (Identity name) (Identity desc)) = Task name desc "NotStarted"
toTask (InProgressT (Identity name) (Identity desc)) = Task name desc "InProgress"
toTask (FinishedT (Identity name) (Identity desc)) = Task name desc "Finished"
toTask (UnknownStateT (Identity name) (Identity desc) (Identity state)) = Task name desc state
toTask (SomeStateT (Identity name) (Identity desc) (Identity state)) = Task name desc state
MrMan's avatar
MrMan committed
155

MrMan's avatar
MrMan committed
156 157 158
toTaskFromF :: Complete TaskF -> Task
toTaskFromF (TaskF (Identity name) (Identity desc) (Identity stateValue)) = Task name desc stateValue

MrMan's avatar
MrMan committed
159
taskNameField :: FieldName
MrMan's avatar
MrMan committed
160
taskNameField = "name"
MrMan's avatar
MrMan committed
161 162

taskDescField :: FieldName
MrMan's avatar
MrMan committed
163
taskDescField = "description"
MrMan's avatar
MrMan committed
164

MrMan's avatar
MrMan committed
165 166 167 168 169 170 171 172 173 174 175 176 177 178 179 180 181
-- | Helper function to access task name for fully specified task
fsTaskName :: forall (state :: TaskState). Complete (TaskFInState state) -> DT.Text
fsTaskName (FinishedT (Identity name) _) = DT.strip name
fsTaskName (InProgressT (Identity name) _) = DT.strip name
fsTaskName (NotStartedT (Identity name) _) = DT.strip name
fsTaskName (UnknownStateT (Identity name) _ _) = DT.strip name
fsTaskName (SomeStateT (Identity name) _ _) = DT.strip name

-- | Helper function to access task desc for fully specified task
fsTaskDesc :: forall (state :: TaskState). Complete (TaskFInState state) -> DT.Text
fsTaskDesc (FinishedT _ (Identity desc)) = DT.strip desc
fsTaskDesc (InProgressT _ (Identity desc)) = DT.strip desc
fsTaskDesc (NotStartedT _ (Identity desc)) = DT.strip desc
fsTaskDesc (UnknownStateT _ (Identity desc) _) = DT.strip desc
fsTaskDesc (SomeStateT _ (Identity desc) _) = DT.strip desc

showState :: forall (state :: TaskState) (f :: Type -> Type). TaskFInState state f -> String
182 183 184 185
showState (FinishedT _ _) = "Finished"
showState (InProgressT _ _) = "InProgress"
showState (NotStartedT _ _) = "NotStarted"

MrMan's avatar
MrMan committed
186

MrMan's avatar
MrMan committed
187
instance Validatable (Complete (TaskFInState state)) where
MrMan's avatar
MrMan committed
188 189
    validationChecks = [checkName, checkDescription]
        where
MrMan's avatar
MrMan committed
190
          checkName :: (Complete (TaskFInState state)) -> Maybe ValidationError
MrMan's avatar
MrMan committed
191 192
          checkName t = if DT.null (fsTaskName t) then Just (InvalidField taskNameField) else Nothing

MrMan's avatar
MrMan committed
193
          checkDescription :: (Complete (TaskFInState state)) -> Maybe ValidationError
MrMan's avatar
MrMan committed
194 195
          checkDescription t = if DT.null (fsTaskDesc t) then Just (InvalidField taskDescField) else Nothing

MrMan's avatar
MrMan committed
196 197 198 199
pTaskName :: Partial (TaskFInState state) -> Maybe DT.Text
pTaskName (FinishedT name _) = DT.strip <$> name
pTaskName (InProgressT name _) = DT.strip <$> name
pTaskName (NotStartedT name _) = DT.strip <$> name
MrMan's avatar
MrMan committed
200

MrMan's avatar
MrMan committed
201 202 203 204
pTaskDesc :: forall (state :: TaskState). Partial (TaskFInState state) -> Maybe DT.Text
pTaskDesc (FinishedT _ desc) = DT.strip <$> desc
pTaskDesc (InProgressT _ desc) = DT.strip <$> desc
pTaskDesc (NotStartedT _ desc) = DT.strip <$> desc
MrMan's avatar
MrMan committed
205

MrMan's avatar
MrMan committed
206
nonEmptyIfPresent :: FieldName -> DT.Text -> Maybe ValidationError
MrMan's avatar
MrMan committed
207 208 209 210
nonEmptyIfPresent fieldname v = if DT.null v then Just (InvalidField fieldname) else Nothing

enumStrIfPresent :: [DT.Text] -> FieldName -> DT.Text -> Maybe ValidationError
enumStrIfPresent validValues fieldname v = if not (elem v validValues) then Just (InvalidField fieldname) else Nothing
MrMan's avatar
MrMan committed
211

MrMan's avatar
MrMan committed
212
instance Validatable (Partial (TaskFInState state)) where
MrMan's avatar
MrMan committed
213 214
    validationChecks = [checkName, checkDescription]
        where
MrMan's avatar
MrMan committed
215
          checkName :: Partial (TaskFInState state) -> Maybe ValidationError
MrMan's avatar
MrMan committed
216
          checkName = maybe Nothing (nonEmptyIfPresent taskNameField) . pTaskName
MrMan's avatar
MrMan committed
217

MrMan's avatar
MrMan committed
218
          checkDescription :: Partial (TaskFInState state) -> Maybe ValidationError
MrMan's avatar
MrMan committed
219
          checkDescription = maybe Nothing (nonEmptyIfPresent taskDescField) . pTaskDesc
220

MrMan's avatar
MrMan committed
221 222 223 224 225 226 227 228 229 230 231 232
instance Validatable (Partial TaskF) where
    validationChecks = [nonEmptyName, nonEmptyDesc, validState]
        where
          nonEmptyName :: Partial TaskF -> Maybe ValidationError
          nonEmptyName = maybe Nothing (nonEmptyIfPresent taskNameField) . tfName

          nonEmptyDesc :: Partial TaskF -> Maybe ValidationError
          nonEmptyDesc = maybe Nothing (nonEmptyIfPresent taskDescField) . tfDesc

          validState :: Partial TaskF -> Maybe ValidationError
          validState = maybe Nothing (enumStrIfPresent validTaskStateValues taskDescField) . tfState

MrMan's avatar
MrMan committed
233 234 235 236 237 238 239 240 241 242 243 244
instance Validatable Task where
    validationChecks = [nonEmptyName, nonEmptyDesc, validState]
        where
          nonEmptyName :: Task -> Maybe ValidationError
          nonEmptyName = maybe Nothing (nonEmptyIfPresent taskNameField) . Just . tName

          nonEmptyDesc :: Task -> Maybe ValidationError
          nonEmptyDesc = maybe Nothing (nonEmptyIfPresent taskDescField) . Just . tDesc

          validState :: Task -> Maybe ValidationError
          validState = maybe Nothing (enumStrIfPresent validTaskStateValues taskDescField) . Just . tState

245 246 247 248 249
----------------
-- Components --
----------------

class Component c where
250 251 252 253 254
    start  :: c -> IO ()
    stop   :: c -> IO ()

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

MrMan's avatar
MrMan committed
256
data WithUUID a = WUUID UUID a deriving (Eq, Show, Read)
257

MrMan's avatar
MrMan committed
258 259 260
instance Functor WithUUID where
    fmap f (WUUID uuid a) = WUUID uuid (f a)

MrMan's avatar
MrMan committed
261 262 263 264 265 266
instance ToJSON a => ToJSON (WithUUID a) where
    toJSON (WUUID uuid obj) = case toJSON obj of
                                obj@(Object map) -> Object $ insert "uuid" (String uuidTxt) map
                                v -> object ["uuid" .= uuid, "data" .= v]
        where
          uuidTxt = toText uuid
MrMan's avatar
MrMan committed
267

268 269 270 271 272
-- | 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
273 274 275 276 277 278 279 280 281 282 283 284 285 286 287 288 289 290 291 292

-- | 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
293
    } deriving (Eq, Show)
294 295 296 297 298 299 300 301 302 303 304 305

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

306
class HasMigratableDB store where
307 308 309 310 311 312 313 314 315 316 317 318 319 320 321 322 323 324
    -- | 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 ())
325

MrMan's avatar
MrMan committed
326
data EntityStoreError = NoSuchEntityES UUID DT.Text
327 328 329
                      | UnexpectedErrorES DT.Text
                      | DisconnectedES DT.Text
                      | ConnectionFailureES DT.Text
MrMan's avatar
MrMan committed
330
                      | UnsupportedOperationES DT.Text
331 332
                        deriving (Eq, Show, Read)

MrMan's avatar
MrMan committed
333 334
instance Exception EntityStoreError

335 336
newtype TableName entity = TN { getTableName :: DT.Text } deriving (Eq, Show, Read)
newtype SQLColumnNames entity = SQLCN { getColumnNames :: [DT.Text] } deriving (Eq, Show, Read)
MrMan's avatar
MrMan committed
337
type SQLColumnName = DT.Text
338

339 340 341
class ToRow entity => SQLInsertable entity where
    tableName    :: TableName entity
    columnNames  :: SQLColumnNames entity
342

343
-- | Alias for the kind of types with a functor applied to one or more fields (this is be F bounded polymorphism, I think)
344 345 346
--   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
347 348 349 350 351 352 353 354 355 356 357 358 359 360 361 362
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)]

363 364 365 366 367 368
data DeletionMode e = Soft
                    | Hard deriving (Eq, Show, Read)

class SQLDeletable entity where
    deletionMode :: DeletionMode entity

369
-- | Generalized typeclass for entity storage.
370 371
class SQLEntityStore store where
    -- | Create an entity
MrMan's avatar
MrMan committed
372
    create :: forall entity.
MrMan's avatar
MrMan committed
373 374 375
              ( SQLInsertable entity
              , SQLInsertable (WithUUID entity)
              , FromRow (WithUUID entity)
376 377
              )
             => store
MrMan's avatar
MrMan committed
378 379
                 -> Validated entity
                 -> IO (Either EntityStoreError (WithUUID entity))
380 381

    -- | Get an entity by ID
MrMan's avatar
MrMan committed
382
    getByUUID :: forall entity.
MrMan's avatar
MrMan committed
383 384
              ( SQLInsertable entity
              , FromRow (WithUUID entity)
MrMan's avatar
MrMan committed
385
              )
386
              => store
MrMan's avatar
MrMan committed
387
                 -> UUID
MrMan's avatar
MrMan committed
388
                 -> IO (Either EntityStoreError (WithUUID entity))
389 390

    -- | Update an existing entity by ID
MrMan's avatar
MrMan committed
391
    updateByUUID :: forall (entity :: FBounded).
MrMan's avatar
MrMan committed
392 393
                  ( SQLInsertable (Complete entity)
                  , SQLUpdatable (Partial entity)
MrMan's avatar
MrMan committed
394 395
                  , FromRow (Complete entity)
                  )
396
                 => store
MrMan's avatar
MrMan committed
397
                     -> UUID
398
                     -> Validated (Partial entity)
MrMan's avatar
MrMan committed
399
                     -> IO (Either EntityStoreError (WithUUID (Complete entity)))
400 401

    -- | Delete an entity by ID
MrMan's avatar
MrMan committed
402 403
    deleteByUUID :: forall entity.
                  ( SQLInsertable entity
404
                  , SQLDeletable entity
MrMan's avatar
MrMan committed
405 406
                  , FromRow entity
                  )
407
                 => store
MrMan's avatar
MrMan committed
408 409
                     -> UUID
                     -> IO (Either EntityStoreError entity)
410

411
    -- | Get a listing of all entities
MrMan's avatar
MrMan committed
412 413 414 415
    list :: forall entity.
            ( SQLInsertable entity
            , FromRow entity
            )
416
           => store
MrMan's avatar
MrMan committed
417
               -> IO (Either EntityStoreError [entity])
418

419 420 421 422 423 424 425 426 427 428 429 430
-- | 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
431 432 433

data Entity where
    TaskE :: TaskName -> Entity