Commit 01e3551c authored by MrMan's avatar MrMan

Merge branch 'part-2' into 'master'

Part 2

See merge request !1
parents a0f584ce ec332515
......@@ -32,6 +32,9 @@ library:
- aeson
- bytestring
- system-filepath
- uuid
- sqlite-simple
- neat-interpolation
executables:
haskell-restish-todo-exe:
......@@ -67,3 +70,14 @@ tests:
dependencies:
- haskell-restish-todo
- hspec
int:
main: Spec.hs
source-dirs: test/Integration
ghc-options:
- -threaded
- -rtsopts
- -with-rtsopts=-N
dependencies:
- haskell-restish-todo
- hspec
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE OverloadedStrings #-}
module Components.TaskStore.Migrations.SQLite where
import NeatInterpolation (text)
import Types (SQLMigration(..), SQLMigrationQuery(..))
migrations :: [SQLMigration]
migrations =
[SQLMigration
{ smFrom=0
, smTo=1
, smQuery=
SQLMigrationQuery
[text|
CREATE TABLE tasks(
uuid TEXT PRIMARY KEY NOT NULL,
name TEXT NOT NULL,
description TEXT NOT NULL,
state TEXT NOT NULL
);
|]
}
]
This diff is collapsed.
......@@ -3,27 +3,39 @@
{-# LANGUAGE DeriveGeneric #-}
{-# LANGUAGE DeriveAnyClass #-}
{-# LANGUAGE StandaloneDeriving #-}
{-# LANGUAGE MultiParamTypeClasses #-}
{-# LANGUAGE InstanceSigs #-}
module Config where
import Data.Monoid
import Control.Exception (Exception, try, throw)
import Filesystem.Path as FP
import Filesystem.Path.CurrentOS as FPCOS
import Control.Applicative ((<|>))
import Control.Monad (join, when)
import Data.Maybe (fromMaybe, isJust)
import Data.Aeson (FromJSON(parseJSON), toJSON, eitherDecode)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Lazy as DBL
import Data.Functor.Identity
import Data.Text.IO as DTI
import Data.Text as DT
import GHC.Generics
import Text.Parsec.Error (ParseError)
import Text.Read (readMaybe)
import Text.Toml (parseTomlDoc)
import Control.Applicative ((<|>))
import Control.Exception (Exception, try, throw)
import Control.Monad (join, when)
import Data.Aeson (FromJSON(parseJSON), toJSON, eitherDecode)
import Data.Aeson.Types (parseEither)
import Data.Bifunctor (bimap, first, second)
import Data.ByteString.Lazy as DBL
import Data.Functor.Identity
import Data.Maybe (fromMaybe, isJust)
import Data.Monoid
import Data.Text as DT
import Data.Text.IO as DTI
import GHC.Generics
import Text.Parsec.Error (ParseError)
import Text.Read (readMaybe)
import Text.Toml (parseTomlDoc)
import Util (rightOrThrow)
import qualified Filesystem.Path as FP
import qualified Filesystem.Path.CurrentOS as FPCOS
defaultHost :: Host
defaultHost = "localhost"
defaultPort :: Port
defaultPort = 5000
defaultTaskStoreFilePath :: FilePath
defaultTaskStoreFilePath = ":memory:"
type Host = String
type Port = Integer
......@@ -40,8 +52,9 @@ deriving instance Exception ConfigurationError
-- | Parametric polymorphism over type f (e.g. `Identity` or `Maybe`)
data AppConfig f = AppConfig
{ host :: f Host
, port :: f Port
{ host :: f Host
, port :: f Port
, taskStoreConfig :: f (TaskStoreConfig f)
}
type CompleteAppConfig = AppConfig Identity
......@@ -56,28 +69,52 @@ deriving instance Eq PartialAppConfig
deriving instance Show PartialAppConfig
deriving instance FromJSON PartialAppConfig
defaultHost :: Host
defaultHost = "localhost"
defaultPort :: Port
defaultPort = 5000
instance Semigroup CompleteAppConfig where
a <> b = b
instance Monoid CompleteAppConfig where
mempty = AppConfig (Identity defaultHost) (Identity defaultPort)
mempty = AppConfig (Identity defaultHost) (Identity defaultPort) (Identity mempty)
instance Semigroup PartialAppConfig where
a <> b = AppConfig { host=resolveMaybes host
, port=resolveMaybes port
, taskStoreConfig=resolveMaybes taskStoreConfig
}
where
resolveMaybes :: (PartialAppConfig -> Maybe a) -> Maybe a
resolveMaybes getter = maybe (getter a) Just (getter b)
resolveMaybes getter = getter b <|> getter a
instance Monoid PartialAppConfig where
mempty = AppConfig Nothing Nothing
mempty = AppConfig Nothing Nothing Nothing
newtype TaskStoreConfig f = TaskStoreConfig { tscDBFilePath :: f FilePath }
type CompleteTaskStoreConfig = TaskStoreConfig Identity
deriving instance Generic CompleteTaskStoreConfig
deriving instance Eq CompleteTaskStoreConfig
deriving instance Show CompleteTaskStoreConfig
deriving instance FromJSON CompleteTaskStoreConfig
type PartialTaskStoreConfig = TaskStoreConfig Maybe
deriving instance Generic PartialTaskStoreConfig
deriving instance Eq PartialTaskStoreConfig
deriving instance Show PartialTaskStoreConfig
deriving instance FromJSON PartialTaskStoreConfig
instance Semigroup CompleteTaskStoreConfig where
a <> b = b
instance Monoid CompleteTaskStoreConfig where
mempty = TaskStoreConfig (Identity defaultTaskStoreFilePath)
instance Semigroup PartialTaskStoreConfig where
a <> b = TaskStoreConfig { tscDBFilePath=resolveMaybes tscDBFilePath }
where
resolveMaybes :: (PartialTaskStoreConfig -> Maybe a) -> Maybe a
resolveMaybes getter = getter a <|> getter b
instance Monoid PartialTaskStoreConfig where
mempty = TaskStoreConfig Nothing
----------
-- JSON --
......@@ -123,31 +160,58 @@ class FromENV cfg where
instance FromENV PartialAppConfig where
fromENV pEnv = AppConfig { host=prop "TODO_HOST"
, port=readMaybe =<< prop "TODO_PORT"
, taskStoreConfig=Just $ fromENV pEnv
}
where
env :: [(String, String)]
env = getProcessEnv pEnv
prop :: String -> Maybe String
prop = flip lookup env
prop = flip lookup (getProcessEnv pEnv)
mergeInPartial :: CompleteAppConfig -> PartialAppConfig -> CompleteAppConfig
mergeInPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
}
instance FromENV PartialTaskStoreConfig where
fromENV pEnv = TaskStoreConfig { tscDBFilePath=prop "TASK_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
instance AbsorbPartial CompleteAppConfig PartialAppConfig where
absorbPartial :: CompleteAppConfig -> PartialAppConfig -> CompleteAppConfig
absorbPartial c p = AppConfig { host = maybe (host c) Identity (host p)
, port = maybe (port c) Identity (port p)
, taskStoreConfig = Identity $ absorbPartial tsc maybeTSC
}
where
tsc = runIdentity $ taskStoreConfig c
maybeTSC = fromMaybe mempty $ taskStoreConfig p
-- | Ensure that an Either resolves to it's Right value, ensure that a
rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(Right v) -> return v
instance AbsorbPartial CompleteTaskStoreConfig PartialTaskStoreConfig where
absorbPartial :: CompleteTaskStoreConfig -> PartialTaskStoreConfig -> CompleteTaskStoreConfig
absorbPartial c p = TaskStoreConfig { tscDBFilePath = maybe (tscDBFilePath c) Identity (tscDBFilePath p) }
buildConfigWithDefault :: CompleteAppConfig -> [PartialAppConfig] -> CompleteAppConfig
buildConfigWithDefault orig partials = orig `mergeInPartial` combinedPartials
buildConfigWithDefault orig partials = orig `absorbPartial` combinedPartials
where
combinedPartials :: PartialAppConfig
combinedPartials = Prelude.foldl (<>) (mempty :: PartialAppConfig) partials
-- | The default configuration *is* a fully specified complete app config @ mempty state
appConfigDefault :: CompleteAppConfig
appConfigDefault = mempty
-- | The default configuration *is* a fully specified complete app config @ mempty state
defaultCompleteAppConfig :: CompleteAppConfig
defaultCompleteAppConfig = mempty
-- | The default configuration *is* a fully specified complete app config @ mempty state
defaultCompleteTaskStoreConfig :: CompleteTaskStoreConfig
defaultCompleteTaskStoreConfig = mempty
-- | The default partially specified configuration is mempty
defaultPartialAppConfig :: PartialAppConfig
defaultPartialAppConfig = mempty
-- | Build an App configuration from a given file, using system environment as well as
makeAppConfig :: Maybe Prelude.FilePath -> ProcessEnvironment -> IO (Either ConfigurationError CompleteAppConfig)
makeAppConfig maybeStrPath env = try generateConfig
......@@ -173,11 +237,8 @@ makeAppConfig maybeStrPath env = try generateConfig
envCfg :: PartialAppConfig
envCfg = fromENV env :: PartialAppConfig
fullySpecifiedPartialCfg :: CompleteAppConfig
fullySpecifiedPartialCfg = mergeInPartial mempty mempty
buildFromEnv :: IO CompleteAppConfig
buildFromEnv = pure $ mergeInPartial fullySpecifiedPartialCfg envCfg
buildFromEnv = pure $ absorbPartial defaultCompleteAppConfig envCfg
getFileConfig :: FPCOS.FilePath -> IO (Either ConfigurationError PartialAppConfig)
getFileConfig = if isJSONFile then fromJSONFile else fromTOMLFile
......
This diff is collapsed.
module Util where
import Control.Exception (Exception, throw)
-- | Ensure that an Either resolves to it's Right value
rightOrThrow :: (Exception a) => Either a b -> IO b
rightOrThrow e = case e of
(Left err) -> throw err
(Right v) -> return v
{-# 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
{-# OPTIONS_GHC -F -pgmF hspec-discover #-}
......@@ -7,12 +7,6 @@ import Data.Functor.Identity
main :: IO ()
main = hspec spec
completeAppDefault :: CompleteAppConfig
completeAppDefault = C.defaultValue
partialAppDefault :: PartialAppConfig
partialAppDefault = C.defaultValue
spec :: Spec
spec = do
describe "defaults" $ do
......@@ -24,6 +18,11 @@ spec = do
describe "default values" $ do
it "CompleteAppConfig has default host" $
host completeAppDefault `shouldBe` Identity C.defaultHost
host C.defaultCompleteAppConfig `shouldBe` Identity C.defaultHost
it "CompleteAppConfig has default port" $
port completeAppDefault `shouldBe` Identity C.defaultPort
port C.defaultCompleteAppConfig `shouldBe` Identity C.defaultPort
it "PartialAppConfig has no default host" $
host C.defaultPartialAppConfig `shouldBe` Nothing
it "PartialAppconfig has no default port" $
port C.defaultPartialAppConfig `shouldBe` Nothing
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