summaryrefslogtreecommitdiff
path: root/Hero/Server.hs
diff options
context:
space:
mode:
Diffstat (limited to 'Hero/Server.hs')
-rw-r--r--Hero/Server.hs35
1 files changed, 21 insertions, 14 deletions
diff --git a/Hero/Server.hs b/Hero/Server.hs
index 4dc80f5..73108be 100644
--- a/Hero/Server.hs
+++ b/Hero/Server.hs
@@ -13,17 +13,19 @@
--
-- : exe mmc
--
+-- : dep acid-state
-- : dep aeson
-- : dep clay
-- : dep containers
--- : dep dhall
-- : dep envy
-- : dep http-types
+-- : dep ixset
-- : dep lucid
-- : dep miso
-- : dep mtl
-- : dep network-uri
-- : dep protolude
+-- : dep safecopy
-- : dep servant
-- : dep servant-lucid
-- : dep servant-server
@@ -40,6 +42,8 @@ module Hero.Server where
import qualified Clay
import Data.Aeson
+import Data.Acid (AcidState)
+import qualified Data.Acid.Abstract as Acid
import Data.Proxy
import Data.Text (Text)
import qualified Data.Text.Lazy as Lazy
@@ -74,13 +78,14 @@ main = bracket startup shutdown $ uncurry Warp.run
say = IO.hPutStrLn IO.stderr
startup = Envy.decodeEnv >>= \case
Left e -> Exit.die e
- Right c -> do
- db <- Database.dummy
+ Right cfg -> do
+ keep <- Database.openLocal (heroDataDir cfg)
say "hero"
- say $ "port: " ++ show (heroPort c)
- say $ "client: " ++ heroClient c
- let waiapp = app db c
- return (heroPort c, waiapp)
+ say $ "port: " ++ show (heroPort cfg)
+ say $ "client: " ++ heroClient cfg
+ say $ "data: " ++ heroDataDir cfg
+ let waiapp = app keep cfg
+ return (heroPort cfg, waiapp)
shutdown :: a -> IO a
shutdown = pure . identity
@@ -89,22 +94,24 @@ data Config
{ -- | HERO_PORT
heroPort :: Warp.Port,
-- | HERO_CLIENT
- heroClient :: FilePath
+ heroClient :: FilePath,
+ -- | HERO_DATA
+ heroDataDir :: FilePath
}
deriving (Generic, Show)
instance Envy.DefConfig Config where
- defConfig = Config 3000 "_bild/Hero.Client/static"
+ defConfig = Config 3000 "_bild/Hero.Client/static" "_keep"
instance Envy.FromEnv Config
-app :: Database.ComicDB -> Config -> Application
-app db cfg =
+app :: AcidState Database.HeroKeep -> Config -> Application
+app keep cfg =
serve
(Proxy @AllRoutes)
( static
:<|> cssHandlers
- :<|> jsonHandlers db
+ :<|> jsonHandlers keep
:<|> serverHandlers
:<|> pure heroManifest
:<|> Tagged handle404
@@ -272,8 +279,8 @@ serverHandlers =
:<|> discoverHandler
:<|> chooseExperienceHandler
-jsonHandlers :: Database.ComicDB -> Server JsonApi
-jsonHandlers = Database.getComics
+jsonHandlers :: AcidState Database.HeroKeep -> Server JsonApi
+jsonHandlers keep = Acid.query' keep $ Database.GetComics 10
homeHandler :: Handler (HtmlPage (View Action))
homeHandler = pure . HtmlPage . home $ initModel homeLink