Initialize Hero database

4 files changed, 132 insertions, 52 deletions

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";