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/Database.hs | 105 +++++++++++++++++++++++++++++++++++++++----------------
 1 file changed, 74 insertions(+), 31 deletions(-)

(limited to 'Hero/Database.hs')

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
-- 
cgit v1.2.3