Commit f3bf8daf authored by MrMan's avatar MrMan

Merge branch 'part-3'

parents 01e3551c a46c6ae0
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE RecordWildCards #-}
module Main where
import Config (AppConfig, Host, Port, ProcessEnvironment(..), makeAppConfig)
import Components.EntityStore.SQLite
import Config (AppConfig(..), EntityStoreConfig, Host, Port, ProcessEnvironment(..), makeAppConfig)
import Control.Monad (join)
import Data.Functor.Identity
import Data.Semigroup ((<>))
import Lib
import Network.Wai.Handler.Warp (run)
import Options.Applicative
import Server (buildApp)
import System.Environment (getEnvironment)
import Text.Pretty.Simple (pPrint)
import Types
import Util (rightOrThrow)
data Options = Options
{ cfgPath :: Maybe FilePath
......@@ -59,12 +66,37 @@ showConfig Options{cfgPath=path} = pullEnvironment
runServer :: Options -> IO ()
runServer Options{cfgPath=path} = pullEnvironment
>>= makeAppConfig path
>> server
>>= 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 :: IO ()
server = putStrLn "<SERVER START>"
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 "test") (Identity "test description")
entityStoreCfg = runIdentity $ entityStoreConfig cfg
appPort = runIdentity $ port cfg
startApp state = putStrLn ("Starting server at port [" <> show appPort <> "]...")
>> run appPort (buildApp state)
main :: IO ()
main = parseOptions
......
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE TypeOperators #-}
{-# LANGUAGE KindSignatures #-}
{-# LANGUAGE ExplicitForAll #-}
{-# LANGUAGE ImpredicativeTypes #-}
{-# LANGUAGE FlexibleInstances #-}
module Server
(buildApp)
where
import Components.EntityStore.SQLite
import Control.Exception (Exception)
import Control.Monad.IO.Class (liftIO)
import Control.Monad.Trans.Reader (ask)
import Data.Aeson (ToJSON(..))
import Data.Maybe (isJust, fromJust)
import Data.Proxy
import Data.Semigroup ((<>))
import Data.UUID (UUID)
import Database.SQLite.Simple (FromRow)
import Servant.API
import Servant (throwError)
import Servant.Server (ServerT, Application, ServantErr(..), serve, hoistServer, err500, err400)
import Types
import qualified Data.ByteString.Lazy.Char8 as DBL8
import qualified Data.Text as DT
type Name = DT.Text
type Greeting = DT.Text
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
todoAPI :: Proxy TodoAPI
todoAPI = Proxy
buildApp :: AppState -> Application
buildApp state = serve todoAPI $ hoistServer todoAPI naturalTransform todoServer
where
naturalTransform = appToServantHandler state
-- | Ensure that an Either resolves to it's Right value
rightOrServantErr :: Exception a => ServantErr -> Either a b -> AppHandler b
rightOrServantErr err (Left _) = throwError err
rightOrServantErr _ (Right v) = return v
-- | Ensure that an Either resolves to it's Right value
rightOrConvertToServantErr :: (Exception err, ServableError err) => Either err b -> AppHandler b
rightOrConvertToServantErr (Left err) = throwError $ toServantError err
rightOrConvertToServantErr (Right v) = return v
genericServerError :: ServantErr
genericServerError = err500 { errBody = "Unexpected server error" }
makeValidationErr :: [ValidationError] -> ServantErr
makeValidationErr verrs = err400 { errBody = "Validation errors occurred:\n " <> DBL8.pack (show verrs) }
class ServableError err where
toServantError :: err -> ServantErr
instance ServableError EntityStoreError where
toServantError (UnexpectedErrorES txt) = err500 { errBody = DBL8.pack (DT.unpack txt) }
toServantError _ = err500 { errBody = "Unexpected error" }
instance ServableError [ValidationError] where
toServantError errs = makeValidationErr errs
......@@ -35,6 +35,9 @@ library:
- uuid
- sqlite-simple
- neat-interpolation
- transformers
- unordered-containers
- bytestring
executables:
haskell-restish-todo-exe:
......@@ -48,6 +51,15 @@ executables:
- haskell-restish-todo
- optparse-applicative
- pretty-simple
- text
- servant
- servant-server
- warp
- transformers
- aeson
- sqlite-simple
- bytestring
- uuid
tests:
haskell-restish-todo-test:
......@@ -81,3 +93,4 @@ tests:
dependencies:
- haskell-restish-todo
- hspec
- uuid
# HLint configuration file
##########################
- arguments: [--color]
- functions:
- {name: unsafePerformIO, within: []} # unsafePerformIO can only appear in no modules
- ignore: {name: Use fmap}
- ignore: {name: Use <$>}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Components.TaskStore.Migrations.SQLite where
module Components.EntityStore.Migrations.SQLite where
import NeatInterpolation (text)
import Types (SQLMigration(..), SQLMigrationQuery(..))
......
......@@ -37,8 +37,11 @@ defaultPort = 5000
defaultTaskStoreFilePath :: FilePath
defaultTaskStoreFilePath = ":memory:"
defaultEntityStoreFilePath :: FilePath
defaultEntityStoreFilePath = ":memory:"
type Host = String
type Port = Integer
type Port = Int
newtype ProcessEnvironment = ProcessEnvironment {getProcessEnv :: [(String, String)]} deriving (Eq)
data ConfigurationError = ConfigParseError String
......@@ -55,6 +58,7 @@ data AppConfig f = AppConfig
{ host :: f Host
, port :: f Port
, taskStoreConfig :: f (TaskStoreConfig f)
, entityStoreConfig :: f (EntityStoreConfig f)
}
type CompleteAppConfig = AppConfig Identity
......@@ -73,21 +77,23 @@ instance Semigroup CompleteAppConfig where
a <> b = b
instance Monoid CompleteAppConfig where
mempty = AppConfig (Identity defaultHost) (Identity defaultPort) (Identity mempty)
mempty = AppConfig (Identity defaultHost) (Identity defaultPort) (Identity mempty) (Identity mempty)
instance Semigroup PartialAppConfig where
a <> b = AppConfig { host=resolveMaybes host
, port=resolveMaybes port
, taskStoreConfig=resolveMaybes taskStoreConfig
, entityStoreConfig=resolveMaybes entityStoreConfig
}
where
resolveMaybes :: (PartialAppConfig -> Maybe a) -> Maybe a
resolveMaybes getter = getter b <|> getter a
instance Monoid PartialAppConfig where
mempty = AppConfig Nothing Nothing Nothing
mempty = AppConfig Nothing Nothing Nothing Nothing
newtype TaskStoreConfig f = TaskStoreConfig { tscDBFilePath :: f FilePath }
newtype EntityStoreConfig f = EntityStoreConfig { escDBFilePath :: f FilePath }
type CompleteTaskStoreConfig = TaskStoreConfig Identity
deriving instance Generic CompleteTaskStoreConfig
......@@ -101,6 +107,18 @@ deriving instance Eq PartialTaskStoreConfig
deriving instance Show PartialTaskStoreConfig
deriving instance FromJSON PartialTaskStoreConfig
type CompleteEntityStoreConfig = EntityStoreConfig Identity
deriving instance Generic CompleteEntityStoreConfig
deriving instance Eq CompleteEntityStoreConfig
deriving instance Show CompleteEntityStoreConfig
deriving instance FromJSON CompleteEntityStoreConfig
type PartialEntityStoreConfig = EntityStoreConfig Maybe
deriving instance Generic PartialEntityStoreConfig
deriving instance Eq PartialEntityStoreConfig
deriving instance Show PartialEntityStoreConfig
deriving instance FromJSON PartialEntityStoreConfig
instance Semigroup CompleteTaskStoreConfig where
a <> b = b
......@@ -116,6 +134,21 @@ instance Semigroup PartialTaskStoreConfig where
instance Monoid PartialTaskStoreConfig where
mempty = TaskStoreConfig Nothing
instance Semigroup CompleteEntityStoreConfig where
a <> b = b
instance Monoid CompleteEntityStoreConfig where
mempty = EntityStoreConfig (Identity defaultEntityStoreFilePath)
instance Semigroup PartialEntityStoreConfig where
a <> b = EntityStoreConfig { escDBFilePath=resolveMaybes escDBFilePath }
where
resolveMaybes :: (PartialEntityStoreConfig -> Maybe a) -> Maybe a
resolveMaybes getter = getter a <|> getter b
instance Monoid PartialEntityStoreConfig where
mempty = EntityStoreConfig Nothing
----------
-- JSON --
----------
......@@ -161,6 +194,7 @@ instance FromENV PartialAppConfig where
fromENV pEnv = AppConfig { host=prop "TODO_HOST"
, port=readMaybe =<< prop "TODO_PORT"
, taskStoreConfig=Just $ fromENV pEnv
, entityStoreConfig=Just $ fromENV pEnv
}
where
prop :: String -> Maybe String
......@@ -172,6 +206,12 @@ instance FromENV PartialTaskStoreConfig where
prop :: String -> Maybe String
prop = flip lookup (getProcessEnv pEnv)
instance FromENV PartialEntityStoreConfig where
fromENV pEnv = EntityStoreConfig { escDBFilePath=prop "ENTITY_STORE_FILE_PATH" }
where
prop :: String -> Maybe String
prop = flip lookup (getProcessEnv pEnv)
-- | The class of configurations that can absorb partials of themselves to maintain a whole
class AbsorbPartial complete partial where
absorbPartial :: complete -> partial -> complete
......@@ -181,15 +221,23 @@ instance AbsorbPartial CompleteAppConfig PartialAppConfig where
absorbPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
, taskStoreConfig = Identity $ absorbPartial tsc maybeTSC
, entityStoreConfig = Identity $ absorbPartial esc maybeESC
}
where
tsc = runIdentity $ taskStoreConfig c
maybeTSC = fromMaybe mempty $ taskStoreConfig p
esc = runIdentity $ entityStoreConfig c
maybeESC = fromMaybe mempty $ entityStoreConfig p
instance AbsorbPartial CompleteTaskStoreConfig PartialTaskStoreConfig where
absorbPartial :: CompleteTaskStoreConfig -> PartialTaskStoreConfig -> CompleteTaskStoreConfig
absorbPartial c p = TaskStoreConfig { tscDBFilePath = maybe (tscDBFilePath c) Identity (tscDBFilePath p) }
instance AbsorbPartial CompleteEntityStoreConfig PartialEntityStoreConfig where
absorbPartial :: CompleteEntityStoreConfig -> PartialEntityStoreConfig -> CompleteEntityStoreConfig
absorbPartial c p = EntityStoreConfig { escDBFilePath = maybe (escDBFilePath c) Identity (escDBFilePath p) }
buildConfigWithDefault :: CompleteAppConfig -> [PartialAppConfig] -> CompleteAppConfig
buildConfigWithDefault orig partials = orig `absorbPartial` combinedPartials
where
......@@ -208,6 +256,10 @@ defaultCompleteAppConfig = mempty
defaultCompleteTaskStoreConfig :: CompleteTaskStoreConfig
defaultCompleteTaskStoreConfig = mempty
-- | The default configuration *is* a fully specified complete app config @ mempty state
defaultCompleteEntityStoreConfig :: CompleteEntityStoreConfig
defaultCompleteEntityStoreConfig = mempty
-- | The default partially specified configuration is mempty
defaultPartialAppConfig :: PartialAppConfig
defaultPartialAppConfig = mempty
......
This diff is collapsed.
module Util where
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE FlexibleInstances #-}
{-# LANGUAGE DeriveGeneric #-}
import Control.Exception (Exception, throw)
module Util
( rightOrThrow )
where
import Control.Exception (Exception, throw)
-- | Ensure that an Either resolves to it's Right value
rightOrThrow :: (Exception a) => Either a b -> IO b
......
{-# LANGUAGE LambdaCase #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE DataKinds #-}
{-# LANGUAGE GADTs #-}
module Components.EntityStore.SQLiteSpec (spec) where
import Components.EntityStore.SQLite (SQLiteEntityStore)
import Control.Monad (when)
import Types
import Data.Either (isLeft)
import Data.Functor.Identity
import Config (defaultCompleteEntityStoreConfig)
import Data.Either (isRight)
import Control.Monad.IO.Class (liftIO)
import Util (rightOrThrow)
import Data.UUID (toText)
import Test.Hspec
makeDefaultStore :: IO (Either EntityStoreError SQLiteEntityStore)
makeDefaultStore = construct defaultCompleteEntityStoreConfig
-- generateTask :: IO (Validated NotStartedTask)
generateTask :: IO (Validated (Complete NotStartedTask))
generateTask = rightOrThrow $ validate $ NotStartedT name desc
where
name = Identity "example"
desc = Identity "this is a example task"
generateTaskNameUpdate :: IO (Validated (Partial NotStartedTask))
generateTaskNameUpdate = rightOrThrow $ validate $ NotStartedT (Just "updated name") Nothing
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "entity store creation" $
it "works with the default config" $ \_ -> liftIO makeDefaultStore
>>= (`shouldBe` True) . isRight
describe "entity store migration" $
it "migrates with the default config (0 -> 1)" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= liftIO . migrate
>>= shouldBe (Right ())
describe "entity store create" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> (create store expected :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>>= \(WUUID uuid task) -> pure (toText uuid /= "" && task == getValidatedObj expected)
>>= (`shouldBe` True)
describe "entity store update" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \original -> (create store original :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= rightOrThrow
-- | Generate and perform update
>>= \expected@(WUUID uuid _) -> generateTaskNameUpdate
>>= updateByUUID store uuid
>>= rightOrThrow
-- | The task should have changed
>>= \returned@(WUUID uuid task) -> pure (toText uuid /= "" && returned /= expected)
>>= (`shouldBe` True)
describe "entity store delete" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
-- | Create a task
>>= \original -> create store original
>>= rightOrThrow
-- | Delete the created task right after creating it
>>= \(WUUID uuid _) -> (deleteByUUID store uuid :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= rightOrThrow
-- | Ensure task returned by the deletion matches created one
>>= \(WUUID _ obj) -> when (obj /= getValidatedObj original) (error "returned deleted object mismatch")
-- | Ensure that a get with the deleted item's ID fails (produces a Left value)
>> (getByUUID store uuid :: IO (Either EntityStoreError (WithUUID (Complete NotStartedTask))))
>>= (`shouldSatisfy` isLeft)
describe "entity store list" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> create store expected
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>> (list store :: IO (Either EntityStoreError [WithUUID Task]))
>>= rightOrThrow
>>= (`shouldBe` 1) . length
{-# LANGUAGE OverloadedStrings #-}
module Components.TaskStore.SQLiteSpec (spec) where
import Components.TaskStore.SQLite (SQLiteTaskStore)
import Types ( Constructable(..)
, HasMigratableDB(..)
, ValidationError
, TaskStore(..)
, TaskStoreError
, SQLMigrationVersion(..)
, Validated
, Validatable(..)
, FullySpecifiedTask
, NotStartedTask
, TaskState(..)
, Task(..)
, TaskName(..)
, TaskDesc(..)
, WithID
, withoutID
, showID
, getValidatedObj
)
import Data.Functor.Identity
import Config (defaultCompleteTaskStoreConfig)
import Data.Either (isRight)
import Control.Monad.IO.Class (liftIO)
import Util (rightOrThrow)
import Test.Hspec
makeDefaultStore :: IO (Either TaskStoreError SQLiteTaskStore)
makeDefaultStore = construct defaultCompleteTaskStoreConfig
-- generateTask :: IO (Validated NotStartedTask)
generateTask :: IO (Validated (Task Identity TaskState))
generateTask = rightOrThrow $ validate Task { tName = Identity $ TaskName "example"
, tDescription = Identity $ TaskDesc "this is a example task"
, tState = Identity NotStarted
}
main :: IO ()
main = hspec spec
spec :: Spec
spec = do
describe "task store creation" $
it "works with the default config" $ \_ -> liftIO makeDefaultStore
>>= (`shouldBe` True) . isRight
describe "task store migration" $
it "migrates with the default config (0 -> 1)" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= liftIO . migrate
>>= shouldBe (Right ())
describe "task store persistTask" $
it "works with default config" $ \_ -> liftIO makeDefaultStore
>>= rightOrThrow
>>= \store -> migrate store
>> generateTask
>>= \expected -> persistTask store expected
>>= rightOrThrow
-- | Ensure that the ID is non-empty when printed, and the object we got back is right
>>= \actualWithID -> pure (showID actualWithID /= "" && withoutID actualWithID == getValidatedObj expected)
>>= shouldBe True
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment