Add user datatype to keep

I also restructured some types so that I could grab a handle on the keep to
close it on shutdown, otherwise the database would be locked and I can't do
anything about it. This might mean I have to delete and start the database from
scratch when I deploy, but that's okay because I haven't stored anything yet.

I also renamed some stuff like 'deck' and 'beam' just for fun. I could make
these into more general interfaces like I always planned to.

Also I haven't really tested this yet, so... next commit will implement the user
login.

5 files changed, 117 insertions, 56 deletions

diff --git a/Hero/App.hs b/Hero/App.hs
index 3aca8be..da2289c 100644
--- a/Hero/App.hs
+++ b/Hero/App.hs
@@ -37,7 +37,6 @@ import Miso
 import qualified Miso (for_)
 import Miso.String
 import Network.RemoteData
-import Protolude hiding (replace)
 import Servant.API
   ( (:<|>) (..),
     (:>),
@@ -99,6 +98,29 @@ instance CanSnakeCase Text where
 comicSlug :: Comic -> Text
 comicSlug Comic {..} = snake comicName <> "-" <> comicIssue
 
+data User
+  = User
+      { userEmail :: Text,
+        userName :: Text,
+        userLibrary :: [Comic]
+      }
+  deriving (Show, Eq, Generic, Data, Ord)
+
+instance Semigroup User where
+  a <> b = User
+    (userEmail a <> userEmail b)
+    (userName a <> userName b)
+    (userLibrary a <> userLibrary b)
+
+instance Monoid User where
+  mempty = User mempty mempty mempty
+
+instance ToJSON User where
+  toJSON = genericToJSON Data.Aeson.defaultOptions
+
+instance FromJSON User where
+  parseJSON = genericParseJSON Data.Aeson.defaultOptions
+
 data Comic
   = Comic
       { comicId :: ComicId,
@@ -122,10 +144,10 @@ class IsMediaObject o where
   thumbnail :: o -> View Action
 
   -- | Render a featured banner.
-  feature :: o -> Library -> View Action
+  feature :: o -> User -> View Action
 
   -- | Media info view
-  info :: o -> Library -> View Action
+  info :: o -> User -> View Action
 
 instance IsMediaObject Comic where
   thumbnail c@Comic {..} =
@@ -200,8 +222,8 @@ type ZoomModel = Int
 data Button
   = Watch Comic
   | Read Comic
-  | Save Comic Library
-  | SaveIcon Comic Library
+  | Save Comic User
+  | SaveIcon Comic User
   | ZoomIcon ZoomModel Comic Page
   | PlayPause MisoString AudioState
   | Arrow Action
@@ -231,8 +253,8 @@ instance Elemental Button where
         PrevPage -> "prev-page"
         NextPage -> "next-page"
         _ -> "prev-page"
-  el (Save c lib) =
-    if c `elem` lib -- in library
+  el (Save c u) =
+    if c `elem` (userLibrary u) -- in library
       then
         a_
           [class_ "wrs-button saved", onClick $ ToggleInLibrary c]
@@ -246,8 +268,8 @@ instance Elemental Button where
           [ img_ [src_ $ ms $ Assets.icon <> "save.svg"],
             span_ [] [text "save"]
           ]
-  el (SaveIcon c lib) =
-    if c `elem` lib -- in library
+  el (SaveIcon c u) =
+    if c `elem` (userLibrary u) -- in library
       then
         button_
           [ class_ "button is-large has-background-black",
@@ -297,8 +319,6 @@ instance Elemental Button where
 data AudioState = Playing | Paused
   deriving (Show, Eq)
 
-type Library = [Comic]
-
 data ComicReaderState
   = NotReading
   | Cover ComicId
@@ -318,7 +338,7 @@ data Model
   = Model
       { uri :: URI,
         appComics :: RemoteData MisoString [Comic],
-        userLibrary :: Library,
+        user :: User,
         dMediaInfo :: Maybe Comic,
         cpState :: ComicReaderState,
         cpAudioState :: AudioState,
@@ -332,7 +352,7 @@ initModel uri_ =
     { uri = uri_,
       appComics = NotAsked,
       dMediaInfo = Nothing,
-      userLibrary = Protolude.empty,
+      user = mempty,
       cpState = detectPlayerState uri_,
       cpAudioState = Paused,
       zoomModel = 100
@@ -466,7 +486,7 @@ home :: Model -> View Action
 home = login
 
 discover :: Model -> View Action
-discover model@Model {userLibrary = lib} =
+discover model@Model {user = u} =
   template
     "discover"
     [ topbar,
@@ -476,9 +496,9 @@ discover model@Model {userLibrary = lib} =
         Failure _ -> [nocomics]
         Success [] -> [nocomics]
         Success (comic : rest) ->
-          [ feature comic lib,
+          [ feature comic u,
             shelf "Recent Releases" (comic : rest),
-            maybeView (`info` lib) $ dMediaInfo model
+            maybeView (`info` u) $ dMediaInfo model
           ],
       appmenu,
       discoverFooter
@@ -488,9 +508,10 @@ discover model@Model {userLibrary = lib} =
 maybeView :: (a -> View action) -> Maybe a -> View action
 maybeView = maybe (text "")
 
-mediaInfo :: Maybe Comic -> Library -> View Action
+mediaInfo :: Maybe Comic -> User -> View Action
 mediaInfo Nothing _ = text ""
-mediaInfo (Just comic) lib = div_ [class_ "media-info"] [info comic lib]
+mediaInfo (Just comic) user =
+  div_ [class_ "media-info"] [info comic user]
 
 appmenu :: View Action
 appmenu = aside_ [id_ "appmenu"] $ btn </ links
@@ -712,7 +733,7 @@ comicControls comic page model =
         ],
       div_
         [class_ "comic-controls-share"]
-        [ el $ SaveIcon comic $ userLibrary model,
+        [ el $ SaveIcon comic $ user model,
           el $ ZoomIcon (zoomModel model) comic page,
           button_
             [class_ "button icon is-large", onClick ToggleFullscreen]
diff --git a/Hero/Client.hs b/Hero/Client.hs
index a513dcd..4189fd8 100644
--- a/Hero/Client.hs
+++ b/Hero/Client.hs
@@ -28,6 +28,7 @@ import Hero.App
     ComicReaderState (..),
     ComicReaderView (..),
     Model (..),
+    User (..),
     audioId,
     chooseExperienceLink,
     comicPlayerFullLink,
@@ -130,12 +131,13 @@ move (ToggleZoom c pg) m = m {cpState = newState} <# pure act
       Reading Full _ _ -> (reading Spread, goto comicPlayerSpreadLink)
       Reading Spread _ _ -> (reading Full, goto comicPlayerFullLink)
       x -> (x, NoOp)
-move (ToggleInLibrary c) model = model {userLibrary = newLib} <# pure NoOp
+move (ToggleInLibrary c) model = model {user = newUser} <# pure NoOp
   where
+    newUser = (user model) { userLibrary = newLib }
     newLib
-      | c `elem` userLibrary model =
-        Protolude.filter (/= c) $ userLibrary model
-      | otherwise = c : userLibrary model
+      | c `elem` (userLibrary $ user model) =
+        Protolude.filter (/= c) $ userLibrary $ user model
+      | otherwise = c : (userLibrary $ user model)
 move (HandleURI u) model = model {uri = u} <# pure NoOp
 move (ChangeURI u) model = model <# do
   pushURI u
diff --git a/Hero/Keep.hs b/Hero/Keep.hs
index 9ac46fa..ee625d8 100644
--- a/Hero/Keep.hs
+++ b/Hero/Keep.hs
@@ -6,11 +6,12 @@
 
 module Hero.Keep
   ( HeroKeep,
-    GetComics(..),
+    GetComics (..),
     getComics,
-    NewComic(..),
+    NewComic (..),
     newComic,
-    openLocal,
+    open,
+    close,
   )
 where
 
@@ -27,9 +28,11 @@ import Hero.App
 -- * Keep
 
 -- | Main database.
-newtype HeroKeep
+data HeroKeep
   = HeroKeep
-      {_comics :: (IxSet Comic)}
+      { _comics :: (IxSet Comic),
+        _users :: (IxSet User)
+      }
   deriving (Data, Typeable)
 
 $(deriveSafeCopy 0 'base ''HeroKeep)
@@ -38,6 +41,8 @@ $(deriveSafeCopy 0 'base ''HeroKeep)
 
 $(deriveSafeCopy 0 'base ''Comic)
 
+$(deriveSafeCopy 0 'base ''User)
+
 $(deriveSafeCopy 0 'base ''ComicId)
 
 instance Indexable Comic where
@@ -50,6 +55,14 @@ instance Indexable Comic where
         ixFun $ \c -> [comicDescription c]
       ]
 
+instance Indexable User where
+  empty =
+    ixSet
+      [ ixFun $ \u -> [userEmail u],
+        ixFun $ \u -> [userName u],
+        ixFun $ \u -> [userLibrary u]
+      ]
+
 newComic :: Comic -> Update HeroKeep Comic
 newComic c = do
   keep <- get
@@ -64,7 +77,14 @@ getComics n = ask /> _comics /> IxSet.toList /> take n
 $(makeAcidic ''HeroKeep ['newComic, 'getComics])
 
 initialHeroKeep :: HeroKeep
-initialHeroKeep = HeroKeep {_comics = IxSet.fromList [theRed] }
+initialHeroKeep =
+  HeroKeep
+    { _comics = IxSet.fromList [theRed],
+      _users = IxSet.fromList
+        [ User "a" "micheal" [],
+          User "b" "ben" []
+        ]
+    }
   where
     theRed =
       Comic
@@ -82,5 +102,8 @@ initialHeroKeep = HeroKeep {_comics = IxSet.fromList [theRed] }
               ]
         }
 
-openLocal :: String -> IO (Acid.AcidState HeroKeep)
-openLocal dir = Acid.openLocalStateFrom dir initialHeroKeep
+open :: String -> IO (Acid.AcidState HeroKeep)
+open dir = Acid.openLocalStateFrom dir initialHeroKeep
+
+close :: Acid.AcidState HeroKeep -> IO ()
+close = Acid.closeAcidState
diff --git a/Hero/Server.hs b/Hero/Server.hs
index d663c37..351e839 100644
--- a/Hero/Server.hs
+++ b/Hero/Server.hs
@@ -41,9 +41,9 @@
 module Hero.Server where
 
 import qualified Clay
-import Data.Aeson
 import Data.Acid (AcidState)
 import qualified Data.Acid.Abstract as Acid
+import Data.Aeson
 import Data.Proxy
 import Data.Text (Text)
 import qualified Data.Text.Lazy as Lazy
@@ -73,30 +73,45 @@ import qualified System.Exit as Exit
 import qualified System.IO as IO
 
 main :: IO ()
-main = bracket startup shutdown $ uncurry Warp.run
+main = bracket startup shutdown run
   where
+    run (cfg, app, _) = Warp.run (heroPort cfg) app
     say = IO.hPutStrLn IO.stderr
     startup = Envy.decodeEnv >>= \case
       Left e -> Exit.die e
       Right cfg -> do
-        keep <- Keep.openLocal (heroDataDir cfg)
+        keep <- Keep.open (heroKeep cfg)
         say "hero"
         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
+        say $ "beam: " ++ heroBeam cfg
+        say $ "keep: " ++ heroKeep cfg
+        let waiapp = mkApp keep cfg
+        return (cfg, waiapp, keep)
+    shutdown :: App -> IO ()
+    shutdown (_, _, keep) = do
+      Keep.close keep
+      return ()
+
+-- This part is a little confusing. I have:
+--
+--   - 'App' which encapsulates the entire runtime state
+--   - 'Config' has stuff I can set at startup
+--   - 'HeroKeep' is the database and any other persistance
+--   - 'mkApp' take the second two and makes a 'Wai.Application', should really be
+--     called 'serve', and might need to be Servant's 'hoistServer' thing
+--
+-- I'm sure this can be cleaned up with a monad stack of some sort, but I
+-- haven't the brain power to think through that. For now, just try and keep
+-- things named clearly so I don't get confused.
+
+-- | This can be generalized I think, put in Biz.App, or something
+type App = (Config, Application, AcidState Keep.HeroKeep)
 
 data Config
   = Config
-      { -- | HERO_PORT
-        heroPort :: Warp.Port,
-        -- | HERO_CLIENT
-        heroClient :: FilePath,
-        -- | HERO_DATA
-        heroDataDir :: FilePath
+      { heroPort :: Warp.Port,
+        heroBeam :: FilePath,
+        heroKeep :: FilePath
       }
   deriving (Generic, Show)
 
@@ -105,8 +120,8 @@ instance Envy.DefConfig Config where
 
 instance Envy.FromEnv Config
 
-app :: AcidState Keep.HeroKeep -> Config -> Application
-app keep cfg =
+mkApp :: AcidState Keep.HeroKeep -> Config -> Application
+mkApp keep cfg =
   serve
     (Proxy @AllRoutes)
     ( static
@@ -117,7 +132,7 @@ app keep cfg =
         :<|> Tagged handle404
     )
   where
-    static = serveDirectoryWith $ defaultWebAppSettings $ heroClient cfg
+    static = serveDirectoryWith $ defaultWebAppSettings $ heroBeam cfg
 
 -- | HtmlPage for setting HTML doctype and header
 newtype HtmlPage a = HtmlPage a
diff --git a/Hero/Service.nix b/Hero/Service.nix
index 8bad6d7..a3c6bd5 100644
--- a/Hero/Service.nix
+++ b/Hero/Service.nix
@@ -18,16 +18,16 @@ in
         The port on which herocomics-server will listen for incoming HTTP traffic.
       '';
     };
-    dataDir = lib.mkOption {
+    keep = lib.mkOption {
       type = lib.types.path;
       default = "/var/lib/hero";
       description = "herocomics-server database directory";
     };
-    server = lib.mkOption {
+    deck = lib.mkOption {
       type = lib.types.package;
       description = "herocomics-server package to use";
     };
-    client = lib.mkOption {
+    beam = lib.mkOption {
       type = lib.types.package;
       description = "herocomics-client package to use";
     };
@@ -42,10 +42,10 @@ in
   };
   config = lib.mkIf cfg.enable {
     systemd.services.herocomics = {
-      path = [ cfg.server ];
+      path = [ cfg.deck ];
       wantedBy = [ "multi-user.target" ];
       script = ''
-        ${cfg.server}/bin/mmc
+        ${cfg.deck}/bin/mmc
       '';
       description = ''
         Hero Comics app server
@@ -53,9 +53,9 @@ in
       serviceConfig = {
         KillSignal = "INT";
         Environment = [
-          "HERO_CLIENT=${cfg.client}/static"
+          "HERO_BEAM=${cfg.beam}/static"
           "HERO_PORT=${toString cfg.port}"
-          "HERO_DATA_DIR=${cfg.dataDir}"
+          "HERO_KEEP=${cfg.keep}"
         ];
         Type = "simple";
         Restart = "on-abort";