From 0ec5d1c5d44ea0c52408db9e58e71ea4f133592c Mon Sep 17 00:00:00 2001 From: Ben Sima Date: Tue, 2 Jun 2020 20:12:21 -0700 Subject: Rename Hero.Database -> Hero.Keep I just like this better. --- Hero/Database.hs | 86 -------------------------------------------------------- Hero/Keep.hs | 86 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++ Hero/Server.hs | 10 +++---- 3 files changed, 91 insertions(+), 91 deletions(-) delete mode 100644 Hero/Database.hs create mode 100644 Hero/Keep.hs (limited to 'Hero') diff --git a/Hero/Database.hs b/Hero/Database.hs deleted file mode 100644 index e3c765c..0000000 --- a/Hero/Database.hs +++ /dev/null @@ -1,86 +0,0 @@ -{-# LANGUAGE DeriveDataTypeable #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeFamilies #-} -{-# OPTIONS_GHC -fno-warn-orphans #-} - -module Hero.Database - ( HeroKeep, - GetComics(..), - getComics, - NewComic(..), - newComic, - openLocal, - ) -where - -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 - --- * 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] - ] - -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..." - ] - } - -openLocal :: String -> IO (Acid.AcidState HeroKeep) -openLocal dir = Acid.openLocalStateFrom dir initialHeroKeep diff --git a/Hero/Keep.hs b/Hero/Keep.hs new file mode 100644 index 0000000..9ac46fa --- /dev/null +++ b/Hero/Keep.hs @@ -0,0 +1,86 @@ +{-# LANGUAGE DeriveDataTypeable #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# OPTIONS_GHC -fno-warn-orphans #-} + +module Hero.Keep + ( HeroKeep, + GetComics(..), + getComics, + NewComic(..), + newComic, + openLocal, + ) +where + +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 + +-- * 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] + ] + +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..." + ] + } + +openLocal :: String -> IO (Acid.AcidState HeroKeep) +openLocal dir = Acid.openLocalStateFrom dir initialHeroKeep diff --git a/Hero/Server.hs b/Hero/Server.hs index 73108be..d663c37 100644 --- a/Hero/Server.hs +++ b/Hero/Server.hs @@ -51,7 +51,7 @@ import qualified Data.Text.Lazy.Encoding as Lazy import GHC.Generics import Hero.App import qualified Hero.Assets as Assets -import qualified Hero.Database as Database +import qualified Hero.Keep as Keep import qualified Hero.Look as Look import qualified Hero.Look.Typography as Typography import qualified Lucid as L @@ -79,7 +79,7 @@ main = bracket startup shutdown $ uncurry Warp.run startup = Envy.decodeEnv >>= \case Left e -> Exit.die e Right cfg -> do - keep <- Database.openLocal (heroDataDir cfg) + keep <- Keep.openLocal (heroDataDir cfg) say "hero" say $ "port: " ++ show (heroPort cfg) say $ "client: " ++ heroClient cfg @@ -105,7 +105,7 @@ instance Envy.DefConfig Config where instance Envy.FromEnv Config -app :: AcidState Database.HeroKeep -> Config -> Application +app :: AcidState Keep.HeroKeep -> Config -> Application app keep cfg = serve (Proxy @AllRoutes) @@ -279,8 +279,8 @@ serverHandlers = :<|> discoverHandler :<|> chooseExperienceHandler -jsonHandlers :: AcidState Database.HeroKeep -> Server JsonApi -jsonHandlers keep = Acid.query' keep $ Database.GetComics 10 +jsonHandlers :: AcidState Keep.HeroKeep -> Server JsonApi +jsonHandlers keep = Acid.query' keep $ Keep.GetComics 10 homeHandler :: Handler (HtmlPage (View Action)) homeHandler = pure . HtmlPage . home $ initModel homeLink -- cgit v1.2.3