From 78774e835ac0c564cf52a5e6dd0bf22b56761c4d Mon Sep 17 00:00:00 2001
From: Ben Sima <ben@bsima.me>
Date: Mon, 1 Jun 2020 22:22:13 -0700
Subject: Initialize Hero database
---
Hero/App.hs | 38 ++++++++++++++++----
Hero/Database.hs | 105 +++++++++++++++++++++++++++++++++++++++----------------
Hero/Server.hs | 35 +++++++++++--------
Hero/Service.nix | 6 ++++
4 files changed, 132 insertions(+), 52 deletions(-)
(limited to 'Hero')
diff --git a/Hero/App.hs b/Hero/App.hs
index a254d80..3aca8be 100644
--- a/Hero/App.hs
+++ b/Hero/App.hs
@@ -1,5 +1,7 @@
{-# LANGUAGE DataKinds #-}
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE DeriveGeneric #-}
+{-# LANGUAGE GeneralizedNewtypeDeriving #-}
{-# LANGUAGE OverloadedStrings #-}
{-# LANGUAGE QuasiQuotes #-}
{-# LANGUAGE RecordWildCards #-}
@@ -19,6 +21,7 @@ import Data.Aeson
genericParseJSON,
genericToJSON,
)
+import Data.Data (Data, Typeable)
import qualified Data.List as List
import qualified Data.List.Split as List
import Data.Proxy (Proxy (..))
@@ -39,6 +42,8 @@ import Servant.API
( (:<|>) (..),
(:>),
Capture,
+ ToHttpApiData,
+ FromHttpApiData,
URI (..),
safeLink,
)
@@ -62,7 +67,26 @@ onPreventClick action =
(\() -> action)
-- TODO: make ComicId a hashid https://hackage.haskell.org/package/hashids-1.0.2.4/docs/Web-Hashids.html
-type ComicId = String
+newtype ComicId
+ = ComicId String
+ deriving
+ ( Show,
+ Eq,
+ Ord,
+ Data,
+ Typeable,
+ Generic,
+ ToMisoString,
+ IsString,
+ ToHttpApiData,
+ FromHttpApiData
+ )
+
+instance ToJSON ComicId where
+ toJSON = genericToJSON Data.Aeson.defaultOptions
+
+instance FromJSON ComicId where
+ parseJSON = genericParseJSON Data.Aeson.defaultOptions
-- | Class for turning different string types to snakeCase.
class CanSnakeCase str where
@@ -84,7 +108,7 @@ data Comic
comicIssue :: Text,
comicDescription :: Text
}
- deriving (Show, Eq, Generic)
+ deriving (Show, Eq, Generic, Data, Ord)
instance ToJSON Comic where
toJSON = genericToJSON Data.Aeson.defaultOptions
@@ -317,11 +341,11 @@ initModel uri_ =
-- | Hacky way to initialize the 'ComicReaderState' from the URI.
detectPlayerState :: URI -> ComicReaderState
detectPlayerState u = case List.splitOn "/" $ uriPath u of
- ["", "comic", id, pg, "experience"] -> ChooseExperience id $ toPage pg
- ["", "comic", id, _, "video"] -> Watching id
- ["", "comic", id, pg, "full"] -> Reading Full id $ toPage pg
- ["", "comic", id, pg] -> Reading Spread id $ toPage pg
- ["", "comic", id] -> Cover id
+ ["", "comic", id, pg, "experience"] -> ChooseExperience (ComicId id) (toPage pg)
+ ["", "comic", id, _, "video"] -> Watching $ ComicId id
+ ["", "comic", id, pg, "full"] -> Reading Full (ComicId id) (toPage pg)
+ ["", "comic", id, pg] -> Reading Spread (ComicId id) (toPage pg)
+ ["", "comic", id] -> Cover $ ComicId id
_ -> NotReading
where
toPage pg = fromMaybe 1 (readMaybe pg :: Maybe Page)
diff --git a/Hero/Database.hs b/Hero/Database.hs
index 5b7f75d..e3c765c 100644
--- a/Hero/Database.hs
+++ b/Hero/Database.hs
@@ -1,43 +1,86 @@
+{-# LANGUAGE DeriveDataTypeable #-}
{-# LANGUAGE OverloadedStrings #-}
+{-# LANGUAGE TemplateHaskell #-}
+{-# LANGUAGE TypeFamilies #-}
{-# OPTIONS_GHC -fno-warn-orphans #-}
module Hero.Database
- ( ComicDB,
+ ( HeroKeep,
+ GetComics(..),
getComics,
- load,
- dummy,
+ NewComic(..),
+ newComic,
+ openLocal,
)
where
-import Data.Map (Map)
-import qualified Data.Map as Map
-import Dhall
+import Alpha
+import qualified Data.Acid as Acid
+import Data.Acid (Update, makeAcidic)
+import Data.Data (Data, Typeable)
+import qualified Data.IxSet as IxSet
+import Data.IxSet (Indexable (..), IxSet, ixFun, ixSet)
+import Data.SafeCopy (base, deriveSafeCopy)
+import qualified Data.Text as Text
import Hero.App
-import Protolude
-import Servant (Handler)
-
-type ComicDB = (Map ComicId Comic)
-
-instance Interpret Comic
-
-load :: IO ComicDB
-load = listToComicDB <$> input auto "./comic-database.dhall"
-
-dummy :: IO ComicDB
-dummy =
- return $
- listToComicDB
- [ Comic
- { comicId = "ComicId",
- comicPages = 10,
- comicName = "Dummy comic",
- comicIssue = "dummy issue",
- comicDescription = "Lorem ipsum"
- }
+
+-- * Keep
+
+-- | Main database.
+newtype HeroKeep
+ = HeroKeep
+ {_comics :: (IxSet Comic)}
+ deriving (Data, Typeable)
+
+$(deriveSafeCopy 0 'base ''HeroKeep)
+
+-- * Index @Comic@
+
+$(deriveSafeCopy 0 'base ''Comic)
+
+$(deriveSafeCopy 0 'base ''ComicId)
+
+instance Indexable Comic where
+ empty =
+ ixSet
+ [ ixFun $ \c -> [comicId c],
+ ixFun $ \c -> [comicPages c],
+ ixFun $ \c -> [comicName c],
+ ixFun $ \c -> [comicIssue c],
+ ixFun $ \c -> [comicDescription c]
]
-listToComicDB :: [Comic] -> ComicDB
-listToComicDB ls = Map.fromList $ (,) <$> comicId <*> identity <$> ls
+newComic :: Comic -> Update HeroKeep Comic
+newComic c = do
+ keep <- get
+ put $ keep {_comics = IxSet.insert c (_comics keep)}
+ return c
+
+getComics :: Int -> Acid.Query HeroKeep [Comic]
+getComics n = ask /> _comics /> IxSet.toList /> take n
+
+-- * Opening the keep
+
+$(makeAcidic ''HeroKeep ['newComic, 'getComics])
+
+initialHeroKeep :: HeroKeep
+initialHeroKeep = HeroKeep {_comics = IxSet.fromList [theRed] }
+ where
+ theRed =
+ Comic
+ { comicId = "1",
+ comicPages = 42,
+ comicName = "The Red",
+ comicIssue = "1.0",
+ comicDescription =
+ Text.unlines
+ [ "In the future, a nuclear world war has changed the course",
+ "of history forever. A single government entity now presides",
+ "over what's left of the world, and prohibits certain content",
+ "that is deemed emotionall dangerous, or \"red\", in attempt",
+ "to maintain order and keep society working..."
+ ]
+ }
-getComics :: ComicDB -> Handler [Comic]
-getComics db = return $ Map.elems db
+openLocal :: String -> IO (Acid.AcidState HeroKeep)
+openLocal dir = Acid.openLocalStateFrom dir initialHeroKeep
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
diff --git a/Hero/Service.nix b/Hero/Service.nix
index f0f4227..8bad6d7 100644
--- a/Hero/Service.nix
+++ b/Hero/Service.nix
@@ -18,6 +18,11 @@ in
The port on which herocomics-server will listen for incoming HTTP traffic.
'';
};
+ dataDir = lib.mkOption {
+ type = lib.types.path;
+ default = "/var/lib/hero";
+ description = "herocomics-server database directory";
+ };
server = lib.mkOption {
type = lib.types.package;
description = "herocomics-server package to use";
@@ -50,6 +55,7 @@ in
Environment = [
"HERO_CLIENT=${cfg.client}/static"
"HERO_PORT=${toString cfg.port}"
+ "HERO_DATA_DIR=${cfg.dataDir}"
];
Type = "simple";
Restart = "on-abort";
--
cgit v1.2.3