diff options
Diffstat (limited to 'Hero/Server.hs')
-rw-r--r-- | Hero/Server.hs | 35 |
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 |